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__ |