File Coverage

blib/lib/Bio/NEXUS/Util/Logger.pm

Criterion	Covered	Total	%
statement	48	78	61.5
branch	14	34	41.1
condition	1	8	12.5
subroutine	9	13	69.2
pod	5	5	100.0
total	77	138	55.8

package Bio::NEXUS::Util::Logger;
use strict;
#use warnings;
use File::Spec;
use Bio::NEXUS::Util::Exceptions 'throw';
use Config;
use vars qw($volume $class_dir $file $VERBOSE $AUTOLOAD);

BEGIN {
	my $class_file = __FILE__;
	( $volume, $class_dir, $file ) = File::Spec->splitpath( $class_file );
	$class_dir =~ s/Bio.NEXUS.Util.?$//;
	#printf "[ %s starting, will use PREFIX=%s where applicable ]\n", __PACKAGE__, $class_dir;
}

{
	my $self;
	my %VERBOSE;
	my %LEVEL;
	my @listeners = (
		sub {
			my $msg = shift;
			print STDERR $msg;
		}
	);
	@LEVEL{ qw(FATAL ERROR WARN INFO DEBUG) } = ( 0 .. 4 );
	$VERBOSE = $LEVEL{'WARN'};

	sub new {
		my $package = shift;
		my %args;

		# singleton object
		if ( not $self ) {
			$self = \$package;
			bless $self, $package;
		}

		# process args
		if (@_) {

			# create hash
			eval { %args = @_ };
			if ($@) {
				throw 'OddHash' => $@;
			}
		}

		# set level
		if ( defined $args{'-level'} ) {

			# check validity
			if ( $args{'-level'} > $LEVEL{'DEBUG'} xor $args{'-level'} < $LEVEL{'FATAL'} ) {
				throw 'OutOfBounds' => "'-level' can be between $LEVEL{'FATAL'} and $LEVEL{'DEBUG'}, $args{'-level'} is outside that range";
			}
			else {
				if ( $args{'-class'} ) {
					$VERBOSE{$args{'-class'}} = $args{'-level'};
				}
				else {
					$VERBOSE = $args{'-level'};
				}
			}
		}

		# done
		return $self;
	}

	sub set_listeners {
		my ( $self, @args ) = @_;
		for my $arg ( @args ) {
			if ( UNIVERSAL::isa( $arg, 'CODE' ) ) {
				push @listeners, $arg;
			}
			else {
				throw 'BadArgs' => "$arg not a CODE reference";
			}
		}
		return $self;
	}

	sub log {
		my ( $self, $level, $msg ) = @_;
		my ( $package, $file1up,  $line1up, $subroutine ) = caller(2);
		my ( $pack0up, $filename, $line,    $sub0up )     = caller(1);
		my $verbosity = exists $VERBOSE{$pack0up} ? $VERBOSE{$pack0up} : $VERBOSE;
		if ( $verbosity >= $LEVEL{$level} ) {
			my $log_string;
			if ( $filename =~ s/\Q$class_dir\E// ) {
				$log_string = sprintf( "%s %s [\$PREFIX/%s, %s] - %s\n",
				$level, $subroutine, $filename, $line, $msg );
			}
			else {
				$log_string = sprintf( "%s %s [%s, %s] - %s\n",
				$level, $subroutine, $filename, $line, $msg );
			}
			$_->( $log_string ) for @listeners;
		}
		return $self;
	}

	sub AUTOLOAD {
		my ( $self, $msg ) = @_;
		my $method = $AUTOLOAD;
		$method =~ s/.*://;
		$method = uc $method;
		if ( exists $LEVEL{$method} ) {
			$self->log( $method, $msg );
		}
	}

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

	sub VERBOSE {
		my $self = shift;
		if (@_) {
			my %opt;
			eval { %opt = @_ };
			if ($@) {
				throw 'OddHash' => $@;
			}
			if ( defined $opt{'-level'} ) {

				# check validity
				if ( $opt{'-level'} > $LEVEL{'DEBUG'} xor $opt{'-level'} < $LEVEL{'FATAL'} ) {
					throw 'OutOfBounds' => "'-level' can be between $LEVEL{'FATAL'} and $LEVEL{'DEBUG'}, not $opt{'-level'}";
				}

				if ( $opt{'-class'} ) {
					$VERBOSE{ $opt{'-class'} } = $opt{'-level'};
					$self->info("Changed verbosity for $opt{'-class'} to $opt{'-level'}");
				}
				else {
					$VERBOSE = $opt{'-level'};
					$self->info("Changed global verbosity to $VERBOSE");
				}
			}
		}
		return $VERBOSE;
	}

	sub DESTROY {} # empty destructor so we don't go up inheritance tree at the end

}

1;

=head1 NAME

Bio::NEXUS::Util::Logger - Logging for Bio::NEXUS.

