File Coverage

blib/lib/Log/Handler.pm
Criterion Covered Total %
statement 312 386 80.8
branch 91 164 55.4
condition 11 26 42.3
subroutine 34 41 82.9
pod 14 14 100.0
total 462 631 73.2


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Log::Handler - Log messages to several outputs.
4              
5             =head1 SYNOPSIS
6              
7             use Log::Handler;
8              
9             my $log = Log::Handler->new();
10              
11             $log->add(
12             file => {
13             filename => "file.log",
14             maxlevel => "debug",
15             minlevel => "warning",
16             }
17             );
18              
19             $log->warning("message");
20              
21             Or
22              
23             use Log::Handler;
24              
25             my $log = Log::Handler->new(
26             screen => {
27             log_to => "STDOUT",
28             maxlevel => "debug",
29             minlevel => "debug",
30             message_layout => "%T [%L] %m (%C)",
31             },
32             screen => {
33             log_to => "STDOUT",
34             maxlevel => "info",
35             minlevel => "notice",
36             },
37             screen => {
38             log_to => "STDERR",
39             maxlevel => "warning",
40             minlevel => "emergency",
41             },
42             );
43              
44             Or
45              
46             use Log::Handler;
47              
48             my $log = Log::Handler->new();
49              
50             $log->config( config => "logger.conf" );
51              
52             # and maybe later
53              
54             $log->reload( config => "logger.conf" );
55              
56             Or
57              
58             # create a application wide logger
59             package MyApp;
60             use Log::Handler;
61             my $log = Log::Handler->create_logger("myapp");
62             $log->add(screen => { maxlevel => "info" });
63             $log->info("info message");
64              
65             # get logger with get_logger()
66             package MyApp::Admin;
67             use Log::Handler;
68             my $log = Log::Handler->get_logger("myapp");
69             $log->info("info message from MyApp::Admin");
70              
71             =head1 DESCRIPTION
72              
73             The C is a object oriented handler for logging, tracing and
74             debugging. It is very easy to use and provides a simple interface for
75             multiple output objects with lots of configuration parameters. You can
76             easily filter the amount of logged information on a per-output base,
77             define priorities, create patterns to format the messages and reload
78             the complete logging machine.
79              
80             See the documentation for details.
81              
82             =head1 IMPORTANT NOTES
83              
84             Note that the default for option C is now set to TRUE and newlines
85             will be appended automatically to each message if no newline exists.
86              
87             A long time I thought about this serious change and have come to
88             the decision to change it.
89              
90             The default for option C from Log::Handler::Output::File is now
91             C and not C anymore.
92              
93             The methods C and C are new since version 0.62.
94             I tested it with Screen.pm, File.pm and DBI.pm and it runs fine.
95             If you find bugs then open a bug report please :-)
96              
97             =head1 LOG LEVELS
98              
99             There are eigth levels available:
100              
101             7 debug
102             6 info
103             5 notice
104             4 warning, warn
105             3 error, err
106             2 critical, crit
107             1 alert
108             0 emergency, emerg
109              
110             C is the highest and C is the lowest level.
111              
112             Level C is the highest level because it basically says to log
113             every peep.
114              
115             =head1 LOG LEVEL METHODS
116              
117             =head2 Level methods
118              
119             =over 4
120              
121             =item B
122              
123             =item B
124              
125             =item B
126              
127             =item B, B
128              
129             =item B, B
130              
131             =item B, B
132              
133             =item B
134              
135             =item B, B
136              
137             =back
138              
139             The call of a log level method is very simple:
140              
141             $log->info("Hello World! How are you?");
142              
143             Or maybe:
144              
145             $log->info("Hello World!", "How are you?");
146              
147             Both calls would log - if level INFO is active:
148              
149             Feb 01 12:56:31 [INFO] Hello World! How are you?
150              
151             =head2 is_* methods
152              
153             =over 4
154              
155             =item B
156              
157             =item B
158              
159             =item B
160              
161             =item B, B
162              
163             =item B, B
164              
165             =item B, B
166              
167             =item B
168              
169             =item B, B
170              
171             =back
172              
173             These twelve methods could be very useful if you want to kwow if the current
174             level would log the message. All methods returns TRUE if the current set
175             of C and C would log the message and FALSE if not.
176              
177             =head1 SPECIAL LOG METHODS
178              
179             =over 4
180              
181             =item B, B
182              
183             =item B
184              
185             =item B
186              
187             =item B
188              
189             =item B
190              
191             =back
192              
193             For a full list take a look into the documentation of L.
194              
195             =head1 METHODS
196              
197             =head2 new()
198              
199             Call C to create a new log handler object.
200              
201             my $log = Log::Handler->new();
202              
203             =head2 add()
204              
205             Call C to add a new output object.
206              
207             The method expects 2 parts of options; the options for the handler and
208             the options for the output module you want to use. The output modules got it's own
209             documentation for all options.
210              
211             Example:
212              
213             use Log::Handler;
214              
215             my $log = Log::Handler->new();
216              
217             $log->add(
218              
219             # Add "file output"
220             file => {
221              
222             # handler options (see Log::Handler)
223             timeformat => "%Y/%m/%d %H:%M:%S",
224             message_layout => "%T [%L] %S: %m",
225             maxlevel => "debug",
226             minlevel => "emergency",
227             die_on_errors => 1,
228             debug_trace => 0,
229             debug_mode => 2,
230             debug_skip => 0,
231              
232             # file options (see Log::Handler::Output::File)
233             filename => "file.log",
234             filelock => 1,
235             fileopen => 1,
236             reopen => 1,
237             autoflush => 1,
238             permissions => "0660",
239             utf8 => 1,
240              
241             }
242             );
243              
244             Take a look to L for more examples.
245              
246             The following options are possible for the handler:
247              
248             =over 4
249              
250             =item B and B
251              
252             With these options it's possible to set the log levels for your program.
253              
254             Example:
255              
256             maxlevel => "error"
257             minlevel => "emergency"
258              
259             # or
260              
261             maxlevel => "err"
262             minlevel => "emerg"
263              
264             # or
265              
266             maxlevel => 3
267             minlevel => 0
268              
269             It's possible to set the log level as string or as number. The default setting
270             for C is C and the default setting for C is
271             C.
272              
273             Example: If C is set to C and C to C
274             then the levels C, C, C, C and C
275             would be logged.
276              
277             You can set both to 8 or C if you want to disable the logging machine.
278              
279             =item B
280              
281             The option C is used to set the format for the placeholder C<%T>.
282             The string is converted with C. The default format is set to
283             S<"%b %d %H:%M:%S"> and looks like
284              
285             Feb 01 12:56:31
286              
287             If you would set the format to S<"%Y/%m/%d %H:%M:%S"> it would looks like
288              
289             2007/02/01 12:56:31
290              
291             =item B
292              
293             This options works like C. You can set a format that is used for
294             the placeholder C<%D>. It's just useful if you want to split the date and time:
295              
296             $log->add(file => {
297             filename => "file.log",
298             dateformat => "%Y-%m-%d",
299             timeformat => "%H:%M:%S",
300             message_layout => "%D %T %L %m",
301             });
302              
303             $log->error("an error here");
304              
305             This looks like
306              
307             2007-02-01 12:56:31 ERROR an error here
308              
309             This option is not used by default.
310              
311             =item B
312              
313             C is a very helpful option. It let the logger appends a newline to
314             the message if a newline doesn't exist.
315              
316             0 - do nothing
317             1 - append a newline if not exist (default)
318              
319             Example:
320              
321             $log->add(
322             screen => {
323             newline => 1,
324             maxlevel => "info",
325             }
326             );
327              
328             $log->info("message\n");
329             $log->info("message");
330              
331             In both cases the message would be logged with a newline at the end.
332              
333             =item B
334              
335             With this option it's possible to create your own message layout with different
336             placeholders in C style. The available placeholders are:
337              
338             %L Log level
339             %T Time or full timestamp (option timeformat)
340             %D Date (option dateformat)
341             %P PID
342             %H Hostname
343             %U User name
344             %G Group name
345             %N Newline
346             %S Program name
347             %C Caller - filename and line number
348             %p Caller - package name
349             %f Caller - file name
350             %l Caller - line number
351             %s Caller - subroutine name
352             %r Runtime in seconds since program start
353             %t Time measurement - replaced with the time since the last call of $log->$level
354             %m Message
355             %% Percent
356              
357             The default message layout is set to S<"%T [%L] %m">.
358              
359             As example the following code
360              
361             $log->alert("foo bar");
362              
363             would log
364              
365             Feb 01 12:56:31 [ALERT] foo bar
366              
367             If you set C to
368              
369             message_layout => "%T foo %L bar %m (%C)"
370              
371             and call
372              
373             $log->info("baz");
374              
375             then it would log
376              
377             Feb 01 12:56:31 foo INFO bar baz (script.pl, line 40)
378              
379             Traces will be appended after the complete message.
380              
381             You can create your own placeholders with the method C.
382              
383             =item B
384              
385             This option is just useful if you want to forward messages to output
386             modules that needs the parts of a message as a hash reference - as
387             example L, L
388             or L.
389              
390             The option expects a list of placeholders:
391              
392             # as a array reference
393             message_pattern => [ qw/%T %L %H %m/ ]
394              
395             # or as a string
396             message_pattern => "%T %L %H %m"
397              
398             The patterns will be replaced with real names as hash keys.
399              
400             %L level
401             %T time
402             %D date
403             %P pid
404             %H hostname
405             %U user
406             %G group
407             %N newline
408             %r runtime
409             %C caller
410             %p package
411             %f filename
412             %l line
413             %s subroutine
414             %S progname
415             %t mtime
416             %m message
417              
418             Here a full code example:
419              
420             use Log::Handler;
421              
422             my $log = Log::Handler->new();
423              
424             $log->add(forward => {
425             forward_to => \&my_func,
426             message_pattern => [ qw/%T %L %H %m/ ],
427             message_layout => "%m",
428             maxlevel => "info",
429             });
430              
431             $log->info("a forwarded message");
432              
433             # now you can access it
434              
435             sub my_func {
436             my $msg = shift;
437             print "Timestamp: $msg->{time}\n";
438             print "Level: $msg->{level}\n";
439             print "Hostname: $msg->{hostname}\n";
440             print "Message: $msg->{message}\n";
441             }
442              
443             =item B
444              
445             C is useful if you want to do something with the message before
446             it will be logged... maybe you want to create your own layout because message_layout
447             doesn't meet your claim.
448              
449             $log->add(
450             screen => {
451             newline => 1,
452             message_layout => "%m (%t)",
453             message_pattern => [ qw/%T %L %H %m/ ],
454             prepare_message => \&format,
455             }
456             );
457              
458             $log->error("foo");
459             $log->error("bar");
460             $log->error("baz");
461              
462             sub format {
463             my $m = shift;
464              
465             $m->{message} = sprintf("%-20s %-20s %-20s %s",
466             $m->{time}, $m->{level}, $m->{hostname}, $m->{message});
467             }
468              
469             The output looks like
470              
471             Mar 08 15:14:20 ERROR h1434036 foo (0.039694)
472             Mar 08 15:14:20 ERROR h1434036 bar (0.000510)
473             Mar 08 15:14:20 ERROR h1434036 baz (0.000274)
474              
475             =item B
476              
477             With this option you can set the priority of your output objects. This means
478             that messages will be logged at first to the outputs with a higher priority.
479             If this option is not set then the default priority begins with 10 and will be
480             increased +1 with each output. Example:
481              
482             We add a output with no priority
483              
484             $log->add(file => { filename => "file1.log" });
485              
486             This output gets the priority of 10. Now we add another output
487              
488             $log->add(file => { filename => "file2.log" });
489              
490             This output gets the priority of 11... and so on.
491              
492             Messages would be logged at first to the output with the priority of 10 and then
493             to the output with the priority of 11. Now you can add another output and set the
494             priority to 1.
495              
496             $log->add(screen => { dump => 1, priority => 1 });
497              
498             Messages would be logged now at first to the screen.
499              
500             =item B
501              
502             Set C to 0 if you don't want that the handler dies on failed
503             write operations.
504              
505             0 - to disable it
506             1 - to enable it
507              
508             If you set C to 0 then you have to control it yourself.
509              
510             $log->info("info message") or die $log->errstr();
511              
512             # or Log::Handler->errstr()
513             # or Log::Handler::errstr()
514             # or $Log::Handler::ERRSTR
515              
516             =item B
517              
518             This option is set to 1 by default.
519              
520             Take a look to the description of the method C for more
521             information about this option.
522              
523             =item B
524              
525             With this option it's possible to set a filter. If the filter is set then
526             only messages will be logged that match the filter. You can pass a regexp,
527             a code reference or a simple string. Example:
528              
529             $log->add(file => {
530             filename => "file.log",
531             maxlevel => 6,
532             filter_message => qr/log this/,
533             # or
534             # filter_message => "log this",
535             # filter_message => '^log only this$',
536             });
537              
538             $log->info("log this");
539             $log->info("but not that");
540              
541             If you pass your own code then you have to check the message yourself.
542              
543             $log->add(file => {
544             filename => "file.log",
545             maxlevel => 6,
546             filter_message => \&my_filter
547             });
548              
549             # return TRUE if you want to log the message, FALSE if not
550             sub my_filter {
551             my $msg = shift;
552             $msg->{message} =~ /your filter/;
553             }
554              
555             It's also possible to define a simple condition with matches. Just pass a
556             hash reference with the options C and C. Example:
557              
558             $log->add(file => {
559             filename => "file.log",
560             maxlevel => 6,
561             filter_message => {
562             match1 => "log this",
563             match2 => qr/with that/,
564             match3 => "(?:or this|or that)",
565             condition => "(match1 && match2) || match3",
566             }
567             });
568              
569             NOTE that re-eval in regexes is not valid! Something like
570              
571             match1 => '(?{unlink("file.txt")})'
572              
573             would cause an error!
574              
575             =item B
576              
577             This is the opposite of option C, but it's only possible to set
578             a simple string or regular expression.
579              
580             $log->add(file => {
581             filename => "file.log",
582             maxlevel => 6,
583             skip => '^do not log this.+$'
584             });
585              
586             =item B
587              
588             The parameter C works like C but is much easier to configure.
589             You can set a comma separated list of modules. As example if you would set the category to
590              
591             category => "MyApp::User"
592              
593             then all messages of MyApp::User and the submodules would be logged.
594              
595             Example:
596              
597             my $log = Log::Handler->new();
598              
599             $log->add(
600             screen => {
601             maxlevel => "info",
602             category => "MyApp::User, MyApp::Session"
603             }
604             );
605              
606             package MyApp;
607             $log->info(__PACKAGE__);
608              
609             package MyApp::Products;
610             $log->info(__PACKAGE__);
611              
612             package MyApp::User;
613             $log->info(__PACKAGE__);
614              
615             package MyApp::Users;
616             $log->info(__PACKAGE__);
617              
618             package MyApp::User::Settings;
619             $log->info(__PACKAGE__);
620              
621             package MyApp::Session;
622             $log->info(__PACKAGE__);
623              
624             package MyApp::Session::Settings;
625             $log->info(__PACKAGE__);
626              
627             The messages of C and C would not be logged.
628              
629             The usage of categories is much faster than to filter by caller.
630              
631             =item B
632              
633             You can use this option to set a package name. Only messages from this
634             packages will be logged.
635              
636             Example:
637              
638             my $log = Log::Handler->new();
639              
640             $log->add(screen => {
641             maxlevel => "info",
642             filter_caller => qr/^Foo::Bar\z/,
643             # or
644             # filter_caller => "^Foo::Bar\z",
645             });
646              
647             package Foo::Bar;
648             $log->info("log this");
649              
650             package Foo::Baz;
651             $log->info("but not that");
652              
653             1;
654              
655             This would only log the message from the package C.
656              
657             =item B
658              
659             This option is just the opposite of C.
660              
661             If you want to log messages from all callers but C:
662              
663             except_caller => qr/^Foo::Bar\z/
664              
665             =item B
666              
667             You can set an alias if you want to get the output object later. Example:
668              
669             my $log = Log::Handler->new();
670              
671             $log->add(screen => {
672             maxlevel => 7,
673             alias => "screen-out",
674             });
675              
676             my $screen = $log->output("screen-out");
677              
678             $screen->log(message => "foo");
679              
680             # or in one step
681              
682             $log->output("screen-out")->log(message => "foo");
683              
684             =item B
685              
686             You can activate a debugger that writes C information about each
687             active log level. The debugger is logging all defined values except C
688             and C. Set C to 1 to activate the debugger.
689             The debugger is set to 0 by default.
690              
691             =item B
692              
693             There are two debug modes: line(1) and block(2) mode. The default mode is 1.
694              
695             The line mode looks like this:
696              
697             use strict;
698             use warnings;
699             use Log::Handler;
700              
701             my $log = Log::Handler->new()
702              
703             $log->add(file => {
704             filename => "*STDOUT",
705             maxlevel => "debug",
706             debug_trace => 1,
707             debug_mode => 1
708             });
709              
710             sub test1 { $log->warning() }
711             sub test2 { &test1; }
712              
713             &test2;
714              
715             Output:
716              
717             Apr 26 12:54:11 [WARNING]
718             CALL(4): package(main) filename(./trace.pl) line(15) subroutine(main::test2) hasargs(0)
719             CALL(3): package(main) filename(./trace.pl) line(13) subroutine(main::test1) hasargs(0)
720             CALL(2): package(main) filename(./trace.pl) line(12) subroutine(Log::Handler::__ANON__) hasargs(1)
721             CALL(1): package(Log::Handler) filename(/usr/local/share/perl/5.8.8/Log/Handler.pm) line(713) subroutine(Log::Handler::_write) hasargs(1)
722             CALL(0): package(Log::Handler) filename(/usr/local/share/perl/5.8.8/Log/Handler.pm) line(1022) subroutine(Devel::Backtrace::new) hasargs(1) wantarray(0)
723              
724             The same code example but the debugger in block mode would looks like this:
725              
726             debug_mode => 2
727              
728             Output:
729              
730             Apr 26 12:52:17 [DEBUG]
731             CALL(4):
732             package main
733             filename ./trace.pl
734             line 15
735             subroutine main::test2
736             hasargs 0
737             CALL(3):
738             package main
739             filename ./trace.pl
740             line 13
741             subroutine main::test1
742             hasargs 0
743             CALL(2):
744             package main
745             filename ./trace.pl
746             line 12
747             subroutine Log::Handler::__ANON__
748             hasargs 1
749             CALL(1):
750             package Log::Handler
751             filename /usr/local/share/perl/5.8.8/Log/Handler.pm
752             line 681
753             subroutine Log::Handler::_write
754             hasargs 1
755             CALL(0):
756             package Log::Handler
757             filename /usr/local/share/perl/5.8.8/Log/Handler.pm
758             line 990
759             subroutine Devel::Backtrace::new
760             hasargs 1
761             wantarray 0
762              
763             =item B
764              
765             This option let skip the C information the count of C.
766              
767             =back
768              
769             =head2 output()
770              
771             Call C to get the output object that you added with
772             the option C.
773              
774             It's possible to access a output directly:
775              
776             $log->output($alias)->log(message => "booo");
777              
778             For more information take a look to the option C.
779              
780             =head2 flush()
781              
782             Call C if you want to send flush to all outputs that can flush.
783              
784             Flush means to flush buffers and/or close and re-open outputs.
785              
786             If you want to send it only to some outputs you can pass the aliases.
787              
788             $log->flush(); # flush all
789             $log->flush("foo", "bar"); # flush only foo and bar
790              
791             If option S<"die_on_errors"> is set to 0 then you can intercept errors with:
792              
793             $log->flush or die $log->errstr;
794              
795             =head2 errstr()
796              
797             Call C if you want to get the last error message. This is useful
798             if you set C to C<0> and the handler wouldn't die on failed
799             write operations.
800              
801             use Log::Handler;
802              
803             my $log = Log::Handler->new();
804              
805             $log->add(file => {
806             filename => "file.log",
807             maxlevel => "info",
808             die_on_errors => 0,
809             });
810              
811             $log->info("Hello World!") or die $log->errstr;
812              
813             Or
814              
815             unless ( $log->info("Hello World!") ) {
816             $error_string = $log->errstr;
817             # do something with $error_string
818             }
819              
820             The exception is that the handler dies in any case if the call of C or
821             C fails because on missing or wrong settings!
822              
823             =head2 config()
824              
825             With this method it's possible to load your output configuration from a file.
826              
827             $log->config(config => "file.conf");
828              
829             Or
830              
831             $log->config(config => {
832             file => [
833             {
834             alias => "error_log",
835             filename => "error.log",
836             maxlevel => "warning",
837             minlevel => "emerg",
838             priority => 1
839             },
840             {
841             alias => "common_log",
842             filename => "common.log",
843             maxlevel => "info",
844             minlevel => "emerg",
845             priority => 2
846             },
847             ],
848             screen => {
849             alias => "screen",
850             maxlevel => "debug",
851             minlevel => "emerg",
852             log_to => "STDERR",
853             },
854             });
855              
856             The key S<"default"> is used here to define default parameters for all file
857             outputs. All other keys (C, C) are used as aliases.
858              
859             Take a look into the documentation of L for more
860             information.
861              
862             =head2 reload()
863              
864             With the method C it's possible to reload the logging
865             machine. Just pass the complete new configuration for all outputs,
866             it works exaclty like C.
867              
868             At first you should know that it's highly recommended to set a alias for
869             each output. If you don't set a alias then the logger doesn't know which
870             output-objects to reload. If a output-objects doesn't have a alias then
871             the objects will be removed and the new configuration will be added.
872              
873             Example:
874              
875             logger.conf
876              
877            
878             alias = debug
879             filename = debug.log
880             maxlevel = debug
881             minlevel = emerg
882            
883              
884            
885             alias = common
886             filename = common.log
887             maxlevel = info
888             minlevel = emerg
889            
890              
891             Load the configuration
892              
893             $log->config(config => "logger.conf");
894              
895             Now change the configuration in logger.conf
896              
897            
898             alias = common
899             filename = common.log
900             maxlevel = notice
901             minlevel = emerg
902            
903              
904            
905             alias = sendmail
906             from = bar@foo.example
907             to = foo@bar.example
908             subject = your subject
909            
910              
911             What happends now...
912              
913             The file-output with the alias C will be removed,
914             the file-output with the alias C will be
915             reloaded and the output with the alias C will be added.
916              
917             If you don't want that output-objects will be removed
918             because they were added internal, then you can set the
919             option C to 0.
920              
921             Example:
922              
923             $log->config(config => "logger.conf");
924              
925             $log->add(
926             forward => {
927             forward_to => \&my_func,
928             remove_on_reload => 0,
929             }
930             );
931              
932             The forward-output is not removed after a reload.
933              
934             =head2 validate()
935              
936             The method C expects the same arguments like C and C.
937              
938             Maybe you want to validate your options before you pass them to C
939             or C.
940              
941             Example:
942              
943             my $log = Log::Handler->new();
944              
945             $log->config( config => \%config );
946              
947             # and maybe later
948              
949             if ( $log->validate( config => \%new_config ) ) {
950             $log->reload( config => \%new_config );
951             } else {
952             warn "unable to reload configuration";
953             warn $log->errstr;
954             }
955              
956             =head2 set_pattern()
957              
958             With this option you can set your own placeholders. Example:
959              
960             $log->set_pattern("%X", "key_name", sub { "value" });
961              
962             # or
963              
964             $log->set_pattern("%X", "key_name", "value");
965              
966             Then you can use this pattern in your message layout:
967              
968             $log->add(file => {
969             filename => "file.log",
970             message_layout => "%X %m%N",
971             });
972              
973             Or use it with C:
974              
975             sub func {
976             my $m = shift;
977             print "$m->{key_name} $m->{message}\n";
978             }
979              
980             $log->add(forward => {
981             forward_to => \&func,
982             message_pattern => "%X %m",
983             });
984              
985             Note: valid character for the key name are: C<[%\w\-\.]+>
986              
987             =head2 set_level()
988              
989             With this method it's possible to change the log level at runtime.
990              
991             To change the log level it's necessary to use a alias - see option C.
992              
993             $log->set_level(
994             $alias => { # option alias
995             minlevel => $new_minlevel,
996             maxlevel => $new_maxlevel,
997             }
998             );
999              
1000             =head2 set_default_param()
1001              
1002             With this methods it's possible to overwrite the default settings for new outputs.
1003              
1004             Normally you would do something like
1005              
1006             $log->add(
1007             file => {
1008             filename => "debug.log",
1009             maxlevel => "info",
1010             timeformat => "%b %d %Y %H:%M:%S",
1011             message_layout => "[%T] %L %P %t %m (%C)"
1012             }
1013             );
1014              
1015             $log->add(
1016             file => {
1017             filename => "error.log",
1018             maxlevel => "error",
1019             timeformat => "%b %d %Y %H:%M:%S",
1020             message_layout => "[%T] %L %P %t %m (%C)"
1021             }
1022             );
1023              
1024             Now you can simplify it with
1025              
1026             $log->set_default_param(
1027             timeformat => "%b %d %Y %H:%M:%S",
1028             message_layout => "[%T] %L %P %t %m (%C)"
1029             );
1030              
1031             $logg->add(
1032             file => {
1033             filename => "debug.log",
1034             maxlevel => "info"
1035             }
1036             );
1037              
1038             $log->add(
1039             file => {
1040             filename => "error.log",
1041             maxlevel => "error"
1042             }
1043             );
1044              
1045             =head2 create_logger()
1046              
1047             C is the same like C but it creates a global
1048             logger.
1049              
1050             my $log = Log::Handler->create_logger("myapp");
1051              
1052             =head2 get_logger()
1053              
1054             With C it's possible to get a logger that was created
1055             with C or with
1056              
1057             use Log::Handler "myapp";
1058              
1059             Just call
1060              
1061             my $log = Log::Handler->get_logger("myapp");
1062              
1063             If the logger does not exists then a new logger will be created
1064             and returned.
1065              
1066             =head2 exists_logger()
1067              
1068             With C it's possible to check if a logger exists
1069             and it returns TRUE or FALSE.
1070              
1071             =head1 EXAMPLES
1072              
1073             L
1074              
1075             =head1 BENCHMARK
1076              
1077             The benchmark (examples/benchmark/benchmark.pl) runs
1078             on a Intel Core i7-920 with the following result:
1079              
1080             simple pattern output took : 1 wallclock secs ( 1.26 usr + 0.01 sys = 1.27 CPU) @ 78740.16/s (n=100000)
1081             default pattern output took : 2 wallclock secs ( 2.08 usr + 0.15 sys = 2.23 CPU) @ 44843.05/s (n=100000)
1082             complex pattern output took : 4 wallclock secs ( 3.22 usr + 0.23 sys = 3.45 CPU) @ 28985.51/s (n=100000)
1083             message pattern output took : 3 wallclock secs ( 2.72 usr + 0.16 sys = 2.88 CPU) @ 34722.22/s (n=100000)
1084             suppressed output took : 0 wallclock secs ( 0.08 usr + 0.00 sys = 0.08 CPU) @ 1250000.00/s (n=100000)
1085             filtered caller output took : 2 wallclock secs ( 2.10 usr + 0.68 sys = 2.78 CPU) @ 35971.22/s (n=100000)
1086             suppressed caller output took : 1 wallclock secs ( 0.54 usr + 0.00 sys = 0.54 CPU) @ 185185.19/s (n=100000)
1087             filtered messages output took : 3 wallclock secs ( 2.62 usr + 0.08 sys = 2.70 CPU) @ 37037.04/s (n=100000)
1088              
1089             =head1 EXTENSIONS
1090              
1091             Send me a mail if you have questions.
1092              
1093             =head1 PREREQUISITES
1094              
1095             Prerequisites for all modules:
1096              
1097             Carp
1098             Data::Dumper
1099             Fcntl
1100             Params::Validate
1101             POSIX
1102             Time::HiRes
1103             Sys::Hostname
1104             UNIVERSAL
1105              
1106             Recommended modules:
1107              
1108             Config::General
1109             Config::Properties
1110             DBI
1111             IO::Socket
1112             Net::SMTP
1113             YAML
1114              
1115             Just for the test suite:
1116              
1117             File::Spec
1118             Test::More
1119              
1120             =head1 EXPORTS
1121              
1122             No exports.
1123              
1124             =head1 REPORT BUGS
1125              
1126             Please report all bugs to .
1127              
1128             =head1 AUTHOR
1129              
1130             Jonny Schulz .
1131              
1132             =head1 QUESTIONS
1133              
1134             Do you have any questions or ideas?
1135              
1136             MAIL:
1137              
1138             IRC: irc.perl.org#perl
1139              
1140             If you send me a mail then add Log::Handler into the subject.
1141              
1142             =head1 COPYRIGHT
1143              
1144             Copyright (C) 2007-2009 by Jonny Schulz. All rights reserved.
1145              
1146             This program is free software; you can redistribute it and/or
1147             modify it under the same terms as Perl itself.
1148              
1149             =cut
1150              
1151             package Log::Handler;
1152              
1153 15     15   1076816 use strict;
  15         157  
  15         453  
