File Coverage

lib/aliased.pm
Criterion Covered Total %
statement 61 63 96.8
branch 15 16 93.7
condition 3 6 50.0
subroutine 16 17 94.1
pod 2 2 100.0
total 97 104 93.2


line stmt bran cond sub pod time code
1             package aliased;
2             # git description: v0.32-9-ge3824a4
3              
4             # ABSTRACT: Use shorter versions of class names.
5             { our $VERSION = '0.33'; }
6             require Exporter;
7             @EXPORT = qw(alias prefix);
8              
9 5     5   68435 use strict;
  5         12  
  5         1168  
10              
11             sub _croak {
12 2     2   9 require Carp;
13 2         335 Carp::croak(@_);
14             }
15              
16             sub import {
17             # Without args, just export @EXPORT
18 16 100   16   8535 goto &Exporter::import if @_ <= 1;
19              
20 13         26 my ( $class, $package, $alias, @import ) = @_;
21              
22 13         30 my $callpack = caller(0);
23 13         26 _load_alias( $package, $callpack, @import );
24 11         47 _make_alias( $package, $callpack, $alias );
25             }
26              
27             sub _get_alias {
28 6     6   7 my $package = shift;
29 6         37 $package =~ s/.*(?:::|')//;
30 6         19 return $package;
31             }
32              
33             sub _make_alias {
34 11     11   14 my ( $package, $callpack, $alias ) = @_;
35              
36 11   66     33 $alias ||= _get_alias($package);
37              
38 11 100       36 my $destination = $alias =~ /::/
39             ? $alias
40             : "$callpack\::$alias";
41              
42             # need a scalar not referenced elsewhere to make the sub inlinable
43 11         12 my $pack2 = $package;
44              
45 5     5   28 no strict 'refs';
  5         7  
  5         1536  
46 11     0   73 *{ $destination } = sub () { $pack2 };
  11         2909  
  0         0  
47             }
48              
49             sub _load_alias {
50 17     17   23 my ( $package, $callpack, @import ) = @_;
51              
52             # We don't localize $SIG{__DIE__} here because we need to be careful about
53             # restoring its value if there is a failure. Very, very tricky.
54 17         31 my $sigdie = $SIG{__DIE__};
55             {
56 17 100       20 my $code =
  17         60  
57             @import == 0
58             ? "package $callpack; use $package;"
59             : "package $callpack; use $package (\@import)";
60 5     5   1996 eval $code;
  5     4   13655  
  5     2   83  
  4     2   721  
  4     2   359  
  4     2   38  
  2         635  
  1         18  
  1         6  
  2         194  
  2         77  
  2         26  
  2         62  
  2         69  
  2         20  
  2         292  
  1         104  
  1         12  
  17         1022  
61 17 100       513 if ( my $error = $@ ) {
62 2         7 $SIG{__DIE__} = $sigdie;
63 2         8 _croak($error);
64             }
65 15 100       61 $sigdie = $SIG{__DIE__}
66             if defined $SIG{__DIE__};
67             }
68              
69             # Make sure a global $SIG{__DIE__} makes it out of the localization.
70 15 100       33 $SIG{__DIE__} = $sigdie if defined $sigdie;
71 15         31 return $package;
72             }
73              
74             sub alias {
75 2     2 1 648 my ( $package, @import ) = @_;
76              
77 2         4 my $callpack = scalar caller(0);
78 2         7 return _load_alias( $package, $callpack, @import );
79             }
80              
81             sub prefix {
82 1     1 1 562 my ($class) = @_;
83             return sub {
84 2     2   261 my ($name) = @_;
85 2         3 my $callpack = caller(0);
86 2 100 33     12 if ( not @_ ) {
    50          
87 1         4 return _load_alias( $class, $callpack );
88             }
89             elsif ( @_ == 1 && defined $name ) {
90 1         4 return _load_alias( "${class}::$name", $callpack );
91             }
92             else {
93 0           _croak("Too many arguments to prefix('$class')");
94             }
95 1         9 };
96             }
97              
98             1;
99              
100             __END__