view release on metacpan or  search on metacpan

lib/App/CELL/Log.pm  view on Meta::CPAN

Takes PARAMHASH as argument. Recognized parameters: 

=over

=item C<ident> -- (i.e., category) string, e.g. 'FooBar' for
the FooBar application, or 'CELLtest' if none given

=item C<show_caller> -- sets the C<$show_caller> package variable (see
above)

=item C<debug_mode> -- sets the C<$debug_mode> package variable (see above)

=back

Always returns 1.

=cut

sub init {
    my ( $self, %ARGS ) = @_;

    # process 'ident'
    if ( defined( $ARGS{ident} ) ) {
        if ( $ARGS{ident} eq $ident and $ident ne 'CELLtest' ) {
            $log->info( "Logging already configured", cell => 1 );
        } else {
            $ident = $ARGS{ident};
            $log_any_obj = Log::Any->get_logger(category => $ident);
        }
    } else {
        $ident = 'CELLtest';
        $log_any_obj = Log::Any->get_logger(category => $ident);
    }    

    # process 'debug_mode' argument
    if ( exists( $ARGS{debug_mode} ) ) {
        $debug_mode = 1 if $ARGS{debug_mode};
        $debug_mode = 0 if not $ARGS{debug_mode};
    }
    #$log->info( "debug_mode is $debug_mode", cell => 1 );
    
    # process 'show_caller'
    if ( exists( $ARGS{show_caller} ) ) {
        $show_caller = 1 if $ARGS{show_caller};
        $show_caller = 0 if not $ARGS{show_caller};
    }

    return 1;
}


=head2 DESTROY

For some reason, Perl 5.012 seems to want a DESTROY method

=cut 

sub DESTROY {
    my $self = shift;
    $self->SUPER::DESTROY if $self->can("SUPER::DESTROY");
}


=head2 AUTOLOAD

Call Log::Any methods after some pre-processing

=cut

sub AUTOLOAD {
    
    my ( $class, $msg_text, @ARGS ) = @_;
    my $method = $AUTOLOAD;
    $method =~ s/.*:://;

    # if method is not in permitted_levels, pass through to Log::Any
    # directly
    if ( not grep { $_ =~ m/$method/i } @permitted_levels ) {
        return $log_any_obj->$method( $msg_text, @ARGS );
    }

    # we are logging a message
    my %ARGS;
    %ARGS = @ARGS if @ARGS % 2 == 0;
    my ( $file, $line );
    my ( $level, $text );
    my $method_uc = uc $method;
    if ( $method_uc eq 'OK' or $method_uc eq 'NOT_OK' ) {
        $level = $method_uc;
        $method_uc = 'INFO';
        $method = 'info';
    } else {
        $level = $method_uc;
    }
    my $method_lc = lc $method;

    # determine what caller info will be displayed, if any
    if ( %ARGS ) {
        if ( $ARGS{caller} ) {
            ( undef, $file, $line ) = @{ $ARGS{caller} };
        } elsif ( $ARGS{suppress_caller} ) {
            ( $file, $line ) = ( '', '' );
        } else {
            ( undef, $file, $line ) = caller;
        }
    } else {
        ( undef, $file, $line ) = caller;
    }

    # if this is a CELL internal debug message, continue only if
    # the CELL_DEBUG_MODE environment variable exists and is true
    if ( $ARGS{'cell'} and ( $method_lc eq 'debug' or $method_lc eq 'trace') ) {
        return unless $ENV{'CELL_DEBUG_MODE'};
    }

    $log->init( ident => $ident ) if not $log_any_obj;
    die "No Log::Any object!" if not $log_any_obj;
    return if not $debug_mode and ( $method_lc eq 'debug' or $method_lc eq 'trace' );
    if ( not $msg_text ) {
        $msg_text = "<NO_TEXT>"