File Coverage

blib/lib/Log/Log4perl/Appender/File.pm
Criterion Covered Total %
statement 132 167 79.0
branch 65 110 59.0
condition 20 33 60.6
subroutine 19 20 95.0
pod 2 9 22.2
total 238 339 70.2


line stmt bran cond sub pod time code
1             ##################################################
2             ##################################################
3              
4             our @ISA = qw(Log::Log4perl::Appender);
5              
6             use warnings;
7 16     16   3751 use strict;
  16         38  
  16         612  
8 16     16   85 use Log::Log4perl::Config::Watch;
  16         43  
  16         367  
9 16     16   88 use Fcntl;
  16         37  
  16         423  
10 16     16   90 use File::Path;
  16         32  
  16         4919  
11 16     16   125 use File::Spec::Functions qw(splitpath catpath);
  16         49  
  16         1260  
12 16     16   7469 use constant _INTERNAL_DEBUG => 0;
  16         13727  
  16         1082  
13 16     16   113 use constant SYSWRITE_UTF8_OK => ( $] < 5.024 );
  16         36  
  16         1242  
14 16     16   102  
  16         34  
  16         32791  
15             ##################################################
16             ##################################################
17             my($class, @options) = @_;
18              
19 49     49 1 223 my $self = {
20             name => "unknown name",
21 49         619 umask => undef,
22             owner => undef,
23             group => undef,
24             autoflush => 1,
25             syswrite => 0,
26             mode => "append",
27             binmode => undef,
28             utf8 => 0,
29             recreate => 0,
30             recreate_check_interval => 30,
31             recreate_check_signal => undef,
32             recreate_pid_write => undef,
33             create_at_logtime => 0,
34             header_text => undef,
35             mkpath => 0,
36             mkpath_umask => 0,
37             @options,
38             };
39              
40             if($self->{create_at_logtime}) {
41             $self->{recreate} = 1;
42 49 100       183 }
43 2         5 for my $param ('umask', 'mkpath_umask') {
44             if(defined $self->{$param} and $self->{$param} =~ /^0/) {
45 49         112 # umask value is a string, meant to be an oct value
46 98 100 66     545 $self->{$param} = oct($self->{$param});
47             }
48 50         213 }
49              
50             die "Mandatory parameter 'filename' missing" unless
51             exists $self->{filename};
52              
53 49 50       163 bless $self, $class;
54              
55 49         178 if($self->{recreate_pid_write}) {
56             print "Creating pid file",
57 49 50       209 " $self->{recreate_pid_write}\n" if _INTERNAL_DEBUG;
58 0         0 open FILE, ">$self->{recreate_pid_write}" or
59             die "Cannot open $self->{recreate_pid_write}";
60 0 0       0 print FILE "$$\n";
61             close FILE;
62 0         0 }
63 0         0  
64             print "Calling syswrite_encoder\n" if _INTERNAL_DEBUG;
65              
66 49         239 $self->{syswrite_encoder} = $self->syswrite_encoder();
67              
68 49         141 print "syswrite_encoder returned\n" if _INTERNAL_DEBUG;
69              
70 49         227 # This will die() if it fails
71             $self->file_open() unless $self->{create_at_logtime};
72              
73 49 100       224 return $self;
74             }
75 49         223  
76             ##################################################
77             ##################################################
78             my($self) = @_;
79              
80             if( !SYSWRITE_UTF8_OK and $self->{syswrite} and $self->{utf8} ) {
81 49     49 0 110 print "Requiring Encode\n" if _INTERNAL_DEBUG;
82             eval { require Encode };
83 49 100 100     246 print "Requiring Encode returned: $@\n" if _INTERNAL_DEBUG;
84 2         3  
85 2         4 if( $@ ) {
  2         512  
86 2         14449 die "syswrite and utf8 requires Encode.pm";
87             } else {
88 2 50       6 return sub { Encode::encode_utf8($_[0]) };
89 0         0 }
90             }
91 2     2   11  
  2         50  
