<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;"># --
# Kernel/System/Log.pm - log wapper
# Copyright (C) 2001-2014 OTRS AG, http://otrs.com/
# --
# This software comes with ABSOLUTELY NO WARRANTY. For details, see
# the enclosed file COPYING for license information (AGPL). If you
# did not receive this file, see http://www.gnu.org/licenses/agpl.txt.
# --

package Kernel::System::Log;
## nofilter(TidyAll::Plugin::OTRS::Perl::PODSpelling)
## nofilter(TidyAll::Plugin::OTRS::Perl::Time)
## nofilter(TidyAll::Plugin::OTRS::Perl::Dumper)
## nofilter(TidyAll::Plugin::OTRS::Perl::Require)

use strict;
use warnings;

use Kernel::System::Encode;

=head1 NAME

Kernel::System::Log - global log interface

=head1 SYNOPSIS

All log functions.

=head1 PUBLIC INTERFACE

=over 4

=cut

=item new()

create a log object

    use Kernel::Config;
    use Kernel::System::Encode;
    use Kernel::System::Log;

    my $ConfigObject = Kernel::Config-&gt;new();
    my $EncodeObject = Kernel::System::Encode-&gt;new(
        ConfigObject =&gt; $ConfigObject,
    );
    my $LogObject    = Kernel::System::Log-&gt;new(
        ConfigObject =&gt; $ConfigObject,
        EncodeObject =&gt; $EncodeObject,
        LogPrefix    =&gt; 'InstallScriptX',  # not required, but highly recommend
    );

=cut

sub new {
    my ( $Type, %Param ) = @_;

    # allocate new hash for object
    my $Self = {};
    bless( $Self, $Type );

    # get config object
    if ( !$Param{ConfigObject} ) {
        die 'Got no ConfigObject!';
    }

    $Self-&gt;{ProductVersion} = $Param{ConfigObject}-&gt;Get('Product') . ' ';
    $Self-&gt;{ProductVersion} .= $Param{ConfigObject}-&gt;Get('Version');

    # get system id
    my $SystemID = $Param{ConfigObject}-&gt;Get('SystemID');

    # get or create encode object
    $Self-&gt;{EncodeObject} = $Param{EncodeObject};
    $Self-&gt;{EncodeObject} ||= Kernel::System::Encode-&gt;new( %{$Self} );

    # check log prefix
    $Self-&gt;{LogPrefix} = $Param{LogPrefix} || '?LogPrefix?';
    $Self-&gt;{LogPrefix} .= '-' . $SystemID;

    # load log backend
    my $GenericModule = $Param{ConfigObject}-&gt;Get('LogModule') || 'Kernel::System::Log::SysLog';
    if ( !eval "require $GenericModule" ) {    ## no critic
        die "Can't load log backend module $GenericModule! $@";
    }

    # create backend handle
    $Self-&gt;{Backend} = $GenericModule-&gt;new(
        %Param,
        EncodeObject =&gt; $Self-&gt;{EncodeObject},
    );

    return $Self if !eval "require IPC::SysV";    ## no critic

    # create the IPC options
    $Self-&gt;{IPC}     = 1;
    $Self-&gt;{IPCKey}  = '444423' . $SystemID;
    $Self-&gt;{IPCSize} = $Param{ConfigObject}-&gt;Get('LogSystemCacheSize') || 32 * 1024;

    # init session data mem
    if ( !eval { $Self-&gt;{Key} = shmget( $Self-&gt;{IPCKey}, $Self-&gt;{IPCSize}, oct(1777) ) } ) {
        $Self-&gt;{Key} = shmget( $Self-&gt;{IPCKey}, 1, oct(1777) );
        $Self-&gt;CleanUp();
        $Self-&gt;{Key} = shmget( $Self-&gt;{IPCKey}, $Self-&gt;{IPCSize}, oct(1777) );
    }

    return $Self;
}

=item Log()

log something. log priorities are 'debug', 'info', 'notice' and 'error'.

These are mapped to the SysLog priorities. Please use the appropriate priority level:

=over

=item debug

Debug-level messages; info useful for debugging the application, not useful during operations.

=item info

Informational messages; normal operational messages - may be used for reporting etc, no action required.

=item notice

Normal but significant condition; events that are unusual but not error conditions, no immediate action required.

=item error

Error conditions. Non-urgent failures, should be relayed to developers or admins, each item must be resolved.

=back

See for more info L&lt;http://en.wikipedia.org/wiki/Syslog#Severity_levels&gt;

    $LogObject-&gt;Log(
        Priority =&gt; 'error',
        Message  =&gt; "Need something!",
    );

=cut

