File Coverage

blib/lib/Route/Switcher.pm
Criterion Covered Total %
statement 39 39 100.0
branch 2 4 50.0
condition 4 4 100.0
subroutine 11 11 100.0
pod 2 3 66.6
total 58 61 95.0


line stmt bran cond sub pod time code
1             package Route::Switcher;
2 2     2   38216 use 5.008001;
  2         6  
  2         74  
3 2     2   11 use strict;
  2         3  
  2         67  
4 2     2   9 use warnings;
  2         8  
  2         80  
5 2     2   11 use base 'Exporter';
  2         3  
  2         406  
6             our $VERSION = "0.01";
7              
8             our @EXPORT = qw/switcher/;
9              
10             my $CALLER = caller;
11             my @methods;
12             my %ORIG_METHOD;
13             our ($base_path,$base_class);
14              
15             sub init {
16 1     1 1 290 my $class = shift;
17 1         4 my @methods = @_;
18 1         38 $class->methods(@_);
19              
20 2     2   10 no strict 'refs';
  2         2  
  2         60  
21 2     2   9 no warnings 'redefine';
  2         2  
  2         594  
22 1         1 for my $method (@methods) {
23 4         16 *{"$CALLER\::$method"} = sub {
24 13   100 13   361 my $path = ($base_path || '') . $_[0];
25 13   100     38 my $dest = ($base_class || '') . $_[1];
26 13         35 $ORIG_METHOD{$method}->($path,$dest);
27 4         17 };
28             }
29             }
30              
31             sub switcher {
32 3     3 1 68 local $base_path = shift;
33 3         3 local $base_class = shift;
34 3         4 my $code = shift;
35 3         13 $code->();
36             }
37              
38             sub methods {
39 1     1 0 18 my $class = shift;
40 1 50       7 if (@_) {
41 1         3 @methods = @_;
42 1         3 _cache_original_method();
43             }
44 1         2 return @methods;
45             }
46              
47              
48             sub _cache_original_method {
49 1     1   2 for my $method (@methods) {
50 4 50       30 next unless( my $sub = $CALLER->can($method));
51 4         10 $ORIG_METHOD{$method} = $sub;
52             }
53             }
54              
55             1;
56              
57             __END__