package Easy::Log; # -t STDOUT -t STDERR ??? my $prefix_dev_backstack = 2; use Easy::Log::Filter; my $filter_file; our $this_package; BEGIN { # this little but of cruft really sucks, but neither 'require' nor 'do' are bahaving as I would expect(akin to a c #include) #require '/home/lengthe/cvs/adg/util/general/Log/Filter.pm'; #require Easy::Log::Filter; #do Easy::Log::Filter; $filter_file = __PACKAGE__ eq 'Easy::Log' ? __FILE__ : ( $INC{'Easy/Log.pm'} or die "Couldn't find location of Easy/Log.pm package" ); $filter_file =~ s|Log.pm|Log/Filter.pm|; print STDERR "filter_file=$filter_file\n" if $ENV{LOG_FILTER_DEBUG}; my $eval = 'package ' . __PACKAGE__ . ';'; # this is somewhat evil, but I need to do it to get filtering in THIS package, as well as packages that use this package open(FILTER, "<$filter_file") or die $!; $eval .= '#' . join("", ); #`cat $filter_file`; # the '#' here comments out the first line of the filter package 'package Easy::Log::Filter;' close FILTER; $eval =~ /(.*)/ms; # for untainting in case taint mode is on $eval = $1; print STDERR "EVAL:#########################\n$eval\n########################\n" if $ENV{LOG_FILTER_DEBUG}; eval "{ $eval }"; (print STDERR '$this_package: ', $this_package, '(', __PACKAGE__, ')', "\n") if $ENV{LOG_FILTER_DEBUG}; $@ and die $@; #die; } # use strict; use Data::Dumper; use IO::File; use Fcntl qw(:flock); use Carp qw( cluck confess ); use File::Spec; if ( $ENV{LOG_USE_CARP} and $ENV{LOG_USE_CARP} eq 'YES' ) { # big ugly stack traces when we encounter a 'warn' or a 'die' $SIG{__WARN__} = \&cluck; $SIG{__DIE__} = \&confess; } use Exporter; our ( %EXPORT_TAGS, @ISA, @EXPORT_OK, @EXPORT, $VERSION ); @ISA = qw( Exporter ); $VERSION = '0.02_01'; %EXPORT_TAGS = ( # available constants for log level text names, these will never be filtered nor will warnings about them ever be made # basically, these are for production level logging (as opposed to the 'shorthand' log levels below in "log_level_[not_]filtered" # as such they can still be used to put the program in DEBUG mode (etc), but for more formalized debugging #log_level => [ Easy::Log::Filter->LOG_LEVELS() ], log_level => [ LOG_LEVELS() ], # global logging object log => [ qw( $log log ) ], # convenient log level aliases that WILL BE FILTERED if appropriate (MUST begin with a $ [eg regular SCALAR variable] #log_level_filtered => [ map { "\$$_" } Easy::Log::Filter->DEFAULT_FILTER() ], ll_filtered => [ map { "\$$_" } DEFAULT_FILTER() ], # same as above, but without '$', these will not be filtered, but if $ENV{WARN_FILTER} is set, warnings about unfiltered log messages will show up # this is useful for debugging when you may want a particular message to be displayed (simply delete the '$') #log_level_not_filtered => [ Easy::Log::Filter->DEFAULT_FILTER() ], ll_not_filtered => [ DEFAULT_FILTER() ], # these are utility methods for output formatting misc => [ qw(space pad dump _caller $hostname ) ], ); $EXPORT_TAGS{all} = [ map {@{$_}} values %EXPORT_TAGS ]; $EXPORT_TAGS{initialize} = [ @{$EXPORT_TAGS{log_level}} ]; $EXPORT_TAGS{basic} = [ map { @{$EXPORT_TAGS{$_}} } qw( log_level log ll_filtered ll_not_filtered) ]; @EXPORT_OK = @{$EXPORT_TAGS{'all'}}; @EXPORT = (); use constant MESSAGE => 'MESSAGE'; # this will send an email to the appointed person use constant DEFAULT => 'DEFAULT'; use constant LOUD => 'LOUD'; use constant CLEAN => 'CLEAN'; use constant EMERG => 'EMERG'; use constant ALERT => 'ALERT'; use constant QUIT => 'QUIT'; use constant EXIT => 'QUIT'; # synonym for QUIT use constant CRIT => 'CRIT'; use constant FATAL => 'FATAL'; # synonym for CRIT use constant FAIL => 'FAIL'; # synonym for CRIT use constant ERROR => 'ERROR'; use constant WARN => 'WARN'; use constant NOTICE => 'NOTICE'; use constant INFO => 'INFO'; use constant DEBUG99 => 'DEBUG99'; use constant DEBUG9 => 'DEBUG9'; use constant DEBUG8 => 'DEBUG8'; use constant DEBUG7 => 'DEBUG7'; use constant DEBUG6 => 'DEBUG6'; use constant DEBUG5 => 'DEBUG5'; use constant DEBUG4 => 'DEBUG4'; use constant DEBUG3 => 'DEBUG3'; use constant DEBUG2 => 'DEBUG2'; use constant DEBUG1 => 'DEBUG1'; use constant DEBUG0 => 'DEBUG0'; use constant DEBUG => 'DEBUG'; use constant TRACE => 'TRACE'; use constant SPEW => 'SPEW'; use constant D_MESSAGE => 'D_MESSAGE'; # this will send an email to the appointed person use constant D_DEFAULT => 'D_DEFAULT'; use constant D_LOUD => 'D_LOUD'; use constant D_CLEAN => 'D_CLEAN'; use constant D_EMERG => 'D_EMERG'; use constant D_ALERT => 'D_ALERT'; use constant D_CRIT => 'D_CRIT'; use constant D_FATAL => 'D_FATAL'; use constant D_FAIL => 'D_FAIL'; use constant D_QUIT => 'D_QUIT'; use constant D_EXIT => 'D_EXIT'; use constant D_ERROR => 'D_ERROR'; use constant D_WARN => 'D_WARN'; use constant D_NOTICE => 'D_NOTICE'; use constant D_INFO => 'D_INFO'; use constant D_DEBUG99 => 'D_DEBUG99'; use constant D_DEBUG9 => 'D_DEBUG9'; use constant D_DEBUG8 => 'D_DEBUG8'; use constant D_DEBUG7 => 'D_DEBUG7'; use constant D_DEBUG6 => 'D_DEBUG6'; use constant D_DEBUG5 => 'D_DEBUG5'; use constant D_DEBUG4 => 'D_DEBUG4'; use constant D_DEBUG3 => 'D_DEBUG3'; use constant D_DEBUG2 => 'D_DEBUG2'; use constant D_DEBUG1 => 'D_DEBUG1'; use constant D_DEBUG0 => 'D_DEBUG0'; use constant D_DEBUG => 'D_DEBUG'; use constant D_TRACE => 'D_TRACE'; use constant D_SPEW => 'D_SPEW'; # the following, when used as log levels in code calling this package with qw(:all) # these may not be worth the clutter # I have also made identically named scalars which if used will cause the log messages to be filtered out # WARNING: without the `$' the log message WILL NOT be filtered out! use constant ll => D_DEFAULT; use constant mll => D_MESSAGE; use constant lll => D_LOUD; use constant cll => D_CLEAN; use constant qll => D_QUIT; use constant ell => D_ERROR; use constant all => D_ALERT; use constant wll => D_WARN; use constant nll => D_NOTICE; use constant ill => D_INFO; use constant dl99 => D_DEBUG99; use constant dl9 => D_DEBUG9; use constant dl8 => D_DEBUG8; use constant dl7 => D_DEBUG7; use constant dl6 => D_DEBUG6; use constant dl5 => D_DEBUG5; use constant dl4 => D_DEBUG4; use constant dl3 => D_DEBUG3; use constant dl2 => D_DEBUG2; use constant dl1 => D_DEBUG1; use constant dl0 => D_DEBUG0; use constant dll => D_DEBUG; use constant tll => D_TRACE; use constant sll => D_SPEW; our ( $p_space, $p_pad ) = ( 8, 8 ); our $STACK_TRACE = $ENV{LOG_STACK_TRACE} || 0; our ( $DUMPER, $log_level, $log, $intlog ); # if we have big warngings set to true for any particular log level then we'll issue a perl 'warn'ing our %BIG_WARN_DEFAULTS = ( ( map { ("DEBUG$_" => 0); } ( 0 .. 9 ) ), ( map { ($_ => 0);} qw( MESSAGE LOUD CLEAN QUIT EXIT EMERG ALERT CRIT FATAL FAIL ERROR WARN NOTICE INFO DEBUG TRACE SPEW ) ), ( qw( WARN 0 ERROR 0 CRIT 1 FATAL 1 FAIL 0 ) ) ); #our %BIG_WARN_ON = map { print STDERR qq'BIG_WARN_ON_$_ => ', ( defined $ENV{"BIG_WARN_ON_$_"} ? $ENV{"BIG_WARN_ON_$_"} : 'undef' ), "\n"; ( $_ => ( defined $ENV{"BIG_WARN_ON_$_"} ? $ENV{"BIG_WARN_ON_$_"} : ( $BIG_WARN_DEFAULTS{$_} || 0 ) )); } keys %BIG_WARN_DEFAULTS; our %BIG_WARN_ON = map { ( $_ => ( defined $ENV{"BIG_WARN_ON_$_"} ? $ENV{"BIG_WARN_ON_$_"} : ( $BIG_WARN_DEFAULTS{$_} || 0 ) )); } keys %BIG_WARN_DEFAULTS; # these were(are?) actually apache constants for logging levels I think anything that gets in that # is preceded with a '_' gets [0] (numerical value) these return the uppercase(?) version of # themselves our %LOG_CODE = ( STDERR => 0x00E0, STDOUT => 0x00E0, CLEAN => 0x00E0, MESSAGE => 0x00E0, LOUD => 0x00E0, CRIT => 0x00E0, FATAL => 0x00E0, FAIL => 0x00E0, QUIT => 0x00E0, EXIT => 0x00E0,# synonym for QUIT EMERG => 0x00E0, ALERT => 0x0080, ERROR => 0x0070, WARN => 0x0060, NOTICE => 0x0050, INFO => 0x0040, DEBUG99 => 0x0040, # this is the same as INFO, but will cause the line number and package to be printed with EVERY log call if LOG_LEVEL is set to anything that matched '.*DEBUG.*' (map { ("DEBUG$_" => ( 0x0030 + $_ )); } ( 0 .. 9 )), DEBUG => 0x0030, TRACE => 0x0020, SPEW => 0x0010, DEFAULT => 0x0030,# set equal to DEBUG ); # translate between our more expanded selection of logging levels to what apache understands our %APACHE_LEVELS = ( DEFAULT => INFO, TRACE => DEBUG, SPEW => DEBUG, DEBUG => DEBUG, (map { ("DEBUG$_" => 'DEBUG'); } ( 0 .. 9, 99 )), INFO => INFO, WARN => WARN, NOTICE => NOTICE, CRIT => CRIT, FATAL => CRIT, FAIL => CRIT, QUIT => CRIT, EXIT => CRIT, ERROR => ERROR, ALERT => ALERT, EMERG => EMERG, LOUD => ERROR, CLEAN => ERROR, ); our ( $ll, $lll, $qll, $cll, $ell, $all, $wll, $nll, $ill, $dll, $tll, $sll, $mll, $dl0, $dl1, $dl2, $dl3, $dl4, $dl5, $dl6, $dl7, $dl8, $dl9, $dl99 ) = ( ll, lll, qll, cll, ell, all, wll, nll, ill, dll, tll, sll, mll, dl0, dl1, dl2, dl3, dl4, dl5, dl6, dl7, dl8, dl9, dl99 ); our $n; our %LEVEL_FHS = map { ($_ => 'STDERR'); } qw(EMERG ALERT CRIT FATAL FAIL ERROR WARN QUIT); #%ALWAYS_LOG is for log levels that should never be dropped, even if the package is blocked from logging our %ALWAYS_LOG = qw( CLEAN 1 CRIT 1 FATAL 1 FAIL 1 QUIT 1 ERROR 1 ALERT 1 EMERG 1 MESSAGE 1 STDOUT 1 STDERR 1 ); foreach my $log_level ( LOG_LEVELS ) { $ALWAYS_LOG{$log_level} ||= 0; } our $default_log_level = 'INFO'; our $default_indent = 1; our $default_pad = 0; $log_level = $ENV{LOG_LEVEL} ||= ( [ map {$ENV{$_}?$_:()}(@{$EXPORT_TAGS{log_level}}) ]->[0] || $default_log_level ); # message terminator (sometimes we DON'T want newlines!) our $default_handle_fatals = 1; our $default_unbuffer = 1; our $default_fh = $ENV{LOG_FILE_DEFAULT} || $ENV{DEFAULT_LOG_FILE} || 'STDOUT'; our %init = ( log_file => $ENV{LOG_FILE} || $default_fh , log_level => $log_level, dump_refs => (exists $ENV{LOG_DUMP_REFS} ) ? $ENV{LOG_DUMP_REFS} : 1 , handle_fatals => (exists $ENV{LOG_HANDLE_FATALS}) ? $ENV{LOG_HANDLE_FATALS} : $default_handle_fatals, exclusive => $ENV{LOG_EXCLUSIVE} || '', unbuffer => (exists $ENV{LOG_UNBUFFER} ? $ENV{LOG_UNBUFFER} : $default_unbuffer), #prefix => \&_prefix_default, ); our %FHS_NO = (); # store list of filehandles indexed by fileno() our %FHS_NA = (); # store list of filehandles indexed by file name our %FHN_NO = (); # corresponding list of filenames for our filehandles indexed by fileno() # OK .. I'm not sure, but trying to use STDIN may be totally retarded #@LEVEL_FHS{qw( STDIN STDOUT STDERR )} = ( \*STDIN , \*STDOUT, \*STDERR ); @FHS_NA{qw( STDIN STDOUT STDERR )} = ( \*STDIN , \*STDOUT, \*STDERR ); @FHN_NO{(map { fileno($_); } @FHS_NA{qw( STDIN STDOUT STDERR )})} = qw( STDIN STDOUT STDERR ); @FHS_NO{keys %FHN_NO} = values %FHN_NO; foreach my $fh ( @FHS_NA{qw( STDOUT STDERR )} ) { $log->{unbuffer} ? _unbuffer( $fh ) : (); } $log = $this_package->new(); $intlog = $this_package->new( { prefix => \&_prefix_dev } ); our $hostname = `hostname`; #print STDERR '$hostname: ', $hostname; chomp $hostname; $intlog->write($dll, '$hostname: ', $hostname ); our @userinfo = get_userinfo(); our $username = $userinfo[0]; my @pathinfo = (File::Spec->splitpath( File::Spec->rel2abs( $0 ))); $intlog->write({prefix=>undef},$sll, '@pathinfo: ', \@pathinfo ); my $path_base = $0; my @o = split( m|/|, $path_base ); $intlog->write($dll, '@o: ', \@o ); my $max_path_seg = 3; my $num_path_seg = scalar @o; #my $path_abbrev = ( $num_path_seg > $max_path_seg ) ? join('/', map {''} ( 1 .. ( $num_path_seg - $max_path_seg ))), '...', @o[$#o - 1 .. $#o ] ) : $path_base; #my $path_abbrev = ( $num_path_seg > $max_path_seg ) ? join('/', (@o[0 .. 2], map {''} ( 4 .. ( $num_path_seg - $max_path_seg ))), '...', @o[$#o - 1 .. $#o ] ) : $path_base; my $path_abbrev = ( $num_path_seg > $max_path_seg ) ? join('/', @o[0 .. 2], '...', @o[$#o - 1 .. $#o ] ) : $path_base; #my $xxx = $intlog; #$xxx->write('STDERR', '%ENV{BIG_WARN_ON_XXX}: ', { map { $_ => ( $ENV{"BIG_WARN_ON_$_"} || 0 ) } keys%BIG_WARN_DEFAULTS } ); #$xxx->write('STDERR', '%BIG_WARN_DEFAULTS: ', \%BIG_WARN_DEFAULTS ); #$xxx->write('STDERR', '%BIG_WARN_ON: ', \%BIG_WARN_ON ); # we don't normally want a stack trace on every log call # enable on any particular call with: $intlog->write({st=>1},$lll, ':'); # enable on all calls with: $log->stack_trace( 1 ); *always_log = \*ALWAYS_LOG; sub ALWAYS_LOG { my $self = shift; my $log_level = shift; $log_level or return %ALWAYS_LOG; $log_level =~ s/^D_//; return $ALWAYS_LOG{$log_level}; } #$intlog->write($lll, '%LOG_CODE: ', "\n", map { (space($_->[0]), ' => ', pad( $_->[1]), "\n") } sort { $a->[1] <=> $b->[1]; } map { [ $_ => $LOG_CODE{$_} ]; } keys %LOG_CODE ); #$intlog->packages('!' . $this_package); # uncomment this to disable all internal logging $ENV{LOG_PACKAGES} ||= ''; if ( $ENV{LOG_PACKAGES} ) { $log->packages($ENV{LOG_PACKAGES}); $intlog->packages($ENV{LOG_PACKAGES}); } # the following two sets of exported variables/subs are for development debugging purposes and are # filtered out at compile time, unless $ENV{LOG_FILTER} is appropriately set. I'm thinking that since # these are for development debugging that they should maybe have some different significance when # it comes to descriptive output. Currently all log messages output the &{$log->{prefix}}(). Perhaps # we should use a bitmask to determine whether or not a log should be output and additionally what # kind of prefix it has. This would allow these to mimic the "production" log levels (in value) # while also allowing us to have more descriptive prefix (caller, etc...) when they are used for # development debugging *log_code = \*LOG_CODE; sub LOG_CODE { my $self = shift; my $log_level = shift; $log_level or return %LOG_CODE; $log_level =~ s/^D_//; return $LOG_CODE{$log_level}; } sub n { exists $_[1] ? $_[0]->{ n } = $_[1] : $_[0]->{ n }; } sub log { exists $_[1] ? $_[0]->{ log } = $_[1] : $_[0]->{ log }; } #sub log { # if ( $_[0] and UNIVERSAL::isa( $_[0], __PACKAGE__ ) ) { # return exists $_[1] ? $_[0]->{ log } = $_[1] : $_[0]->{ log }; # } else { # return $log; # } #} sub log_level { exists $_[1] ? $_[0]->{ log_level } = $_[1] : $_[0]->{ log_level }; } sub dump_refs { exists $_[1] ? $_[0]->{ dump_refs } = $_[1] : $_[0]->{ dump_refs }; } sub handle_fatals { exists $_[1] ? $_[0]->{ handle_fatals } = $_[1] : $_[0]->{ handle_fatals }; } sub exclusive { exists $_[1] ? $_[0]->{ exclusive } = $_[1] : $_[0]->{ exclusive }; } sub stack_trace { exists $_[1] ? $_[0]->{ stack_trace } = $_[1] : $_[0]->{ stack_trace }; } sub email { exists $_[1] ? $_[0]->{ email } = $_[1] : $_[0]->{ email }; } sub prefix { exists $_[1] ? $_[0]->{ prefix } = $_[1] : $_[0]->{ prefix }; } sub terse { exists $_[1] ? $_[0]->{ terse } = $_[1] : $_[0]->{ terse }; } sub unbuffer { exists $_[1] ? $_[0]->{ unbuffer } = $_[1] : $_[0]->{ unbuffer }; } *autoflush = \&unbuffer; sub log_file { # this needs to be able to take a file handle as well as a filename or symbolic filehandle name (eg 'STDOUT') # I was going to set up something here to be able to pass in a whole list of LEVEL => $file pairs, but on second though, just call the method repeatedly my $self = shift; my $level = shift || ''; #my @caller = _caller(); # print STDERR __LINE__, "-" x 80, "\n", @caller, "\n";# if $ENV{LOG_PACKAGES_DEBUG}; # print STDERR __LINE__, " LEVEL=$level\n";# if $ENV{LOG_PACKAGES_DEBUG}; my $dest = shift || ''; # print STDERR __LINE__, " DEST=$dest\n";# if $ENV{LOG_PACKAGES_DEBUG}; my $key = 'log_file'; # print STDERR __LINE__, " KEY=$key\n";# if $ENV{LOG_PACKAGES_DEBUG}; my $valid_level = scalar map { $_ eq $level ? 1 : (); } LOG_LEVELS() if $level; if ( $level and not $valid_level ) { if ( $dest ) { #houston we have a problem } else { $dest = $level; } } elsif ( $level and $valid_level ) { $key .= "_$level"; } if ( $dest ) { $self->{$key} = $dest; } # print STDERR __LINE__, " VALID_LEVEL=$valid_level\n";# if $ENV{LOG_PACKAGES_DEBUG}; # print STDERR __LINE__, " LEVEL=$level\n";# if $ENV{LOG_PACKAGES_DEBUG}; # print STDERR __LINE__, " DEST=$dest\n";# if $ENV{LOG_PACKAGES_DEBUG}; # print STDERR __LINE__, " KEY=$key\n";# if $ENV{LOG_PACKAGES_DEBUG}; # print STDERR __LINE__, " RETURN=$self->{$key}\n";# if $ENV{LOG_PACKAGES_DEBUG}; # print STDERR __LINE__, "-" x 80, "\n";# if $ENV{LOG_PACKAGES_DEBUG}; return $self->{$key}; } sub log_file_multiplex { my $self = shift; # I should change this to accept filehandles as well if ( scalar @_ > 2 ) { die " Called with too many arguments the several ways this could be called, maximum of 2 arguments allowed 0: () ===> with no arguments, return the log_file unadorned with a specific log_level 1: ===> set the log_file for any LEVEL not otherwise spoken for to the specified FILE (or 'STDERR', 'STDOUT') 2: ===> return the log_file for the LEVEL specified 3: [ , ] ===> set the log_file for any LEVEL not otherwise spoken for to be multiplexed across the specified files in list [ FILE1, FILE2, ..., FILEn] 4: [ , , ..., ] ===> return the log_file for the list of LEVELs specified 5: => ===> set the log_file for the LEVEL specified to FILE 6: => [ , , ..., ] ===> set the log_file for the LEVEL specified to multiplex across files in list [ FILE1, FILE2, ..., FILEn] 7: [ , ] => ===> set the log_file for the LEVELS specified to the same file FILE 8: [ , ] => [ , , ..., ] ===> set the log_file for the LEVELS specified to multiplex across files in list [ FILE1, FILE2, ..., FILEn] "; } my $key = 'log_file'; #$key = 'log_file_multiplex'; my $level = shift || ''; my $dest = shift || ''; if ( not $level and not $dest ) { ###### return $self->{$key}; ###### ###################################### } my $reflevel; my $refdest; unless ( ref $level eq 'ARRAY' ) { $reflevel = 0; $level = [ $level ]; } else { $reflevel = 1; } if ( $level and not $dest ) { # check to see if this is specifying just a level, or just a dest my $valid_level = scalar map { $_ eq $level->[0] ? 1 : (); } LOG_LEVELS() if $level->[0]; if ( $valid_level ) { my @return; foreach my $l ( @$level ) { my $vl = scalar map { $_ eq $l ? 1 : (); } LOG_LEVELS(); unless ( $vl ) { die " Something is awry with the arguments you passed: " . join(', ', @$level ) . " "; } else { push @return, $self->{$key}{$l}; } } ###### return $reflevel ? \@return : $return[0]; ###### ###################################### } else { # if the arg is not a valid log level then it must be a destination file or filehandle $refdest = $reflevel; $dest = $level; undef $level; } } unless ( ref $dest eq 'ARRAY' ) { $refdest = 0; $dest = [ $dest ]; } else { $refdest = defined $refdest ? $refdest : 0; } if ( $dest and not $level ) { # we got only one argument and it was a destination without the level specified # this means by default we want to multiplex across the files given $self->{$key} = $dest; ###### return $self->{$key}; ###### ###################################### } # here we have both level and dest, which should each now be array refs foreach my $l ( @$level ) { my $k = "${key}_$l"; my $pd = $self->{$k}; # check to see where $pd and $dest do not agree, close all filehandles in$pd which are not also in $dest $self->{$k} = $dest; } return $self->{$key}; } sub packages { # this sets up lists of DO and DONT log for packages specified at runtime # if any DO log lists are set up then we will log ONLY from packages who appear in the DO list EVEN IF they are also in the DONT list # if any DONT log lists are set up then we will NEVER log from packages in the DONT log list UNLESS they are in the DO log list my $self = shift; if ( exists $_[0] ) { my @new_packages = @_; my $packages = $self->{packages_array} ||= []; my $do_log = $packages->[0] ||= []; my $dont_log = $packages->[1] ||= []; foreach my $package_set ( @new_packages ) { my @package_set = split(/\#/, $package_set ); foreach my $package ( @package_set ) { next unless ($package and $package !~ /^\s+$/); print STDERR __PACKAGE__, ":", __LINE__, ": ", '$package: ' , $package, "\n" if $ENV{LOG_PACKAGES_DEBUG}; if ( $package =~ s/^\!// ) { #it's a dont unless( grep { /^$package$/ } @$dont_log ) { print STDERR __PACKAGE__, ":", __LINE__, ": ", 'DONT ::: $package: \'' , $package, "'\n" if $ENV{LOG_PACKAGES_DEBUG}; push @$dont_log, $package; } } else { unless( grep { /^$package$/ } @$do_log ) { print STDERR __PACKAGE__, ":", __LINE__, ": ", 'DO ::: $package: \'' , $package, "'\n" if $ENV{LOG_PACKAGES_DEBUG}; push @$do_log, $package; } } } } if ( my $packages = $self->{packages_array} ) { my $do_log = $packages->[0]; print STDERR __PACKAGE__, ":", __LINE__, ": ", '$do_log: ' , scalar @$do_log , " :: '", join('|', @$do_log) , "'\n" if $ENV{LOG_PACKAGES_DEBUG}; my $dont_log = $packages->[1]; print STDERR __PACKAGE__, ":", __LINE__, ": ", '$dont_log: ', scalar @$dont_log, " :: '", join('|', @$dont_log), "'\n" if $ENV{LOG_PACKAGES_DEBUG}; my $packages_rx = $self->{packages} ||= []; my $do_log_rx = scalar @$do_log ? [ map { qr/$_/; } @$do_log ] : []; #scalar @$do_log ? join('|', @$do_log ) : undef; print STDERR __PACKAGE__, ":", __LINE__, ": ", '$do_log_rx: ' , scalar @$do_log_rx , " :: '", join('|', @$do_log_rx) , "'\n" if $ENV{LOG_PACKAGES_DEBUG}; my $dont_log_rx = scalar @$dont_log ? [ map { qr/$_/; } @$dont_log ] : []; #scalar @$dont_log ? join('|', @$dont_log ) : undef; print STDERR __PACKAGE__, ":", __LINE__, ": ", '$dont_log_rx: ', scalar @$dont_log_rx, " :: '", join('|', @$dont_log_rx), "'\n" if $ENV{LOG_PACKAGES_DEBUG}; $packages_rx->[0] = $do_log_rx; $packages_rx->[1] = $dont_log_rx; } } return $self->{packages}; } sub clone { my $self = shift; my $VAR1 = $self->dump( @_ ); my $clone = eval $VAR1; $clone->{prefix} = $self->{prefix} if ( UNIVERSAL::isa( $clone, $this_package ) and ref $self->{prefix} eq 'CODE' ); return $clone; } #print STDERR $this_package, " STDERR ", __LINE__, " ::: OH MY! ... ", $log->dump([ \@_ ]); #print STDOUT $this_package, " STDOUT ", __LINE__, " ::: OH MY! ... ", $log->dump([ \@_ ]); sub new { #print STDERR _caller(); my $self = shift; my $class = ref $self || $self || $this_package; $self = bless {}, $class; $self->init( @_ ); return $self; } sub init { my $self = shift; my $init = shift; if ( defined $init ) { unless ( ref $init eq 'HASH' ) { unshift @_, $init; $init = { @_ }; } } else { $init = {}; } $init = { %init , %$init }; # override defaults with init args passed in while ( my ( $key, $value ) = each %$init ) { next unless $key; #$self->{$key} = $value; $self->$key( $value ); } while ( my ( $level, $fh ) = each %LEVEL_FHS ) { $self->log_file( $level => $fh ); } #print STDERR "$self: ", &dump( $self, -d => $self ); return $self; }; sub dump { my $DUMP = ''; my $self = shift; (print STDERR $this_package, " STDERR ", __LINE__, " ::: OH MY!:: ", __PACKAGE__->_caller(), Dumper(\@_), "\n") if $ENV{LOG_INTERNAL_DUMP_DEBUG}; my $class = ref $self || $self; my ( $dumps, $names ); my ( $pure, $deep, $indent, $id, $terse, $pad, $deparse ); if ( $_[0] and $_[0] =~ /^-/ ) { my $args = { @_ }; $dumps = $args->{-d} || $args->{-dump} || $self; $names = $args->{-n} || $args->{-names} || undef; $dumps = [ $dumps ] unless ( ref $names eq 'ARRAY' ); $pure = $args->{-pure} || 0 ; $deep = $args->{-deep} || 0 ; $indent = ( defined $args->{-indent} ? $args->{-indent} : $default_indent ); $id = $args->{-id} || 0; $terse = $args->{-terse} || 0 ; $pad = $args->{-p} || $args->{-pad} || ' ' x $default_pad; $deparse = $args->{-deparse} || 0; if ( $terse and not defined $indent ) { $indent = 0; } } else { $dumps = shift || $self; $names = shift || undef; $pure = shift || 0; $deep = shift || 0; $indent = shift || $default_indent; $id = shift || 0; $terse = shift || 0; $pad = shift || ' ' x $default_pad; $deparse = shift || 0; } (print STDERR $this_package, " STDERR ", __LINE__, " ::: OH MY!:: ", __PACKAGE__->_caller(), Dumper([( $pure, $deep, $indent, $id, $terse)]), "\n") if $ENV{LOG_INTERNAL_DUMP_DEBUG}; ( defined $dumps ) and ( ref $dumps eq 'ARRAY' ) or ( $dumps = [ $dumps ] ); ( defined $names ) and ( ref $names eq 'ARRAY' ) or ( $names = [ $names ] ); if ( $id ) { for( my $i = 0; $i <= $#$dumps; $i++ ) { my $d = $dumps->[$i]; my $n = ref $d ? $d : \$d; $names->[$i] = $n; } } my $dumper = Data::Dumper->new( $dumps , $names ); $dumper->Pad ( $pad ) if defined $pad; $dumper->Purity ( $pure ) if defined $pure; $dumper->Deepcopy( $deep ) if defined $deep; $dumper->Terse ( $terse ) if defined $terse; $dumper->Indent ( $indent ) if defined $indent; $dumper->Deparse ( $deparse ) if defined $deparse; $DUMP = $dumper->Dump(); return $DUMP } #sub _prepare_message { # my $self = shift; # my $level = shift; # my $args = shift; # my @inmsg = @_; # my $dump_refs = exists $args->{dump_refs} ? $args->{dump_refs} # : exists $self->{dump_refs} ? $self->{dump_refs} # : $level eq 'SPEW'; # my @outmsg = (); # my $tmp; # # $level = $args->{level} || $level; # my $log_level = $args->{log_level} || $self->{log_level} || $ENV{LOG_LEVEL}; # print STDERR __LINE__, " LOG_LEVEL='$log_level', LEVEL='$level', \$args->{prefix}='$args->{prefix}'\n" if ($ENV{LOG_INTERNAL_DEBUG} > 2); # my $prefix = exists $args->{prefix} ? $args->{prefix} # : $log_level =~ /^D_/ ? \&_prefix_dev # : $level =~ /CLEAN/ ? '' # : defined $self->{prefix} ? $self->{prefix} # : $level =~ /^D/ ? \&_prefix_dev # : $log_level =~ /(SPEW)/ ? \&_prefix_dev # #: $level =~ /QUIT/ ? \&_prefix_dev # : $level =~ /CRIT/ ? \&_prefix_dev # : $level =~ /FATAL/ ? \&_prefix_dev # : $level =~ /FAIL/ ? \&_prefix_dev # : \&_prefix_default; # my @prefix; # my @prefix_out; # my $add_dev_prefix; # my $log_file = $args->{log_file} || $self->log_file( $level ) || $self->log_file(); # if ( exists $args->{prefix} # and $log_level =~ /^D_/ # and $log_file =~ /^(STDOUT|STDERR)$/ # ) { # $add_dev_prefix = 1; # } # push @prefix, \&_prefix_dev if $add_dev_prefix; # push @prefix, $prefix if defined $prefix; # # really we should have somethings that checks the %args for ALL of the possible settings # my $st = $STACK_TRACE; # $STACK_TRACE = exists $args->{stack_trace} ? $args->{stack_trace} # : defined $self->{stack_trace} ? $self->{stack_trace} # : $STACK_TRACE; # # my $code_resolve_cnt_max = 10; # foreach my $p ( @prefix ) { # my $code_resolve_cnt = 0; # CORE_PREFIX: # while ( ref $p eq 'CODE' ) { # $p = &$p( $level, $args ); # last CODE_PREFIX if ( $code_resolve_cnt++ > $code_resolve_cnt_max ); # } # unshift @inmsg, $p; # #unshift @prefix_out, $p; # } # $STACK_TRACE = $st;# restore the previous setting # # # my $prefix_length = [ split("\n", join( '', @prefix_out)) ]; # # $prefix_length = $prefix_length->[-1]; # # $prefix_length = length $prefix_length; # my ($msg, $d); # INMSG: while ( scalar @inmsg ) { # $tmp = undef; # $msg = shift @inmsg; # defined $msg or $msg = 'undef';#'(UNDEFINED ELEMENT IN LOG MESSAGE ARGUMENTS)'; # my $code_resolve_cnt = 0; # CHECK_REF: # if (( my $ref = ref $msg ) and $dump_refs ) { # # this next line of cruft is here so you can pass arguments to ->dump() without having to prepend with a minus sign # my @extra_args = map { $_ =~ /^(terse|deep|pure|id|indent)$/ ? ( "-$_" => $args->{$_} ) : ( $_ => $args->{$_} ) } keys %$args; # (print STDERR $this_package, " STDERR ", __LINE__, " ::: OH MY!:: ", __PACKAGE__->_caller(), $self->dump(-d=> [\@extra_args], -n =>['extra_args']), "\n") if ( $ENV{LOG_INTERNAL_DEBUG} > 4 ); # if ( $ref eq 'CODE' ) { # $d = &$msg(); # $msg = $d; # goto CHECK_REF unless ( ref $msg eq 'CODE' and $code_resolve_cnt++ > $code_resolve_cnt_max ); # } else { # #$d = $self->dump(-d=>[$msg],-n=>["$msg"], -deep => 0, @extra_args, -pad => (' ' x ( $prefix_length + length $msg) )); # #$d = $self->dump(-d=>[$msg],-n=>["$msg"], -deep => 0, @extra_args, -pad => (' ' x ( $prefix_length) )); # #$d =~ s/^\s+//; # #$d = "\n" . $self->dump(-d=>[$msg],-n=>["$msg"], -deep => 0, @extra_args, -pad => (' ' x $prefix_length ) ); # #$d = "\n" . $self->dump(-d=>[$msg],-n=>["$msg"], -deep => 0, -indent => 1, @extra_args ); # $d = "\n" . $self->dump(-d=>[$msg],-n=>["$msg"], -deep => 0, -indent => 1, @extra_args ); # } # $msg = $d; # } # push @outmsg, $msg; # } # if ( $add_dev_prefix # and $outmsg[-1] !~ /\n$/ms # ) { # push @outmsg, "\n"; # }; # return @outmsg; #} *_prefix_default = \&_prefix_prod; sub _time { my @lt = localtime(); #( 0, 1, 2, 3, 4, 5, 6, 7, 8) #($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = join('',$lt[5]+1900, map { length $_ < 2 ? "0$_" : $_; } (($lt[4]+1),($lt[3])) ) . ' ' . join('', map { length $_ < 2 ? "0$_" : $_;} @lt[2,1,0]), } sub _prefix_prod { print STDERR __LINE__, " 'prefix_prod'\n" if ($ENV{LOG_INTERNAL_DEBUG} > 2); my $level = shift; return '['.join('][',map { space(pad($_, $p_pad), $p_space), } "$username\@$hostname:$$", _time(), uc $level )."] " ; } sub _prefix_brief { print STDERR __LINE__, " 'prefix_brief'\n" if ($ENV{LOG_INTERNAL_DEBUG} > 2); my $level = shift; return '['.join('][',map { space(pad($_, $p_pad), $p_space), } "$username\@$hostname:$$", _time(), )."] " ; } sub _prefix_dev { print STDERR __LINE__, " 'prefix_dev_long'\n" if ($ENV{LOG_INTERNAL_DEBUG} > 2); my $level = shift; my $args = shift; my $backstack = $args->{backstack} || 0; #"$username\@$hostname:$$:$path_abbrev:$path_base", my $return = '--['.join("]\n--[",map { space(pad($_, $p_pad), $p_space), } #__PACKAGE__->_caller($backstack + 3), # we need a 3 here to ignore (skip over) the subroutine calls within the logging module itself # was 3 before we inlined something __PACKAGE__->_caller($backstack + $prefix_dev_backstack), # we need a 2 here to ignore (skip over) the subroutine calls within the logging module itself )."] " . "\n" ; $return .= _prefix_prod( $level, $args, @_ ); $return .= "\n" if ( $level =~ /CLEAN/ ); return $return; } my %level_cache = (); sub _check_level { my $self = shift; my $msg = shift; my $args = {}; my $level = shift @$msg; ref $level eq 'HASH' and ($args=$level) and $level=shift @$msg; my $map_level = $level; $map_level =~ s/^D_//; #print "LEVEL : '$level'\n"; #print "MAP_LEVEL: '$map_level'\n"; $args->{log_file} ||= $self->{"log_file_$level"} || $self->{"log_file"}; my $log_level = $args->{log_level} ||= $self->{log_level} || DEFAULT; my $map_log_level = $log_level; $map_log_level =~ s/^D_//; my ( $_level, $_log_level ) = @LOG_CODE{$map_level, $map_log_level}; print STDERR "\nLEVELS: $log_level:$map_log_level:$_log_level ... $level:$map_level:$_level\n" if $ENV{LOG_LEVEL_DEBUG}; if ( not defined $_level ) { $intlog->write({stack_trace => 1 }, ERROR, "Illegal log level '$level' setting it to 'DEFAULT'"); unshift @$msg, ( $level = 'DEFAULT' ); return $self->_check_level( $msg ) unless exists $level_cache{$level}; $intlog->write( ERROR, "Illegal log level '$level' trouble setting it to $level"); return undef; } my @return = ($level, $_level, $log_level, $_log_level, $args); #_actually_log( $self, -level => LOUD, -FH => \*STDOUT, -message => \@return ); return @return; } sub write { #print STDOUT $this_package, " STDOUT ", __LINE__, " ::: OH MY! ... ", $intlog->dump([ \@_ ]); # print STDERR $this_package," :: ", join(', ', caller()), "\n"; my $self = shift; ref $self or $self = $log; (print STDOUT $this_package, " STDOUT ", __LINE__, " ::: OH MY!:: ", __PACKAGE__->_caller(), $self->dump(-d=> [$_[0]], -n =>['_args']), "\n") if ( $ENV{LOG_INTERNAL_DEBUG} > 4 ); my @msg = @_; #my ($level, $_level, $log_level, $_log_level, $args) = $self->_check_level( \@msg ); my ($level, $_level, $log_level, $_log_level, $args); my $use_level; my $map_level; CHECK_LEVEL: #sub _check_level { { #my $self = shift; #my $msg = shift; my $msg = \@msg; #my $args = {}; $args = {}; #my $level = shift @$msg; $level = shift @$msg; ref $level eq 'HASH' and ($args=$level) and $level=shift @$msg; $use_level = $args->{level} || $level; $map_level = $use_level; $map_level =~ s/^D_//; #print "LEVEL : '$level'\n"; #print "MAP_LEVEL: '$map_level'\n"; $args->{log_file} ||= $self->{"log_file_$level"} || $self->{"log_file"}; $log_level = $args->{log_level} || $self->{log_level} || $ENV{LOG_LEVEL} || 'DEFAULT'; my $map_log_level = $log_level; $map_log_level =~ s/^D_//; #my ( $_level, $_log_level ) = @LOG_CODE{$map_level, $map_log_level}; ( $_level, $_log_level ) = @LOG_CODE{$map_level, $map_log_level}; print STDERR "\nLEVELS: $log_level:$map_log_level:$_log_level ... $level:$map_level:$_level\n" if $ENV{LOG_LEVEL_DEBUG}; if ( not defined $_level ) { $intlog->write({stack_trace => 1 }, ERROR, "Illegal log level '$level' setting it to 'DEFAULT'"); unshift @$msg, ( $level = 'DEFAULT' ); #return $self->_check_level( $msg ) unless exists $level_cache{$level}; if ( not exists $level_cache{$level} ) { goto CHECK_LEVEL; #($level, $_level, $log_level, $_log_level, $args) = $self->_check_level( $msg ); } else { $intlog->write( ERROR, "Illegal log level '$level' trouble setting it to $level"); return undef; } } # my @return = ($level, $_level, $log_level, $_log_level, $args); # #_actually_log( $self, -level => LOUD, -FH => \*STDOUT, -message => \@return ); # return @return; } # this needs to be set up to log at any of severa levels which may be set simultaneously # eg log at WARN and TRACE # log levels should be a list # ie @_log_levels rather than $_log_level my $backstack = $args->{backstack} || 0; my $return = \@msg; my $status = 1; (print STDERR 'XXXXXX ', $this_package, " STDERR ", __LINE__, " ::: OH MY! status=$status ... \$ALWAYS_LOG{$map_level}: '", $ALWAYS_LOG{$map_level}, "' :: ", __PACKAGE__->_caller(), $self->dump(-d=> [$args], -n =>['args']), "\n") if ( $ENV{LOG_INTERNAL_DEBUG} > 4 ); if( not $ALWAYS_LOG{$map_level} ) { if ( my $e = $self->{exclusive} ) { $level =~ /$e/ or $status = 0;# or return join( '', @$return ); } else { $_level >= $_log_level or $status = 0; #or return join( '', map { defined $_ ? $_ : 'undef' } @$return ); } } (print STDERR 'XXXXXX ', $this_package, " STDERR ", __LINE__, " ::: OH MY! status=$status ... \$ALWAYS_LOG{$map_level}: '", $ALWAYS_LOG{$map_level}, "' :: ", __PACKAGE__->_caller(), $self->dump(-d=> [$args], -n =>['args']), "\n") if ( $ENV{LOG_INTERNAL_DEBUG} > 4 ); if ( #not $ALWAYS_LOG{$map_level} and $status and my $packages = $self->{packages} ) { my $do_match; my $dont_match; my $do_log_rx = $packages->[0]; my $dont_log_rx = $packages->[1]; my $log_called_package = _log_called_package(1)->[0]; #print STDERR __PACKAGE__, ":", __LINE__, ": ", "LOG CALLED PACKAGE: '$log_called_package'\n"; if ( scalar @$do_log_rx ) { foreach my $do_rx ( @$do_log_rx ) { if ( $log_called_package =~ /^($do_rx)$/ ) { #print STDERR "DO LOG: $do_log_rx\n"; #$do_match = ( $do_match and length $do_match > length $do_rx ) ? $do_match : $do_rx; $do_match = $do_rx; } } $do_match or $status = 0; } if ( $status and scalar @$dont_log_rx ) { foreach my $dont_rx ( @$dont_log_rx ) { if ( $status #and not $do_match #and ( not $do_match or ( $dont_log_rx =~ /$do_log_rx/ )) and $log_called_package =~ /^($dont_rx)$/ ) { #$dont_match = ( $dont_match and length $dont_match > length $dont_rx ) ? $dont_match : $dont_rx; $dont_match = $dont_rx; $status = 0; } } } if ( $do_match and $dont_match ) { # if it matches on both DO and DONT, what are we supposed to do? Here we simply say that the match with the lengthiest regex wins $status = ( length $do_match > length $dont_match ) ? 1 : 0 ; print STDERR __PACKAGE__, ":", __LINE__, ": ", "DO status=$status ($do_match): $do_log_rx\n" if $ENV{LOG_PACKAGES_DEBUG}; print STDERR __PACKAGE__, ":", __LINE__, ": ", "DONT status=$status ($dont_match): $dont_log_rx\n" if $ENV{LOG_PACKAGES_DEBUG}; } } print STDERR __LINE__, " LOG_LEVEL='$log_level', LEVEL='$level', MAP_LEVEL='$map_level', \$args->{prefix}='$args->{prefix}'\n" if ($ENV{LOG_INTERNAL_DEBUG} > 2); if ( $status ) { #warn "STATUS: $status ::: $level:$_level ... $log_level:$_log_level"; # this is an effort at in-lining some subroutines #@msg = $self->_prepare_message( $level, $args, @msg ); #sub _prepare_message { { # my $self = shift; # my $level = shift; # my $args = shift; # my @inmsg = @_; my @inmsg = @msg; my $dump_refs = exists $args->{dump_refs} ? $args->{dump_refs} : exists $self->{dump_refs} ? $self->{dump_refs} : $level eq 'SPEW'; my @outmsg = (); my $tmp; my $prefix = exists $args->{prefix} ? $args->{prefix} : $log_level =~ /^D_/ ? \&_prefix_dev : $use_level =~ /CLEAN/ ? '' : defined $self->{prefix} ? $self->{prefix} : $use_level =~ /^D/ ? \&_prefix_dev : $log_level =~ /SPEW/ ? \&_prefix_dev #: $use_level =~ /QUIT/ ? \&_prefix_dev : $use_level =~ /CRIT/ ? \&_prefix_dev : $use_level =~ /FATAL/ ? \&_prefix_dev : $use_level =~ /FAIL/ ? \&_prefix_dev : \&_prefix_default; my @prefix; my @prefix_out; my $add_dev_prefix; my $log_file = $args->{log_file} || $self->log_file( $level ) || $self->log_file(); if ( exists $args->{prefix} and $log_level =~ /^D_/ and $log_file =~ /^(STDOUT|STDERR)$/ ) { $add_dev_prefix = 1; } push @prefix, \&_prefix_dev if $add_dev_prefix; push @prefix, $prefix if defined $prefix; my $code_resolve_cnt = 0; my $code_resolve_cnt_max = 10; # really we should have somethings that checks the %args for ALL of the possible settings my $st = $STACK_TRACE; $STACK_TRACE = exists $args->{stack_trace} ? $args->{stack_trace} : defined $self->{stack_trace} ? $self->{stack_trace} : $STACK_TRACE; foreach my $p ( @prefix ) { CODE_PREFIX: while ( ref $p eq 'CODE' ) { $p = &$p( $level, $args ); last CODE_PREFIX if ( $code_resolve_cnt++ > $code_resolve_cnt_max ); } unshift @inmsg, $p; #unshift @prefix_out, $p; } $STACK_TRACE = $st;# restore the previous setting # my $prefix_length = [ split("\n", join( '', @prefix_out)) ]; # $prefix_length = $prefix_length->[-1]; # $prefix_length = length $prefix_length; my ($msg, $d); INMSG: while ( scalar @inmsg ) { $tmp = undef; $msg = shift @inmsg; defined $msg or $msg = 'undef';#'(UNDEFINED ELEMENT IN LOG MESSAGE ARGUMENTS)'; my $code_resolve_cnt = 0; CHECK_REF: if (( my $ref = ref $msg ) and $dump_refs ) { # this next line of cruft is here so you can pass arguments to ->dump() without having to prepend with a minus sign my @extra_args = map { $_ =~ /^(terse|deep|pure|id|indent|deparse)$/ ? ( "-$_" => $args->{$_} ) : ( $_ => $args->{$_} ) } keys %$args; (print STDERR $this_package, " STDERR ", __LINE__, " ::: OH MY!:: ", __PACKAGE__->_caller(), $self->dump(-d=> [\@extra_args], -n =>['extra_args']), "\n") if ( $ENV{LOG_INTERNAL_DEBUG} > 4 ); if ( $ref eq 'CODE' ) { $d = &$msg(); $msg = $d; goto CHECK_REF unless ( ref $msg eq 'CODE' and $code_resolve_cnt++ > $code_resolve_cnt_max ); } else { #$d = $self->dump(-d=>[$msg],-n=>["$msg"], -deep => 0, @extra_args, -pad => (' ' x ( $prefix_length + length $msg) )); #$d = $self->dump(-d=>[$msg],-n=>["$msg"], -deep => 0, @extra_args, -pad => (' ' x ( $prefix_length) )); #$d =~ s/^\s+//; #$d = "\n" . $self->dump(-d=>[$msg],-n=>["$msg"], -deep => 0, @extra_args, -pad => (' ' x $prefix_length ) ); #$d = "\n" . $self->dump(-d=>[$msg],-n=>["$msg"], -deep => 0, -indent => 1, @extra_args ); $d = "\n" . $self->dump(-d=>[$msg],-n=>["$msg"], -deep => 0, -xxindent => 1, -deparse => 1, @extra_args ); } $msg = $d; } push @outmsg, $msg; } if ( $add_dev_prefix and $outmsg[-1] !~ /\n$/ms and not defined $args->{n} ) { push @outmsg, "\n"; }; #return @outmsg; @msg = @outmsg; } $n = exists $args->{n} ? $args->{n} : ($self->{n} || "\n"); (print STDERR $this_package, " STDERR ", __LINE__, " ::: OH MY! ... \$ALWAYS_LOG{$use_level}: '", $ALWAYS_LOG{$use_level}, "' :: ", __PACKAGE__->_caller(), $self->dump(-d=> [$args], -n =>['args']), "\n") if ( $ENV{LOG_INTERNAL_DEBUG} > 4 ); unless ( $args->{dont_actually_log} ) { #$return = $self->_actually_log( %$args, -level => $use_level, -message => $return ); %$args = ( %$args, -level => $level, -message => $return ); #sub _actually_log { { #print STDERR $this_package, " ", __LINE__, " ::: OH MY! ... ", $_[0]->dump([ \@_ ]); #my $self = shift; #(warn $this_package, " STDOUT ", __LINE__, " ::: OH MY!:: ", __PACKAGE__->_caller(), $self->dump(-d=> [\@_], -n =>['_']), "\n") if $ENV{LOG_INTERNAL_DEBUG}; #my $args = { @_ }; $args->{-terse} ||= $self->{terse}; $args->{-level} ||= INFO; $args->{-message} ||= ' - -- NO MESSAGE -- - '; my $fh = $self->fh( %$args ); if ( not $fh ) { my $log_file = $self->log_file($args->{-level}); my $error_level = FATAL; if ( not $log->handle_fatals() ) { $error_level = ERROR; } $intlog->write($error_level, "No filehandle for `", $args->{-level}, "' on `", $log_file, "'", \%FHS_NA); exit 1 if $log->handle_fatals(); #return undef; $return = undef; } else { #print "MESSAGE: $message\n"; #return $self->_WRITE( %$args, -FH => $fh ); $return = $self->_WRITE( -FH => $fh, %$args ); } }; defined $return or $status = undef; } # if ( $use_level eq MESSAGE ) { # if ( my $email = $args->{email} ? $args->{email} : $self->{email} ) { # # we should send a message to the bloke? # } else { # #$intlog->write(ERROR, "No email address specified to send MESSAGE: $return"); # $self->write(ALERT, "No email address specified to send MESSAGE: $return") unless $self->{DEBUG}{NO_ALERT}; # } # } $n = undef; } ref $return eq 'ARRAY' and $return = join('', map { defined $_ ? $_ : 'undef' } @$return); #print STDOUT $this_package, " STDOUT ", __LINE__, " ::: OH MY! ... ", $intlog->dump([ \@_ ]); return wantarray ? ( $status, $return ) : $status ; } sub _actually_log { #print STDERR $this_package, " ", __LINE__, " ::: OH MY! ... ", $_[0]->dump([ \@_ ]); my $self = shift; #(warn $this_package, " STDOUT ", __LINE__, " ::: OH MY!:: ", __PACKAGE__->_caller(), $self->dump(-d=> [\@_], -n =>['_']), "\n") if $ENV{LOG_INTERNAL_DEBUG}; my $args = { @_ }; $args->{-terse} ||= $self->{terse}; $args->{-level} ||= INFO; $args->{-message} ||= ' - -- NO MESSAGE -- - '; my $fh = $self->fh( %$args ); unless ( $fh ) { my $log_file = $self->log_file($args->{-level}); my $error_level = FATAL; if ( not $log->handle_fatals() ) { $error_level = ERROR; } $intlog->write($error_level, "No filehandle for `$args->{-level}' on $log_file"); #exit 1; return undef; } #print "MESSAGE: $message\n"; return $self->_WRITE( %$args, -FH => $fh ); }; #@f{qw(package filename line subroutine hasargs wantarray evaltext is_require hints bitmask )}=caller(); my @showf = qw(package filename line subroutine hasargs wantarray evaltext is_require ); sub called_from { my $self = shift; my $f = exists $_[0] ? (shift) : (( ref $self ? 2 : $self ) || 2); $intlog->write($dll, '$f: ', $f ); my $lcpa = $self->_log_called_package( $f ); $intlog->write($dll, '$lcpa: ', $lcpa ); my $lcp = $lcpa->[0]; $intlog->write($dll, '$lcp: ', $lcp ); return $lcp; } sub _log_called_package { my $self = shift; my $f = shift || ( ref $self ? 0 : $self ) || 0; my $nf = $f + 1; my $log_called_package = ''; my $log_called_file = ''; my @caller = (); my @f = caller($f); my ( $package, $filename, $line, $subroutine ) = @f; #print '( $package, $filename, $line, $subroutine ) = ', "( $package, $filename, $line, $subroutine ) [$f]\n"; my @nf = caller($nf); my ( $npackage, $nfilename, $nline, $nsubroutine ) = @nf; #print '( $npackage, $nfilename, $nline, $nsubroutine ) = ', "( $npackage, $nfilename, $nline, $nsubroutine ) [$nf]\n"; if ( $nsubroutine ) { $log_called_package = "$nsubroutine:$line"; $log_called_file = "$filename:$line"; } elsif ( $package ) { $log_called_package = "$package:$line"; $log_called_file = "$filename:$line"; } return [ $log_called_package, $log_called_file, \@f, \@nf ]; } sub _caller { my $self = shift; my $f = shift || 0; my @caller = (); if ( $STACK_TRACE ) { # I wonder if there is a single call to give me a stack trace like I want, I know Carp will cluck() but why didn't I use that in the first place? # did I just do my own for some easier to read formatting? my $s = 0; my %mes; my @mes = ({map{$mes{$_}=!$mes{$_}?length$_:($mes{$_}$_);}@showf}); my $width = 0; my $depth = 0; while (1) { my %f; $depth = $f + ++$s; @f{ @showf, qw( hints bitmask )}= caller($depth); # this is probably a stupid way to break out of this loop, we basically keep stepping back up the stack until there is nothing left last unless join('',map{$f{$_}?$f{$_}:''}(@showf)); $width=0; my $x = 0; #push @mes, "$s => \n\t", join("\n\t",map{(space( $_ . "(" . $x++ . ")") . " => " . ($f{$_}?$f{$_}:'undef')) }@showf), "\n"; foreach (@showf) {$f{$_} ||= 'undef';$mes{$_}=!$mes{$_}?length$f{$_}:($mes{$_}{$_},$mes{$_}+2,$sep) . ' | ');}@showf;$sep='';(@c,"\n");}else{()}}@mes),'_' x $width,"\n",); push @caller, @m; } my $log_called_f = _log_called_package( $f ); print STDERR 'log_called_f: ', $self->dump( [ $log_called_f ] ), "\n" if $ENV{LOG_DEBUG}; my $log_called_at = _log_called_package( $f + 1 ); print STDERR 'log_called_at: ', $self->dump( [ $log_called_at ] ), "\n" if $ENV{LOG_DEBUG}; if ( not $log_called_at->[0] ) { $log_called_at = $log_called_f; } my $called_called_from = _log_called_package( $f + 2 ); if ( not $called_called_from->[0] ) { $called_called_from = $log_called_at; } print STDERR 'log_called_f: ', $self->dump( [ $log_called_f ] ), "\n" if $ENV{LOG_DEBUG}; print STDERR 'log_called_at: ', $self->dump( [ $log_called_at ] ), "\n" if $ENV{LOG_DEBUG}; print STDERR 'called_called_from: ', $self->dump( [ $called_called_from ] ), "\n" if $ENV{LOG_DEBUG}; push @caller, "log call at $log_called_at->[0] in file $log_called_at->[1]"; #push @caller, "$log_called_at->[0] called from $called_called_from->[0] in file $called_called_from->[1]"; push @caller, "called from $called_called_from->[0] in file $called_called_from->[1]"; return wantarray ? @caller : join('', @caller ); } LOGS: { # a cache of open log objects for output # this may not be too desirable in the end because # you lose individual control of the log level, file ... and such # although I may be able to fix that my %LOGS = ( STDOUT => $this_package->object( { log_file => 'STDOUT', log_level => $log_level } ), STDIN => $this_package->object( { log_file => 'STDIN' , log_level => $log_level } ), STDERR => $this_package->object( { log_file => 'STDERR', log_level => $log_level } ), ); # unless otherwise specified we will use STDERR as our output stream $LOGS{DEFAULT} = $LOGS{$default_fh}; #use Carp qw( cluck confess ); #local $SIG{__WARN__} = \&cluck; #local $SIG{__DIE__} = \&confess; sub object { # there should probably be a better way of specifying which existing # logging object should be used rather than REALLOG my $self = shift; my $class = ref $self || $self; #carp( " -- $self->object() CALLER -- " ); $self = $class->new( @_ ) unless ref $self; my @args = @_; my $args; if ( my $init = shift @args ) { ref $init eq 'HASH' and $args = $init; ref $init eq 'ARRAY' and 1; } my $log = $args->{log} || $class || 'DEFAULT'; $log = $LOGS{$log} ||= ($class eq $this_package ? $self : $this_package->new(@_)); return $log if $log; # hmmm failed? return delete $LOGS{$log}; } } #print STDERR __FILE__, ":", __LINE__, " :: \n", $log->dump( -n => [ 'FHS_NA', 'FHS_NO'], -d => [ \%FHS_NA, \%FHS_NO]), "\n"; FILEHANDLES : { # a cache of open filehandles for output # I may want to split this into open_fh, get_fh, close_fh (with perhaps an argument helper of get_fh_file_args or something, to sort out the passed arguments for each of the potential functions mentioned ) sub close_fh { # simply closes the current filehandle and removes if from the list of open handles my $self = shift; my $status = 'NA'; if ( my $fh = $self->fh( @_, no_open => 1 ) ) { $intlog->write($dll, '$fh: ', $fh ); #; # the problem here, is that if arguments were passed, and no such filehandle was already op, then fh() is going to open a filehandle, give it to us whereupon we are going to immediately close it. That kind of sucks. my $file_no = fileno($fh); my $file = $FHN_NO{$file_no}; my $file_clean = $file; $file_clean =~ s/^\s*([>]{1,2})\s*//; if ( $ENV{LOG_DEBUG} ) { print STDERR "file_no='$file_no'\n"; print STDERR "file='$file'\n"; print STDERR "file_clean='$file_clean'\n"; } if ($fh and $file_no) { $status = close($fh) or warn "Couldn't close filehandle on '$file': $!"; delete $FHS_NA{$file_clean}; delete $FHS_NO{$file_no}; delete $FHN_NO{$file_no}; } } else { #$intlog->write($dl7, '@_: ', \@_ ); #die; } return $status; } *get_fh = \&fh; sub fh { # this is a bit fucky nutty, I would like to pull all of the file handle-handling stuff into another package, I would like to add hooks for on-the-fly (de)compression, preferably all in perl (making it platform independent), but with outside programs if necessary #print STDERR __PACKAGE__, ":", __LINE__, "\n"; #print STDOUT __PACKAGE__, ":", __LINE__, "\n"; my $self = shift; #return $FHS_NA{STDERR}; my $args = { @_ }; #print STDOUT join(" ", @_), "\n"; my $level = $args->{-level} || DEFAULT; my $file; my $fh; my $file_no; my $file_clean; #_WRITE( "SHITBALLS", " \$level = '$level'\n" ); if ( $level =~ /^(STDERR|STDOUT)$/i ) { $fh = $FHS_NA{"\U$level"}; $file_no = fileno($fh); $file = $level; $file_clean = $file; } else { $file = $args->{"log_file_$level"}; $file ||= $args->{log_file}; #print STDERR __PACKAGE__, ":", __LINE__, "\n"; #print STDOUT __PACKAGE__, ":", __LINE__, "\n"; $file ||= $self->{"log_file_$level"}; #print STDERR __PACKAGE__, ":", __LINE__, "\n"; #print STDOUT __PACKAGE__, ":", __LINE__, "\n"; $file ||= $self->{log_file}; #print STDERR __PACKAGE__, ":", __LINE__, "\n"; #print STDOUT __PACKAGE__, ":", __LINE__, "\n"; $file ||= $LEVEL_FHS{$level}; #print STDERR __PACKAGE__, ":", __LINE__, "\n"; #print STDOUT __PACKAGE__, ":", __LINE__, "\n"; $file ||= $default_fh; #print STDERR __PACKAGE__, ":", __LINE__, "\n"; #print STDOUT __PACKAGE__, ":", __LINE__, "\n"; $fh = $args->{fh};# || $FHS_NA{$file_clean}; # $file_clean = $file; # $file_clean =~ s/^\s*([>]{1,2})\s*//; # $fh = $args->{fh} || $FHS_NA{$file_clean}; #print STDERR __PACKAGE__, ":", __LINE__, "\n"; #print STDOUT __PACKAGE__, ":", __LINE__, "\n"; } #fileno($fh); #print STDERR __PACKAGE__, ":", __LINE__, "\n"; #print STDOUT __PACKAGE__, ":", __LINE__, "\n"; #print STDERR "FH: [$level] :: ", $fh, ":", fileno($fh), " ::: $file $args->{log_file}\n"; #print STDOUT "FH: [$level] :: ", $fh, ":", fileno($fh), " ::: $file $args->{log_file}\n"; #print STDERR __PACKAGE__, ":", __LINE__, "FH: [$level] :: ", ($fh||'undef'), ":", " ::: $file_clean $args->{log_file}\n"; #print STDOUT __PACKAGE__, ":", __LINE__, "FH: [$level] :: ", ($fh||'undef'), ":", " ::: $file_clean $args->{log_file}\n"; my @fhs; my $reffh; if ( ref $fh eq 'ARRAY' ) { $reffh = 1; @fhs = @$fh; } else { $reffh = 0; @fhs = $fh; } my @return; if ( $fh ) { foreach my $_fh ( @fhs ) { $file_no = fileno($_fh); #print STDERR __PACKAGE__, ":", __LINE__, "file_no: $file_no\n"; #print STDOUT __PACKAGE__, ":", __LINE__, "file_no: $file_no\n"; if ( defined $file_no ) { # I don't know if I should cache this here, because we may not have been responsible for opening it #::# $FHS_NA{$file_clean} = $fh; #::# $FHN_NO{$file_no} = $file; #::# $FHS_NO{$file_no} = $fh; push @return, $_fh; } else { warn "$!: $file"; } } return $reffh ? \@return : $return[0]; } my @files; my $reffile; if ( ref $file eq 'ARRAY' ) { $reffile = 1; @files = @$file; } else { $reffile = 0; @files = $file; } #print STDERR __FILE__, ":", __LINE__, " :: \n", $self->dump( -n => [ 'FHS_NA', 'FHS_NO', 'FHN_NO'], -d => [ \%FHS_NA, \%FHS_NO, \%FHN_NO]), "\n"; #print STDERR __FILE__, ":", __LINE__, " :: \n", $self->dump( -n => [ 'files'], -d => [ \@files ]), "\n"; foreach my $_file ( @files ) { #print STDERR __FILE__, ":", __LINE__, " :: \n", $self->dump( -n => [ '_file'], -d => [ $_file ]), "\n"; my $_file_clean; $_file_clean = $_file; $_file_clean =~ s/^\s*(\||[>]{1,2})\s*//; #print STDERR __FILE__, ":", __LINE__, " :: \n", $self->dump( -n => [ '_file_clean'], -d => [ $_file_clean ]), "\n"; my $_fh = $FHS_NA{$_file_clean}; if ( $args->{no_open} ) { push @return, $_fh; } else { unless ( $_fh ) { if ( fileno($_file) ) { $_fh = $_file; } else { my $mode; if ( $_file =~ /^\s*(\||[>]{1,2})/ ) { $mode = $1; } else { $mode = -f $_file_clean ? '>>' : '>'; } $_fh = new IO::File or die $!; print STDERR "Opening new filehandle for '$_file' on '$mode' '$_file_clean'\n" if $ENV{LOG_DEBUG}; my $opened = $_fh->open( "$mode$_file_clean" ); unless ( $opened ) { my $error_level = FATAL; if ( not $log->handle_fatals() ) { $error_level = ERROR; } $intlog->write($error_level, "$mode $_file_clean : $!"); return undef; } #print STDERR "Opened new filehandle '$opened' for '$file' on '$mode' '$file_clean'\n"; #print STDOUT "Opened new filehandle '$opened' for '$file' on '$mode' '$file_clean'\n"; } } my $_file_no = fileno($_fh); defined $_file_no or die $!; #print STDERR "Got fileno on new filehandle '$file_no' for '$file' on '$mode' '$file_clean'\n"; #print STDOUT "Got fileno on new filehandle '$file_no' for '$file' on '$mode' '$file_clean'\n"; ################################################################################ # this locking screwed me all up once when I was running under mod_perl # I think it was the exclusive lock collision between different httpd child processes # I should make this a per-file option I guess # in any case this wouldn't really work in an NFS environment, because there advisory locks are IPC based #my $flocked = flock $fh, LOCK_EX or die $!; #print STDERR "Got lock on new filehandle '$flocked' for '$file' on '$mode' '$file_clean'\n"; #print STDOUT "Got lock on new filehandle '$flocked' for '$file' on '$mode' '$file_clean'\n"; ################################################################################ $FHS_NA{$_file_clean} = $_fh; $FHS_NO{$_file_no} = $_fh; $FHN_NO{$_file_no} = $_file; # print STDERR __PACKAGE__, ":", __LINE__, "\n"; # print STDOUT __PACKAGE__, ":", __LINE__, "\n"; ( $self->{unbuffer} or $args->{unbuffer} ) and _unbuffer( $_fh ); # print STDERR __PACKAGE__, ":", __LINE__, "\n"; # print STDOUT __PACKAGE__, ":", __LINE__, "\n"; push @return, $_fh; } #print STDERR __FILE__, ":", __LINE__, " :: \n", $self->dump( -n => [ 'FHS_NA', 'FHS_NO', 'FHN_NO'], -d => [ \%FHS_NA, \%FHS_NO, \%FHN_NO]), "\n"; } return $reffile ? \@return : $return[0]; } sub _unbuffer { my $fh = shift; my $selected = select; # disable buffering on this filehandle select $fh; $| = 1; # restore previously selected filehandle select $selected; return $fh; } sub _WRITE { my $self = shift; #print STDERR __FILE__, ":", __LINE__, " :: ", $self->dump([ \@_ ]), "\n"; my $message; my $fh; my $args = {}; if ( $_[0] =~ /^-/ ) { $args = { @_ }; $message = $args->{-message} or return undef; ref $message eq 'ARRAY' or $message = [ $message ] ; $fh = $args->{-FH}; } else { shift @_ if ( $fh = $FHS_NA{$_[0]} ); local $STACK_TRACE = 1; print STDERR __FILE__, ":", __LINE__, " :: ", $self->dump([ \@_ ]), "\n"; $message = [ join ' ', __PACKAGE__->_caller(), map { defined $_ ? $_ : 'undef'; } @_ ] ; exit 1; } my $level = $args->{-level} || CLEAN; my $return = join '', map { defined $_ ? $_ : 'undef'; } @$message; if ( $args->{-terse} ) { $return =~ s/\s+/ /mg; } $fh ||= $FHS_NA{$default_fh}; my @fhs; my $reffh; if ( ref $fh eq 'ARRAY' ) { $reffh = 1; @fhs = @$fh; } else { $reffh = 0; @fhs = $fh; } foreach my $_fh ( @fhs ) { #print STDERR __FILE__, ":", __LINE__, " :: \n", $self->dump( -n => [ 'fh', 'FHS_NA', 'FHS_NO'], -d => [ $_fh, \%FHS_NA, \%FHS_NO]), "\n"; fileno($_fh) or $_fh = $FHS_NA{$_fh} or die "Invalid filehandle: " . $self->dump( -n => [ 'fh' ], -d => [ $_fh ] ); #_lock( $_fh ); print $_fh $return, $n or die ( "$!: arguments to _WRITE were => " . $self->dump( -n => [ 'args' ], -d => [ $args ] )); #_unlock( $_fh ); } #print STDERR "level=`", ($level || 'undef'), "'\n"; if ( $level =~ /^(CRIT|FATAL)$/ and ( defined $args->{handle_fatals} ? $args->{handle_fatals} : $self->{handle_fatals} ) ) { local $STACK_TRACE = 1; die $self->_caller( ) . "\n$return"; #die "$level\n"; die "FATAL error! $return\n"; } if ( $BIG_WARN_ON{$level} ) { #print STDERR "\n\n\nDOING BIG WARN ON '$level' '$ENV{BIG_WARN_ON_FATAL}'\n\n\n"; #local $STACK_TRACE = 1; warn $self->_caller( ) . "\n$return"; #die; } if ( $level eq QUIT ) { exit ($args->{QUIT} || $args->{EXIT} || $LOG_CODE{QUIT} ) unless $self->{DEBUG}{NO_QUIT}; } return $return; } } sub _lock { my $fh = shift; #flock($fh,LOCK_EX); # and, in case someone appended # while we were waiting... seek($fh, 0, 2); } sub _unlock { my $fh = shift; #flock($fh,LOCK_UN); } sub get_userinfo { if ( $^O =~ /mswin/i ) { return ( $ENV{USERNAME} ); } else { return getpwuid $<; } } END { # delete $FHS_NA{STDERR}; # delete $FHS_NA{STDOUT}; # foreach my $fh ( values %FHS_NA ) { # $fh->close(); # } } 1; __END__ =head1 NAME Easy::Log - Easy to use, feature rich general purpose logging utility =head1 SYNOPSIS use Easy::Log; $log = new Easy::Log; =item $log->write([{ OPTIONS }], , @message ); This is the main function for this package. If the first argument is a hash reference, it is taken as options to the logger for this log call ONLY, and may contain values for ANY of the options that the logger knows how to use. The first argument after the optional OPTIONS hash MUST BE the log level for this log. If it ends up being something that is not a log_level, then a default log_level is assigned to the write call. If the $log->write($log_level, @message) is equal to or greater than the $log->log_level() [or the $OPTIONS->{log_level}] then it will be output, otherwise it will not. =item $log->clone( [$data] ); make a duplicate of the supplied $data or this log object if no data is supplied. Uses data dumper to duplicate original, therefore CODE references are not necessarily handled, although the contents of $log->prefix() will be assigned to the new (cloned) object from the original. returns the cloned object =head2 OPTIONS =item $log->n(); set the message terminator for this log object, each log message output will be terminated with the contents of this setting (default "\n") =item $log->log(); set/return the log object to use for actual write operation, this occurrs AFTER the decision as to whether or not this log message will be processed. This allows one to set the log object to another logging module (such as running under apache) =item $log->log_file(); set the output file for messages processed through this log object ( can be a file path ( TBD -- or a file handle -- TBD -- a subroutine which returns a filehandle of filename -- TBD ), the default is 'STDOUT'. In the case of a file path, you may specify a write mode in the normal fashion: '>' to overwrite, '>>' to append ( eg $log->log_file( ">>$filename" ) or $log->write({log_file => ">$filename"}, $log_level, ...) If you specify '>' then the target file will be clobbered on the first $log->write() call when the target file is specified and a write file handle will be opened for the remainder of the life of the process. In subsequent calls, even if a '>' is specified, the file will not be re-clobbered, unless the filehandle has been explicitly closed since the last $log->write() call. =item $log->log_level(); set the threshold for which messages will actiually be logged, only messages with a log_level set to a (numerically) higher value will be output (default => WARN) =item $log->dump_refs(); set the behavior when references are encountered in the message list contents (default => 1) if true, use data dumper to dump out the references =item $log->handle_fatals(); if true, log module will terminate program execution on any log calls marked as FATAL or CRIT (CRIT for now [maybe add EMERG], default => 1) =item $log->exclusive(); if true, and set to a colon delimited set of log_level indicators, this log object will only output its message if the current log call is for a level listed in exclusive (default => undef) =item $log->stack_trace(); if true (and this log message is of sufficient log_level to be output), issue a pretty little stack trace for the log call =item $log->email(); #NOT YET IMPLEMENTED for a log level of MESSAGE, send the log message to the email address listed here, if not set, and a MESSAGE log comes in, then send the email to the owner of the process =item $log->prefix(); set the prefix that each log message will have, may be either a string, or a CODE ref =head1 DESCRIPTION This logging facility has many features developers may find handy. =item FILTERING One of the coolest things is FILTERING (see log_level_filtered). Using filtering we can greatly decrease the performance penalty of copious log entries (each requireing >1 subroutine call) by filtering out log messages at compile time. Here is the general idea: # FILTERED $log->write($dll, "Nifty stuff"); # NOT-FILTERED, but will issue a warning if $ENV{WARN_FILTER} is true. # because it looks kind of like a log_level indicator that sould be filtered ($dll) $log->write(dll, "Nifty stuff"); # NOT-FILTERED, functionally equivalent to previous example $log->write(DEBUG, "Nifty stuff"); =item PACKAGE SPECIFIC LOGGING Need docs here - set environment variable to a `#' separated list of regular expressions to match the names of packages where log messages should or should not be logged eg LOG_PACKAGES='!.*Foo.*#.*Bar.*' -- this would explicitly exclude log messages from any package matching Foo and would include log messages from packages matching Bar (this particular setting would effectively allow messages ONLY from packages matching Bar, because of an implicit deny for anything NOT matching Bar -- precedence is ALLOW -> DENY such that you can DENY broadly and ALLOW more specifically within a previously denied set) TBD -- Allow the setting of log levels on a per package basis eg '.*Foo.*=(DEBUG|INFO)' =item LOG_EXCLUSIVE Need docs here - Log only message whose log level matches the exclusive setting TBD -- Allow the setting of packages on a per log levels basis eg '(DEBUG|INFO)=.*Foo.*' similar to the proposed situation for LOG_PACKAGES =head2 EXPORT None by default. =over 8 =item log exports a log object into your namespace. This is most likely an application global log object meaning that if you wan't specific logging behavior in any given package, you'll probably want to intanntiate a new log object =item log_level exports several constants into your namespace: DEFAULT MESSAGE LOUD CLEAN EMERG ALERT CRIT FATAL ERROR WARN NOTICE INFO DEBUG TRACE SPEW =item log_level_filtered these are scalar variable ($) aliases for the constants mentioned in log_level, the convention is that each alias begins with the same letter as the real log_level, followed by 2 `l's (eg ERROR => $ell, DEBUG => $dll, etc) These log_level specifiers, when used with the leading dollar sign MAY BE FILTERED OUT depending upon the settings for $ENV{LOG_FILTER} =item log_level_not_filtered in name, these are identical to the log_level_filtered variables, but they are implemented as constants (no leading $) and they ARE NOT SUBJECT TO FILTERING AS IS THE CASE FOR log_level_filtered =back =head1 HISTORY =over 8 =item 0.01 Basic package w/ full functionality, but no docs yet =item 0.01.1 Basic package w/ full functionality, but no docs yet, used make dist to create pause upload =item 0.01.2 Added some documentation =back =head1 TODO =over 8 =item 0.01 DOCUMENTATION DOCUMENTATION DOCUMENTATION DOCUMENTATION DOCUMENTATION !!!!! =item 0.02 change the codes which represent the log_levels such that $xll style log calls can have slightly different behavior in terms of being programmer-debug calls, which will probably want to have detailed prefix informtaion, while non-programmer-debug calls may want different prefix info ($dll vs DEBUG) =back =head1 AUTHOR Theo Lengyel, Edirt@cpan.org =head1 SEE ALSO L. =cut