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