92             return undef;
93             }
94              
95 47         219 ##################################################
96             ##################################################
97             my($self) = @_;
98              
99             return $self->{filename};
100             }
101 1     1 1 4  
102             ##################################################
103 1         7 ##################################################
104             my($self) = @_;
105              
106             my $arrows = ">";
107             my $sysmode = (O_CREAT|O_WRONLY);
108              
109 58     58 0 126  
110             if($self->{mode} eq "append") {
111 58         109 $arrows = ">>";
112 58         102 $sysmode |= O_APPEND;
113             } elsif ($self->{mode} eq "pipe") {
114             $arrows = "|";
115 58 100       182 } else {
    50          
116 39         68 $sysmode |= O_TRUNC;
117 39         255 }
118              
119 0         0 my $fh = do { local *FH; *FH; };
120              
121 19         37  
122             my $didnt_exist = ! -e $self->{filename};
123             if($didnt_exist && $self->{mkpath}) {
124 58         236 my ($volume, $path, $file) = splitpath($self->{filename});
  58         156  
  58         229  
125             if($path ne '' && !-e $path) {
126             my $old_umask = umask($self->{mkpath_umask}) if defined $self->{mkpath_umask};
127 58         1256 my $options = {};
128 58 100 100     333 foreach my $param (qw(owner group) ) {
129 2         12 $options->{$param} = $self->{$param} if defined $self->{$param};
130 2 50 33     60 }
131 2 50       22 eval {
132 2         7 mkpath(catpath($volume, $path, ''),$options);
133 2         6 };
134 4 50       10 umask($old_umask) if defined $old_umask;
135             die "Can't create path ${path} ($!)" if $@;
136 2         14 }
137 2         11 }
138              
139 2 50       760 my $old_umask = umask($self->{umask}) if defined $self->{umask};
140 2 50       12  
141             eval {
142             if($self->{syswrite}) {
143             sysopen $fh, "$self->{filename}", $sysmode or
144 58 100       196 die "Can't sysopen $self->{filename} ($!)";
145             } else {
146 58         119 open $fh, "$arrows$self->{filename}" or
147 58 100       180 die "Can't open $self->{filename} ($!)";
148 11 50       717 }
149             };
150             umask($old_umask) if defined $old_umask;
151 47 50       3897 die $@ if $@;
152              
153             if($didnt_exist and
154             ( defined $self->{owner} or defined $self->{group} )
155 58 100       353 ) {
156 58 50       136  
157             eval { $self->perms_fix() };
158 58 50 33     291  
      66        
159             if($@) {
160             # Cleanup and re-throw
161             unlink $self->{filename};
162 0         0 die $@;
  0         0  
163             }
164 0 0       0 }
165              
166 0         0 if($self->{recreate}) {
167 0         0 $self->{watcher} = Log::Log4perl::Config::Watch->new(
168             file => $self->{filename},
169             (defined $self->{recreate_check_interval} ?
170             (check_interval => $self->{recreate_check_interval}) : ()),
171 58 100       173 (defined $self->{recreate_check_signal} ?
172             (signal => $self->{recreate_check_signal}) : ()),
173             );
174             }
175              
176             $self->{fh} = $fh;
177 19 50       257  
    100          
