package TimeTame;
# Minimal subclassing attempt for Time::Piece
use 5.006;
use strict;
use warnings;
use Carp;
require Exporter;
use Time::Piece;
use base qw( Time::Piece Exporter );
our @EXPORT = @Time::Piece::EXPORT;
our %EXPORT_TAGS = %Time::Piece::EXPORT_TAGS;
# So our exported time functions and overloaded operators work on our
# new derived classes (and any that derive from *this* class), we
# leave a bread crumb trail during the import. We can't directly check
# isa relationships at this point because @ISA has not been set up
# yet. We'll delay that check for later, using our crumbs.
our($Maybe_Bless, $Source_Bless);
sub import {
my $call = 0;
my $pkg;
while ($pkg = caller($call)) {
last unless $pkg && $pkg ne 'main';
$Maybe_Bless = $pkg;
++$call;
}
$Maybe_Bless ||= __PACKAGE__;
__PACKAGE__->export_to_level(1, @_);
}
{
no warnings 'redefine';
sub Time::Piece::_mktime {
my ($time, $islocal) = @_;
my $class;
if (ref $time) {
$class = ref $time;
$time->[Time::Piece::c_epoch] = undef;
return wantarray ? @$time : bless [@$time, $islocal], $class;
}
if ($time !~ /^\d+$/) {
$class = $time;
$time = undef;
}
else {
$class = $Source_Bless ? $Source_Bless : __PACKAGE__->_set_bless;
}
my @time = $islocal ?
CORE::localtime($time) : CORE::gmtime($time);
wantarray ? @time : bless [@time, $time, $islocal], $class;
}
use warnings;
}
sub _set_bless {
my $class = shift;
$class ||= __PACKAGE__;
$Source_Bless = $Maybe_Bless if $Maybe_Bless &&
$Maybe_Bless->isa($class);
$Source_Bless ||= $class;
}
1;
####
package TimeFoo;
use 5.006;
use strict;
use warnings;
require Exporter;
use TimeTame;
use base qw(TimeTame Exporter);
our @EXPORT = @TimeTame::EXPORT;
our %EXPORT_TAGS = %TimeTame::EXPORT_TAGS;
1;
####
#!/usr/bin/perl -w
use TimeFoo;
use Time::Seconds;
foreach $str (qw(TimeFoo TimeTame Time::Piece)) {
print "TimeFoo ", TimeFoo->isa($str) ? "isa " : "is not a ", "$str\n";
}
$t = localtime;
print "localtime made a ", ref $t, " $t\n";
$t2 = TimeFoo->new;
print "new made a ", ref $t2, " $t2\n";
$t3 = $t2 + ONE_DAY;
print "Add made a ", ref $t3, " $t3\n";