1#!/usr/bin/perl 2# 3# $Id: Logger.pm 755 2009-03-23 16:13:09Z calle $ 4# 5# Copyright (c) 2007 .SE (The Internet Infrastructure Foundation). 6# All rights reserved. 7# 8# Redistribution and use in source and binary forms, with or without 9# modification, are permitted provided that the following conditions 10# are met: 11# 1. Redistributions of source code must retain the above copyright 12# notice, this list of conditions and the following disclaimer. 13# 2. Redistributions in binary form must reproduce the above copyright 14# notice, this list of conditions and the following disclaimer in the 15# documentation and/or other materials provided with the distribution. 16# 17# THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 18# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 19# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 21# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 23# GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 24# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 25# IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 26# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN 27# IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28# 29###################################################################### 30 31package DNSCheck::Logger; 32 33require 5.008; 34use warnings; 35use strict; 36 37our $SVN_VERSION = '$Revision: 755 $'; 38 39use Time::HiRes qw(time); 40use DNSCheck::Locale; 41use Data::Dumper; 42 43###################################################################### 44 45sub new { 46 my $proto = shift; 47 my $class = ref($proto) || $proto; 48 my $self = {}; 49 50 my $parent = shift; 51 my $config = $parent->config; 52 my $loglevels = $config->get('loglevels'); 53 54 $self->{interactive} = $config->get('logging')->{interactive}; 55 $self->{debug} = $config->get('debug'); 56 57 if ($config->get('locale')) { 58 $self->{locale} = DNSCheck::Locale->new($config->get('locale')); 59 } 60 61 if ($loglevels) { 62 $self->{loglevels} = $loglevels; 63 } else { 64 $self->{loglevels} = undef; 65 } 66 67 $self->{logname} = undef; 68 $self->{messages} = (); 69 70 $self->{module_stack} = [0]; 71 $self->{module_id} = 0; 72 73 $self->{start} = time; 74 75 bless $self, $class; 76} 77 78sub clear { 79 my $self = shift; 80 $self->{messages} = (); 81 $self->{module_stack} = [0]; 82 $self->{module_id} = 0; 83} 84 85sub logname { 86 my $self = shift; 87 my $arg = shift; 88 89 if ($arg) { 90 $self->{logname} = $arg; 91 } 92 93 return $self->{logname}; 94} 95 96sub add { 97 my $self = shift; 98 99 my @module_stack = @{ $self->{module_stack} }; 100 my $module_id = -1; 101 my $parent_module_id = -1; 102 103 if ($#module_stack > 0) { 104 $module_id = $module_stack[$#module_stack]; 105 $parent_module_id = $module_stack[$#module_stack - 1]; 106 } 107 108 my $entry; 109 $entry->{timestamp} = time; 110 $entry->{level} = shift; 111 $entry->{tag} = shift; 112 $entry->{module_id} = $module_id; # Id of module that logged entry 113 $entry->{parent_module_id} = 114 $parent_module_id; # Id of module that called current one 115 $entry->{arg} = [@_]; 116 117 push @{ $self->{messages} }, $entry; 118 119 if ($self->{interactive}) { 120 $self->print(); 121 $self->{messages} = (); 122 } 123} 124 125sub auto { 126 my $self = shift; 127 128 my $tag = shift; 129 my $level = undef; 130 131 if ($self->{loglevels}->{$tag}) { 132 $level = uc($self->{loglevels}->{$tag}); 133 } else { 134 $level = "DEBUG"; 135 } 136 137 $self->add($level, $tag, @_); 138 139 # return 1 for ERROR or CRITICAL 140 if ($level eq "ERROR" or $level eq "CRITICAL") { 141 return 1; 142 } else { 143 return 0; 144 } 145} 146 147sub dump { 148 my $self = shift; 149 150 my $context = $self->{logname} ? sprintf("%s ", $self->{logname}) : ""; 151 152 foreach my $e (@{ $self->{messages} }) { 153 printf STDERR ( 154 "%s:%s%s [%s] %s\n", 155 $e->{timestamp}, $context, $e->{level}, $e->{tag}, 156 join(";", @{ $e->{arg} }) 157 ); 158 } 159} 160 161sub print { 162 my $self = shift; 163 my $locale = shift; 164 165 STDOUT->autoflush(1); 166 167 my $context = $self->{logname} ? sprintf("%s ", $self->{logname}) : ""; 168 169 foreach my $e (@{ $self->{messages} }) { 170 if ($e->{level} eq 'DEBUG' and !$self->{debug}) { 171 next; 172 } 173 if ($self->{locale}) { 174 printf( 175 "%7.3f: %s%s %s\n", 176 ($e->{timestamp} - $self->{start}), 177 $context, $e->{level}, 178 $self->{locale}->expand($e->{tag}, @{ $e->{arg} }) 179 ); 180 181 } else { 182 printf( 183 "%7.3f: %s%s [%s] %s\n", 184 ($e->{timestamp} - $self->{start}), 185 $context, $e->{level}, $e->{tag}, join(";", @{ $e->{arg} }) 186 ); 187 } 188 } 189} 190 191sub export { 192 my $self = shift; 193 194 my @buffer = (); 195 my $context = $self->{logname} ? $self->{logname} : ""; 196 197 foreach my $e (@{ $self->{messages} }) { 198 my @logentry = ( 199 $e->{timestamp}, $context, $e->{level}, $e->{tag}, $e->{module_id}, 200 $e->{parent_module_id}, 201 @{ $e->{arg} } 202 ); 203 204 push @buffer, \@logentry; 205 } 206 207 return \@buffer; 208} 209 210sub count_string { 211 my $self = shift; 212 my $string = shift; 213 214 return scalar grep { $_->{level} eq $string } @{ $self->{messages} }; 215} 216 217sub count_debug { my $self = shift; return $self->count_string('DEBUG'); } 218sub count_info { my $self = shift; return $self->count_string('INFO'); } 219sub count_warning { my $self = shift; return $self->count_string('WARNING'); } 220sub count_notice { my $self = shift; return $self->count_string('NOTICE'); } 221sub count_error { my $self = shift; return $self->count_string('ERROR'); } 222sub count_critical { my $self = shift; return $self->count_string('CRITICAL'); } 223 224sub get_next_entry { 225 my $self = shift; 226 227 if (!defined($self->{_iter_index})) { 228 $self->{_iter_index} = 0; 229 } 230 231 if ($self->{_iter_index} > $#{ $self->{messages} }) { 232 $self->{_iter_index} = 0; 233 return; 234 } 235 236 my $e = $self->{messages}[$self->{_iter_index}]; 237 $self->{_iter_index}++; 238 239 return $e; 240} 241 242# module_stack_push() creates a unique (autoincrement) identifier for the 243# module that called the function, and saves it in module stack - an array 244# of module ids 245# 246# module_stack_pop() removes one module id from the top of the stack 247# 248# This way, by calling module_stack_push when entering the module, and 249# module_stack_pop when exiting, it is ensured that in module_stack there 250# is a valid list of module ids that called the current module. On top of 251# the stack is the current module id, and the next one is id of the parent 252# module. 253 254sub module_stack_push { 255 my $self = shift; 256 $self->{module_id}++; 257 push @{ $self->{module_stack} }, $self->{module_id}; 258} 259 260sub module_stack_pop { 261 my $self = shift; 262 pop @{ $self->{module_stack} }; 263} 264 2651; 266 267__END__ 268 269 270=head1 NAME 271 272DNSCheck::Logger - Logger Subsystem 273 274=head1 DESCRIPTION 275 276The logger object keeps track of the results from the DNSCheck system. 277 278=head1 METHODS 279 280=over 281 282=item ->new(); 283 284Object creation. Do not use this, use the L<DNSCheck::logger()> method. 285 286=item ->clear(); 287 288Delete all current content in the object. 289 290=item ->logname($name); 291 292Set the log name. 293 294=item ->auto(I<tag>, I<arg1>, I<arg2>, ..., I<argN>); 295 296Add an entry to the log. You should only need to use this if you're writing 297more tests for DNSCheck. The tag needs to be defined in the locale YAML file, 298and the number of arguments specified there must match the number given when 299calling the method. 300 301If the I<interactive> key is set in the system's config object, this method 302will print the log entry rather than store it internally. 303 304=item ->dump(); 305 306Send a textual raw dump of the object's contents to standard error. 307 308=item ->print(); 309 310Send a textual dump of the object's contents to standard output. If a locale 311is set, the output will be translated from raw tags to human-readable 312messages. 313 314=item ->export(); 315 316Return a list with all messages currently in the object. 317 318=item ->get_next_entry() 319 320Returns a hashref with the next log entry. If this method has never been alled 321before on this object, the "next" entry is the first one. It will then iterate 322through the entries until all have been returned, and after that it will 323return C<undef>. It is possible to add more entries without upsetting the 324iterator. This is, however, not really the intened use. The purpose is to be 325able to process all log entries without needing to know anything about their 326storage or copying possibly large arrays. See below for an example of use. 327 328=item ->count_debug 329 330=item ->count_info 331 332=item ->count_notice 333 334=item ->count_warning 335 336=item ->count_error 337 338=item ->count_critical 339 340Returns the number of current entries of the various severity levels. The 341level a given tag is considered to be is specified in F<policy.yaml>. 342 343=back 344 345=head1 LOG ENTRIES 346 347Each entry in the log is a hash. The L<export()> and L<get_next_entry()> 348methods return them, as a list or one at a time. There are a bunch of keys in 349the hashes: 350 351=over 352 353=item tag 354 355The message tag, as given when the entry was added. If it can't be found in 356F<policy.yaml>, it'll be considered to have no arguments and be of level 357DEBUG. 358 359=item timestamp 360 361The time when the entry was added, as a string representing a float value in 362seconds since the Unix epoch. 363 364=item level 365 366The severity level, as taken from F<policy.yaml>. 367 368=item arg 369 370A reference to a list with message arguments. 371 372=item module_id 373 374=item parent_module_id 375 376Numbers that represent the call hieararchy of test modules. Used by the 377standard web gui. 378 379=back 380 381=head1 EXAMPLES 382 383 use DNSCheck; 384 385 my $dc = DNSCheck->new; 386 387 $dc->zone->test("iis.se"); 388 389 while (defined(my $entry = $dc->logger->get_next_entry)) { 390 print $entry->{tag} 391 } 392 393 394=cut 395