178             if ($self->{autoflush} and ! $self->{syswrite}) {
179             my $oldfh = select $self->{fh};
180             $| = 1;
181 58         175 select $oldfh;
182             }
183 58 100 66     351  
184 47         276 if (defined $self->{binmode}) {
185 47         177 binmode $self->{fh}, $self->{binmode};
186 47         167 }
187              
188             if ($self->{utf8}) {
189 58 100       204 # older perls can handle syswrite+utf8 just fine
190 2         11 if(SYSWRITE_UTF8_OK or !$self->{syswrite}) {
191             binmode $self->{fh}, ":utf8";
192             }
193 58 100       177 }
194              
195 3 100       8 if(defined $self->{header_text}) {
196 1         5 if( $self->{header_text} !~ /\n\Z/ ) {
197             $self->{header_text} .= "\n";
198             }
199              
200 58 100       213 # quick and dirty print/syswrite without the usual
201 2 50       9 # log() recreate magic.
202 2         7 local $self->{recreate} = 0;
203             $self->log( message => $self->{header_text} );
204             }
205             }
206              
207 2         7 ##################################################
208 2         6 ##################################################
209             my($self) = @_;
210              
211             if(defined $self->{fh}) {
212             $self->close_with_care( $self->{ fh } );
213             }
214              
215 11     11 0 29 undef $self->{fh};
216             }
217 11 100       37  
218 9         34 ##################################################
219             ##################################################
220             my($self) = @_;
221 11         57  
222             my ($uid_org, $gid_org) = (stat $self->{filename})[4,5];
223              
224             my ($uid, $gid) = ($uid_org, $gid_org);
225              
226             if(!defined $uid) {
227 0     0 0 0 die "stat of $self->{filename} failed ($!)";
228             }
229 0         0  
230             my $needs_fixing = 0;
231 0         0  
232             if(defined $self->{owner}) {
233 0 0       0 $uid = $self->{owner};
234 0         0 if($self->{owner} !~ /^\d+$/) {
235             $uid = (getpwnam($self->{owner}))[2];
236             die "Unknown user: $self->{owner}" unless defined $uid;
237 0         0 }
238             }
239 0 0       0  
240 0         0 if(defined $self->{group}) {
241 0 0       0 $gid = $self->{group};
242 0         0 if($self->{group} !~ /^\d+$/) {
243 0 0       0 $gid = getgrnam($self->{group});
244              
245             die "Unknown group: $self->{group}" unless defined $gid;
246             }
247 0 0       0 }
248 0         0 if($uid != $uid_org or $gid != $gid_org) {
249 0 0       0 chown($uid, $gid, $self->{filename}) or
250 0         0 die "chown('$uid', '$gid') on '$self->{filename}' failed: $!";
251             }
252 0 0       0 }
253              
254             ##################################################
255 0 0 0     0 ##################################################
256 0 0       0 my($self, $new_filename) = @_;
257              
258             print "Switching file from $self->{filename} to $new_filename\n" if
259             _INTERNAL_DEBUG;
260              
261             $self->file_close();
262             $self->{filename} = $new_filename;
263             $self->file_open();
264 11     11 0 32 }
265              
266 11         17 ##################################################
267             ##################################################
268             my($self, %params) = @_;
269 11         57  
270 11         28 # Warning: this function gets called by file_open() which assumes
271 11         40 # it can use it as a simple print/syswrite wrapper by temporary
272             # disabling the 'recreate' entry. Add anything fancy here and
273             # fix up file_open() accordingly.
274              
275             if($self->{recreate}) {
276             if($self->{recreate_check_signal}) {
277 69     69 0 305 if(!$self->{watcher} or
278             $self->{watcher}->{signal_caught}) {
279             $self->file_switch($self->{filename});
280             $self->{watcher}->{signal_caught} = 0;
281             }
282             } else {
283             if(!$self->{watcher} or
284 69 100       213 $self->{watcher}->file_has_moved()) {
285 20 100       107 $self->file_switch($self->{filename});
286 9 100 100     51 }
287             }
288 4         15 }
289 4         9  
290             my $fh = $self->{fh};
291              
292 11 100 100     79 if($self->{syswrite}) {
293             my $rc =
294 6         36 syswrite( $fh,
295             $self->{ syswrite_encoder } ?
296             $self->{ syswrite_encoder }->($params{message}) :
297             $params{message} );
298              
299 69         205 if(!defined $rc) {
300             die "Cannot syswrite to '$self->{filename}': $!";
301 69 100       183 }
302             } else {
303             print $fh $params{message} or
304             die "Cannot write to '$self->{filename}': $!";
305             }
306 13 100       324 }
307              
308 13 50       123 ##################################################
309 0         0 ##################################################
310             my($self) = @_;
311              
312             if ($self->{fh}) {
313 56 50       2673 my $fh = $self->{fh};
314             $self->close_with_care( $fh );
315             }
316             }
317              
318             ###########################################
319             ###########################################
320 47     47   1719 my( $self, $fh ) = @_;
321              
322 47 50       172 my $prev_rc = $?;
323 47         138  
324 47         146 my $rc = close $fh;
325              
326             # [rt #84723] If a sig handler is reaping the child generated
327             # by close() internally before close() gets to it, it'll
328             # result in a weird (but benign) error that we don't want to
329             # expose to the user.
330             if( !$rc ) {
331 56     56 0 172 if( $self->{ mode } eq "pipe" and
332             $!{ ECHILD } ) {
333 56         151 if( $Log::Log4perl::CHATTY_DESTROY_METHODS ) {
334             warn "$$: pipe closed with ECHILD error -- guess that's ok";
335 56         1334 }
336             $? = $prev_rc;
337             } else {
338             warn "Can't close $self->{filename} ($!)";
339             }
340             }
341 56 50       291  
342 0 0 0     0 return $rc;
343 5     5   2368 }
  5         7295  
  5         52  
