view release on metacpan or  search on metacpan

lib/Bio/Phylo/Util/Logger.pm  view on Meta::CPAN

package Bio::Phylo::Util::Logger;
use strict;
use warnings;
use base 'Exporter';
use Term::ANSIColor;
use Bio::Phylo::Util::Exceptions 'throw';
use Bio::Phylo::Util::CONSTANT qw'/looks_like/';

our ( %VERBOSITY, $PREFIX, %STYLE );
our $STYLE       = 'detailed';
our $COLORED     = 1; # new default: we use colors
our $TRACEBACK   = 0;
our @EXPORT_OK   = qw(DEBUG INFO WARN ERROR FATAL VERBOSE);
our %EXPORT_TAGS = ( 'simple' => [@EXPORT_OK], 'levels' => [@EXPORT_OK] );
our %COLORS      = (
	'DEBUG' => 'blue', 
	'INFO'  => 'green',
	'WARN'  => 'yellow',
	'ERROR' => 'bold red',
	'FATAL' => 'red',
);

BEGIN {
    
    # compute the path to the root of Bio::Phylo,
    # use that as the default prefix
    my $package = __PACKAGE__;
    my $file    = __FILE__;
    $package    =~ s/::/\//g;
    $package   .= '.pm';
    $file       =~ s/\Q$package\E$//;
    $PREFIX     = $file;
    
    # set verbosity to 2, i.e. warn
    $VERBOSITY{'*'} = $ENV{'BIO_PHYLO_VERBOSITY'} || 2;
    
    # define verbosity styles
    %STYLE = (
    	'simple'   => '${level}: $message',
    	'detailed' => '$level $sub [$file $line] - $message',    
    );
}

{
    my %levels = ( FATAL => 0, ERROR => 1, WARN => 2, INFO => 3, DEBUG => 4 );
    my @listeners = ( sub {
    	my ( $string, $level ) = @_;
    	if ( $COLORED and -t STDERR ) {
    		print STDERR colored( $string, $COLORS{$level} ); 
    	}
    	else {
    		print STDERR $string;
    	}
    } ); # default

    # dummy constructor that dispatches to VERBOSE(),
    # then returns the package name
    sub new {
        my $class = shift;
        $class->VERBOSE(@_) if @_;
        return $class;
    }

    # set additional listeners
    sub set_listeners {
        my ( $class, @args ) = @_;
        for my $arg (@args) {
            if ( looks_like_instance $arg, 'CODE' ) {
                push @listeners, $arg;
            }
            else {
                throw 'BadArgs' => "$arg not a CODE reference";
            }
        }
        return $class;
    }
    
    # this is never called directly. rather, messages are dispatched here
    # by the DEBUG() ... FATAL() subs below