sub Log {
    my ( $Self, %Param ) = @_;

    my $Priority = $Param{Priority} || 'debug';
    my $Message  = $Param{MSG}      || $Param{Message} || '???';
    my $Caller   = $Param{Caller}   || 0;

    # returns the context of the current subroutine and sub-subroutine!
    my ( $Package1, $Filename1, $Line1, $Subroutine1 ) = caller( $Caller + 0 );
    my ( $Package2, $Filename2, $Line2, $Subroutine2 ) = caller( $Caller + 1 );

    $Subroutine2 ||= $0;

    # log backend
    $Self-&gt;{Backend}-&gt;Log(
        Priority  =&gt; $Priority,
        Message   =&gt; $Message,
        LogPrefix =&gt; $Self-&gt;{LogPrefix},
        Module    =&gt; $Subroutine2,
        Line      =&gt; $Line1,
    );

    # if error, write it to STDERR
    if ( $Priority =~ /^error/i ) {

        ## no critic
        my $Error = sprintf "ERROR: $Self-&gt;{LogPrefix} Perl: %vd OS: $^O Time: "
            . localtime() . "\n\n", $^V;
        ## use critic

        $Error .= " Message: $Message\n\n";

        if ( %ENV &amp;&amp; ( $ENV{REMOTE_ADDR} || $ENV{REQUEST_URI} ) ) {

            my $RemoteAddress = $ENV{REMOTE_ADDR} || '-';
            my $RequestURI    = $ENV{REQUEST_URI} || '-';

            $Error .= " RemoteAddress: $RemoteAddress\n";
            $Error .= " RequestURI: $RequestURI\n\n";
        }

        $Error .= " Traceback ($$): \n";

        COUNT:
        for ( my $Count = 0; $Count &lt; 30; $Count++ ) {

            my ( $Package1, $Filename1, $Line1, $Subroutine1 ) = caller( $Caller + $Count );

            last COUNT if !$Line1;

            my ( $Package2, $Filename2, $Line2, $Subroutine2 ) = caller( $Caller + 1 + $Count );

            # if there is no caller module use the file name
            $Subroutine2 ||= $0;

            # print line if upper caller module exists
            my $VersionString = '';

            eval { $VersionString = $Package1-&gt;VERSION || ''; };    ## no critic

            # Version is present
            if ($VersionString) {
                $VersionString = 'v' . $VersionString;
            }

            # OTRS modules do not have a version variable
            elsif ( index( $Package1, 'Kernel::' ) &gt; -1 ) {
                $VersionString = $Self-&gt;{ProductVersion};
            }

            # Other modules
            else {
                $VersionString = 'unknown version';
            }

            $Error .= "   Module: $Subroutine2 ($VersionString) Line: $Line1\n";

            last COUNT if !$Line2;
        }

        $Error .= "\n";
        print STDERR $Error;

        # store data (for the frontend)
        $Self-&gt;{error}-&gt;{Message}   = $Message;
        $Self-&gt;{error}-&gt;{Traceback} = $Error;
    }

    # remember to info and notice messages
    elsif ( lc $Priority eq 'info' || lc $Priority eq 'notice' ) {
        $Self-&gt;{ lc $Priority }-&gt;{Message} = $Message;
    }

    # write shm cache log
    if ( lc $Priority ne 'debug' &amp;&amp; $Self-&gt;{IPC} ) {

        $Priority = lc $Priority;

        my $Data   = localtime() . ";;$Priority;;$Self-&gt;{LogPrefix};;$Message\n";    ## no critic
        my $String = $Self-&gt;GetLog();

        shmwrite( $Self-&gt;{Key}, $Data . $String, 0, $Self-&gt;{IPCSize} ) || die $!;
    }

    return 1;
}

=item GetLogEntry()

to get the last log info back

    my $Message = $LogObject-&gt;GetLogEntry(
        Type =&gt; 'error', # error|info|notice
        What =&gt; 'Message', # Message|Traceback
    );

=cut

sub GetLogEntry {
    my ( $Self, %Param ) = @_;

    return $Self-&gt;{ lc $Param{Type} }-&gt;{ $Param{What} } || '';
}

=item GetLog()

to get the tmp log data (from shared memory - ipc) in csv form

    my $CSVLog = $LogObject-&gt;GetLog();

=cut

sub GetLog {
    my ( $Self, %Param ) = @_;

    my $String = '';
    if ( $Self-&gt;{IPC} ) {
        shmread( $Self-&gt;{Key}, $String, 0, $Self-&gt;{IPCSize} ) || die "$!";
    }

    # encode the string
    $Self-&gt;{EncodeObject}-&gt;EncodeInput( \$String );

    return $String;
}

=item CleanUp()

to clean up tmp log data from shared memory (ipc)

    $LogObject-&gt;CleanUp();

=cut

sub CleanUp {
    my ( $Self, %Param ) = @_;

    return 1 if !$Self-&gt;{IPC};

    # remove the shm
    if ( !shmctl( $Self-&gt;{Key}, 0, 0 ) ) {
        $Self-&gt;Log(
            Priority =&gt; 'error',
            Message  =&gt; "Can't remove shm for log: $!",
        );
        return;
    }

    return 1;
}

=item Dumper()

dump a perl variable to log

    $LogObject-&gt;Dumper(@Array);

    or

    $LogObject-&gt;Dumper(%Hash);

=cut

sub Dumper {
    my ( $Self, @Data ) = @_;

    require Data::Dumper;    ## no critic

    # returns the context of the current subroutine and sub-subroutine!
    my ( $Package1, $Filename1, $Line1, $Subroutine1 ) = caller(0);
    my ( $Package2, $Filename2, $Line2, $Subroutine2 ) = caller(1);

    $Subroutine2 ||= $0;

    # log backend
    $Self-&gt;{Backend}-&gt;Log(
        Priority  =&gt; 'debug',
        Message   =&gt; substr( Data::Dumper::Dumper(@Data), 0, 600600600 ),    ## no critic
        LogPrefix =&gt; $Self-&gt;{LogPrefix},
        Module    =&gt; $Subroutine2,
        Line      =&gt; $Line1,
    );

    return 1;
}

1;

=back

=head1 TERMS AND CONDITIONS

This software is part of the OTRS project (L&lt;http://otrs.org/&gt;).

This software comes with ABSOLUTELY NO WARRANTY. For details, see
the enclosed file COPYING for license information (AGPL). If you
did not receive this file, see L&lt;http://www.gnu.org/licenses/agpl.txt&gt;.

=cut
</pre></body></html>