344 0 0       0  
345 0         0 1;
346              
347 0         0  
348             =encoding utf8
349 0         0  
350             =head1 NAME
351              
352             Log::Log4perl::Appender::File - Log to file
353 56         542  
354             =head1 SYNOPSIS
355              
356             use Log::Log4perl::Appender::File;
357              
358             my $app = Log::Log4perl::Appender::File->new(
359             filename => 'file.log',
360             mode => 'append',
361             autoflush => 1,
362             umask => 0222,
363             );
364              
365             $file->log(message => "Log me\n");
366              
367             =head1 DESCRIPTION
368              
369             This is a simple appender for writing to a file.
370              
371             The C<log()> method takes a single scalar. If a newline character
372             should terminate the message, it has to be added explicitly.
373              
374             Upon destruction of the object, the filehandle to access the
375             file is flushed and closed.
376              
377             If you want to switch over to a different logfile, use the
378             C<file_switch($newfile)> method which will first close the old
379             file handle and then open a one to the new file specified.
380              
381             =head2 OPTIONS
382              
383             =over 4
384              
385             =item filename
386              
387             Name of the log file.
388              
389             =item mode
390              
391             Messages will be append to the file if C<$mode> is set to the
392             string C<"append">. Will clobber the file
393             if set to C<"clobber">. If it is C<"pipe">, the file will be understood
394             as executable to pipe output to. Default mode is C<"append">.
395              
396             =item autoflush
397              
398             C<autoflush>, if set to a true value, triggers flushing the data
399             out to the file on every call to C<log()>. C<autoflush> is on by default.
400              
401             =item syswrite
402              
403             C<syswrite>, if set to a true value, makes sure that the appender uses
404             syswrite() instead of print() to log the message. C<syswrite()> usually
405             maps to the operating system's C<write()> function and makes sure that
406             no other process writes to the same log file while C<write()> is busy.
407             Might safe you from having to use other synchronisation measures like
408             semaphores (see: Synchronized appender).
409              
410             =item umask
411              
412             Specifies the C<umask> to use when creating the file, determining
413             the file's permission settings.
414             If set to C<0022> (default), new
415             files will be created with C<rw-r--r--> permissions.
416             If set to C<0000>, new files will be created with C<rw-rw-rw-> permissions.
417              
418             =item owner
419              
420             If set, specifies that the owner of the newly created log file should
421             be different from the effective user id of the running process.
422             Only makes sense if the process is running as root.
423             Both numerical user ids and user names are acceptable.
424             Log4perl does not attempt to change the ownership of I<existing> files.
425              
426             =item group
427              
428             If set, specifies that the group of the newly created log file should
429             be different from the effective group id of the running process.
430             Only makes sense if the process is running as root.
431             Both numerical group ids and group names are acceptable.
432             Log4perl does not attempt to change the group membership of I<existing> files.
433              
434             =item utf8
435              
436             If you're printing out Unicode strings, the output filehandle needs
437             to be set into C<:utf8> mode:
438              
439             my $app = Log::Log4perl::Appender::File->new(
440             filename => 'file.log',
441             mode => 'append',
442             utf8 => 1,
443             );
444              
445             =item binmode
446              
447             To manipulate the output filehandle via C<binmode()>, use the
448             binmode parameter:
449              
450             my $app = Log::Log4perl::Appender::File->new(
451             filename => 'file.log',
452             mode => 'append',
453             binmode => ":utf8",
454             );
455              
456             A setting of ":utf8" for C<binmode> is equivalent to specifying
457             the C<utf8> option (see above).
458              
459             =item recreate
460              
461             Normally, if a file appender logs to a file and the file gets moved to
462             a different location (e.g. via C<mv>), the appender's open file handle
463             will automatically follow the file to the new location.
464              
465             This may be undesirable. When using an external logfile rotator,
466             for example, the appender should create a new file under the old name
467             and start logging into it. If the C<recreate> option is set to a true value,
468             C<Log::Log4perl::Appender::File> will do exactly that. It defaults to
469             false. Check the C<recreate_check_interval> option for performance
470             optimizations with this feature.
471              
472             =item recreate_check_interval
473              
474             In C<recreate> mode, the appender has to continuously check if the
475             file it is logging to is still in the same location. This check is
476             fairly expensive, since it has to call C<stat> on the file name and
477             figure out if its inode has changed. Doing this with every call
478             to C<log> can be prohibitively expensive. Setting it to a positive
479             integer value N will only check the file every N seconds. It defaults to 30.
480              
481             This obviously means that the appender will continue writing to
482             a moved file until the next check occurs, in the worst case
483             this will happen C<recreate_check_interval> seconds after the file
484             has been moved or deleted. If this is undesirable,
485             setting C<recreate_check_interval> to 0 will have the
486             appender check the file with I<every> call to C<log()>.
487              
488             =item recreate_check_signal
489              
490             In C<recreate> mode, if this option is set to a signal name
491             (e.g. "USR1"), the appender will recreate a missing logfile
492             when it receives the signal. It uses less resources than constant
493             polling. The usual limitation with perl's signal handling apply.
494             Check the FAQ for using this option with the log rotating
495             utility C<newsyslog>.
496              
497             =item recreate_pid_write
498              
499             The popular log rotating utility C<newsyslog> expects a pid file
500             in order to send the application a signal when its logs have
501             been rotated. This option expects a path to a file where the pid
502             of the currently running application gets written to.
503             Check the FAQ for using this option with the log rotating
504             utility C<newsyslog>.
505              
506             =item create_at_logtime
507              
508             The file appender typically creates its logfile in its constructor, i.e.
509             at Log4perl C<init()> time. This is desirable for most use cases, because
510             it makes sure that file permission problems get detected right away, and
511             not after days/weeks/months of operation when the appender suddenly needs
512             to log something and fails because of a problem that was obvious at
513             startup.
514              
515             However, there are rare use cases where the file shouldn't be created
516             at Log4perl C<init()> time, e.g. if the appender can't be used by the current
517             user although it is defined in the configuration file. If you set
518             C<create_at_logtime> to a true value, the file appender will try to create
519             the file at log time. Note that this setting lets permission problems
520             sit undetected until log time, which might be undesirable.
521              
522             =item header_text
523              
524             If you want Log4perl to print a header into every newly opened
525             (or re-opened) logfile, set C<header_text> to either a string
526             or a subroutine returning a string. If the message doesn't have a newline,
527             a newline at the end of the header will be provided.
528              
529             =item mkpath
530              
531             If this this option is set to true,
532             the directory path will be created if it does not exist yet.
533              
534             =item mkpath_umask
535              
536             Specifies the C<umask> to use when creating the directory, determining
537             the directory's permission settings.
538             If set to C<0022> (default), new
539             directory will be created with C<rwxr-xr-x> permissions.
540             If set to C<0000>, new directory will be created with C<rwxrwxrwx> permissions.
541              
542             =back
543              
544             Design and implementation of this module has been greatly inspired by
545             Dave Rolsky's C<Log::Dispatch> appender framework.
546              
547             =head1 LICENSE
548              
549             Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt>
550             and Kevin Goess E<lt>cpan@goess.orgE<gt>.
551              
552             This library is free software; you can redistribute it and/or modify
553             it under the same terms as Perl itself.
554              
555             =head1 AUTHOR
556              
557             Please contribute patches to the project on Github:
558              
559             http://github.com/mschilli/log4perl
560              
561             Send bug reports or requests for enhancements to the authors via our
562              
563             MAILING LIST (questions, bug reports, suggestions/patches):
564             log4perl-devel@lists.sourceforge.net
565              
566             Authors (please contact them via the list above, not directly):
567             Mike Schilli <m@perlmeister.com>,
568             Kevin Goess <cpan@goess.org>
569              
570             Contributors (in alphabetical order):
571             Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton
572             Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony
573             Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy
574             Grundman, Paul Harrington, Alexander Hartmaier David Hull,
575             Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter,
576             Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope,
577             Lars Thegler, David Viner, Mac Yang.
578