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