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


line stmt bran cond sub pod time code
1             # Copyright 2009, 2010, 2011, 2013, 2016 Kevin Ryde
2              
3             # This file is part of Time-Duration-Locale.
4             #
5             # Time-Duration-Locale is free software; you can redistribute it and/or
6             # modify it under the terms of the GNU General Public License as published
7             # by the Free Software Foundation; either version 3, or (at your option) any
8             # later version.
9             #
10             # Time-Duration-Locale is distributed in the hope that it will be useful,
11             # but WITHOUT ANY WARRANTY; without even the implied warranty of
12             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
13             # Public License for more details.
14             #
15             # You should have received a copy of the GNU General Public License along
16             # with Time-Duration-Locale. If not, see .
17              
18             package Time::Duration::Filter;
19 2     2   42 use 5.004;
  2         6  
20 2     2   9 use strict;
  2         4  
  2         58  
21 2     2   9 no strict 'refs';
  2         2  
  2         66  
22 2     2   9 use Carp;
  2         3  
  2         180  
23 2     2   1477 use Module::Load;
  2         2489  
  2         14  
24 2     2   121 use vars qw($VERSION $AUTOLOAD);
  2         2  
  2         372  
25              
26             $VERSION = 11;
27              
28             # uncomment this to run the ### lines
29             # use Smart::Comments;
30              
31              
32             my @_target_ISA = ('Exporter');
33              
34             sub import {
35 2     2   4 shift; # $class own __PACKAGE__
36 2         9 setup (scalar caller(), @_);
37             }
38             sub setup {
39 2     2 0 6 my ($package, %options) = @_;
40 2   50     17 my $from = $options{'from'} || 'Time::Duration';
41 2         8 Module::Load::load ($from);
42              
43             ### setup: $package
44             ### $from
45 2     2   12 no strict;
  2         3  
  2         1068  
46 2         6152 *{"${package}::AUTOLOAD"} = \&_target_AUTOLOAD;
  2         27  
47 2         5 *{"${package}::can"} = \&_target_can;
  2         12  
48 2         5 ${"${package}::_from"} = $from;
  2         11  
49              
50 2         13 require Exporter;
51 2         4 *{"${package}::ISA"} = \@_target_ISA;
  2         22  
52              
53             # same exports as the $from package
54 2         7 foreach my $varname ('EXPORT','EXPORT_OK') {
55 4 50       5 if (my $aref = *{"${from}::$varname"}{ARRAY}) {
  4         21  
56             ### store array: $varname
57 4         6 *{"${package}::$varname"} = $aref;
  4         21  
58             }
59             }
60 2         5 foreach my $varname ('EXPORT_TAGS') {
61 2 50       14 if (my $href = *{"${from}::$varname"}{HASH}) {
  2         85  
62             ### store hash: $varname
63 0         0 *{"${package}::$varname"} = $href;
  0         0  
64             }
65             }
66             }
67              
68             sub _target_can {
69 3     3   3034 my ($class, $name) = @_;
70 3   100     53 return ($class->SUPER::can($name) || _make_func ($class, $name));
71             }
72             sub _target_AUTOLOAD {
73             ### TDF AUTOLOAD of: $AUTOLOAD
74 13     13   2825 my ($package, $name) = ($AUTOLOAD =~ /(.*)::(.*)/);
75             my $subr = _make_func ($package, $name)
76 13   100     38 || die "No function $name exported by " . ${"${package}::_from"};
77 12         26 goto $subr;
78             }
79              
80             sub _make_func {
81 15     15   54 my ($package, $name) = @_;
82              
83 15 100       17 scalar(grep {$_ eq $name} @{"${package}::EXPORT_OK"})
  180         322  
  15         70  
84             or return; # no such function
85              
86 13         15 my $from = ${"${package}::_from"};
  13         35  
87 13         29 my $from_func = "${from}::$name";
88 13         21 my $filter_func = "${package}::_filter";
89             ### from: $from_func
90             ### filter: $filter_func
91              
92 13     20   75 my $subr = sub { &$filter_func (&$from_func (@_)) };
  20         854  
93 13         18 *{"${package}::$name"} = $subr;
  13         53  
94 13         56 return $subr;
95             }
96              
97              
98             # if ($name eq '_filter') {
99             # die "$package didn't define a _filter() function";
100             # }
101             # if ($name =~ /^_f/) {
102             # die "Oops, bad autoload $AUTOLOAD";
103             # }
104              
105             1;
106             __END__