line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Symbol::Rename; |
2
|
1
|
|
|
1
|
|
51948
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
28
|
|
3
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
31
|
|
4
|
|
|
|
|
|
|
|
5
|
1
|
|
|
1
|
|
6
|
use Carp qw/croak/; |
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
69
|
|
6
|
1
|
|
|
1
|
|
5
|
use B; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
655
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
our $VERSION = '0.000001'; |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
my %SIGMAP = ( |
11
|
|
|
|
|
|
|
'&' => 'CODE', |
12
|
|
|
|
|
|
|
'$' => 'SCALAR', |
13
|
|
|
|
|
|
|
'%' => 'HASH', |
14
|
|
|
|
|
|
|
'@' => 'ARRAY', |
15
|
|
|
|
|
|
|
# Others are unsupported. |
16
|
|
|
|
|
|
|
); |
17
|
|
|
|
|
|
|
my %TYPEMAP = reverse %SIGMAP; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
sub import { |
20
|
7
|
|
|
7
|
|
1713
|
my $class = shift; |
21
|
7
|
50
|
|
|
|
40
|
return unless @_; |
22
|
7
|
|
|
|
|
16
|
my ($opts, %renames) = _parse_args(@_); |
23
|
|
|
|
|
|
|
|
24
|
6
|
|
66
|
|
|
27
|
my $package = delete $opts->{package} || caller; |
25
|
|
|
|
|
|
|
|
26
|
6
|
100
|
|
|
|
126
|
croak "Unsupported option(s): " . join(", ", keys %$opts) |
27
|
|
|
|
|
|
|
if keys %$opts; |
28
|
|
|
|
|
|
|
|
29
|
5
|
|
|
|
|
14
|
_rename_symbols($package, %renames); |
30
|
|
|
|
|
|
|
} |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
sub rename_symbols { |
33
|
2
|
|
|
2
|
0
|
4
|
my $class = shift; |
34
|
2
|
|
|
|
|
6
|
my ($opts, %renames) = _parse_args(@_); |
35
|
|
|
|
|
|
|
|
36
|
2
|
50
|
|
|
|
8
|
croak "Unsupported options: " . join(", ", keys %$opts) |
37
|
|
|
|
|
|
|
if keys %$opts; |
38
|
|
|
|
|
|
|
|
39
|
2
|
|
|
|
|
5
|
_rename_symbols($class, %renames); |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
sub _parse_args { |
43
|
9
|
|
|
9
|
|
10
|
my (%opts, %renames); |
44
|
|
|
|
|
|
|
|
45
|
9
|
|
|
|
|
28
|
while (my $symbol = shift @_) { |
46
|
15
|
100
|
|
|
|
40
|
if ($symbol =~ m/^-(.*)$/) { |
47
|
5
|
100
|
|
|
|
204
|
$opts{$1} = shift @_ or croak "No argument provided for option '-$1'"; |
48
|
4
|
|
|
|
|
13
|
next; |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
|
51
|
10
|
|
|
|
|
40
|
my ($sig, $name) = ($symbol =~ qw/^(\W?)(.*)$/); |
52
|
10
|
100
|
|
|
|
26
|
my $type = $sig ? $SIGMAP{$sig} : 'CODE'; |
53
|
10
|
50
|
|
|
|
18
|
croak "Unsupported sigil ($sig) on symbol '$symbol'" unless $type; |
54
|
|
|
|
|
|
|
|
55
|
10
|
50
|
|
|
|
44
|
my $new_name = shift(@_) or croak "No new name was specified for symbol '$symbol'"; |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
croak "Symbol '$symbol' ($type, $name) listed multiple times" |
58
|
10
|
50
|
|
|
|
27
|
if $renames{$name}->{$type}; |
59
|
|
|
|
|
|
|
|
60
|
10
|
|
|
|
|
46
|
$renames{$name}->{$type} = $new_name; |
61
|
|
|
|
|
|
|
} |
62
|
|
|
|
|
|
|
|
63
|
8
|
|
|
|
|
30
|
return (\%opts, %renames); |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
sub _symbol_exists { |
67
|
60
|
|
|
60
|
|
158
|
my ($globref, $type) = @_; |
68
|
|
|
|
|
|
|
|
69
|
60
|
100
|
|
|
|
156
|
return defined(*{$globref}{$type}) |
|
44
|
|
|
|
|
481
|
|
70
|
|
|
|
|
|
|
unless $type eq 'SCALAR'; |
71
|
|
|
|
|
|
|
|
72
|
16
|
50
|
|
|
|
43
|
return defined(${ *{$globref}{$type} }) |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
73
|
|
|
|
|
|
|
if $] < 5.010; |
74
|
|
|
|
|
|
|
|
75
|
16
|
|
|
|
|
81
|
my $sv = B::svref_2object($globref)->SV; |
76
|
16
|
100
|
|
|
|
110
|
return 1 if $sv->isa('B::SV'); |
77
|
8
|
50
|
|
|
|
28
|
return 0 unless $sv->isa('B::SPECIAL'); |
78
|
8
|
|
|
|
|
40
|
return $B::specialsv_name[$$sv] ne 'Nullsv'; |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
sub _rename_symbols { |
82
|
7
|
|
|
7
|
|
11
|
my $class = shift; |
83
|
7
|
|
|
|
|
14
|
my %renames = @_; |
84
|
|
|
|
|
|
|
|
85
|
1
|
|
|
1
|
|
6
|
no strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
52
|
|
86
|
7
|
|
|
|
|
7
|
my $stash = \%{"$class\::"}; |
|
7
|
|
|
|
|
28
|
|
87
|
1
|
|
|
1
|
|
6
|
use strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
43
|
|
88
|
|
|
|
|
|
|
|
89
|
7
|
|
|
|
|
18
|
for my $name (keys %renames) { |
90
|
7
|
|
|
|
|
11
|
my $types = $renames{$name}; |
91
|
|
|
|
|
|
|
|
92
|
1
|
|
|
1
|
|
5
|
no strict 'refs'; |
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
53
|
|
93
|
7
|
|
|
|
|
9
|
local *GLOBCLONE = *{"$class\::$name"}; |
|
7
|
|
|
|
|
29
|
|
94
|
1
|
|
|
1
|
|
5
|
use strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
46
|
|
95
|
|
|
|
|
|
|
|
96
|
7
|
|
|
|
|
16
|
delete $stash->{$name}; |
97
|
|
|
|
|
|
|
|
98
|
7
|
|
|
|
|
10
|
for my $type (qw/CODE SCALAR HASH ARRAY FORMAT IO/) { |
99
|
32
|
100
|
|
|
|
128
|
if (my $new_name = $types->{$type}) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
100
|
1
|
|
|
1
|
|
5
|
no strict 'refs'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
47
|
|
101
|
10
|
|
|
|
|
10
|
my $destglob = \*{"$class\::$new_name"}; |
|
10
|
|
|
|
|
27
|
|
102
|
1
|
|
|
1
|
|
5
|
use strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
95
|
|
103
|
|
|
|
|
|
|
|
104
|
10
|
100
|
|
|
|
19
|
croak "Destination symbol '$TYPEMAP{$type}$class\::$new_name' already exists" |
105
|
|
|
|
|
|
|
if _symbol_exists($destglob, $type); |
106
|
|
|
|
|
|
|
|
107
|
9
|
100
|
|
|
|
22
|
croak "Origin symbol '$TYPEMAP{$type}$class\::$name' does not exist" |
108
|
|
|
|
|
|
|
unless _symbol_exists(\*GLOBCLONE, $type); |
109
|
|
|
|
|
|
|
|
110
|
1
|
|
|
1
|
|
5
|
no strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
73
|
|
111
|
8
|
|
|
|
|
15
|
*{"$class\::$new_name"} = *GLOBCLONE{$type}; |
|
8
|
|
|
|
|
25
|
|
112
|
|
|
|
|
|
|
} |
113
|
2
|
|
|
|
|
7
|
elsif($type eq 'SCALAR' ? defined ${*GLOBCLONE{$type}} : defined *GLOBCLONE{$type}) { |
114
|
1
|
|
|
1
|
|
5
|
no strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
115
|
|
115
|
6
|
|
|
|
|
10
|
*{"$class\::$name"} = *GLOBCLONE{$type}; |
|
6
|
|
|
|
|
21
|
|
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
} |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
1; |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
__END__ |