File Coverage

blib/lib/Time/Duration/Filter.pm

Criterion	Covered	Total	%
statement	60	62	96.7
branch	4	6	66.6
condition	6	7	85.7
subroutine	13	13	100.0
pod	0	1	0.0
total	83	89	93.2

# Copyright 2009, 2010, 2011, 2013, 2016 Kevin Ryde

# This file is part of Time-Duration-Locale.
#
# Time-Duration-Locale is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as published
# by the Free Software Foundation; either version 3, or (at your option) any
# later version.
#
# Time-Duration-Locale is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General
# Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Time-Duration-Locale.  If not, see .

package Time::Duration::Filter;
use 5.004;
use strict;
no strict 'refs';
use Carp;
use Module::Load;
use vars qw($VERSION $AUTOLOAD);

$VERSION = 12;

# uncomment this to run the ### lines
# use Smart::Comments;


my @_target_ISA = ('Exporter');

sub import {
  shift; # $class own __PACKAGE__
  setup (scalar caller(), @_);
}
sub setup {
  my ($package, %options) = @_;
  my $from = $options{'from'} || 'Time::Duration';
  Module::Load::load ($from);

  ### setup: $package
  ### $from
  no strict;
  *{"${package}::AUTOLOAD"} = \&_target_AUTOLOAD;
  *{"${package}::can"}      = \&_target_can;
  ${"${package}::_from"}    = $from;

  require Exporter;
  *{"${package}::ISA"}      = \@_target_ISA;

  # same exports as the $from package
  foreach my $varname ('EXPORT','EXPORT_OK') {
    if (my $aref = *{"${from}::$varname"}{ARRAY}) {
      ### store array: $varname
      *{"${package}::$varname"} = $aref;
    }
  }
  foreach my $varname ('EXPORT_TAGS') {
    if (my $href = *{"${from}::$varname"}{HASH}) {
      ### store hash: $varname
      *{"${package}::$varname"} = $href;
    }
  }
}

sub _target_can {
  my ($class, $name) = @_;
  return ($class->SUPER::can($name) || _make_func ($class, $name));
}
sub _target_AUTOLOAD {
  ### TDF AUTOLOAD of: $AUTOLOAD
  my ($package, $name) = ($AUTOLOAD =~ /(.*)::(.*)/);
  my $subr = _make_func ($package, $name)
    || die "No function $name exported by " . ${"${package}::_from"};
  goto $subr;
}

sub _make_func {
  my ($package, $name) = @_;

  scalar(grep {$_ eq $name} @{"${package}::EXPORT_OK"})
    or return; # no such function

  my $from = ${"${package}::_from"};
  my $from_func = "${from}::$name";
  my $filter_func = "${package}::_filter";
  ### from: $from_func
  ### filter: $filter_func

  my $subr = sub { &$filter_func (&$from_func (@_)) };
  *{"${package}::$name"} = $subr;
  return $subr;
}


#   if ($name eq '_filter') {
#     die "$package didn't define a _filter() function";
#   }
#   if ($name =~ /^_f/) {
#     die "Oops, bad autoload $AUTOLOAD";
#   }

1;
__END__