File Coverage

blib/lib/Log/Dispatch/FileRotate.pm
Criterion Covered Total %
statement 218 275 79.2
branch 61 116 52.5
condition 27 66 40.9
subroutine 21 22 95.4
pod 6 10 60.0
total 333 489 68.1


line stmt bran cond sub pod time code
1             package Log::Dispatch::FileRotate;
2             $Log::Dispatch::FileRotate::VERSION = '1.38';
3             # ABSTRACT: Log to Files that Archive/Rotate Themselves
4              
5             require 5.005;
6 8     8   2125704 use strict;
  8         48  
  8         251  
7              
8 8     8   43 use base 'Log::Dispatch::Output';
  8         15  
  8         3527  
9              
10 8     8   868632 use Date::Manip;
  8         1141377  
  8         1074  
11 8     8   79 use File::Spec;
  8         16  
  8         187  
12 8     8   4030 use Log::Dispatch::File;
  8         253322  
  8         328  
13 8     8   4315 use Log::Dispatch::FileRotate::Mutex;
  8         20  
  8         22929  
14              
15             sub DESTROY {
16 8     8   151845 my $self = shift;
17              
18             # get rid of current LDF
19 8 50       38 if ($self->{LDF}) {
20 8         46 delete $self->{LDF};
21             }
22             }
23              
24              
25             sub new {
26 9     9 1 63806 my $proto = shift;
27 9   33     56 my $class = ref $proto || $proto;
28              
29 9         70 my %p = @_;
30              
31 9         37 my $self = bless {}, $class;
32              
33             # Turn ON/OFF debugging as required
34 9         62 $self->{debug} = $p{DEBUG};
35 9         76 $self->_basic_init(%p);
36 9         1051 $self->{LDF} = Log::Dispatch::File->new(%p); # Our log
37              
38 9 50       3290 unless (defined $self->{timer}) {
39 9     237   59 $self->{timer} = sub { time };
  237         408  
40             }
41              
42             # Keep a copy of interesting stuff as well
43 9         32 $self->{params} = \%p;
44              
45             # Size defaults to 10meg in all failure modes, hopefully
46 9         23 my $ten_meg = 1024*1024*10;
47 9         19 my $two_gig = 1024*1024*1024*2;
48 9         20 my $size = $ten_meg;
49              
50 9 100       31 if (defined $p{size}) {
51             # allow perl-literal style nubers 10_000_000 -> 10000000
52 6         23 $p{size} =~ s/_//g;
53 6         14 $size = $p{size};
54             }
55              
56 9 50 33     112 unless ($size =~ /^\d+$/ && $size < $two_gig && $size > 0) {
      33        
57 0         0 $size = $ten_meg;
58             }
59              
60 9         28 $self->{size} = $size;
61              
62             # Max number of files defaults to 1. No limit enforced here. Only
63             # positive whole numbers allowed
64 9         20 $self->{max} = $p{max};
65              
66 9 50 66     94 unless (defined $self->{max} && $self->{max} =~ /^\d+$/ && $self->{max} > 0) {
      66        
67 2         3 $self->{max} = 1
68             }
69              
70             # Get a name for our Lock file
71 9         24 my $name = $self->{params}->{filename};
72 9         142 my ($vol, $dir, $f) = File::Spec->splitpath($name);
73 9   50     30 $dir ||= '.';
74 9   33     24 $f ||= $name;
75              
76 9         83 $self->{lf} = File::Spec->catpath($vol, $dir, ".${f}.LCK");
77 9         54 $self->debug('Lock file is '.$self->{lf});
78              
79             # Have we been called with a time based rotation pattern then setup
80             # timebased stuff. TZ is important and must match current TZ or all
81             # bets are off!
82 9 100       30 if (defined $p{TZ}) {
83             # Date::Manip deprecated TZ= in 6.x. In order to maintain backwards
84             # compat with 5.8, we use TZ if setdate is not avilable. Otherwise we
85             # use setdate.
86 1         547 require version;
87 1 50       2156 if (version->parse(DateManipVersion()) < version->parse('6.0')) {
88 0         0 Date_Init("TZ=".$p{TZ});
89             }
90             else {
91             # Date::Manip 6.x deprecates TZ, use SetDate instead
92 1         70 Date_Init("setdate=now,".$p{TZ});
93             }
94             }
95              
96 9 100       1990 if (defined $p{DatePattern}) {
97 7         39 $self->setDatePattern($p{DatePattern});
98             }
99              
100 9 50       50 $self->{check_both} = $p{check_both} ? 1 : 0;
101              
102             # User callback to rotate the file.
103 9         40 $self->{user_constraint} = $p{user_constraint};
104              
105             # A post rotate callback.
106 9         48 $self->{post_rotate} = $p{post_rotate};
107              
108             # Flag this as first creation point
109 9         30 $self->{new} = 1;
110              
111 9         56 return $self;
112             }
113              
114              
115             sub filename {
116 230     230 1 337 my $self = shift;
117              
118 230         463 return $self->{params}->{filename};
119             }
120              
121              
122             ###########################################################################
123             #
124             # Subroutine setDatePattern
125             #
126             # Args: a single string or ArrayRef of strings
127             #
128             # Rtns: Nothing
129             #
130             # Description:
131             # Set a recurrance for file rotation. We accept Date::Manip
132             # recurrances and the log4j/DailyRollingFileAppender patterns
133             #
134             # Date:Manip =>
135             # 0:0:0:0:5:30:0 every 5 hours and 30 minutes
136             # 0:0:0:2*12:30:0 every 2 days at 12:30 (each day)
137             # 3*1:0:2:12:0:0 every 3 years on Jan 2 at noon
138             #
139             # DailyRollingFileAppender =>
140             # yyyy-MM
141             # yyyy-ww
142             # yyyy-MM-dd
143             # yyyy-MM-dd-a
144             # yyyy-MM-dd-HH
145             # yyyy-MM-dd-HH-MM
146             #
147             # To specify multiple recurances in a single string seperate them with a
148             # comma: yyyy-MM-dd,0:0:0:2*12:30:0
149             #
150             sub setDatePattern {
151 7     7 1 20 my ($self, $arg) = @_;
152              
153 7         15 local($_); # Don't crap on $_
154 7         25 my @pats = ();
155              
156 7         82 my %lookup = (
157             # Y:M:W:D:H:M:S
158             'yyyy-mm' => '0:1*0:1:0:0:0', # Every Month
159             'yyyy-ww' => '0:0:1*0:0:0:0', # Every week
160             'yyyy-dd' => '0:0:0:1*0:0:0', # Every day
161             'yyyy-mm-dd' => '0:0:0:1*0:0:0', # Every day
162             'yyyy-dd-a' => '0:0:0:1*12:0:0', # Every day 12noon
163             'yyyy-mm-dd-a' => '0:0:0:1*12:0:0', # Every day 12noon
164             'yyyy-dd-hh' => '0:0:0:0:1*0:0', # Every hour
165             'yyyy-mm-dd-hh' => '0:0:0:0:1*0:0', # Every hour
166             'yyyy-dd-hh-mm' => '0:0:0:0:0:1*0', # Every minute
167             'yyyy-mm-dd-hh-mm' => '0:0:0:0:0:1*0', # Every minute
168             );
169              
170             # Convert arg to array
171 7 50       36 if (ref $arg eq 'ARRAY') {
    50          
172 0         0 @pats = @$arg;
173             }
174             elsif (!ref $arg) {
175 7         32 $arg =~ s/\s+//go;
176 7         27 @pats = split /;/, $arg;
177             }
178             else {
179 0         0 die "Bad reference type argument ".ref $arg;
180             }
181              
182             # Handle (possibly multiple) recurrances
183 7         20 foreach my $pat (@pats) {
184             # Convert any log4j patterns across
185 7 50       37 if ($pat =~ /^yyyy/i) {
186             # log4j style
187 7         25 $pat = $lookup{lc $pat};
188              
189             # Default to daily on bad pattern
190 7 50       29 unless (defined $pat) {
191 0         0 warn "Bad Rotation pattern ($pat) using yyyy-dd\n";
192 0         0 $pat = 'yyyy-dd';
193             }
194             }
195              
196 7         30 my $abs = $self->_get_next_occurance($pat);
197              
198 7         49 $self->debug("Adding [dates,pat] =>[$abs,$pat]");
199              
200 7         21 my $ref = [$abs, $pat];
201              
202 7         16 push @{$self->{recurrance}}, $ref;
  7         94  
203             }
204             }
205              
206              
207             sub log_message {
208 228     228 1 33346 my ($self, %p) = @_;
209              
210 228         556 my $mutex = $self->rotate(1);
211              
212 228 50       449 unless (defined $mutex) {
213 0         0 $self->error('not logging');
214 0         0 return;
215             }
216              
217 228         499 $self->debug('normal log');
218              
219 228         662 $self->logit($p{message});
220              
221 228         678 $self->debug('releasing lock');
222              
223 228         618 $mutex->unlock;
224             }
225              
226              
227             sub rotate {
228 228     228 1 409 my ($self, $hold_lock) = @_;
229             # NOTE: $hold_lock is internal use only!
230              
231 228         449 my $max_size = $self->{size};
232 228         382 my $numfiles = $self->{max};
233 228         539 my $name = $self->filename();
234 228         450 my $fh = $self->{LDF}->{fh};
235              
236             # Prime our time based data outside the critical code area
237 228         500 my ($in_time_mode,$time_to_rotate) = $self->time_to_rotate();
238              
239 228         423 my $user_rotation = 0;
240 228 50       505 if (ref $self->{user_constraint} eq 'CODE') {
241             eval {
242 0         0 $user_rotation = &{$self->{user_constraint}}();
  0         0  
243              
244 0         0 1;
245 0 0       0 } or do {
246 0         0 $self->error("user's callback error: $@");
247             };
248             }
249              
250             # Handle critical code for logging. No changes if someone else is in. We
251             # lock a lockfile, not the actual log filehandle since the log filehandle
252             # will change if we rotate the logs.
253 228         518 my $mutex = $self->mutex_for_path($self->{lf});
254              
255 228 50       596 unless ($mutex->lock) {
256 0         0 $self->error("failed to get lock: $!");
257 0         0 return;
258             }
259              
260 228         746 $self->debug('got lock');
261              
262 228         368 my $have_to_rotate = 0;
263 228         2371 my ($inode, $size) = (stat $fh)[1,7]; # real inode and size
264 228         2984 my $finode = (stat $name)[1]; # inode of filename for comparision
265              
266 228 50       1617 $self->debug("s=$size, i=$inode, f=".
267             (defined $finode ? $finode : "undef") .
268             ", n=$name");
269              
270             # If finode and inode are the same then nobody has done a rename
271             # under us and we can continue. Otherwise just close and reopen.
272 228 50 33     855 if (!defined $finode || $inode != $finode) {
273             # Oops someone moved things on us. So just reopen our log
274 0         0 delete $self->{LDF}; # Should get rid of current LDF
275 0         0 $self->{LDF} = Log::Dispatch::File->new(%{$self->{params}}); # Our log
  0         0  
276              
277 0         0 $self->debug('Someone else rotated');
278             }
279             else {
280 228         389 my $check_both = $self->{check_both};
281 228 50       445 my $rotate_by_size = ($size >= $max_size) ? 1 : 0;
282              
283 228 50 66     1627 if(($in_time_mode && $time_to_rotate) ||
      33        
      66        
      33        
      33        
      33        
284             (!$in_time_mode && $rotate_by_size) ||
285             ($rotate_by_size && $check_both) ||
286             ($user_rotation))
287             {
288 1         2 $have_to_rotate = 1;
289             }
290              
291 228         840 $self->debug("in time mode: $in_time_mode; time to rotate: $time_to_rotate;"
292             ." rotate by size: $rotate_by_size; check_both: $check_both;"
293             ." user rotation: $user_rotation; have to rotate: $have_to_rotate");
294             }
295              
296 228 100       497 if ($have_to_rotate) {
297             # Shut down the log
298 1         8 delete $self->{LDF}; # Should get rid of current LDF
299              
300 1         37 $self->debug('Rotating');
301 1         5 $self->_for_each_file(\&_move_file);
302 1         4 $self->debug('Rotating Done');
303              
304             # reopen the logfile for writing.
305 1         1 $self->{LDF} = Log::Dispatch::File->new(%{$self->{params}}); # Our log
  1         13  
306              
307 1 50       432 if (ref $self->{post_rotate} eq 'CODE') {
308 0         0 $self->debug('Calling user post-rotate callback');
309 0         0 $self->_for_each_file($self->{post_rotate});
310             }
311             }
312              
313 228 50       454 if ($hold_lock) {
314 228         527 return $mutex;
315             }
316              
317 0         0 $mutex->unlock;
318              
319 0         0 return $have_to_rotate;
320             }
321              
322             sub _for_each_file {
323 1     1   4 my ($self, $callback) = @_;
324              
325 1         3 my $basename = $self->filename();
326 1         3 my $idx = $self->{max} - 1;
327              
328 1         4 while ($idx >= 0) {
329 6         11 my $filename = $basename;
330              
331 6 100       13 if ($idx) {
332 5         12 $filename .= ".$idx";
333             }
334              
335             eval {
336 6 100       96 if (-f $filename) {
337 1         4 &{$callback}($filename, $idx, $self);
  1         4  
338             }
339              
340 6         19 1;
341 6 50       10 } or do {
342 0         0 $self->error("callback error: $@");
343             };
344              
345 6         16 $idx--;
346             }
347              
348 1         2 return undef;
349             }
350              
351             sub _move_file {
352 1     1   3 my ($filename, $idx, $fileRotate) = @_;
353              
354 1         4 my $basename = $fileRotate->filename();
355 1         5 my $newfile = $basename . '.' . ($idx+1);
356              
357 1         7 $fileRotate->debug("rename $filename $newfile");
358              
359 1         40 rename $filename, $newfile;
360              
361 1         14 return undef;
362             }
363              
364             sub logit {
365 228     228 0 366 my ($self, $message) = @_;
366              
367             # Make sure we are at the EOF
368 228         2143 seek $self->{LDF}{fh}, 0, 2;
369              
370 228         1212 $self->{LDF}->log_message(message => $message);
371              
372 228         7070 return;
373             }
374              
375             {
376             my %MUTEXES;
377              
378             sub mutex_for_path {
379 228     228 0 422 my ($self, $path) = @_;
380              
381 228         295 my %args;
382              
383             # use same permissions for the Mutex file
384 228 100       476 if (exists $self->{params}{permissions}) {
385 3         8 $args{permissions} = $self->{params}{permissions};
386             }
387              
388 228   66     676 $MUTEXES{$path} ||= Log::Dispatch::FileRotate::Mutex->new($path, %args);
389             }
390             }
391              
392             ###########################################################################
393             #
394             # Subroutine time_to_rotate
395             #
396             # Args: none
397             #
398             # Rtns: (1,n) if we are in time mode and its time to rotate
399             # n defines the number of timers that expired
400             # (1,0) if we are in time mode but not ready to rotate
401             # (0,0) otherwise
402             #
403             # Description:
404             # time_to_rotate - update internal clocks and return status as
405             # defined above
406             #
407             # If we have just been created then the first recurrance is an indication
408             # to check against the log file.
409             #
410             #
411             # my ($in_time_mode,$time_to_rotate) = $self->time_to_rotate();
412             sub time_to_rotate {
413 228     228 0 330 my $self = shift;
414              
415 228         404 my $mode = defined $self->{recurrance};
416 228         381 my $rotate = 0;
417              
418 228 50       556 if ($mode) {
419             # Then do some checking and update ourselves if we think we need
420             # to rotate. Wether we rotate or not is up to our caller. We
421             # assume they know what they are doing!
422              
423             # Only stat the log file here if we are in our first invocation.
424             my $ftime = $self->{new}
425 228 100       639 ? (stat $self->{LDF}{fh})[9]
426             : 0;
427              
428             # Check need for rotation. Loop through our recurrances looking
429             # for expiration times. Any we find that have expired we update.
430 228         469 my $tm = $self->{timer}->();
431 228         365 my @recur = @{$self->{recurrance}};
  228         468  
432              
433 228         513 $self->{recurrance} = [];
434              
435 228         435 for my $rec (@recur) {
436 228         477 my ($abs, $pat) = @$rec;
437              
438             # Extra checking
439 228 50 33     949 unless (defined $abs && $abs) {
440 0         0 warn "Bad time found for recurrance pattern $pat: $abs\n";
441 0         0 next;
442             }
443              
444 228         343 my $dorotate = 0;
445              
446             # If this is first time through
447 228 100       594 if ($self->{new}) {
    100          
448             # If it needs a rotate then flag it
449 7 50       50 if ($ftime <= $abs) {
450             # Then we need to rotate
451 0         0 $self->debug("Need rotate file($ftime) <= $abs");
452 0         0 $rotate++;
453 0         0 $dorotate++; # Just for debugging
454             }
455              
456             # Move to next occurance regardless
457 7         54 $self->debug("Dropping initial occurance($abs)");
458 7         32 $abs = $self->_get_next_occurance($pat);
459 7 50 33     55 unless (defined $abs && $abs) {
460 0         0 warn "Next occurance is null for $pat\n";
461 0         0 $abs = 0;
462             }
463             }
464             elsif ($abs <= $tm) {
465             # Then we need to rotate
466 1         19 $self->debug("Need rotate $abs <= $tm");
467 1         10 $abs = $self->_get_next_occurance($pat);
468 1 50 33     7 unless (defined $abs && $abs) {
469 0         0 warn "Next occurance is null for $pat\n";
470 0         0 $abs = 0;
471             }
472              
473 1         2 $rotate++;
474 1         2 $dorotate++; # Just for debugging
475             }
476              
477 228 50       469 if ($abs) {
478 228         319 push @{$self->{recurrance}}, [$abs, $pat];
  228         652  
479             }
480              
481 228         804 $self->debug("time_to_rotate(mode,rotate,next) => ($mode,$dorotate,$abs)");
482             }
483             }
484              
485 228         371 $self->{new} = 0; # No longer brand-spankers
486              
487 228         663 $self->debug("time_to_rotate(mode,rotate) => ($mode,$rotate)");
488              
489 228 50       779 return wantarray ? ($mode, $rotate) : $rotate;
490             }
491              
492             ###########################################################################
493             #
494             # Subroutine _gen_occurance
495             #
496             # Args: Date::Manip occurance pattern
497             #
498             # Rtns: array of dates for next few events
499             #
500             # If asked we will return an inital occurance that is before the current
501             # time. This can be used to see if we need to rotate on start up. We are
502             # often called by CGI (short lived) proggies :-(
503             #
504             sub _gen_occurance {
505 7     7   19 my ($self, $pat, $initial) = @_;
506              
507             # Do we return an initial occurance before the current time?
508 7   50     26 $initial ||= 0;
509              
510 7         16 my $range = '';
511 7         15 my $base = 'now'; # default to calcs based on the current time
512              
513 7 50       45 if ($pat =~ /^0:0:0:0:0/) {
    50          
    0          
    0          
    0          
514             # Small recurrance less than 1 hour
515 0         0 $range = "4 hours later";
516 0 0       0 $base = "1 hours ago" if $initial;
517             }
518             elsif ($pat =~ /^0:0:0:0/) {
519             # recurrance less than 1 day
520 7         13 $range = "4 days later";
521 7 50       24 $base = "1 days ago" if $initial;
522             }
523             elsif ($pat =~ /^0:0:0:/) {
524             # recurrance less than 1 week
525 0         0 $range = "4 weeks later";
526 0 0       0 $base = "1 weeks ago" if $initial;
527             }
528             elsif ($pat =~ /^0:0:/) {
529             # recurrance less than 1 month
530 0         0 $range = "4 months later";
531 0 0       0 $base = "1 months ago" if $initial;
532             }
533             elsif ($pat =~ /^0:/) {
534             # recurrance less than 1 year
535 0         0 $range = "24 months later";
536 0 0       0 $base = "24 months ago" if $initial;
537             }
538             else {
539             # years
540 0         0 my ($yrs) = $pat =~ m/^(\d+):/;
541              
542 0   0     0 $yrs ||= 1;
543              
544 0         0 my $months = $yrs * 4 * 12;
545              
546 0         0 $range = "$months months later";
547 0 0       0 $base = "$months months ago" if $initial;
548             }
549              
550             # The next date must start at least 1 second away from now other wise
551             # we may rotate for every message we recieve with in this second :-(
552 7         47 my $start = DateCalc($base,"+ 1 second");
553              
554 7         313529 $self->debug("ParseRecur($pat,$base,$start,$range);");
555              
556 7         36 my @dates = ParseRecur($pat,$base,$start,$range);
557              
558             # Just in case we have a bad parse or our assumptions are wrong.
559             # We default to days
560 7 50       1572538 unless (scalar @dates >= 2) {
561 0         0 warn "Failed to parse ($pat). Going daily\n";
562              
563 0 0       0 if ($initial) {
564 0         0 @dates = ParseRecur('0:0:0:1*0:0:0',"2 days ago","2 days ago","1 months later");
565             }
566             else {
567 0         0 @dates = ParseRecur('0:0:0:1*0:0:0',"now","now","1 months later");
568             }
569             }
570              
571             # Convert the dates to seconds since the epoch so we can use
572             # numerical comparision instead of textual
573 7         27 my @epochs = ();
574 7         37 my @a = ('%Y','%m','%d','%H','%M','%S');
575 7         29 foreach (@dates) {
576 840         2288 my ($y,$m,$d,$h,$mn,$s) = Date::Manip::UnixDate($_, @a);
577              
578 840         612673 my $e = Date_SecsSince1970GMT($m,$d,$y,$h,$mn,$s);
579              
580 840         427090 $self->debug("Date to epochs ($_) => ($e)");
581              
582 840         2249 push @epochs, $e;
583             }
584              
585             # Clean out all but the one previous to now if we are doing an
586             # initial occurance
587 7         27 my $now = time;
588              
589 7 50       58 if ($initial) {
590 7         21 my $before = '';
591              
592 7   66     82 while (@epochs && $epochs[0] <= $now) {
593 168         465 $before = shift @epochs;
594             }
595              
596 7 50       46 if ($before) {
597 7         21 unshift @epochs, $before;
598             }
599             }
600             else {
601             # Clean out dates that occur before now, being careful not to loop
602             # forever (thanks James).
603 0   0     0 while (@epochs && $epochs[0] <= $now) {
604 0         0 shift @epochs;
605             }
606             }
607              
608 7         291 $self->debug("Recurrances are at: ". join "\n\t", @dates);
609              
610 7 50       55 warn "No recurrances found! Probably a timezone issue!\n" unless @dates;
611              
612 7         201 return @epochs;
613             }
614              
615             ###########################################################################
616             #
617             # Subroutine _get_next_occurance
618             #
619             # Args: Date::Manip occurance pattern
620             #
621             # Rtns: date
622             #
623             # We don't want to call Date::Manip::ParseRecur too often as it is very
624             # expensive. So, we cache what is returned from _gen_occurance().
625             sub _get_next_occurance {
626 15     15   50 my ($self, $pat) = @_;
627              
628             # (ms) Throw out expired occurances
629 15         40 my $now = $self->{timer}->();
630              
631 15 100       59 if (defined $self->{dates}{$pat}) {
632 8         27 while (@{$self->{dates}{$pat}}) {
  17         60  
633 17 100       56 last if $self->{dates}{$pat}->[0] >= $now;
634 9         11 shift @{$self->{dates}{$pat}};
  9         17  
635             }
636             }
637              
638             # If this is first time then generate some new ones including one
639             # before our time to test against the log file
640 15 100 33     55 unless (defined $self->{'dates'}{$pat}) {
641 7         30 @{$self->{'dates'}{$pat}} = $self->_gen_occurance($pat,1);
  7         67  
642             }
643             elsif (scalar(@{$self->{'dates'}{$pat}}) < 2) {
644             # close to the end of what we have
645             @{$self->{'dates'}{$pat}} = $self->_gen_occurance($pat);
646             }
647              
648 15         44 return shift @{$self->{'dates'}{$pat}};
  15         57  
649             }
650              
651              
652             sub debug {
653 2477     2477 1 4627 my ($self, $message) = @_;
654              
655 2477 50       6056 return unless $self->{debug};
656              
657 0           warn localtime() . " $$ $message\n";
658              
659 0           return;
660             }
661              
662             sub error {
663 0     0 0   my ($self, $message) = @_;
664              
665 0           chomp $message;
666              
667 0           warn "$$ " . __PACKAGE__ . " $message\n";
668             }
669              
670             1;
671              
672             __END__
673              
674             =pod
675              
676             =encoding UTF-8
677              
678             =head1 NAME
679              
680             Log::Dispatch::FileRotate - Log to Files that Archive/Rotate Themselves
681              
682             =head1 VERSION
683              
684             version 1.38
685              
686             =head1 SYNOPSIS
687              
688             use Log::Dispatch::FileRotate;
689              
690             my $logger = Log::Dispatch::FileRotate->new(
691             name => 'file1',
692             min_level => 'info',
693             filename => 'Somefile.log',
694             mode => 'append' ,
695             size => 10*1024*1024,
696             max => 6);
697              
698             # or for a time based rotation
699              
700             my $logger = Log::Dispatch::FileRotate->new(
701             name => 'file1',
702             min_level => 'info',
703             filename => 'Somefile.log',
704             mode => 'append' ,
705             TZ => 'AEDT',
706             DatePattern => 'yyyy-dd-HH');
707              
708             # and attach to Log::Dispatch
709             my $dispatcher = Log::Dispatch->new;
710             $dispatcher->add($logger);
711              
712             $dispatcher->log( level => 'info', message => "your comment\n" );
713              
714             =head1 DESCRIPTION
715              
716             This module extends the base class L<Log::Dispatch::Output> to provides a
717             simple object for logging to files under the Log::Dispatch::* system, and
718             automatically rotating them according to different constraints. This is
719             basically a L<Log::Dispatch::File> wrapper with additions.
720              
721             =head2 Rotation
722              
723             There are three different constraints which decide when a file must be
724             rotated.
725              
726             The first is by size: when the log file grows more than a specified
727             size, then it's rotated.
728              
729             The second constraint is with occurrences. If a L</DatePattern> is defined, a
730             file rotation ignores size constraint (unless C<check_both>) and uses the
731             defined date pattern constraints. When using L</DatePattern> make sure TZ is
732             defined correctly and that the TZ you use is understood by Date::Manip. We use
733             Date::Manip to generate our recurrences. Bad TZ equals bad recurrences equals
734             surprises! Read the L<Date::Manip> man page for more details on
735             TZ. L</DatePattern> will default to a daily rotate if your entered pattern is
736             incorrect. You will also get a warning message.
737              
738             You can also check both constraints together by using the C<check_both>
739             parameter.
740              
741             The latter constraint is a user callback. This function is called outside the
742             restricted area (see L</Concurrency>) and,
743             if it returns a true value, a rotation will happen unconditionally.
744              
745             All check are made before logging. The C<rotate> method leaves us check these
746             constraints without logging anything.
747              
748             To let more power at the user, a C<post_rotate> callback it'll call after every
749             rotation.
750              
751             =head2 Concurrency
752              
753             Multiple writers are allowed by this module. There is a restricted area where
754             only one writer can be inside. This is done by using an external lock file,
755             which name is "C<.filename.LCK>" (never deleted).
756              
757             The user constraint and the L</DatePattern> constraint are checked outside this
758             restricted area. So, when you write a callback, don't rely on the logging
759             file because it can disappear under your feet.
760              
761             Within this restricted area we:
762              
763             =over 4
764              
765             =item *
766              
767             check the size constraint
768              
769             =item *
770              
771             eventually rotate the log file
772              
773             =item *
774              
775             if it's defined, call the C<post_rotate> function
776              
777             =item *
778              
779             write the log message
780              
781             =back
782              
783             =head1 METHODS
784              
785             =head2 new(%p)
786              
787             The constructor takes the following parameters in addition to parameters
788             documented in L<Log::Dispatch::File>:
789              
790             =over 4
791              
792             =item max ($)
793              
794             The maximum number of log files to create. Default 1.
795              
796             =item size ($)
797              
798             The maximum (or close to) size the log file can grow too. Default 10M.
799              
800             =item DatePattern ($)
801              
802             The L</DatePattern> as defined above.
803              
804             =item TZ ($)
805              
806             The TimeZone time based calculations should be done in. This should match
807             L<Date::Manip>'s concept of timezones and of course your machines timezone.
808              
809             =item check_both ($)
810              
811             1 for checking L</DatePattern> and size concurrently, 0 otherwise. Default 0.
812              
813             =item user_constraint (\&)
814              
815             If this callback is defined and returns true, a rotation will happen
816             unconditionally.
817              
818             =item post_rotate (\&)
819              
820             This callback is called after that all files were rotated. Will be called one
821             time for every rotated file (in reverse order) with this arguments:
822              
823             =over 4
824              
825             =item C<filename>
826              
827             the path of the rotated file
828              
829             =item C<index>
830              
831             the index of the rotated file from C<max>-1 to 0, in the latter case
832             C<filename> is the new, empty, log file
833              
834             =item C<fileRotate>
835              
836             a object reference to this instance
837              
838             =back
839              
840             With this, you can have infinite files renaming each time the rotated file
841             log. E.g:
842              
843             my $file = Log::Dispatch::FileRotate
844             ->new(
845             ...
846             post_rotate => sub {
847             my ($filename, $idx, $fileRotate) = @_;
848             if ($idx == 1) {
849             use POSIX qw(strftime);
850             my $basename = $fileRotate->filename();
851             my $newfilename =
852             $basename . '.' . strftime('%Y%m%d%H%M%S', localtime());
853             $fileRotate->debug("moving $filename to $newfilename");
854             rename($filename, $newfilename);
855             }
856             },
857             );
858              
859             B<Note>: this is called within the restricted area (see L</Concurrency>). This
860             means that any other concurrent process is locked in the meanwhile. For the
861             same reason, don't use the C<log()> or C<log_message()> methods because you
862             will get a deadlock!
863              
864             =item DEBUG ($)
865              
866             Turn on lots of warning messages to STDERR about what this module is
867             doing if set to 1. Really only useful to me.
868              
869             =back
870              
871             =head2 filename()
872              
873             Returns the log filename.
874              
875             =head2 setDatePattern( $ or [ $, $, ... ] )
876              
877             Set a new suite of recurrances for file rotation. You can pass in a
878             single string or a reference to an array of strings. Multiple recurrences
879             can also be define within a single string by seperating them with a
880             semi-colon (;)
881              
882             See the discussion above regarding the setDatePattern paramater for more
883             details.
884              
885             =head2 log_message( message => $ )
886              
887             Sends a message to the appropriate output. Generally this shouldn't
888             be called directly but should be called through the C<log()> method
889             (in L<Log::Dispatch::Output>).
890              
891             =head2 rotate()
892              
893             Rotates the file, if it has to be done. You can call this method if you want to
894             check, and eventually do, a rotation without logging anything.
895              
896             Returns 1 if a rotation was done, 0 otherwise. C<undef> on error.
897              
898             =head2 debug($)
899              
900             If C<DEBUG> is true, prints a standard warning message.
901              
902             =head1 Tip
903              
904             If you have multiple writers that were started at different times you
905             will find each writer will try to rotate the log file at a recurrence
906             calculated from its start time. To sync all the writers just use a config
907             file and update it after starting your last writer. This will cause
908             C<new()> to be called by each of the writers
909             close to the same time, and if your recurrences aren't too close together
910             all should sync up just nicely.
911              
912             I initially assumed a long running process but it seems people are using
913             this module as part of short running CGI programs. So, now we look at the
914             last modified time stamp of the log file and compare it to a previous
915             occurance of a L</DatePattern>, on startup only. If the file stat shows
916             the mtime to be earlier than the previous recurrance then I rotate the
917             log file.
918              
919             =head1 DatePattern
920              
921             As I said earlier we use L<Date::Manip> for generating our recurrence
922             events. This means we can understand L<Date::Manip>'s recurrence patterns
923             and the normal log4j DatePatterns. We don't use DatePattern to define the
924             extension of the log file though.
925              
926             DatePattern can therefore take forms like:
927              
928             Date::Manip style
929             0:0:0:0:5:30:0 every 5 hours and 30 minutes
930             0:0:0:2*12:30:0 every 2 days at 12:30 (each day)
931             3*1:0:2:12:0:0 every 3 years on Jan 2 at noon
932              
933             DailyRollingFileAppender log4j style
934             yyyy-MM every month
935             yyyy-ww every week
936             yyyy-MM-dd every day
937             yyyy-MM-dd-a every day at noon
938             yyyy-MM-dd-HH every hour
939             yyyy-MM-dd-HH-MM every minute
940              
941             To specify multiple recurrences in a single string separate them with a
942             semicolon:
943             yyyy-MM-dd; 0:0:0:2*12:30:0
944              
945             This says we want to rotate every day AND every 2 days at 12:30. Put in
946             as many as you like.
947              
948             A complete description of L<Date::Manip> recurrences is beyond us here
949             except to quote (from the man page):
950              
951             A recur description is a string of the format
952             Y:M:W:D:H:MN:S . Exactly one of the colons may
953             optionally be replaced by an asterisk, or an asterisk
954             may be prepended to the string.
955              
956             Any value "N" to the left of the asterisk refers to
957             the "Nth" one. Any value to the right of the asterisk
958             refers to a value as it appears on a calendar/clock.
959             Values to the right can be listed a single values,
960             ranges (2 numbers separated by a dash "-"), or a comma
961             separated list of values or ranges. In a few cases,
962             negative values are appropriate.
963              
964             This is best illustrated by example.
965              
966             0:0:2:1:0:0:0 every 2 weeks and 1 day
967             0:0:0:0:5:30:0 every 5 hours and 30 minutes
968             0:0:0:2*12:30:0 every 2 days at 12:30 (each day)
969             3*1:0:2:12:0:0 every 3 years on Jan 2 at noon
970             0:1*0:2:12,14:0:0 2nd of every month at 12:00 and 14:00
971             1:0:0*45:0:0:0 45th day of every year
972             0:1*4:2:0:0:0 4th tuesday (day 2) of every month
973             0:1*-1:2:0:0:0 last tuesday of every month
974             0:1:0*-2:0:0:0 2nd to last day of every month
975              
976             =head1 TODO
977              
978             compression, signal based rotates, proper test suite
979              
980             Could possibly use L<Logfile::Rotate> as well/instead.
981              
982             =head1 SEE ALSO
983              
984             =over 4
985              
986             =item *
987              
988             L<Log::Dispatch::File::Stamped>
989              
990             Log directly to timestamped files.
991              
992             =back
993              
994             =head1 HISTORY
995              
996             Originally written by Mark Pfeiffer, <markpf at mlp-consulting dot com dot au>
997             inspired by Dave Rolsky's, <autarch at urth dot org>, code :-)
998              
999             Kevin Goess <cpan at goess dot org> suggested multiple writers should be
1000             supported. He also conned me into doing the time based stuff. Thanks Kevin!
1001             :-)
1002              
1003             Thanks also to Dan Waldheim for helping with some of the locking issues in a
1004             forked environment.
1005              
1006             And thanks to Stephen Gordon for his more portable code on lockfile naming.
1007              
1008             =head1 SOURCE
1009              
1010             The development version is on github at L<https://https://github.com/mschout/perl-log-dispatch-filerotate>
1011             and may be cloned from L<git://https://github.com/mschout/perl-log-dispatch-filerotate.git>
1012              
1013             =head1 BUGS
1014              
1015             Please report any bugs or feature requests on the bugtracker website
1016             L<https://github.com/mschout/perl-log-dispatch-filerotate/issues>
1017              
1018             When submitting a bug or request, please include a test-file or a
1019             patch to an existing test-file that illustrates the bug or desired
1020             feature.
1021              
1022             =head1 AUTHOR
1023              
1024             Michael Schout <mschout@cpan.org>
1025              
1026             =head1 COPYRIGHT AND LICENSE
1027              
1028             This software is copyright (c) 2005 by Mark Pfeiffer.
1029              
1030             This is free software; you can redistribute it and/or modify it under
1031             the same terms as the Perl 5 programming language system itself.
1032              
1033             =cut