view release on metacpan or  search on metacpan

lib/DBIx/JCL.pm  view on Meta::CPAN

    my ($addrlist, $message) = split m/~/, $params;
    $mail_pagerto = $addrlist;
    _log_send_page($message, 'MESSAGE');
    exit 0;
}

sub _sys_help {
=begin wiki

!3 _sys_help

Parameters: ( p1, p2, p3 )

Please write this documentation.

Returns:

=cut
    my $verbose = shift;
    $verbose = 0 unless $verbose;
    my $section;

    if ( $verbose == 0 ) {
        print "\nUSAGE\n      $script_file [options]\n\n";
        print "Use option -h   for help with options\n";
        print "Use option -hp  for help with option parameters\n";
        print "Use option -man for system documentation\n";
        exit 1;
    }

    if ( $verbose == 1 ) { $section = 'OPTIONS'; };
    if ( $verbose == 2 ) { $section = 'ARGUMENTS'; };

    print "\n";
    my %podparams = (
        infile  => $path_lib_dir."DBIx/JCL.pm",
        outfile => "STDOUT",
        section => $section,
    );
    wikipod2text( %podparams );
    exit 1;
}

sub _log_init_log_file {
=begin wiki

!3 _log_init_log_file

Parameters: ( p1, p2, p3 )

Please write this documentation.

Returns:

=cut
    ## log file rotation if generations > 0
    if ( -e $log_filefull && $log_gdg > 0 ) {
        _log_rotate();
    }

    ## create new locked log file
    ## if the file is already locked, will wait until the file is unlocked
    my $fh = new IO::LockedFile(">$log_filefull")
        or sys_die( 'Failed opening log file', 0 );
    ## close and unlock the file
    $fh->close();

    $sys_log_open = 1;

    return 0;
}

sub _log_write_to_log {
=begin wiki

!3 _log_write_to_log

Parameters: ( p1, p2, p3 )

Please write this documentation.

Returns:

=cut
    my ($level, $force, $msg, $exmsg) = @_;
    my ($message,$exmessage);

    if ( ref $exmsg eq 'ARRAY' ) {
        my $lead = ' ' x 18;
        $lead .= '+ ';
        my @output = map { $lead . $_ . "\n" } @{$exmsg};
        my $exmessage = join '', @output;
        $exmessage =~ s/\n$//ms;
        $message = $msg . "\n" . $exmessage;
    } else {
        $message = $msg;
        $message =~ s/\n/ /g;
    }

    if ( $log_logging_levels =~ /$level/ || $force ) {
        _log_print_log( $level, $message );
    }

    _log_send_notifications( $level, $force, $msg );

    return 0;
}

sub _log_write_to_screen {
=begin wiki

!3 _log_write_to_screen

Parameters: ( p1, p2, p3 )

Please write this documentation.

Returns:

=cut
    my ($level, $force, $msg, $exmsg) = @_;
    my ($message,$exmessage);

    if ( ref $exmsg eq 'ARRAY' ) {
        my $lead = ' ' x 18;
        $lead .= '+ ';
        my @output = map { $lead . $_ . "\n" } @{$exmsg};
        my $exmessage = join '', @output;
        $message = $msg . "\n" . $exmessage;
    } else {
        $message = $msg;
        $message =~ s/\n/ /g;
    }

    $message = _log_trim_msg( $message );

    if ( $opt_verbose ) {
        print "$message\n";
    } else {
        if ( $log_console_levels =~ /$level/ || $force ) {
            print "$message\n";
        }
    }

    return 0;
}

sub _log_print_log {
=begin wiki

!3 _log_print_log

Parameters: ( p1, p2, p3 )

Please write this documentation.

Returns:

=cut
    my ($level, $message) = @_;

    my $preamble = time2str( '%Y/%m/%d %T', time );
    if ( $level eq 'FATAL' ) { $preamble .= ' FATAL'; }
    if ( $level eq 'ERROR' ) { $preamble .= ' ERROR'; }
    if ( $level eq 'WARN'  ) { $preamble .= ' WARNING'; }

    ## open locked log file for appending
    ## if the file is already locked, will wait until the file is unlocked
    my $fh = new IO::LockedFile(">>$log_filefull")
        or sys_die( 'Failed opening log file', 0 );
    print {$fh} "$preamble $message\n";
    ## close and unlock the file
    $fh->close();
    return 0;
}

sub _log_trim_msg {
=begin wiki

!3 _log_trim_msg

Parameters: ( message )

Format log file text so that it looks good when printed to STDOUT.  This \
function is only called from the logging functions. This takes message \
text that was previously retrieved by dbms_output_get and stringified by \
a logging function and removes the leading whitespace from each line of \
text, if there is any. This is made necessary due to the fact that this \
text started life as an array of lines retrieved from dbms_output_get(), \
and each of these lines had leading whitespace to make them more readable \
in the log file.

Returns:

=cut
    my $msg = shift;
    my $trimmed = '';
    if ( $msg =~ /\n/ms ) {   ## trim leading spaces from multi-line messages
        foreach my $m ( split m/\n/, $msg ) {
            $m =~ s/^\s+//;
            $trimmed .= $m."\n";
        }
        $trimmed =~ s/\n$//ms;
    } else {
        $trimmed = $msg;
    }
    return $trimmed;
}

sub _log_send_notifications {
=begin wiki

!3 _log_send_notifications

Parameters: ( message, severity_level )

Send email and pager notifications based on supplied severity. If the \
severity levels for email and or pager notifications are at or below the \
severity level supplied to this function, a notification will be sent.

Note: if running under test harness (different than test mode), all \
messages are logged, but no notifications of any severity will be generated. \
Generation of actual email and pager notices is not testable using the test \
harness.

Returns:

=cut