package Time::Piece::Adaptive;
use warnings;
use strict;
no warnings 'redefine';
=head1 VERSION
Version 0.03
=cut
our $VERSION = 0.03;
=head1 NAME
Time::Piece::Adaptive - subclass of Time::Piece which allows the default
stringification function to be set.
=head1 REQUIRES
Subclasses Time::Piece.
=head1 SYNOPSIS
See Time::Piece
I actually think this subclass encapsulates the behavior I would expect from
Time::Piece, but I haven't been able to elicit a response from the authors of
Time::Piece.
=head1 EXPORT
=over 4
=item * gmtime
=item * localtime
=item * :override:
=back
See Time::Piece for more.
=cut
use vars qw(@ISA @EXPORT %EXPORT_TAGS);
require Exporter;
require DynaLoader;
use Time::Piece;
@ISA = qw(Time::Piece);
@EXPORT = qw(
localtime
gmtime
);
%EXPORT_TAGS = (
':override' => 'internal',
);
my %_special_exports = (
localtime => sub { my $c = $_[0]; sub { $c->localtime(@_) } },
gmtime => sub { my $c = $_[0]; sub { $c->gmtime(@_) } },
);
sub _export
{
my ($class, $to, @methods) = @_;
for my $method (@methods)
{
if (exists $_special_exports{$method})
{
no strict 'refs';
no warnings 'redefine';
*{$to . "::$method"} = $_special_exports{$method}->($class);
} else {
$class->SUPER::export ($to, $method);
}
}
}
sub import
{
# replace CORE::GLOBAL localtime and gmtime if required
my $class = shift;
my %params;
map $params{$_}++, @_, @EXPORT;
if (delete $params{':override'})
{
$class->_export ('CORE::GLOBAL', keys %params);
}
else
{
$class->_export((caller)[0], keys %params);
}
}
=head1 METHODS
=head2 new
my $t1 = new Time::Piece::Adaptive (time, stringify => "%Y%m%d%H%M%S");
print "The MySql timestamp was $t1.";
my $t2 = new Time::Piece::Adaptive (time,
stringify => \&my_func,
stringify_args => $my_data);
Like the constructor for Time::Piece, except it may set the default
stringify function.
The above examples are semanticly equivalent to:
my $t1 = new Time::Piece::Adaptive (time);
$t1->set_stringify ("%Y%m%d%H%M%S");
print "The MySql timestamp was $t1.";
my $t2 = new Time::Piece::Adaptive (time);
$t2->set_stringify (\&my_func, $my_data);
=cut
sub new
{
my $class = shift;
my $time = shift
unless $_[0] && ($_[0] eq "stringify" || $_[0] eq "stringify_arg");
my %args = @_;
my $self = $class->SUPER::new ($time);
my $stringify = $args{stringify} if exists $args{stringify};
my $stringify_args = $args{stringify_args} if exists $args{stringify_args};
$self->set_stringify ($stringify, $stringify_args);
return $self;
}
=head2 localtime
=head2 gmtime
C<localtime> and C<gmtime> work like Time::Piece's versions, except they accept
stringify arguments, as C<new>.
=cut
sub localtime {
unshift @_, __PACKAGE__ unless eval {$_[0]->isa ('Time::Piece')};
my $class = shift;
my $time = shift
unless $_[0] && ($_[0] eq "stringify" || $_[0] eq "stringify_arg");
$time = time unless defined $time;
return $class->_mktime ($time, 1, @_);
}
sub gmtime {
unshift @_, __PACKAGE__ unless eval {$_[0]->isa ('Time::Piece')};
my $class = shift;
my $time = shift
unless $_[0] && ($_[0] eq "stringify" || $_[0] eq "stringify_arg");
$time = time unless defined $time;
return $class->_mktime ($time, 0, @_);
}
sub _mktime
{
my ($class, $time, $islocal, %args) = @_;
return $class->SUPER::_mktime ($time) if wantarray;
my $self = $class->SUPER::_mktime ($time);
my $stringify = $args{stringify} if exists $args{stringify};
my $stringify_args = $args{stringify_args} if exists $args{stringify_args};
$self->set_stringify ($stringify, $stringify_args);
return $self;
}
=head2 set_stringify
$t->set_stringify ($format, $arg);
print "The date is $t.";
If C<$format> is a reference to a function, set the stringify function to
C<$format>, which should return a string when passed a reference to an
instantiated Time::Piece and C<$arg>.
If C<$format> is a string, use it to format an output string using
C<strftime> (any C<$arg> is ignored).
When called without specifying C<$format>, restore the default stringifier
(C<&Time::Piece::cdate>).
=cut
use overload '""' => \&_stringify;
use constant 'c_stringify_func' => 11;
use constant 'c_stringify_arg' => 12;
sub _stringify
{
my ($self) = @_;
my $func = $self->[c_stringify_func];
my $arg = $self->[c_stringify_arg];
my $string = &{$func}($self, $arg);
return $string;
}
sub set_stringify
{
my ($self, $format, $arg) = @_;
if (ref $format) {
$self->[c_stringify_func] = $format;
if (defined $arg) {
$self->[c_stringify_arg] = $arg if defined $arg;
} else {
delete $self->[c_stringify_arg];
}
} elsif (defined $format) {
$self->[c_stringify_func] = \&Time::Piece::strftime;
$self->[c_stringify_arg] = $format;
} else {
$self->[c_stringify_func] = \&Time::Piece::cdate;
delete $self->[c_stringify_arg];
}
}
=head2 add
=head2 subtract
Like the Time::Piece functions of the same name, except C<stringify> and
C<stringify_arg> arguments are accepted.
Also, when a Time::Piece::Adaptive object is subtracted from an arbitrary
object, it is converted to a string according to its stringify function and
passed to perl for handling.
=cut
use overload
'-' => \&subtract,
'+' => \&add;
sub subtract
{
my $time = shift;
if ($_[1])
{
# SWAPED is set and our parent doesn't know how to handle
# NOTDATE - DATE. For backwards compatibility reasons, return
# the result as if the string $time resolves to was subtracted
# from NOTDATE.
return $_[0] - "$time";
}
my $new = $time->SUPER::subtract (@_);
$new->set_stringify ($time->[c_stringify_func],
$time->[c_stringify_arg])
if $new->isa ('Time::Piece');
return $new;
}
sub add
{
my ($time) = shift;
my $new = $time->SUPER::add (@_);
$new->set_stringify ($time->[c_stringify_func],
$time->[c_stringify_arg]);
return $new;
}
=head2 strptime
my $t = Time::Piece::Adaptive::strptime ($mysqltime, "%Y%m%d%H%M%S");
print "The MySql timestamp was $t.";
my $t = Time::Piece::Adaptive::strptime ($mysqltime, "%Y%m%d%H%M%S",
stringify =>
\&Time::Piece::Adaptive::cdate);
print "The MySql timestamp was $t.";
Like the C<Time::Piece::strptime>, except a stringify function may be set as
per C<Time::Piece::Adaptive::new> and, if the stringify function is not
explicitly specified, then it is set by calling C<set_stringify ($format)> on
the new object with the same C<$format> string passed to C<strptime>.
=cut
sub strptime
{
my ($time, $string, $format, %args) = @_;
my $self = $time->SUPER::strptime ($string, $format);
my $stringify = exists $args{stringify} ? $args{stringify} : $format;
my $stringify_args = $args{stringify_args} if exists $args{stringify_args};
$self->set_stringify ($stringify, $stringify_args);
return $self;
}
=head1 SEE ALSO
=over 4
=item L<Time::Piece>
=back
=head1 AUTHOR
Derek Price, C<< <derek at ximbiot.com> >>
=head1 BUGS
Please report any bugs or feature requests to
C<time-piece-adaptive at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Time-Piece-Adaptive>.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc Time::Piece::Adaptive
You can also look for information at:
=over 4
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/Time-Piece-Adaptive>
=item * CPAN Ratings
L<http://cpanratings.perl.org/d/Time-Piece-Adaptive>
=item * RT: CPAN's request tracker
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Time-Piece-Adaptive>
=item * Search CPAN
L<http://search.cpan.org/dist/Time-Piece-Adaptive>
=back
=head1 COPYRIGHT & LICENSE
Copyright 2006 Derek Price, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1;