1154 15     15   77 use warnings;
  15         28  
  15         369  
1155 15     15   73 use Carp;
  15         24  
  15         888  
1156 15     15   8699 use Params::Validate qw//;
  15         143660  
  15         440  
1157 15     15   6688 use Log::Handler::Output;
  15         41  
  15         151  
1158 15     15   8252 use Log::Handler::Config;
  15         39  
  15         154  
1159 15     15   6978 use Log::Handler::Pattern;
  15         38  
  15         139  
1160 15     15   471 use UNIVERSAL;
  15         31  
  15         45  
1161 15     15   400 use base qw(Log::Handler::Levels);
  15         28  
  15         7462  
1162              
1163             our $VERSION = "0.89";
1164             our $ERRSTR = "";
1165              
1166             # $TRACE and $CALLER_LEVEL are both used as global
1167             # variables in other packages as well. You shouldn't
1168             # manipulate them if you don't know what you do.
1169             #
1170             # $TRACE is used to turn on/off tracing.
1171             #
1172             # $CALLER_LEVEL is used to determine the current caller level
1173             our $CALLER_LEVEL = 0;
1174             our $TRACE = 0;
1175              
1176             # safe logger by app
1177             my %LOGGER;
1178              
1179             # Some constants...
1180 15     15   120 use constant PRIORITY => 10;
  15         30  
  15         1183  
