Log-Log4perl-1.46HEADLog-Log4perl-1.46master

1 files changed, 545 insertions, 0 deletions

diff --git a/lib/Log/Log4perl/Appender/File.pm b/lib/Log/Log4perl/Appender/File.pm
new file mode 100755
index 0000000..484f416
--- /dev/null
+++ b/lib/Log/Log4perl/Appender/File.pm
@@ -0,0 +1,545 @@
+##################################################
+package Log::Log4perl::Appender::File;
+##################################################
+
+our @ISA = qw(Log::Log4perl::Appender);
+
+use warnings;
+use strict;
+use Log::Log4perl::Config::Watch;
+use Fcntl;
+use File::Path;
+use File::Spec::Functions qw(splitpath);
+use constant _INTERNAL_DEBUG => 0;
+
+##################################################
+sub new {
+##################################################
+    my($class, @options) = @_;
+
+    my $self = {
+        name      => "unknown name",
+        umask     => undef,
+        owner     => undef,
+        group     => undef,
+        autoflush => 1,
+        syswrite  => 0,
+        mode      => "append",
+        binmode   => undef,
+        utf8      => undef,
+        recreate  => 0,
+        recreate_check_interval => 30,
+        recreate_check_signal   => undef,
+        recreate_pid_write      => undef,
+        create_at_logtime       => 0,
+        header_text             => undef,
+        mkpath                  => 0,
+        mkpath_umask            => 0,
+        @options,
+    };
+
+    if($self->{create_at_logtime}) {
+        $self->{recreate}  = 1;
+    }
+    for my $param ('umask', 'mkpath_umask') {
+        if(defined $self->{$param} and $self->{$param} =~ /^0/) {
+                # umask value is a string, meant to be an oct value
+            $self->{$param} = oct($self->{$param});
+        }
+    }
+
+    die "Mandatory parameter 'filename' missing" unless
+        exists $self->{filename};
+
+    bless $self, $class;
+
+    if($self->{recreate_pid_write}) {
+        print "Creating pid file",
+              " $self->{recreate_pid_write}\n" if _INTERNAL_DEBUG;
+        open FILE, ">$self->{recreate_pid_write}" or
+            die "Cannot open $self->{recreate_pid_write}";
+        print FILE "$$\n";
+        close FILE;
+    }
+
+        # This will die() if it fails
+    $self->file_open() unless $self->{create_at_logtime};
+
+    return $self;
+}
+
+##################################################
+sub filename {
+##################################################
+    my($self) = @_;
+
+    return $self->{filename};
+}
+
+##################################################
+sub file_open {
+##################################################
+    my($self) = @_;
+
+    my $arrows  = ">";
+    my $sysmode = (O_CREAT|O_WRONLY);
+
+
+    if($self->{mode} eq "append") {
+        $arrows   = ">>";
+        $sysmode |= O_APPEND;
+    } elsif ($self->{mode} eq "pipe") {
+        $arrows = "|";
+    } else {
+        $sysmode |= O_TRUNC;
+    }
+
+    my $fh = do { local *FH; *FH; };
+
+
+    my $didnt_exist = ! -e $self->{filename};
+    if($didnt_exist && $self->{mkpath}) {
+        my ($volume, $path, $file) = splitpath($self->{filename});
+        if($path ne '' && !-e $path) {
+            my $old_umask = umask($self->{mkpath_umask}) if defined $self->{mkpath_umask};
+            my $options = {};
+            foreach my $param (qw(owner group) ) {
+                $options->{$param} = $self->{$param} if defined $self->{$param};
+            }
+            eval {
+                mkpath($path,$options);
+            };
+            umask($old_umask) if defined $old_umask;
+            die "Can't create path ${path} ($!)" if $@;
+        }
+    }
+
+    my $old_umask = umask($self->{umask}) if defined $self->{umask};
+
+    eval {
+        if($self->{syswrite}) {
+            sysopen $fh, "$self->{filename}", $sysmode or
+                die "Can't sysopen $self->{filename} ($!)";
+        } else {
+            open $fh, "$arrows$self->{filename}" or
+                die "Can't open $self->{filename} ($!)";
+        }
+    };
+    umask($old_umask) if defined $old_umask;
+    die $@ if $@;
+
+    if($didnt_exist and
+         ( defined $self->{owner} or defined $self->{group} )
+      ) {
+
+        eval { $self->perms_fix() };
+
+        if($@) {
+              # Cleanup and re-throw
+            unlink $self->{filename};
+            die $@;
+        }
+    }
+
+    if($self->{recreate}) {
+        $self->{watcher} = Log::Log4perl::Config::Watch->new(
+            file           => $self->{filename},
+            (defined $self->{recreate_check_interval} ?
+              (check_interval => $self->{recreate_check_interval}) : ()),
+            (defined $self->{recreate_check_signal} ?
+              (signal => $self->{recreate_check_signal}) : ()),
+        );
+    }
+
+    $self->{fh} = $fh;
+
+    if ($self->{autoflush} and ! $self->{syswrite}) {
+        my $oldfh = select $self->{fh};
+        $| = 1;
+        select $oldfh;
+    }
+
+    if (defined $self->{binmode}) {
+        binmode $self->{fh}, $self->{binmode};
+    }
+
+    if (defined $self->{utf8}) {
+        binmode $self->{fh}, ":utf8";
+    }
+
+    if(defined $self->{header_text}) {
+        if( $self->{header_text} !~ /\n\Z/ ) {
+            $self->{header_text} .= "\n";
+        }
+        my $fh = $self->{fh};
+        print $fh $self->{header_text};
+    }
+}
+
+##################################################
+sub file_close {
+##################################################
+    my($self) = @_;
+
+    if(defined $self->{fh}) {
+        $self->close_with_care( $self->{ fh } );
+    }
+
+    undef $self->{fh};
+}
+
+##################################################
+sub perms_fix {
+##################################################
+    my($self) = @_;
+
+    my ($uid_org, $gid_org) = (stat $self->{filename})[4,5];
+
+    my ($uid, $gid) = ($uid_org, $gid_org);
+
+    if(!defined $uid) {
+        die "stat of $self->{filename} failed ($!)";
+    }
+
+    my $needs_fixing = 0;
+
+    if(defined $self->{owner}) {
+        $uid = $self->{owner};
+        if($self->{owner} !~ /^\d+$/) {
+            $uid = (getpwnam($self->{owner}))[2];
+            die "Unknown user: $self->{owner}" unless defined $uid;
+        }
+    }
+
+    if(defined $self->{group}) {
+        $gid = $self->{group};
+        if($self->{group} !~ /^\d+$/) {
+            $gid = getgrnam($self->{group});
+
+            die "Unknown group: $self->{group}" unless defined $gid;
+        }
+    }
+    if($uid != $uid_org or $gid != $gid_org) {
+        chown($uid, $gid, $self->{filename}) or
+            die "chown('$uid', '$gid') on '$self->{filename}' failed: $!";
+    }
+}
+
+##################################################
+sub file_switch {
+##################################################
+    my($self, $new_filename) = @_;
+
+    print "Switching file from $self->{filename} to $new_filename\n" if
+        _INTERNAL_DEBUG;
+
+    $self->file_close();
+    $self->{filename} = $new_filename;
+    $self->file_open();
+}
+
+##################################################
+sub log {
+##################################################
+    my($self, %params) = @_;
+
+    if($self->{recreate}) {
+        if($self->{recreate_check_signal}) {
+            if(!$self->{watcher} or
+               $self->{watcher}->{signal_caught}) {
+                $self->file_switch($self->{filename});
+                $self->{watcher}->{signal_caught} = 0;
+            }
+        } else {
+            if(!$self->{watcher} or
+                $self->{watcher}->file_has_moved()) {
+                $self->file_switch($self->{filename});
+            }
+        }
+    }
+
+    my $fh = $self->{fh};
+
+    if($self->{syswrite}) {
+       defined (syswrite $fh, $params{message}) or
+           die "Cannot syswrite to '$self->{filename}': $!";
+    } else {
+        print $fh $params{message} or
+            die "Cannot write to '$self->{filename}': $!";
+    }
+}
+
+##################################################
+sub DESTROY {
+##################################################
+    my($self) = @_;
+
+    if ($self->{fh}) {
+        my $fh = $self->{fh};
+        $self->close_with_care( $fh );
+    }
+}
+
+###########################################
+sub close_with_care {
+###########################################
+    my( $self, $fh ) = @_;
+
+    my $prev_rc = $?;
+
+    my $rc = close $fh;
+
+      # [rt #84723] If a sig handler is reaping the child generated
+      # by close() internally before close() gets to it, it'll
+      # result in a weird (but benign) error that we don't want to
+      # expose to the user.
+    if( !$rc ) {
+        if( $self->{ mode } eq "pipe" and
+            $!{ ECHILD } ) {
+            if( $Log::Log4perl::CHATTY_DESTROY_METHODS ) {
+                warn "$$: pipe closed with ECHILD error -- guess that's ok";
+            }
+            $? = $prev_rc;
+        } else {
+            warn "Can't close $self->{filename} ($!)";
+        }
+    }
+
+    return $rc;
+}
+
+1;
+
+__END__
+
+=encoding utf8
+
+=head1 NAME
+
+Log::Log4perl::Appender::File - Log to file
+
+=head1 SYNOPSIS
+
+    use Log::Log4perl::Appender::File;
+
+    my $app = Log::Log4perl::Appender::File->new(
+      filename  => 'file.log',
+      mode      => 'append',
+      autoflush => 1,
+      umask     => 0222,
+    );
+
+    $file->log(message => "Log me\n");
+
+=head1 DESCRIPTION
+
+This is a simple appender for writing to a file.
+
+The C<log()> method takes a single scalar. If a newline character
+should terminate the message, it has to be added explicitly.
+
+Upon destruction of the object, the filehandle to access the
+file is flushed and closed.
+
+If you want to switch over to a different logfile, use the
+C<file_switch($newfile)> method which will first close the old
+file handle and then open a one to the new file specified.
+
+=head2 OPTIONS
+
+=over 4
+
+=item filename
+
+Name of the log file.
+
+=item mode
+
+Messages will be append to the file if C<$mode> is set to the
+string C<"append">. Will clobber the file
+if set to C<"clobber">. If it is C<"pipe">, the file will be understood
+as executable to pipe output to. Default mode is C<"append">.
+
+=item autoflush
+
+C<autoflush>, if set to a true value, triggers flushing the data
+out to the file on every call to C<log()>. C<autoflush> is on by default.
+
+=item syswrite
+
+C<syswrite>, if set to a true value, makes sure that the appender uses
+syswrite() instead of print() to log the message. C<syswrite()> usually
+maps to the operating system's C<write()> function and makes sure that
+no other process writes to the same log file while C<write()> is busy.
+Might safe you from having to use other synchronisation measures like
+semaphores (see: Synchronized appender).
+
+=item umask
+
+Specifies the C<umask> to use when creating the file, determining
+the file's permission settings.
+If set to C<0022> (default), new
+files will be created with C<rw-r--r--> permissions.
+If set to C<0000>, new files will be created with C<rw-rw-rw-> permissions.
+
+=item owner
+
+If set, specifies that the owner of the newly created log file should
+be different from the effective user id of the running process.
+Only makes sense if the process is running as root.
+Both numerical user ids and user names are acceptable.
+Log4perl does not attempt to change the ownership of I<existing> files.
+
+=item group
+
+If set, specifies that the group of the newly created log file should
+be different from the effective group id of the running process.
+Only makes sense if the process is running as root.
+Both numerical group ids and group names are acceptable.
+Log4perl does not attempt to change the group membership of I<existing> files.
+
+=item utf8
+
+If you're printing out Unicode strings, the output filehandle needs
+to be set into C<:utf8> mode:
+
+    my $app = Log::Log4perl::Appender::File->new(
+      filename  => 'file.log',
+      mode      => 'append',
+      utf8      => 1,
+    );
+
+=item binmode
+
+To manipulate the output filehandle via C<binmode()>, use the
+binmode parameter:
+
+    my $app = Log::Log4perl::Appender::File->new(
+      filename  => 'file.log',
+      mode      => 'append',
+      binmode   => ":utf8",
+    );
+
+A setting of ":utf8" for C<binmode> is equivalent to specifying
+the C<utf8> option (see above).
+
+=item recreate
+
+Normally, if a file appender logs to a file and the file gets moved to
+a different location (e.g. via C<mv>), the appender's open file handle
+will automatically follow the file to the new location.
+
+This may be undesirable. When using an external logfile rotator,
+for example, the appender should create a new file under the old name
+and start logging into it. If the C<recreate> option is set to a true value,
+C<Log::Log4perl::Appender::File> will do exactly that. It defaults to
+false. Check the C<recreate_check_interval> option for performance
+optimizations with this feature.
+
+=item recreate_check_interval
+
+In C<recreate> mode, the appender has to continuously check if the
+file it is logging to is still in the same location. This check is
+fairly expensive, since it has to call C<stat> on the file name and
+figure out if its inode has changed. Doing this with every call
+to C<log> can be prohibitively expensive. Setting it to a positive
+integer value N will only check the file every N seconds. It defaults to 30.
+
+This obviously means that the appender will continue writing to
+a moved file until the next check occurs, in the worst case
+this will happen C<recreate_check_interval> seconds after the file
+has been moved or deleted. If this is undesirable,
+setting C<recreate_check_interval> to 0 will have the
+appender check the file with I<every> call to C<log()>.
+
+=item recreate_check_signal
+
+In C<recreate> mode, if this option is set to a signal name
+(e.g. "USR1"), the appender will recreate a missing logfile
+when it receives the signal. It uses less resources than constant
+polling. The usual limitation with perl's signal handling apply.
+Check the FAQ for using this option with the log rotating
+utility C<newsyslog>.
+
+=item recreate_pid_write
+
+The popular log rotating utility C<newsyslog> expects a pid file
+in order to send the application a signal when its logs have
+been rotated. This option expects a path to a file where the pid
+of the currently running application gets written to.
+Check the FAQ for using this option with the log rotating
+utility C<newsyslog>.
+
+=item create_at_logtime
+
+The file appender typically creates its logfile in its constructor, i.e.
+at Log4perl C<init()> time. This is desirable for most use cases, because
+it makes sure that file permission problems get detected right away, and
+not after days/weeks/months of operation when the appender suddenly needs
+to log something and fails because of a problem that was obvious at
+startup.
+
+However, there are rare use cases where the file shouldn't be created
+at Log4perl C<init()> time, e.g. if the appender can't be used by the current
+user although it is defined in the configuration file. If you set
+C<create_at_logtime> to a true value, the file appender will try to create
+the file at log time. Note that this setting lets permission problems
+sit undetected until log time, which might be undesirable.
+
+=item header_text
+
+If you want Log4perl to print a header into every newly opened
+(or re-opened) logfile, set C<header_text> to either a string
+or a subroutine returning a string. If the message doesn't have a newline,
+a newline at the end of the header will be provided.
+
+=item mkpath
+
+If this this option is set to true,
+the directory path will be created if it does not exist yet.
+
+=item mkpath_umask
+
+Specifies the C<umask> to use when creating the directory, determining
+the directory's permission settings.
+If set to C<0022> (default), new
+directory will be created with C<rwxr-xr-x> permissions.
+If set to C<0000>, new directory will be created with C<rwxrwxrwx> permissions.
+
+=back
+
+Design and implementation of this module has been greatly inspired by
+Dave Rolsky's C<Log::Dispatch> appender framework.
+
+=head1 LICENSE
+
+Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt>
+and Kevin Goess E<lt>cpan@goess.orgE<gt>.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Please contribute patches to the project on Github:
+
+    http://github.com/mschilli/log4perl
+
+Send bug reports or requests for enhancements to the authors via our
+
+MAILING LIST (questions, bug reports, suggestions/patches):
+log4perl-devel@lists.sourceforge.net
+
+Authors (please contact them via the list above, not directly):
+Mike Schilli <m@perlmeister.com>,
+Kevin Goess <cpan@goess.org>
+
+Contributors (in alphabetical order):
+Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton
+Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony
+Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy
+Grundman, Paul Harrington, Alexander Hartmaier  David Hull,
+Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter,
+Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope,
+Lars Thegler, David Viner, Mac Yang.
+