1package DateTime::Format::W3CDTF;
2
3use strict;
4use warnings;
5
6use vars qw ($VERSION);
7
8$VERSION = '0.06';
9
10use DateTime;
11use DateTime::TimeZone;
12
13sub new {
14    my $class = shift;
15
16    return bless {}, $class;
17}
18
19sub parse_datetime {
20    my ( $self, $date ) = @_;
21
22    my @fields = qw/ year month day hour minute second fraction time_zone /;
23    my @values =
24       ( $date =~ /^(\d\d\d\d) # Year
25                    (?:-(\d\d) # -Month
26                     (?:-(\d\d) # -Day
27                      (?:T
28                       (\d\d):(\d\d) # Hour:Minute
29                       (?:
30                          :(\d\d)     # :Second
31                          (\.\d+)?    # .Fractional_Second
32                       )?
33                       ( Z          # UTC
34                       | [+-]\d\d:\d\d    # Hour:Minute TZ offset
35                         (?::\d\d)?       # :Second TZ offset
36                       )?)?)?)?$/x )
37         or die "Invalid W3CDTF datetime string ($date)";
38    my %p;
39    for ( my $i=0; $i < @values; $i++ ) {  # Oh how I wish Perl had zip
40       next unless defined $values[$i];
41       $p{$fields[$i]} = $values[$i];
42    }
43
44### support for YYYY-MM-DDT24:00:00 as a syntactic form for 00:00:00 on the day following YYYY-MM-DD
45### this is allowed in xsd dateTime syntactic forms, but not W3CDTF.
46#     my $next_day    = 0;
47#     if (defined($p{hour}) and defined($p{minute}) and defined($p{second})) {
48#         if ($p{hour} eq '24') {
49#             if ($p{second} eq '00' and $p{minute} eq '00') {
50#                 $p{hour}    = '00';
51#                 $next_day++;
52#             } else {
53#                 die "Cannot use hour value '24' with non-zero minutes and seconds\n";
54#             }
55#         }
56#     }
57
58    if ( !$p{time_zone} ) {
59        $p{time_zone} = 'floating';
60    } elsif ( $p{time_zone} eq 'Z' ) {
61        $p{time_zone} = 'UTC';
62    }
63
64    if ( $p{fraction} ) {
65        $p{nanosecond} = $p{fraction} * 1_000_000_000;
66        delete $p{fraction}
67    }
68
69    my $dt = DateTime->new( %p );
70#     if ($next_day) {
71#         $dt->add( day => 1 );
72#     }
73    return $dt;
74}
75
76sub format_datetime {
77    my ( $self, $dt ) = @_;
78
79    my $base = sprintf(
80        '%04d-%02d-%02dT%02d:%02d:%02d',
81        $dt->year, $dt->month,  $dt->day,
82        $dt->hour, $dt->minute, $dt->second
83    );
84
85    if ( $dt->nanosecond ) {
86        my $secs = sprintf "%f", $dt->nanosecond / 1_000_000_000;
87        $secs =~ s/^0//;
88        $base .= $secs;
89    }
90
91    my $tz = $dt->time_zone;
92
93    return $base if $tz->is_floating;
94
95    return $base . 'Z' if $tz->is_utc;
96
97    my $offset = $dt->offset();
98
99    return $base unless defined $offset;
100
101    return $base . _offset_as_string($offset)
102}
103
104sub format_date {
105    my ( $self, $dt ) = @_;
106
107    my $base = sprintf( '%04d-%02d-%02d', $dt->year, $dt->month, $dt->day );
108    return $base;
109}
110
111# minor offset_as_string variant w/ :
112#
113sub _offset_as_string {
114    my $offset = shift;
115
116    return undef unless defined $offset;
117
118    my $sign = $offset < 0 ? '-' : '+';
119
120    my $hours = $offset / ( 60 * 60 );
121    $hours = abs($hours) % 24;
122
123    my $mins = ( $offset % ( 60 * 60 ) ) / 60;
124
125    my $secs = $offset % 60;
126
127    return (
128        $secs
129        ? sprintf( '%s%02d:%02d:%02d', $sign, $hours, $mins, $secs )
130        : sprintf( '%s%02d:%02d',      $sign, $hours, $mins )
131    );
132}
133
1341;
135
136__END__
137
138=head1 NAME
139
140DateTime::Format::W3CDTF - Parse and format W3CDTF datetime strings
141
142=head1 SYNOPSIS
143
144  use DateTime::Format::W3CDTF;
145
146  my $w3c = DateTime::Format::W3CDTF->new;
147  my $dt = $w3c->parse_datetime( '2003-02-15T13:50:05-05:00' );
148
149  # 2003-02-15T13:50:05-05:00
150  $w3c->format_datetime($dt);
151
152=head1 DESCRIPTION
153
154This module understands the W3CDTF date/time format, an ISO 8601 profile,
155defined at http://www.w3.org/TR/NOTE-datetime.  This format as the native
156date format of RSS 1.0.
157
158It can be used to parse these formats in order to create the appropriate
159objects.
160
161=head1 METHODS
162
163This API is currently experimental and may change in the future.
164
165=over 4
166
167=item * new()
168
169Returns a new W3CDTF parser object.
170
171=item * parse_datetime($string)
172
173Given a W3CDTF datetime string, this method will return a new
174C<DateTime> object.
175
176If given an improperly formatted string, this method may die.
177
178=item * format_datetime($datetime)
179
180Given a C<DateTime> object, this methods returns a W3CDTF datetime
181string.
182
183NOTE: As of version 0.4, format_datetime no longer attempts to truncate
184datetimes without a time component.  This is due to the fact that C<DateTime>
185doesn't distinguish between a date with no time component, and midnight.
186
187=item * format_date($datetime)
188
189Given a C<DateTime> object, return a W3CDTF datetime string without the time component.
190
191=back
192
193=head1 SUPPORT
194
195Support for this module is provided via the datetime@perl.org email
196list. See http://datetime.perl.org/?MailingList for details.
197
198Please submit bugs to the CPAN RT system at
199http://rt.cpan.org/NoAuth/ReportBug.html?Queue=datetime-format-w3cdtf or via
200email at bug-datetime-format-w3cdtf@rt.cpan.org.
201
202=head1 AUTHOR
203
204Dave Rolsky E<lt>autarch@urth.orgE<gt>
205
206=head1 CREDITS
207
208This module is maintained by Gregory Todd Williams E<lt>gwilliams@cpan.orgE<gt>.
209It was originally created by Kellan Elliott-McCrea E<lt>kellan@protest.netE<gt>.
210
211This module was inspired by L<DateTime::Format::ICal>
212
213=head1 COPYRIGHT
214
215Copyright (c) 2009 David Rolsky.  All rights reserved.  This
216program is free software; you can redistribute it and/or modify it
217under the same terms as Perl itself.
218
219Copyright (c) 2003 Kellan Elliott-McCrea
220
221Portions of the code in this distribution are derived from other
222works.  Please see the CREDITS file for more details.
223
224The full text of the license can be found in the LICENSE file included
225with this module.
226
227=head1 SEE ALSO
228
229datetime@perl.org mailing list
230
231http://datetime.perl.org/
232
233=cut
234