view release on metacpan or  search on metacpan

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

    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
    sub LOG ($$) {
        my ( $message, $level ) = @_;
        no warnings 'uninitialized';
        
        # probe the call stack
        my ( $pack2, $file2, $line2, $sub  ) = caller( $TRACEBACK + 2 );
        my ( $pack1, $file,  $line,  $sub1 ) = caller( $TRACEBACK + 1 );
        
        # cascade verbosity from global to local
        my $verbosity = $VERBOSITY{'*'}; # global
        $verbosity = $VERBOSITY{$pack1} if exists $VERBOSITY{$pack1}; # package
        $verbosity = $VERBOSITY{$sub}  if $sub and exists $VERBOSITY{$sub}; # sub
        
        # verbosity is higher than the current caller, proceed
        if ( $verbosity >= $levels{$level} ) {            

            # strip the prefix from the calling file's path
            if ( index($file, $PREFIX) == 0 ) {
                $file =~ s/^\Q$PREFIX\E//;
            }
            
            # select one of the templates
            my $string;
            my $s = $STYLE{$STYLE};
            $string = eval "qq[$s\n]";
            
            # dispatch to the listeners
            $_->( $string, $level, $sub, $file, $line, $message ) for @listeners;
        }       
    }
    
    # these subs both return their verbosity constants and, if
    # provided with a message, dispatch the message to LOG()
    sub FATAL (;$) { LOG $_[0], 'FATAL' if $_[0]; $levels{'FATAL'} } 
    sub ERROR (;$) { LOG $_[0], 'ERROR' if $_[0]; $levels{'ERROR'} }
    sub WARN  (;$) { LOG $_[0], 'WARN'  if $_[0]; $levels{'WARN'}  }
    sub INFO  (;$) { LOG $_[0], 'INFO'  if $_[0]; $levels{'INFO'}  }
    sub DEBUG (;$) { LOG $_[0], 'DEBUG' if $_[0]; $levels{'DEBUG'} } 

    sub PREFIX {
        my ( $class, $prefix ) = @_;
        $PREFIX = $prefix if $prefix;
        return $PREFIX;
    }

    sub VERBOSE {
        shift if ref $_[0] or $_[0] eq __PACKAGE__;
        if (@_) {
            my %opt = looks_like_hash @_;
            my $level = $opt{'-level'};
            
            # verbosity is specified
            if ( defined $level ) {

                # check validity
                if ( $level > 4 xor $level < 0 ) {
                    throw 'OutOfBounds' => "'-level' can be between 0 and 4, not $level";
                }
                
                # verbosity is specified for one or more packages
                if ( my $class = $opt{'-class'} ) {
                    if ( ref $class eq 'ARRAY' ) {
                        for my $c ( @{ $class } ) {
                            $VERBOSITY{$c} = $level;
                            INFO "Changed verbosity for class $c to $level";
                        }
                    }
                    else {
                        $VERBOSITY{$class} = $level;