File Coverage

blib/lib/Bio/Phylo/Util/Logger.pm
Criterion Covered Total %
statement 76 134 56.7
branch 23 64 35.9
condition 5 18 27.7
subroutine 17 27 62.9
pod 16 17 94.1
total 137 260 52.6


line stmt bran cond sub pod time code
1             package Bio::Phylo::Util::Logger;
2 57     57   338 use strict;
  57         110  
  57         1462  
3 57     57   269 use warnings;
  57         101  
  57         1345  
4 57     57   260 use base 'Exporter';
  57         98  
  57         4796  
5 57     57   21242 use Term::ANSIColor;
  57         378578  
  57         3925  
6 57     57   421 use Bio::Phylo::Util::Exceptions 'throw';
  57         118  
  57         2318  
7 57     57   3133 use Bio::Phylo::Util::CONSTANT qw'/looks_like/';
  57         106  
  57         18126  
8              
9             our ( %VERBOSITY, $PREFIX, %STYLE );
10             our $STYLE = 'detailed';
11             our $COLORED = 1; # new default: we use colors
12             our $TRACEBACK = 0;
13             our @EXPORT_OK = qw(DEBUG INFO WARN ERROR FATAL VERBOSE);
14             our %EXPORT_TAGS = ( 'simple' => [@EXPORT_OK], 'levels' => [@EXPORT_OK] );
15             our %COLORS = (
16             'DEBUG' => 'blue',
17             'INFO' => 'green',
18             'WARN' => 'yellow',
19             'ERROR' => 'bold red',
20             'FATAL' => 'red',
21             );
22              
23             BEGIN {
24            
25             # compute the path to the root of Bio::Phylo,
26             # use that as the default prefix
27 57     57   236 my $package = __PACKAGE__;
28 57         104 my $file = __FILE__;
29 57         267 $package =~ s/::/\//g;
30 57         152 $package .= '.pm';
31 57         844 $file =~ s/\Q$package\E$//;
32 57         147 $PREFIX = $file;
33            
34             # set verbosity to 2, i.e. warn
35 57   50     428 $VERBOSITY{'*'} = $ENV{'BIO_PHYLO_VERBOSITY'} || 2;
36            
37             # define verbosity styles
38 57         73881 %STYLE = (
39             'simple' => '${level}: $message',
40             'detailed' => '$level $sub [$file $line] - $message',
41             );
42             }
43              
44             {
45             my %levels = ( FATAL => 0, ERROR => 1, WARN => 2, INFO => 3, DEBUG => 4 );
46             my @listeners = ( sub {
47             my ( $string, $level ) = @_;
48             if ( $COLORED and -t STDERR ) {
49             print STDERR colored( $string, $COLORS{$level} );
50             }
51             else {
52             print STDERR $string;
53             }
54             } ); # default
55              
56             # dummy constructor that dispatches to VERBOSE(),
57             # then returns the package name
58             sub new {
59 200     200 1 898 my $class = shift;
60 200 50       1532 $class->VERBOSE(@_) if @_;
61 200         1322 return $class;
62             }
63              
64             # set additional listeners
65             sub set_listeners {
66 2     2 1 13 my ( $class, @args ) = @_;
67 2         4 for my $arg (@args) {
68 2 100       6 if ( looks_like_instance $arg, 'CODE' ) {
69 1         3 push @listeners, $arg;
70             }
71             else {
72 1         7 throw 'BadArgs' => "$arg not a CODE reference";
73             }
74             }
75 1         4 return $class;
76             }
77            
78             # this is never called directly. rather, messages are dispatched here
79             # by the DEBUG() ... FATAL() subs below
80             sub LOG ($$) {
81 248228     248228 0 366393 my ( $message, $level ) = @_;
82            
83             # probe the call stack
84 248228         905285 my ( $pack2, $file2, $line2, $sub ) = caller( $TRACEBACK + 2 );
85 248228         806767 my ( $pack1, $file, $line, $sub1 ) = caller( $TRACEBACK + 1 );
86            
87             # cascade verbosity from global to local
88 248228         427131 my $verbosity = $VERBOSITY{'*'}; # global
89 248228 50       404657 $verbosity = $VERBOSITY{$pack1} if exists $VERBOSITY{$pack1}; # package
90 248228 50 33     603635 $verbosity = $VERBOSITY{$sub} if $sub and exists $VERBOSITY{$sub}; # sub
91            
92             # verbosity is higher than the current caller, proceed
93 248228 50       481044 if ( $verbosity >= $levels{$level} ) {
94              
95             # strip the prefix from the calling file's path
96 0 0       0 if ( index($file, $PREFIX) == 0 ) {
97 0         0 $file =~ s/^\Q$PREFIX\E//;
98             }
99            
100             # select one of the templates
101 0         0 my $string;
102 0         0 my $s = $STYLE{$STYLE};
103 0         0 $string = eval "qq[$s\n]";
104            
105             # dispatch to the listeners
106 0         0 $_->( $string, $level, $sub, $file, $line, $message ) for @listeners;
107             }
108             }
109            
110             # these subs both return their verbosity constants and, if
111             # provided with a message, dispatch the message to LOG()
112 0 0   0 1 0 sub FATAL (;$) { LOG $_[0], 'FATAL' if $_[0]; $levels{'FATAL'} }
  0         0  
113 0 0   0 1 0 sub ERROR (;$) { LOG $_[0], 'ERROR' if $_[0]; $levels{'ERROR'} }
  0         0  
114 4 50   4 1 15 sub WARN (;$) { LOG $_[0], 'WARN' if $_[0]; $levels{'WARN'} }
  4         8  
115 66121 50   66121 1 155330 sub INFO (;$) { LOG $_[0], 'INFO' if $_[0]; $levels{'INFO'} }
  66121         81144  
116 182113 100   182113 1 400677 sub DEBUG (;$) { LOG $_[0], 'DEBUG' if $_[0]; $levels{'DEBUG'} }
  182113         218999  
117              
118             sub PREFIX {
119 0     0 1 0 my ( $class, $prefix ) = @_;
120 0 0       0 $PREFIX = $prefix if $prefix;
121 0         0 return $PREFIX;
122             }
123              
124             sub VERBOSE {
125 14 100 66 14 1 126 shift if ref $_[0] or $_[0] eq __PACKAGE__;
126 14 50       51 if (@_) {
127 14         55 my %opt = looks_like_hash @_;
128 14         41 my $level = $opt{'-level'};
129            
130             # verbosity is specified
131 14 50       49 if ( defined $level ) {
132              
133             # check validity
134 14 50 25     93 if ( $level > 4 xor $level < 0 ) {
135 0         0 throw 'OutOfBounds' => "'-level' can be between 0 and 4, not $level";
136             }
137            
138             # verbosity is specified for one or more packages
139 14 50       90 if ( my $class = $opt{'-class'} ) {
    50          
140 0 0       0 if ( ref $class eq 'ARRAY' ) {
141 0         0 for my $c ( @{ $class } ) {
  0         0  
142 0         0 $VERBOSITY{$c} = $level;
143 0         0 INFO "Changed verbosity for class $c to $level";
144             }
145             }
146             else {
147 0         0 $VERBOSITY{$class} = $level;
148 0         0 INFO "Changed verbosity for class $class to $level";
149             }
150             }
151            
152             # verbosity is specified for one or more methods
153             elsif ( my $method = $opt{'-method'} ) {
154 0 0       0 if ( ref $method eq 'ARRAY' ) {
155 0         0 for my $m ( @{ $method } ) {
  0         0  
156 0         0 $VERBOSITY{$m} = $level;
157 0         0 INFO "Changed verbosity for method $m to $level";
158             }
159             }
160             else {
161 0         0 $VERBOSITY{$method} = $level;
162 0         0 INFO "Changed verbosity for method $method to $level";
163             }
164             }
165            
166             # verbosity is set globally
167             else {
168 14         39 $VERBOSITY{'*'} = $level;
169 14         81 INFO "Changed global verbosity to $VERBOSITY{'*'}";
170             }
171             }
172            
173             # log to a file
174 14 50       64 if ( $opt{'-file'} ) {
175 0 0       0 open my $fh, '>>', $opt{'-file'} or throw 'FileError' => $!;
176 0     0   0 __PACKAGE__->set_listeners(sub { print $fh shift });
  0         0  
177             }
178            
179             # log to a handle
180 14 50       57 if ( $opt{'-handle'} ) {
181 0         0 my $fh = $opt{'-handle'};
182 0     0   0 __PACKAGE__->set_listeners(sub { print $fh shift });
  0         0  
183             }
184            
185             # log to listeners
186 14 50       53 if ( $opt{'-listeners'} ) {
187 0         0 __PACKAGE__->set_listeners(@{$opt{'-listeners'}});
  0         0  
188             }
189            
190             # update the prefix
191 14 50       52 if ( $opt{'-prefix'} ) {
192 0         0 __PACKAGE__->PREFIX($opt{'-prefix'});
193             }
194            
195             # set logstyle
196 14 50       47 if ( $opt{'-style'} ) {
197 0         0 my $s = lc $opt{'-style'};
198 0 0       0 if ( exists $STYLE{$s} ) {
199 0         0 $STYLE = $s;
200             }
201             }
202            
203             # turn colors on/off. default is on.
204 14 50       59 $COLORED = !!$opt{'-colors'} if defined $opt{'-colors'};
205             }
206 14         49 return $VERBOSITY{'*'};
207             }
208            
209             # Change the terminal to a predefined color. For example to make sure that
210             # an entire exception (or part of it) is marked up as FATAL, or so that the
211             # output from an external command is marked up as DEBUG.
212             sub start_color {
213 0     0 1 0 my ( $self, $level, $handle ) = @_;
214 0 0       0 $handle = \*STDERR if not $handle;
215 0 0 0     0 if ( $COLORED and -t $handle ) {
216 0         0 print $handle color $COLORS{$level};
217             }
218 0         0 return $COLORS{$level};
219             }
220            
221             sub stop_color {
222 0     0 1 0 my ( $self, $handle ) = @_;
223 0 0       0 $handle = \*STDERR if not $handle;
224 0 0 0     0 if ( $COLORED and -t $handle ) {
225 0         0 print $handle color 'reset';
226             }
227 0         0 return $self;
228             }
229            
230             # aliases for singleton methods
231             sub fatal {
232 0     0 1 0 my $self = shift;
233 0         0 $TRACEBACK++;
234 0         0 FATAL shift;
235 0         0 $TRACEBACK--;
236             }
237             sub error {
238 0     0 1 0 my $self = shift;
239 0         0 $TRACEBACK++;
240 0         0 ERROR shift;
241 0         0 $TRACEBACK--;
242             }
243             sub warn {
244 4     4 1 9 my $self = shift;
245 4         6 $TRACEBACK++;
246 4         12 WARN shift;
247 4         38 $TRACEBACK--;
248             }
249             sub info {
250 64109     64109 1 87304 my $self = shift;
251 64109         73763 $TRACEBACK++;
252 64109         114772 INFO shift;
253 64109         94344 $TRACEBACK--;
254             }
255             sub debug {
256 182113     182113 1 236640 my $self = shift;
257 182113         206093 $TRACEBACK++;
258 182113         312708 DEBUG shift;
259 182113         277721 $TRACEBACK--;
260             }
261            
262             # empty destructor so we don't go up inheritance tree at the end
263       0     sub DESTROY {}
264             }
265             1;
266              
267             =head1 NAME
268              
269             Bio::Phylo::Util::Logger - Logger of internal messages of several severity
270             levels
271              
272             =head1 SYNOPSIS
273              
274             use strict;
275             use Bio::Phylo::Util::Logger ':levels'; # import level constants
276             use Bio::Phylo::IO 'parse';
277             use Bio::Phylo::Factory;
278            
279             # Set the verbosity level of the tree class.
280             # "DEBUG" is the most verbose level. All log messages
281             # emanating from the tree class will be
282             # transmitted. For this to work the level constants
283             # have to have been imported!
284             use Bio::Phylo::Forest::Tree 'verbose' => DEBUG; # note: DEBUG is not quoted!
285            
286             # Create a file handle for logger to write to.
287             # This is not necessary, by default the logger
288             # writes to STDERR, but sometimes you will want
289             # to write to a file, as per this example.
290             open my $fh, '>', 'parsing.log' or die $!;
291            
292             # Create a logger object.
293             my $fac = Bio::Phylo::Factory->new;
294             my $logger = $fac->create_logger;
295            
296             # Set the verbosity level of the set_name
297             # method in the base class. Messages coming
298             # from this method will be transmitted.
299             $logger->VERBOSE(
300             '-level' => DEBUG, # note, not quoted, this is a constant!
301             '-method' => 'Bio::Phylo::set_name', # quoted, otherwise bareword error!
302             );
303            
304             # 'Listeners' are subroutine references that
305             # are executed when a message is transmitted.
306             # The first argument passed to these subroutines
307             # is the log message. This particular listener
308             # will write the message to the 'parsing.log'
309             # file, if the $fh file handle is still open.
310             $logger->set_listeners(
311             sub {
312             my ($msg) = @_;
313             if ( $fh->opened ) {
314             print $fh $msg;
315             }
316             }
317             );
318              
319             # Now parse a tree, and see what is logged.
320             my $tree = parse(
321             '-format' => 'newick',
322             '-string' => do { local $/; <DATA> },
323             )->first;
324              
325             # Cleanly close the log handle.
326             close $fh;
327            
328             __DATA__
329             ((((A,B),C),D),E);
330              
331             The example above will write something like the following to the log file:
332              
333             INFO Bio::Phylo::Forest::Tree::new [Bio/Phylo/Forest/Tree.pm, 99] - constructor called for 'Bio::Phylo::Forest::Tree'
334             INFO Bio::Phylo::set_name [Bio/Phylo.pm, 281] - setting name 'A'
335             INFO Bio::Phylo::set_name [Bio/Phylo.pm, 281] - setting name 'B'
336             INFO Bio::Phylo::set_name [Bio/Phylo.pm, 281] - setting name 'C'
337             INFO Bio::Phylo::set_name [Bio/Phylo.pm, 281] - setting name 'D'
338             INFO Bio::Phylo::set_name [Bio/Phylo.pm, 281] - setting name 'E'
339              
340             =head1 DESCRIPTION
341              
342             This class defines a logger, a utility object for logging messages.
343             The other objects in Bio::Phylo use this logger to give detailed feedback
344             about what they are doing at per-class, per-method, user-configurable log levels
345             (DEBUG, INFO, WARN, ERROR and FATAL). These log levels are constants that are
346             optionally exported by this class by passing the ':levels' argument to your
347             'use' statement, like so:
348              
349             use Bio::Phylo::Util::Logger ':levels';
350              
351             If for some reason you don't want this behaviour (i.e. because there is
352             something else by these same names in your namespace) you must use the fully
353             qualified names for these levels, i.e. Bio::Phylo::Util::Logger::DEBUG and
354             so on.
355              
356             The least verbose is level FATAL, in which case only 'fatal' messages are shown.
357             The most verbose level, DEBUG, shows debugging messages, including from internal
358             methods (i.e. ones that start with underscores, and special 'ALLCAPS' perl
359             methods like DESTROY or TIEARRAY). For example, to monitor what the root class
360             is doing, you would say:
361              
362             $logger->( -class => 'Bio::Phylo', -level => DEBUG )
363              
364             To define global verbosity you can omit the -class argument. To set verbosity
365             at a more granular level, you can use the -method argument, which takes a
366             fully qualified method name such as 'Bio::Phylo::set_name', such that messages
367             originating from within that method's body get a different verbosity level.
368              
369             =head1 METHODS
370              
371             =head2 CONSTRUCTOR
372              
373             =over
374              
375             =item new()
376              
377             Constructor for Logger.
378              
379             Type : Constructor
380             Title : new
381             Usage : my $logger = Bio::Phylo::Util::Logger->new;
382             Function: Instantiates a logger
383             Returns : a Bio::Phylo::Util::Logger object
384             Args : -level => Bio::Phylo::Util::Logger::INFO (DEBUG/INFO/WARN/ERROR/FATAL)
385             -class => a package (or array ref) for which to set verbosity (optional)
386             -method => a sub name (or array ref) for which to set verbosity (optional)
387             -file => a file to which to append logging messages
388             -listeners => array ref of subs that handle logging messages
389             -prefix => a path fragment to strip from the paths in logging messages
390            
391              
392             =back
393              
394             =head2 VERBOSITY LEVELS
395              
396             =over
397              
398             =item FATAL
399              
400             Rarely happens, usually an exception is thrown instead.
401              
402             =item ERROR
403              
404             If this happens, something is seriously wrong that needs to be addressed.
405              
406             =item WARN
407              
408             If this happens, something is seriously wrong that needs to be addressed.
409              
410             =item INFO
411              
412             If something weird is happening, turn up verbosity to this level as it might
413             explain some of the assumptions the code is making.
414              
415             =item DEBUG
416              
417             This is very verbose, probably only useful if you write core Bio::Phylo code.
418              
419             =back
420              
421             =head2 LOGGING METHODS
422              
423             =over
424              
425             =item debug()
426              
427             Prints argument debugging message, depending on verbosity.
428              
429             Type : logging method
430             Title : debug
431             Usage : $logger->debug( "debugging message" );
432             Function: prints debugging message, depending on verbosity
433             Returns : invocant
434             Args : logging message
435              
436             =item info()
437              
438             Prints argument informational message, depending on verbosity.
439              
440             Type : logging method
441             Title : info
442             Usage : $logger->info( "info message" );
443             Function: prints info message, depending on verbosity
444             Returns : invocant
445             Args : logging message
446              
447             =item warn()
448              
449             Prints argument warning message, depending on verbosity.
450              
451             Type : logging method
452             Title : warn
453             Usage : $logger->warn( "warning message" );
454             Function: prints warning message, depending on verbosity
455             Returns : invocant
456             Args : logging message
457              
458             =item error()
459              
460             Prints argument error message, depending on verbosity.
461              
462             Type : logging method
463             Title : error
464             Usage : $logger->error( "error message" );
465             Function: prints error message, depending on verbosity
466             Returns : invocant
467             Args : logging message
468              
469             =item fatal()
470              
471             Prints argument fatal message, depending on verbosity.
472              
473             Type : logging method
474             Title : fatal
475             Usage : $logger->fatal( "fatal message" );
476             Function: prints fatal message, depending on verbosity
477             Returns : invocant
478             Args : logging message
479              
480             =item set_listeners()
481              
482             Adds listeners to send log messages to.
483              
484             Type : Mutator
485             Title : set_listeners()
486             Usage : $logger->set_listeners( sub { warn shift } )
487             Function: Sets additional listeners to log to (e.g. a file)
488             Returns : invocant
489             Args : One or more code references
490             Comments: On execution of the listeners, the @_ arguments are:
491             $log_string, # the formatted log string
492             $level, # log level, i.e DEBUG, INFO, WARN, ERROR or FATAL
493             $subroutine, # the calling subroutine
494             $filename, # filename where log method was called
495             $line, # line where log method was called
496             $msg # the unformatted message
497              
498             =item start_color()
499              
500             Changes color of output stream to that of specified logging level. This so that for
501             example all errors are automatically marked up as 'FATAL', or all output generated
502             by an external program is marked up as 'DEBUG'
503              
504             Type : Mutator
505             Title : start_color()
506             Usage : $logger->start_color( 'DEBUG', \*STDOUT )
507             Function: Changes color of output stream
508             Returns : color name
509             Args : Log level whose color to use,
510             (optional) which stream to change, default is STDERR
511              
512             =item stop_color()
513              
514             Resets the color initiated by start_color()
515              
516             Type : Mutator
517             Title : stop_color()
518             Usage : $logger->stop_color( \*STDOUT )
519             Function: Changes color of output stream
520             Returns : color name
521             Args : (Optional) which stream to reset, default is STDERR
522              
523              
524             =item PREFIX()
525              
526             Getter and setter of path prefix to strip from source file paths in messages.
527             By default, messages will have a field such as C<[$PREFIX/Bio/Phylo.pm, 280]>,
528             which indicates the message was sent from line 280 in file Bio/Phylo.pm inside
529             path $PREFIX. This is done so that your log won't be cluttered with
530             unnecessarily long paths. To find out what C<$PREFIX> is set to, call the
531             PREFIX() method on the logger, and to change it provide a path argument
532             relative to which the paths to source files will be constructed.
533              
534             Type : Mutator/Accessor
535             Title : PREFIX()
536             Usage : $logger->PREFIX( '/path/to/bio/phylo' )
537             Function: Sets/gets $PREFIX
538             Returns : Verbose level
539             Args : Optional: a path
540             Comments:
541              
542             =item VERBOSE()
543              
544             Setter for the verbose level. This comes in five levels:
545              
546             FATAL = only fatal messages (though, when something fatal happens, you'll most
547             likely get an exception object),
548            
549             ERROR = errors (hopefully recoverable),
550            
551             WARN = warnings (recoverable),
552            
553             INFO = info (useful diagnostics),
554            
555             DEBUG = debug (almost every method call)
556              
557             Without additional arguments, i.e. by just calling VERBOSE( -level => $level ),
558             you set the global verbosity level. By default this is 2. By increasing this
559             level, the number of messages quickly becomes too great to make sense out of.
560             To focus on a particular class, you can add the -class => 'Some::Class'
561             (where 'Some::Class' stands for any of the class names in the Bio::Phylo
562             release) argument, which means that messages originating from that class will
563             have a different (presumably higher) verbosity level than the global level.
564             By adding the -method => 'Fully::Qualified::method_name' (say,
565             'Bio::Phylo::set_name'), you can change the verbosity of a specific method. When
566             evaluating whether or not to transmit a message, the method-specific verbosity
567             level takes precedence over the class-specific level, which takes precedence
568             over the global level.
569              
570             Type : Mutator
571             Title : VERBOSE()
572             Usage : $logger->VERBOSE( -level => $level )
573             Function: Sets/gets verbose level
574             Returns : Verbose level
575             Args : -level => 4 # or lower
576            
577             # optional, or any other class
578             -class => 'Bio::Phylo'
579            
580             # optional, fully qualified method name
581             -method' => 'Bio::Phylo::set_name'
582              
583             =back
584              
585             =head1 SEE ALSO
586              
587             There is a mailing list at L<https://groups.google.com/forum/#!forum/bio-phylo>
588             for any user or developer questions and discussions.
589              
590             Also see the manual: L<Bio::Phylo::Manual> and L<http://rutgervos.blogspot.com>.
591              
592             =head1 CITATION
593              
594             If you use Bio::Phylo in published research, please cite it:
595              
596             B<Rutger A Vos>, B<Jason Caravas>, B<Klaas Hartmann>, B<Mark A Jensen>
597             and B<Chase Miller>, 2011. Bio::Phylo - phyloinformatic analysis using Perl.
598             I<BMC Bioinformatics> B<12>:63.
599             L<http://dx.doi.org/10.1186/1471-2105-12-63>
600              
601             =cut