=head1 SYNOPSIS

 use Bio::NEXUS::Util::Logger;

 # can instantiate as (singleton) object, in this case telling it that only
 # messages from Bio::NEXUS::Forest with log level >= 3 are displayed...
 my $logger->new( -level => 3, -class => 'Bio::NEXUS::Matrix' );


 #...or use static...
 Bio::NEXUS::Util::Logger->info("Log level too low for this to be printed");
 Bio::NEXUS::Matrix->VERBOSE( -level => 2 );
 Bio::NEXUS::Util::Logger->info("Not any more, now we're talking");


=head1 DESCRIPTION

This class defines a logger, a utility object for logging messages.
The other objects in Bio::NEXUS use this logger to give detailed feedback
about what they are doing at per-class, user-configurable log levels
(debug, info, warn, error and fatal). You can tell the logger for each
class how verbose to be. The least verbose is level 0, in which case only
'fatal' messages are shown. The most verbose level, 4, shows debugging
messages, include from internal methods (i.e. ones that start with
underscores, and special 'ALLCAPS' perl methods like DESTROY or TIEARRAY).
For example, to monitor what the root class is
doing, you would say:

 $logger->( -class => 'Bio::NEXUS', -level => 4 )

To define global verbosity you can omit the -class argument.

=head1 METHODS

=head2 CONSTRUCTOR

=over

=item new()

Constructor for Logger.

 Type    : Constructor
 Title   : new
 Usage   : my $logger = Bio::NEXUS::Util::Logger->new;
 Function: Instantiates a logger
 Returns : a Bio::NEXUS::Util::Logger object
 Args    : -verbose => verbosity, 0 .. 4 (optional)
 		   -package => a package for which to set verbosity (optional)

=back

head2 LOGGING METHODS

=over

=item log()

Prints argument debugging message, depending on verbosity.

 Type    : logging method
 Title   : log
 Usage   : $logger->log( "WARN", "warning message" );
 Function: prints logging message, depending on verbosity
 Returns : invocant
 Args    : message log level, logging message

=item debug()

Prints argument debugging message, depending on verbosity.

 Type    : logging method
 Title   : debug
 Usage   : $logger->debug( "debugging message" );
 Function: prints debugging message, depending on verbosity
 Returns : invocant
 Args    : logging message

=item info()

Prints argument informational message, depending on verbosity.

 Type    : logging method
 Title   : info
 Usage   : $logger->info( "info message" );
 Function: prints info message, depending on verbosity
 Returns : invocant
 Args    : logging message

=item warn()

Prints argument warning message, depending on verbosity.

 Type    : logging method
 Title   : warn
 Usage   : $logger->warn( "warning message" );
 Function: prints warning message, depending on verbosity
 Returns : invocant
 Args    : logging message

=item error()

Prints argument error message, depending on verbosity.

 Type    : logging method
 Title   : error
 Usage   : $logger->error( "error message" );
 Function: prints error message, depending on verbosity
 Returns : invocant
 Args    : logging message

=item fatal()

Prints argument fatal message, depending on verbosity.

 Type    : logging method
 Title   : fatal
 Usage   : $logger->fatal( "fatal message" );
 Function: prints fatal message, depending on verbosity
 Returns : invocant
 Args    : logging message

=item set_listeners()

Adds listeners to send log messages to.

 Type    : Mutator
 Title   : set_listeners()
 Usage   : Bio::NEXUS::Util::Logger->set_listeners( sub { warn shift } )
 Function: Sets additional listeners to log to (e.g. a file)
 Returns : invocant
 Args    : One or more code references
 Comments: On execution of the listeners, the first (and only) argument
           is the log message.

=item PREFIX()

Getter and setter of path prefix to strip from source file paths in messages.

 Type    : Mutator/Accessor
 Title   : PREFIX()
 Usage   : Bio::NEXUS::Util::Logger->PREFIX( '/path/to/Bio/NEXUS' )
 Function: Sets/gets $PREFIX
 Returns : Verbose level
 Args    : Optional: a path
 Comments:

=item VERBOSE()

Setter for the verbose level. This comes in five levels: 0 = only
fatal messages (though, when something fatal happens, you'll most likely get
an exception object), 1 = errors (hopefully recoverable), 2 = warnings
(recoverable), 3 = info (useful diagnostics), 4 = debug (almost every method call)

 Type    : Mutator
 Title   : VERBOSE()
 Usage   : Bio::NEXUS::Util::Logger->VERBOSE( -level => $level )
 Function: Sets/gets verbose level
 Returns : Verbose level
 Args    : 0 <= $level && $level <= 4
 Comments:

=back

=head1 REVISION

 $Id: Logger.pm,v 1.3 2010/09/22 20:05:51 astoltzfus Exp $

=cut