1181 15     15   101 use constant BOOL_RX => qr/^[01]\z/;
  15         65  
  15         1269  
1182 15     15   110 use constant NUMB_RX => qr/^\d+\z/;
  15         37  
  15         2768  
1183 15         3381 use constant LEVEL_RX => qr/^(?:
1184             8 | nothing |
1185             7 | debug |
1186             6 | info |
1187             5 | notice |
1188             4 | warning | warn |
1189             3 | error | err |
1190             2 | critical | crit |
1191             1 | alert |
1192             0 | emergency | emerg |
1193             fatal
1194 15     15   117 )\z/x;
  15         34  
1195              
1196             # to convert minlevel and maxlevel to a number
1197             our %LEVEL_BY_STRING = (
1198             DEBUG => 7,
1199             INFO => 6,
1200             NOTICE => 5,
1201             WARNING => 4,
1202             WARN => 4,
1203             ERROR => 3,
1204             ERR => 3,
1205             CRITICAL => 2,
1206             CRIT => 2,
1207             ALERT => 1,
1208             EMERGENCY => 0,
1209             EMERG => 0,
1210             FATAL => 0,
1211             );
1212              
1213             # to iterate from minlevel to maxlevel and
1214             # create an HoA with all active levels
1215             our @LEVEL_BY_NUM = qw(
1216             EMERGENCY
1217             ALERT
1218             CRITICAL
1219             ERROR
1220             WARNING
1221             NOTICE
1222             INFO
1223             DEBUG
1224             NOTHING
1225             );
1226              
1227             # shortcuts for each output
1228             our %AVAILABLE_OUTPUTS = (
1229             file => "Log::Handler::Output::File",
1230             email => "Log::Handler::Output::Email",
1231             sendmail => "Log::Handler::Output::Sendmail",
1232             forward => "Log::Handler::Output::Forward",
1233             dbi => "Log::Handler::Output::DBI",
1234             screen => "Log::Handler::Output::Screen",
1235             socket => "Log::Handler::Output::Socket",
1236             gearman => "Log::Handler::Output::Gearman",
1237             );
1238              
1239             # use Log::Handler foo => "LOGFOO", bar => "LOGBAR";
1240             # use Log::Handler qw/foo LOGFOO bar LOGBAR/;
1241             sub import {
1242 15 100   15   26202 return unless @_ > 1;
1243 1         3 my $class = shift;
1244 1 50       5 my %create = @_ > 1 ? @_ : (@_, undef);
1245 1         3 my $caller = (caller)[0];
1246              
1247 1         4 foreach my $appl (keys %create) {
1248 1         2 my $export = $create{$appl};
1249 1         2 my $logger = ();
1250              
1251 1 50       6 if (!exists $LOGGER{$appl}) {
1252 1         3 $LOGGER{$appl} = __PACKAGE__->new();
1253             }
1254              
1255 1 50       3 if ($export) {
1256 15     15   110 no strict "refs";
  15         32  
  15         67959  
1257 1         3 my $method = $caller."::".$export;
1258 1     0   4 *{$method} = sub { $LOGGER{$appl} };
  1         1695  
  0         0  
1259             }
1260             }
1261             }
1262              
1263             sub get_logger {
1264 2 50   2 1 587 @_ == 2 || croak 'Usage: Log::Handler->get_logger($app)';
1265 2         5 my ($class, $logger) = @_;
1266              
1267 2 50       6 if (!exists $LOGGER{$logger}) {
1268 0         0 return $class->create_logger($logger);
1269             }
1270              
1271 2         41 return $LOGGER{$logger};
1272             }
1273              
1274             sub create_logger {
1275 2 50   2 1 925 @_ == 2 || croak 'Usage: Log::Handler->create_logger($app)';
1276 2         6 my ($class, $logger) = @_;
1277              
1278 2 50       7 if (!exists $LOGGER{$logger}) {
1279 2         11 $LOGGER{$logger} = __PACKAGE__->new();
1280             }
1281              
1282 2         6 return $LOGGER{$logger};
1283             }
1284              
1285             sub exists_logger {
1286 0 0   0 1 0 @_ == 2 || croak 'Usage: Log::Handler->exists_logger($app)';
1287 0         0 my ($class, $logger) = @_;
1288              
1289 0 0       0 if (exists $LOGGER{$logger}) {
1290 0         0 return 1;
1291             }
1292              
1293 0         0 return undef;
1294             }
1295              
1296             sub new {
1297 16     16 1 3317 my $class = shift;
1298              
1299 16         98 my $self = bless {
1300             priority => PRIORITY, # start priority
1301             levels => { }, # outputs (Output.pm) stored by active levels
1302             alias => { }, # outputs (Output.pm) stored by an alias
1303             outputs => [ ], # all Output::* objects - for flush()
1304             pattern => # default pattern
1305             &Log::Handler::Pattern::get_pattern,
1306             param_defaults => { }
1307             }, $class;
1308              
1309 16 50       82 if (@_) {
1310 0 0       0 if ($_[0] eq "config") {
1311 0         0 $self->config(@_);
1312             } else {
1313 0         0 $self->add(@_);
1314             }
1315             }
1316              
1317 16         52 return $self;
1318             }
1319              
1320             sub add {
1321 32     32 1 1356 my ($self, @args) = @_;
1322              
1323 32 50 33     192 if ($args[0] && $args[0] eq "config") {
1324 0         0 return $self->config(@args);
1325             }
1326              
1327 32 50       104 if (@args > 2) {
1328 0 0       0 if (@args % 2 != 0) {
1329 0         0 Carp::croak 'Odd number of arguments to Log::Handler::add';
1330             }
1331 0         0 while (@args) {
1332 0         0 my $type = shift @args;
1333 0         0 my $conf = shift @args;
1334 0         0 $self->add($type, $conf);
1335             }
1336 0         0 return 1;
1337             }
1338              
1339             # At first the config will be splitted into
1340             # the package name (Log::Handler::Output::*),
1341             # the options for the handler and the options
1342             # for the output-module.
1343 32         106 my ($package, $h_opts, $o_opts) = $self->_split_config(@args);
1344              
1345             # In the next step the handler options
1346             # must be validated.
1347 32         126 $h_opts = $self->_validate_options($h_opts);
1348              
1349             # Create the new output-object.
1350 32         108 my $output = $self->_new_output($package, $h_opts, $o_opts);
1351              
1352             # Add the output to $self.
1353 32         126 $self->_add_output($output);
1354              
1355 32         123 return 1;
1356             }
1357              
1358             sub config {
1359 2 50   2 1 33 @_ > 1 or Carp::croak 'Usage: $log->config( %param )';
1360 2         5 my $self = shift;
1361 2         16 my $config = Log::Handler::Config->config(@_);
1362              
1363             # Structure:
1364             # $config->{file} = [ output config ];
1365             # $config->{dbi} = [ output config ];
1366              
1367 2         8 foreach my $type (keys %$config) {
1368 3         6 for my $c (@{$config->{$type}}) {
  3         8  
1369 7         16 $self->add($type, $c);
1370             }
1371             }
1372              
1373 2         10 return 1;
1374             }
1375              
1376             sub validate {
1377 2     2 1 6 my $self = shift;
1378 2         5 my @v_opts = (); # validated options
1379              
1380 2         3 eval {
1381 2         18 my $config = Log::Handler::Config->config(@_);
1382              
1383 2         7 foreach my $type (keys %$config) {
1384 2         4 foreach my $output_config (@{ $config->{$type} }) {
  2         5  
1385 6         20 my ($package, $h_opts, $o_opts) = $self->_split_config($type, $output_config);
1386 6         21 $h_opts = $self->_validate_options($h_opts);
1387 6 50       24 $o_opts = $package->validate($o_opts) or die $package->errstr;
1388 6         34 push @v_opts, { p => $package, h => $h_opts, o => $o_opts, n => $output_config };
1389             }
1390             }
1391             };
1392              
1393 2 50       8 if ($@) {
1394 0         0 return $self->_raise_error($@);
1395             }
1396              
1397 2         6 return \@v_opts;
1398             }
1399              
1400             sub reload {
1401 2     2 1 321 my $self = shift;
1402 2         8 my $opts = $self->validate(@_);
1403              
1404 2 50       8 if (!$opts) {
1405 0         0 return undef;
1406             }
1407              
1408             # Store all aliases that were reloaded or added,
1409             # because all output-objects that weren't reloaded
1410             # should be removed.
1411 2         6 my %reloaded = ();
1412              
1413             # Reload in a eval block to prevent that the
1414             # program dies - daemons shouldn't die :-)
1415 2         3 eval {
1416 2         6 foreach my $output_config (@$opts) {
1417 6         13 my $package = $output_config->{p}; # package name like Log::Handler::Output::File
1418 6         9 my $h_opts = $output_config->{h}; # handler options to reload
1419 6         9 my $o_opts = $output_config->{o}; # output options to reload
1420 6         9 my $n_opts = $output_config->{n}; # add a new output
1421 6         24 my $alias = $h_opts->{alias};
1422              
1423 6         16 $reloaded{$alias} = 1;
1424              
1425             # If the alias doesn't exists then a new
1426             # output-objects is created, otherwise the
1427             # output-object is reloaded.
1428 6 100       17 if (!$self->output($alias)) {
1429             # If the alias does not exists we use
1430             # the alias that was generated by validate().
1431 3 100       8 if (!exists $n_opts->{alias}) {
1432 1         3 $n_opts->{alias} = $h_opts->{alias};
1433             }
1434             # Add the new output to Log::Handler
1435 3         7 $self->add($package => $n_opts);
1436             } else {
1437 3         15 $self->{alias}->{$alias}->reload($h_opts);
1438 3 50       14 $self->output($alias)->reload($o_opts)
1439             or die $self->output($alias)->errstr;
1440             }
1441             }
1442             };
1443              
1444 2 50       13 if ($@) {
1445 0         0 return $self->_raise_error($@);
1446             }
1447              
1448             # Rebuild the arrays...
1449 2         10 $self->{levels} = { };
1450 2         5 $self->{outputs} = [ ];
1451              
1452 2         5 foreach my $alias (keys %{ $self->{alias} }) {
  2         8  
1453 8         12 my $output = $self->{alias}->{$alias};
1454              
1455             # Delete all objects that wasn't reloaded and have
1456             # set the flag "remove_on_reload".
1457              
1458 8 100 66     28 if (!exists $reloaded{$alias} && $output->{remove_on_reload}) {
1459             # At this point the output object should be destroyed,
1460             # because the last reference was stored here.
1461 2         5 eval { delete $self->{alias}->{$alias} };
  2         3  
1462              
1463 2 50       32 if ($@) {
1464 0         0 warn $@;
1465             }
1466             } else {
1467             # At this point the output object should be destroyed,
1468 6         15 $self->_add_output($output);
1469             }
1470             }
1471              
1472 2         41 return 1;
1473             }
1474              
1475             sub set_default_param {
1476 0     0 1 0 my $self = shift;
1477              
1478 0         0 while (@_) {
1479 0         0 my $param = shift;
1480 0         0 my $value = shift;
1481 0         0 $self->{param_defaults}->{$param} = $value;
1482             }
1483             }
1484              
1485             sub set_pattern {
1486 3 50 33 3 1 581 (@_ == 3 || @_ == 4)
1487             or Carp::croak 'Usage: $log->set_pattern( $pattern, $name, $code )';
1488              
1489 3         5 my $self = shift;
1490 3         6 my $pattern = shift;
1491              
1492             # If no $name is set then we use $pattern as name
1493 3 50       12 my ($name, $code) = @_ == 2 ? @_ : ($pattern, @_);
1494              
1495 3 50       13 if ($pattern !~ /^%[a-ln-z]\z/i) {
1496 0         0 Carp::croak "invalid pattern '$pattern'";
1497             }
1498              
1499 3 50 33     20 if (!defined $name || $name !~ /^[%\w\-\.]+\z/) {
1500 0         0 Carp::croak "invalid/missing name for pattern '$pattern'";
1501             }
1502              
1503 3 100       11 if (ref($code) ne "CODE") {
1504 1         3 my $str = $code;
1505 1     1   5 $code = sub { $str };
  1         13  
1506             }
1507              
1508             # Structure:
1509             # $self->{pattern}->{"%X"}->{name} = "name-of-x";
1510             # $self->{pattern}->{"%X"}->{code} = "value-of-x";
1511 3         15 $self->{pattern}->{$pattern}->{name} = $name;
1512 3         10 $self->{pattern}->{$pattern}->{code} = $code;
1513             }
1514              
1515             sub set_level {
1516 4 50   4 1 31 @_ == 3 or Carp::croak 'Usage: $log->set_level( $alias => { minlevel => $min, maxlevel => $max } )';
1517 4         9 my ($self, $name, $new) = @_;
1518 4         9 my $alias = $self->{alias};
1519              
1520 4 50       8 if (!exists $alias->{$name}) {
1521 0         0 Carp::croak "alias '$name' does not exists";
1522             }
1523              
1524 4 50       12 if (ref($new) ne "HASH") {
1525 0         0 Carp::croak "the second parameter to set_level() must be a hash reference";
1526             }
1527              
1528 4 0 33     10 if (!defined $new->{minlevel} && !defined $new->{maxlevel}) {
1529 0         0 Carp::croak "no new level given to set_level()";
1530             }
1531              
1532 4         7 foreach my $level (qw/minlevel maxlevel/) {
1533 8 50       16 next unless defined $new->{$level};
1534              
1535 8 50       34 if ($new->{$level} =~ LEVEL_RX) {
1536 8         17 $alias->{$name}->{$level} = $new->{$level};
1537 8 50       19 next if $new->{$level} =~ /^\d\z/;
1538 8         17 $new->{$level} = uc($new->{$level});
1539 8         18 $new->{$level} = $LEVEL_BY_STRING{ $new->{$level} };
1540 8         17 $alias->{$name}->{$level} = $new->{$level};
1541             } else {
1542 0         0 Carp::croak "invalid level set to set_level()";
1543             }
1544             }
1545              
1546 4         11 $alias->{$name}->{levels} = { };
1547 4         13 my $levels = $self->{levels} = { };
1548              
1549 4         11 foreach my $level_num ($alias->{$name}->{minlevel} .. $alias->{$name}->{maxlevel}) {
1550 28         39 my $level = $LEVEL_BY_NUM[ $level_num ];
1551 28         45 $alias->{$name}->{levels}->{$level} = 1;
1552              
1553 28 100       50 if ($level_num < 4) {
1554 16         26 $alias->{$name}->{levels}->{FATAL} = 1;
1555             }
1556             }
1557              
1558 4         7 foreach my $output (@{ $self->{outputs} }) {
  4         42  
1559 12         17 foreach my $level (keys %{$output->{levels}}) {
  12         41  
1560 84 100       137 if ($levels->{$level}) {
1561 48         52 my @old_order = @{$levels->{$level}};
  48         78  
1562 48         66 push @old_order, $output;
1563             $levels->{$level} = [
1564 116         212 map { $_->[0] }
1565 88         141 sort { $a->[1] <=> $b->[1] }
1566 48         61 map { [ $_, $_->{priority} ] } @old_order
  116         209  
1567             ];
1568             } else {
1569 36         41 push @{$levels->{$level}}, $output;
  36         75  
1570             }
1571             }
1572             }
1573              
1574 4         23 return 1;
1575             }
1576              
1577             sub output {
1578 13 50   13 1 60 @_ == 2 or Carp::croak 'Usage: $log->output( $alias )';
1579 13         29 my ($self, $name) = @_;
1580 13         24 my $alias = $self->{alias};
1581 13 100       54 return exists $alias->{$name} ? $alias->{$name}->{output} : undef;
1582             }
1583              
1584             sub flush {
1585 0     0 1 0 my ($self, @alias) = @_;
1586 0         0 my $errors = ();
1587              
1588 0 0       0 if (@alias) {
1589 0         0 foreach my $name (@alias) {
1590 0         0 my $output = $self->output($name);
1591 0 0 0     0 next unless $output && UNIVERSAL::can($output, "flush");
1592              
1593 0 0       0 if ( !$output->flush ) {
1594 0 0       0 if ( defined $errors ) {
1595 0         0 $errors .= "; " . $output->errstr;
1596             } else {
1597 0         0 $errors = $output->errstr;
1598             }
1599             }
1600             }
1601             } else {
1602 0         0 foreach my $output (@{$self->{outputs}}) {
  0         0  
1603 0 0       0 next unless UNIVERSAL::can($output, "flush");
1604              
1605 0 0       0 if ( !$output->flush ) {
1606 0 0       0 if ( defined $errors ) {
1607 0         0 $errors .= "; " . $output->errstr;
1608             } else {
1609 0         0 $errors = $output->errstr;
1610             }
1611             }
1612             }
1613             }
1614              
1615 0 0       0 return defined $errors ? $self->_raise_error($errors) : 1;
1616             }
1617              
1618             sub errstr {
1619 0     0 1 0 return $ERRSTR;
1620             }
1621              
1622             #
1623             # private stuff
1624             #
1625              
1626             sub _build_params {
1627 38     38   67 my $self = shift;
1628              
1629 38         900 my %params = (
1630             timeformat => {
1631             type => Params::Validate::SCALAR,
1632             default => "%b %d %H:%M:%S",
1633             },
1634             dateformat => {
1635             type => Params::Validate::SCALAR,
1636             default => "%b %d %Y",
1637             },
1638             message_layout => {
1639             type => Params::Validate::SCALAR,
1640             default => "%T [%L] %m",
1641             },
1642             message_pattern => {
1643             type => Params::Validate::SCALAR
1644             | Params::Validate::ARRAYREF,
1645             optional => 1,
1646             },
1647             prepare_message => {
1648             type => Params::Validate::CODEREF,
1649             optional => 1,
1650             },
1651             newline => {
1652             type => Params::Validate::SCALAR,
1653             regex => BOOL_RX,
1654             default => 1,
1655             },
1656             minlevel => {
1657             type => Params::Validate::SCALAR,
1658             regex => LEVEL_RX,
1659             default => 0,
1660             },
1661             maxlevel => {
1662             type => Params::Validate::SCALAR,
1663             regex => LEVEL_RX,
1664             default => 4,
1665             },
1666             die_on_errors => {
1667             type => Params::Validate::SCALAR,
1668             regex => BOOL_RX,
1669             default => 1,
1670             },
1671             priority => {
1672             type => Params::Validate::SCALAR,
1673             regex => NUMB_RX,
1674             default => undef,
1675             },
1676             debug_trace => {
1677             type => Params::Validate::SCALAR,
1678             regex => BOOL_RX,
1679             default => 0,
1680             },
1681             debug_mode => {
1682             type => Params::Validate::SCALAR,
1683             regex => NUMB_RX,
1684             default => 1,
1685             },
1686             debug_skip => {
1687             type => Params::Validate::SCALAR,
1688             regex => NUMB_RX,
1689             default => 0,
1690             },
1691             alias => {
1692             type => Params::Validate::SCALAR,
1693             optional => 1,
1694             },
1695             skip_message => {
1696             type => Params::Validate::SCALAR,
1697             optional => 1
1698             },
1699             filter_message => {
1700             type => Params::Validate::SCALAR # "foo"
1701             | Params::Validate::SCALARREF # qr/foo/
1702             | Params::Validate::CODEREF # sub { shift->{message} =~ /foo/ }
1703             | Params::Validate::HASHREF, # matchN, condition
1704             optional => 1,
1705             },
1706             filter_caller => {
1707             type => Params::Validate::SCALAR | Params::Validate::SCALARREF,
1708             optional => 1,
1709             },
1710             category => {
1711             type => Params::Validate::SCALAR,
1712             optional => 1,
1713             },
1714             except_caller => {
1715             type => Params::Validate::SCALAR | Params::Validate::SCALARREF,
1716             optional => 1,
1717             },
1718             remove_on_reload => {
1719             type => Params::Validate::SCALAR,
1720             default => 1,
1721             }
1722             );
1723              
1724 38         74 foreach my $param (keys %{$self->{param_defaults}}) {
  38         127  
1725 0 0       0 if (!exists $params{$param}) {
1726 0         0 Carp::croak "parameter '$param' does not exists";
1727             }
1728 0         0 $params{$param}{default} = $self->{param_defaults}->{$param};
1729             }
1730              
1731 38         741 return \%params;
1732             }
1733              
1734             sub _split_config {
1735 38     38   68 my $self = shift;
1736 38         63 my $type = shift;
1737 38   50     95 my $args = shift || { };
1738 38         66 my $package = ();
1739              
1740             # Split the handler and output options from $args.
1741 38         148 my ($handler_opts, $output_opts) = $self->_split_options($args);
1742              
1743             # Try to determine which output is wanted...
1744 38 100       160 if (exists $AVAILABLE_OUTPUTS{$type}) {
    50          
1745 35         72 $package = $AVAILABLE_OUTPUTS{$type};
1746             } elsif ($type =~ /::/) {
1747 3         5 $package = $type;
1748             } else {
1749 0         0 $package = "Log::Handler::Output::" . ucfirst($type);
1750             }
1751              
1752 38         2659 eval "require $package";
1753              
1754 38 50       211 if ($@) {
1755 0         0 Carp::croak($@);
1756             }
1757              
1758 38         161 return ($package, $handler_opts, $output_opts);
1759             }
1760              
1761             sub _new_output {
1762 32     32   103 my ($self, $package, $h_opts, $o_opts) = @_;
1763              
1764 32 50       146 my $o_obj = $package->new($o_opts)
1765             or Carp::croak $package->errstr;
1766              
1767 32         180 my $o_main_obj = Log::Handler::Output->new($h_opts, $o_obj);
1768              
1769 32         66 return $o_main_obj;
1770             }
1771              
1772             sub _split_options {
1773 38     38   133 my ($self, $opts) = @_;
1774 38         69 my (%handler_opts, %output_opts);
1775              
1776             # It's possible to pass all options for the handler and for the
1777             # output to add(). These options must be splitted. The options
1778             # for the handler will be passed to Log::Handler::Output. The
1779             # options for the output will be passed - as example - to
1780             # Log::Handler::Output::File.
1781              
1782 38         103 my %split_options = map { $_ => 0 } qw(
  798         1371  
1783             alias
1784             debug_mode
1785             debug_skip
1786             debug_trace
1787             die_on_errors
1788             filter
1789             filter_message
1790             filter_caller
1791             skip_message
1792             except_caller
1793             maxlevel
1794             message_layout
1795             message_pattern
1796             prepare_message
1797             minlevel
1798             newline
1799             priority
1800             timeformat
1801             dateformat
1802             remove_on_reload
1803             category
1804             );
1805              
1806 38         189 foreach my $key (keys %$opts) {
1807 170 100       310 if (exists $split_options{$key}) {
1808 122         231 $handler_opts{$key} = $opts->{$key};
1809             } else {
1810 48         105 $output_opts{$key} = $opts->{$key};
1811             }
1812             }
1813              
1814 38         186 return (\%handler_opts, \%output_opts);
1815             }
1816              
1817             sub _add_output {
1818 38     38   76 my ($self, $output) = @_;
1819 38         77 my $levels = $self->{levels};
1820              
1821             # Structure:
1822             # $self->{levels}->{INFO} = [ outputs ordered by priority ]
1823             #
1824             # All outputs that would log the level INFO will be stored to the
1825             # hash-tree $self->{levels}->{INFO}. On this way it's possible
1826             # to check very fast if the level is active
1827             #
1828             # my $levels = $self->{levels};
1829             # if (exists $levels->{INFO}) { ... }
1830             #
1831             # and loop over all output objects and pass the message to it.
1832              
1833 38         63 foreach my $level (keys %{$output->{levels}}) {
  38         163  
1834 245 100       459 if ($levels->{$level}) {
1835 138         162 my @old_order = @{$levels->{$level}};
  138         233  
1836 138         196 push @old_order, $output;
1837             $levels->{$level} = [
1838 489         907 map { $_->[0] }
1839 554         800 sort { $a->[1] <=> $b->[1] }
1840 138         197 map { [ $_, $_->{priority} ] } @old_order
  489         887  
1841             ];
1842             } else {
1843 107         170 push @{$levels->{$level}}, $output;
  107         271  
1844             }
1845             }
1846              
1847             # Structure:
1848             # $self->{alias}->{$alias} = $output_object
1849             #
1850             # All outputs with an alias are stored to this hash tree.
1851             # Each output can be fetched with output($alias);
1852              
1853 38 50       150 if ($output->{alias}) {
1854 38         76 my $alias = $output->{alias};
1855 38         173 $self->{alias}->{$alias} = $output;
1856             }
1857              
1858             # save all outputs here
1859 38         76 push @{$self->{outputs}}, $output;
  38         101  
1860             }
1861              
1862             sub _validate_options {
1863 38     38   98 my ($self, @args) = @_;
1864 38         188 my $pattern = $self->{pattern};
1865 38         83 my $alias = $self->{alias};
1866 38         83 my %wanted = ();
1867              
1868             # Option "filter" is deprecated.
1869 38 50       110 if (exists $args[0]{filter}) {
1870 0         0 $args[0]{filter_message} = delete $args[0]{filter};
1871             }
1872              
1873 38         132 my %options = Params::Validate::validate(@args, $self->_build_params);
1874              
1875 38 50       2236 if ($options{category}) {
1876 0         0 my $category = $options{category};
1877 0         0 $category =~ s/\s//g;
1878 0         0 $category = "^(?:" . join("|", map { $_ } split(/,/, $category) ) . ")(?:::|\\z)";
  0         0  
1879 0         0 $options{category} = qr/$category/;
1880             }
1881              
1882 38 100       131 if (!$options{alias}) {
1883 19         33 for (;;) {
1884 19         382 my $rand = rand();
1885              
1886 19 50       167 if (exists $alias->{$rand}) {
1887 0         0 next;
1888             }
1889              
1890 19         48 $options{alias} = $rand;
1891 19         47 last;
1892             }
1893             }
1894              
1895 38 100       99 if ($options{filter_message}) {
1896 3         10 $options{filter_message} = $self->_validate_filter($options{filter_message});
1897             }
1898              
1899             # set a default priority if not set
1900 38 100       101 if (!defined $options{priority}) {
1901 20         55 $options{priority} = $self->{priority}++;
1902             }
1903              
1904             # replace the level strings with numbers
1905 38         84 foreach my $opt (qw/minlevel maxlevel/) {
1906 76 100       276 next if $options{$opt} =~ /^\d\z/;
1907 46         101 my $level = uc($options{$opt});
1908 46         124 $options{$opt} = $LEVEL_BY_STRING{$level};
1909             }
1910              
1911             # iterate from minlevel to maxlevel and create
1912             # a hash tree with all active levels
1913 38         143 foreach my $level_num ($options{minlevel} .. $options{maxlevel}) {
1914 210         316 my $level = $LEVEL_BY_NUM[ $level_num ];
1915 210         374 $options{levels}{$level} = 1;
1916 210 100       403 next if $level_num > 3;
1917 140         261 $options{levels}{FATAL} = 1;
1918             }
1919              
1920 38 100       103 if ($options{message_pattern}) {
1921 2 50       12 if (!ref($options{message_pattern})) {
1922 0         0 $options{message_pattern} = [ split /\s+/, $options{message_pattern} ];
1923             }
1924 2         5 foreach my $p (@{$options{message_pattern}}) {
  2         7  
1925 16 50       28 if (!exists $pattern->{$p}) {
1926 0         0 Carp::croak "undefined pattern '$p'";
1927             }
1928 16         27 $wanted{$p} = undef;
1929             }
1930              
1931             # If message_pattern is set to "%T %L %m" then the code
1932             # should looks like:
1933             #
1934             # sub {
1935             # my ($w, $m) = @_; # %wanted pattern, %message
1936             # $m->{$_} = $w->{$_} for qw/time level message/;
1937             # }
1938              
1939 2         6 my $func = 'sub { my ($w, $m) = @_; $m->{$_} = $w->{$_} for qw/';
1940 2         10 $func .= join(" ", map { $pattern->{$_}->{name} } keys %wanted);
  16         33  
1941 2         6 $func .= "/ }";
1942 2         8 $options{message_pattern_func} = $func;
1943 2         242 $options{message_pattern_code} = eval $func;
1944 2 50       11 Carp::croak $@ if $@;
1945             }
1946              
1947 38 100       96 if ($options{message_layout}) {
1948 37         84 my (@chunks, $func);
1949              
1950             # If the message layout is set to "%T [%L] %m" then the code
1951             # should looks like:
1952             #
1953             # sub {
1954             # my ($w, $m) = @_; # %wanted pattern, %message
1955             # $m->{"message"} =
1956             # $w->{"time"}
1957             # . " ["
1958             # . $w->{"level"}
1959             # . "] "
1960             # . $w->{"message"}
1961             # );
1962             # }
1963              
1964 37         306 foreach my $p ( split /(?:(%[a-zA-Z])|(%)%)/, $options{message_layout} ) {
1965 268 100 100     778 next unless defined $p && length($p);
1966 168 100       325 if ( exists $pattern->{$p} ) {
1967 101         174 $wanted{$p} = undef;
1968 101         173 my $name = $pattern->{$p}->{name};
1969 101         332 push @chunks, "\$w->{'$name'}";
1970             } else {
1971             # quote backslash and apostrophe
1972 67         128 $p =~ s/\\/\\\\/g;
1973 67         104 $p =~ s/'/\\'/g;
1974 67         147 push @chunks, "'$p'";
1975             }
1976             }
1977              
1978 37 50       121 if (@chunks) {
1979 37         67 $func = 'sub { my ($w, $m) = @_; $m->{message} = ';
1980 37         130 $func .= join(".", @chunks);
1981 37         88 $func .= " }";
1982             }
1983              
1984 37         98 $options{message_layout_func} = $func;
1985 37         4278 $options{message_layout_code} = eval $func;
1986 37 50       170 Carp::croak $@ if $@;
1987             }
1988              
1989             # %m is default
1990 38         77 delete $wanted{"%m"};
1991              
1992             # The references to the patterns are stored to all outputs.
1993             # If a pattern will be changed with set_pattern() then the
1994             # changed pattern is available for each output.
1995 38         170 $options{wanted_pattern} = [ map { $pattern->{$_} } keys %wanted ];
  80         210  
1996 38         186 return \%options;
1997             }
1998              
1999             sub _validate_filter {
2000 3     3   6 my ($self, $args) = @_;
2001 3         6 my $ref = ref($args);
2002 3         6 my %filter;
2003              
2004             # A filter can be passed as CODE, as a Regexp, as a simple string
2005             # that will be embed in a Regexp or as a condition.
2006              
2007 3 100       55 if ($ref eq "CODE") {
    50          
    100          
2008 1         8 $filter{code} = $args;
2009             } elsif ($ref eq "Regexp") {
2010 0     0   0 $filter{code} = sub { $_[0]->{message} =~ $args };
  0         0  
2011             } elsif (!$ref) {
2012 1     8   7 $filter{code} = sub { $_[0]->{message} =~ /$args/ };
  8         52  
2013             } else {
2014 1         10 %filter = %$args;
2015              
2016             # Structure:
2017             # $filter->{code} = &code
2018             # $filter->{func} = $code_as_string
2019             # $filter->{condition} = $users_condition
2020             # $filter->{result}->{matchN} = $result_of_matchN
2021             # $filter->{matchN} = qr//
2022             #
2023             # Each matchN will be checked on the message and the BOOL results
2024             # will be stored to $filter->{result}->{matchN}. Then the results
2025             # will be passed to &code. &code returns 0 or 1.
2026             #
2027             # As example if the filter is set to
2028             #
2029             # filter => {
2030             # match1 => qr/foo/,
2031             # match2 => qr/bar/,
2032             # condition => "(match1 && match2)",
2033             # }
2034             #
2035             # Then the bool results will be saved:
2036             #
2037             # $filter->{result}->{match1} = $message =~ $filter->{match1};
2038             # $filter->{result}->{match2} = $message =~ $filter->{match2};
2039             #
2040             # The code for the filter should looks like:
2041             #
2042             # $filter->{code} =
2043             # sub {
2044             # my $m = shift;
2045             # ($m->{match1} && $m->{match2})
2046             # }
2047             #
2048             # &$code($filter->{result});
2049              
2050 1 50 33     13 if (!defined $filter{condition} || $filter{condition} !~ /\w/) {
2051 0         0 Carp::croak "missing condition for paramater 'filter'";
2052             }
2053              
2054             # Remove all valid characters from the condition
2055             # and check if invalid characters left.
2056 1         2 my $cond = $filter{condition};
2057 1         8 $cond =~ s/match\d+//g;
2058 1         5 $cond =~ s/[()&|!<>=\s\d]+//;
2059              
2060 1 50       3 if ($cond) {
2061 0         0 Carp::croak "invalid characters in condition: '$cond'";
2062             }
2063              
2064 1         8 foreach my $m ($filter{condition} =~ /(match\d+)/g) {
2065 3 50       10 if (!exists $filter{$m}) {
2066 0         0 Carp::croak "missing regexp for $m";
2067             }
2068 3         8 $ref = ref($filter{$m});
2069 3 100       8 if (!$ref) {
    50          
2070 2         55 $filter{$m} = qr/$filter{$m}/;
2071             } elsif ($ref ne "Regexp") {
2072 0         0 Carp::croak "invalid value for option 'filter:$m'";
2073             }
2074 3         10 $filter{result}{$m} = "";
2075             }
2076              
2077 1         3 $filter{func} = 'sub { my $m = shift; ';
2078 1         5 $filter{func} .= $filter{condition}."; }";
2079 1         16 $filter{func} =~ s/(match\d+)/\$m->{$1}/g;
2080 1         108 $filter{code} = eval $filter{func};
2081             }
2082              
2083 3         9 return \%filter;
2084             }
2085              
2086             sub _raise_error {
2087 0     0     $ERRSTR = $_[1];
2088 0           return undef;
2089             }
2090              
2091             1;