view release on metacpan or  search on metacpan

lib/Algorithm/Genetic/Diploid/Logger.pm  view on Meta::CPAN

		if ( 'simple' eq lc $arg ) {
			$formatter = \&_simple_formatter;
		}
		elsif ( 'medium' eq lc $arg ) {
			$formatter = \&_medium_formatter;
		}
		elsif ( 'verbose' eq lc $arg ) {
			$formatter = \&_verbose_formatter;
		}
	}
}

# destructor does nothing
sub DESTROY {}

=back

=head1 VERBOSITY LEVELS

The following constants are available when using this package with the use qualifier
':levels', i.e. C<use Algorithm::Genetic::Diploid::Logger ':levels';>. They represent
different verbosity levels that can be set globally, and/or at package level, and/or
at method level.

=over

=item FATAL

Only most severe messages are transmitted.

=cut

sub FATAL () { 0 }

=item ERROR

Possibly unrecoverable errors are transmitted.

=cut

sub ERROR () { 1 }

=item WARN

Warnings are transmitted. This is the default.

=cut

sub WARN ()  { 2 }

=item INFO

Informational messages are transmitted.

=cut

sub INFO ()  { 3 }

=item DEBUG

Everything is transmitted, including debugging messages.

=cut

sub DEBUG () { 4 }

# constants mapped to string for AUTOLOAD
my %levels = (
	'fatal' => FATAL,
	'error' => ERROR,
	'warn'  => WARN,
	'info'  => INFO,
	'debug' => DEBUG,
);

sub _simple_formatter {
	my %args = @_;
	my ( $level, $sub, $file, $line, $msg ) = @args{('level','sub','file','line','msg')};
	return sprintf "%s %s\n", $level, $msg;
}

sub _verbose_formatter {
	my %args = @_;
	my ( $level, $sub, $file, $line, $msg ) = @args{('level','sub','file','line','msg')};
	return sprintf "%s %s [%s, %s] - %s\n", $level, $sub, $file, $line, $msg;
}

sub _medium_formatter {
	my %args = @_;
	my ( $level, $sub, $file, $line, $msg ) = @args{('level','sub','file','line','msg')};
	return sprintf "%s %s [%s] - %s\n", $level, $sub, $line, $msg;
}

# this is where methods such as $log->info ultimately are routed to
sub AUTOLOAD {
	my ( $self, $msg ) = @_;
	my $method = $AUTOLOAD;
	$method =~ s/.+://;
	
	# only proceed if method was one of fatal..debug
	if ( exists $levels{$method} ) {
		my ( $package, $file1up, $line1up, $subroutine ) = caller( 1 );
		my ( $pack0up, $filename, $line, $sub0up )       = caller( 0 );
		
		# calculate what the verbosity is for the current context
		# (either at sub, package or global level)
		my $verbosity;
		if ( exists $VERBOSE{$subroutine} ) {
			$verbosity = $VERBOSE{$subroutine};
		}
		elsif ( exists $VERBOSE{$pack0up} ) {
			$verbosity = $VERBOSE{$pack0up};
		}
		else {
			$verbosity = $VERBOSE;
		}
		
		# we need to do something with the message
		if ( $verbosity >= $levels{$method} ) {
			printf STDERR $formatter->( 
				'level' => uc $method, 
				'sub'   => $subroutine, 
				'file'  => $filename, 
				'line'  => $line, 
				'msg'   => $msg,
			);
		}
	}
}

=back

=cut

1;