1###########################################
2package Log::Log4perl::DateFormat;
3###########################################
4use warnings;
5use strict;
6
7use Carp qw( croak );
8
9our $GMTIME = 0;
10
11my @MONTH_NAMES = qw(
12January February March April May June July
13August September October November December);
14
15my @WEEK_DAYS = qw(
16Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
17
18###########################################
19sub new {
20###########################################
21    my($class, $format) = @_;
22
23    my $self = {
24                  stack => [],
25                  fmt   => undef,
26               };
27
28    bless $self, $class;
29
30        # Predefined formats
31    if($format eq "ABSOLUTE") {
32        $format = "HH:mm:ss,SSS";
33    } elsif($format eq "DATE") {
34        $format = "dd MMM yyyy HH:mm:ss,SSS";
35    } elsif($format eq "ISO8601") {
36        $format = "yyyy-MM-dd HH:mm:ss,SSS";
37    } elsif($format eq "APACHE") {
38        $format = "[EEE MMM dd HH:mm:ss yyyy]";
39    }
40
41    if($format) {
42        $self->prepare($format);
43    }
44
45    return $self;
46}
47
48###########################################
49sub prepare {
50###########################################
51    my($self, $format) = @_;
52
53    # the actual DateTime spec allows for literal text delimited by
54    # single quotes; a single quote can be embedded in the literal
55    # text by using two single quotes.
56    #
57    # my strategy here is to split the format into active and literal
58    # "chunks"; active chunks are prepared using $self->rep() as
59    # before, while literal chunks get transformed to accomodate
60    # single quotes and to protect percent signs.
61    #
62    # motivation: the "recommended" ISO-8601 date spec for a time in
63    # UTC is actually:
64    #
65    #     YYYY-mm-dd'T'hh:mm:ss.SSS'Z'
66
67    my $fmt = "";
68
69    foreach my $chunk ( split /('(?:''|[^'])*')/, $format ) {
70        if ( $chunk =~ /\A'(.*)'\z/ ) {
71              # literal text
72            my $literal = $1;
73            $literal =~ s/''/'/g;
74            $literal =~ s/\%/\%\%/g;
75            $fmt .= $literal;
76        } elsif ( $chunk =~ /'/ ) {
77              # single quotes should always be in a literal
78            croak "bad date format \"$format\": " .
79                  "unmatched single quote in chunk \"$chunk\"";
80        } else {
81            # handle active chunks just like before
82            $chunk =~ s/(([GyMdhHmsSEeDFwWakKzZ])\2*)/$self->rep($1)/ge;
83            $fmt .= $chunk;
84        }
85    }
86
87    return $self->{fmt} = $fmt;
88}
89
90###########################################
91sub rep {
92###########################################
93    my ($self, $string) = @_;
94
95    my $first = substr $string, 0, 1;
96    my $len   = length $string;
97
98    my $time=time();
99    my @g = gmtime($time);
100    my @t = localtime($time);
101    my $z = $t[1]-$g[1]+($t[2]-$g[2])*60+($t[7]-$g[7])*1440+
102            ($t[5]-$g[5])*(525600+(abs($t[7]-$g[7])>364)*1440);
103    my $offset = sprintf("%+.2d%.2d", $z/60, "00");
104
105    #my ($s,$mi,$h,$d,$mo,$y,$wd,$yd,$dst) = localtime($time);
106
107    # Here's how this works:
108    # Detect what kind of parameter we're dealing with and determine
109    # what type of sprintf-placeholder to return (%d, %02d, %s or whatever).
110    # Then, we're setting up an array, specific to the current format,
111    # that can be used later on to compute the components of the placeholders
112    # one by one when we get the components of the current time later on
113    # via localtime.
114
115    # So, we're parsing the "yyyy/MM" format once, replace it by, say
116    # "%04d:%02d" and store an array that says "for the first placeholder,
117    # get the localtime-parameter on index #5 (which is years since the
118    # epoch), add 1900 to it and pass it on to sprintf(). For the 2nd
119    # placeholder, get the localtime component at index #2 (which is hours)
120    # and pass it on unmodified to sprintf.
121
122    # So, the array to compute the time format at logtime contains
123    # as many elements as the original SimpleDateFormat contained. Each
124    # entry is a arrary ref, holding an array with 2 elements: The index
125    # into the localtime to obtain the value and a reference to a subroutine
126    # to do computations eventually. The subroutine expects the orginal
127    # localtime() time component (like year since the epoch) and returns
128    # the desired value for sprintf (like y+1900).
129
130    # This way, we're parsing the original format only once (during system
131    # startup) and during runtime all we do is call localtime *once* and
132    # run a number of blazingly fast computations, according to the number
133    # of placeholders in the format.
134
135###########
136#G - epoch#
137###########
138    if($first eq "G") {
139        # Always constant
140        return "AD";
141
142###################
143#e - epoch seconds#
144###################
145    } elsif($first eq "e") {
146          # index (0) irrelevant, but we return time() which
147          # comes in as 2nd parameter
148        push @{$self->{stack}}, [0, sub { return $_[1] }];
149        return "%d";
150
151##########
152#y - year#
153##########
154    } elsif($first eq "y") {
155        if($len >= 4) {
156            # 4-digit year
157            push @{$self->{stack}}, [5, sub { return $_[0] + 1900 }];
158            return "%04d";
159        } else {
160            # 2-digit year
161            push @{$self->{stack}}, [5, sub { $_[0] % 100 }];
162            return "%02d";
163        }
164
165###########
166#M - month#
167###########
168    } elsif($first eq "M") {
169        if($len >= 3) {
170            # Use month name
171            push @{$self->{stack}}, [4, sub { return $MONTH_NAMES[$_[0]] }];
172           if($len >= 4) {
173                return "%s";
174            } else {
175               return "%.3s";
176            }
177        } elsif($len == 2) {
178            # Use zero-padded month number
179            push @{$self->{stack}}, [4, sub { $_[0]+1 }];
180            return "%02d";
181        } else {
182            # Use zero-padded month number
183            push @{$self->{stack}}, [4, sub { $_[0]+1 }];
184            return "%d";
185        }
186
187##################
188#d - day of month#
189##################
190    } elsif($first eq "d") {
191        push @{$self->{stack}}, [3, sub { return $_[0] }];
192        return "%0" . $len . "d";
193
194##################
195#h - am/pm hour#
196##################
197    } elsif($first eq "h") {
198        push @{$self->{stack}}, [2, sub { ($_[0] % 12) || 12 }];
199        return "%0" . $len . "d";
200
201##################
202#H - 24 hour#
203##################
204    } elsif($first eq "H") {
205        push @{$self->{stack}}, [2, sub { return $_[0] }];
206        return "%0" . $len . "d";
207
208##################
209#m - minute#
210##################
211    } elsif($first eq "m") {
212        push @{$self->{stack}}, [1, sub { return $_[0] }];
213        return "%0" . $len . "d";
214
215##################
216#s - second#
217##################
218    } elsif($first eq "s") {
219        push @{$self->{stack}}, [0, sub { return $_[0] }];
220        return "%0" . $len . "d";
221
222##################
223#E - day of week #
224##################
225    } elsif($first eq "E") {
226        push @{$self->{stack}}, [6, sub { $WEEK_DAYS[$_[0]] }];
227       if($len >= 4) {
228            return "%${len}s";
229        } else {
230           return "%.3s";
231        }
232
233######################
234#D - day of the year #
235######################
236    } elsif($first eq "D") {
237        push @{$self->{stack}}, [7, sub { $_[0] + 1}];
238        return "%0" . $len . "d";
239
240######################
241#a - am/pm marker    #
242######################
243    } elsif($first eq "a") {
244        push @{$self->{stack}}, [2, sub { $_[0] < 12 ? "AM" : "PM" }];
245        return "%${len}s";
246
247######################
248#S - milliseconds    #
249######################
250    } elsif($first eq "S") {
251        push @{$self->{stack}},
252             [9, sub { substr sprintf("%06d", $_[0]), 0, $len }];
253        return "%s";
254
255###############################
256#Z - RFC 822 time zone  -0800 #
257###############################
258    } elsif($first eq "Z") {
259        push @{$self->{stack}}, [10, sub { $offset }];
260        return "$offset";
261
262#############################
263#Something that's not defined
264#(F=day of week in month
265# w=week in year W=week in month
266# k=hour in day K=hour in am/pm
267# z=timezone
268#############################
269    } else {
270        return "-- '$first' not (yet) implemented --";
271    }
272
273    return $string;
274}
275
276###########################################
277sub format {
278###########################################
279    my($self, $secs, $msecs) = @_;
280
281    $msecs = 0 unless defined $msecs;
282
283    my @time;
284
285    if($GMTIME) {
286        @time = gmtime($secs);
287    } else {
288        @time = localtime($secs);
289    }
290
291        # add milliseconds
292    push @time, $msecs;
293
294    my @values = ();
295
296    for(@{$self->{stack}}) {
297        my($val, $code) = @$_;
298        if($code) {
299            push @values, $code->($time[$val], $secs);
300        } else {
301            push @values, $time[$val];
302        }
303    }
304
305    return sprintf($self->{fmt}, @values);
306}
307
3081;
309
310__END__
311
312=head1 NAME
313
314Log::Log4perl::DateFormat - Log4perl advanced date formatter helper class
315
316=head1 SYNOPSIS
317
318    use Log::Log4perl::DateFormat;
319
320    my $format = Log::Log4perl::DateFormat->new("HH:mm:ss,SSS");
321
322    # Simple time, resolution in seconds
323    my $time = time();
324    print $format->format($time), "\n";
325        # => "17:02:39,000"
326
327    # Advanced time, resultion in milliseconds
328    use Time::HiRes;
329    my ($secs, $msecs) = Time::HiRes::gettimeofday();
330    print $format->format($secs, $msecs), "\n";
331        # => "17:02:39,959"
332
333=head1 DESCRIPTION
334
335C<Log::Log4perl::DateFormat> is a low-level helper class for the
336advanced date formatting functions in C<Log::Log4perl::Layout::PatternLayout>.
337
338Unless you're writing your own Layout class like
339L<Log::Log4perl::Layout::PatternLayout>, there's probably not much use
340for you to read this.
341
342C<Log::Log4perl::DateFormat> is a formatter which allows dates to be
343formatted according to the log4j spec on
344
345    http://download.oracle.com/javase/1.4.2/docs/api/java/text/SimpleDateFormat.html
346
347which allows the following placeholders to be recognized and processed:
348
349    Symbol Meaning              Presentation    Example
350    ------ -------              ------------    -------
351    G      era designator       (Text)          AD
352    e      epoch seconds        (Number)        1315011604
353    y      year                 (Number)        1996
354    M      month in year        (Text & Number) July & 07
355    d      day in month         (Number)        10
356    h      hour in am/pm (1~12) (Number)        12
357    H      hour in day (0~23)   (Number)        0
358    m      minute in hour       (Number)        30
359    s      second in minute     (Number)        55
360    S      millisecond          (Number)        978
361    E      day in week          (Text)          Tuesday
362    D      day in year          (Number)        189
363    F      day of week in month (Number)        2 (2nd Wed in July)
364    w      week in year         (Number)        27
365    W      week in month        (Number)        2
366    a      am/pm marker         (Text)          PM
367    k      hour in day (1~24)   (Number)        24
368    K      hour in am/pm (0~11) (Number)        0
369    z      time zone            (Text)          Pacific Standard Time
370    Z      RFC 822 time zone    (Text)          -0800
371    '      escape for text      (Delimiter)
372    ''     single quote         (Literal)       '
373
374For example, if you want to format the current Unix time in
375C<"MM/dd HH:mm"> format, all you have to do is this:
376
377    use Log::Log4perl::DateFormat;
378
379    my $format = Log::Log4perl::DateFormat->new("MM/dd HH:mm");
380
381    my $time = time();
382    print $format->format($time), "\n";
383
384While the C<new()> method is expensive, because it parses the format
385strings and sets up all kinds of structures behind the scenes,
386followup calls to C<format()> are fast, because C<DateFormat> will
387just call C<localtime()> and C<sprintf()> once to return the formatted
388date/time string.
389
390So, typically, you would initialize the formatter once and then reuse
391it over and over again to display all kinds of time values.
392
393Also, for your convenience,
394the following predefined formats are available, just as outlined in the
395log4j spec:
396
397    Format   Equivalent                     Example
398    ABSOLUTE "HH:mm:ss,SSS"                 "15:49:37,459"
399    DATE     "dd MMM yyyy HH:mm:ss,SSS"     "06 Nov 1994 15:49:37,459"
400    ISO8601  "yyyy-MM-dd HH:mm:ss,SSS"      "1999-11-27 15:49:37,459"
401    APACHE   "[EEE MMM dd HH:mm:ss yyyy]"   "[Wed Mar 16 15:49:37 2005]"
402
403So, instead of passing
404
405    Log::Log4perl::DateFormat->new("HH:mm:ss,SSS");
406
407you could just as well say
408
409    Log::Log4perl::DateFormat->new("ABSOLUTE");
410
411and get the same result later on.
412
413=head2 Known Shortcomings
414
415The following placeholders are currently I<not> recognized, unless
416someone (and that could be you :) implements them:
417
418    F day of week in month
419    w week in year
420    W week in month
421    k hour in day
422    K hour in am/pm
423    z timezone (but we got 'Z' for the numeric time zone value)
424
425Also, C<Log::Log4perl::DateFormat> just knows about English week and
426month names, internationalization support has to be added.
427
428=head1 LICENSE
429
430Copyright 2002-2012 by Mike Schilli E<lt>m@perlmeister.comE<gt>
431and Kevin Goess E<lt>cpan@goess.orgE<gt>.
432
433This library is free software; you can redistribute it and/or modify
434it under the same terms as Perl itself.
435
436=head1 AUTHOR
437
438Please contribute patches to the project on Github:
439
440    http://github.com/mschilli/log4perl
441
442Send bug reports or requests for enhancements to the authors via our
443
444MAILING LIST (questions, bug reports, suggestions/patches):
445log4perl-devel@lists.sourceforge.net
446
447Authors (please contact them via the list above, not directly):
448Mike Schilli <m@perlmeister.com>,
449Kevin Goess <cpan@goess.org>
450
451Contributors (in alphabetical order):
452Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton
453Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony
454Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy
455Grundman, Paul Harrington, David Hull, Robert Jacobson, Jason Kohles,
456Jeff Macdonald, Markus Peter, Brett Rann, Peter Rabbitson, Erik
457Selberg, Aaron Straup Cope, Lars Thegler, David Viner, Mac Yang.
458
459