view release on metacpan or  search on metacpan

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

	);	
	@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;
	}