line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#------------------------------------------------------------------- |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# Python::Decorator - Python decorators for Perl5 |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# $Id: Decorator.pm,v 1.6 2008-11-05 20:56:42 erwan Exp $ |
6
|
|
|
|
|
|
|
# |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
package Python::Decorator; |
9
|
|
|
|
|
|
|
|
10
|
1
|
|
|
1
|
|
243158
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
33
|
|
11
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
30
|
|
12
|
1
|
|
|
1
|
|
5
|
use Carp qw(croak confess); |
|
1
|
|
|
|
|
8
|
|
|
1
|
|
|
|
|
49
|
|
13
|
1
|
|
|
1
|
|
1727
|
use Data::Dumper; |
|
1
|
|
|
|
|
9865
|
|
|
1
|
|
|
|
|
164
|
|
14
|
1
|
|
|
1
|
|
13
|
use PPI; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
23
|
|
15
|
1
|
|
|
1
|
|
2115
|
use PPI::Find; |
|
1
|
|
|
|
|
1107
|
|
|
1
|
|
|
|
|
28
|
|
16
|
1
|
|
|
1
|
|
8
|
use PPI::Token::Word; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
30
|
|
17
|
1
|
|
|
1
|
|
8
|
use Filter::Util::Call; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
1053
|
|
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
our $VERSION = '0.03'; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
# import - just call filter_add from Filter::Util::Call |
22
|
|
|
|
|
|
|
sub import { |
23
|
1
|
|
|
1
|
|
11
|
my ($class,%args) = @_; |
24
|
1
|
|
33
|
|
|
10
|
$class = ref $class || $class; |
25
|
|
|
|
|
|
|
|
26
|
1
|
|
|
|
|
3
|
my $self = bless({},$class); |
27
|
|
|
|
|
|
|
|
28
|
1
|
50
|
|
|
|
5
|
if (exists $args{debug}) { |
29
|
0
|
0
|
|
|
|
0
|
croak "import argument debug must be 0 or 1" |
30
|
|
|
|
|
|
|
if ($args{debug} !~ /^(0|1)$/); |
31
|
0
|
|
|
|
|
0
|
$self->{debug} = $args{debug}; |
32
|
0
|
|
|
|
|
0
|
delete $args{debug}; |
33
|
|
|
|
|
|
|
} |
34
|
|
|
|
|
|
|
|
35
|
1
|
50
|
|
|
|
4
|
croak "unsupported import arguments: ".join(" ", keys %args) |
36
|
|
|
|
|
|
|
if (scalar keys %args); |
37
|
|
|
|
|
|
|
|
38
|
1
|
|
|
|
|
6
|
filter_add($self); |
39
|
|
|
|
|
|
|
} |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
# |
42
|
|
|
|
|
|
|
# filter - filter the source |
43
|
|
|
|
|
|
|
# |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
# NOTE: we use PPI to parse the filtered source code instead of using |
46
|
|
|
|
|
|
|
# simple regexps and support a smaller but standard subset of possible |
47
|
|
|
|
|
|
|
# syntaxes for sub declaration. For just playing around with |
48
|
|
|
|
|
|
|
# decorators, regexps would have been enough, but I also wanted to |
49
|
|
|
|
|
|
|
# experiment using PPI in a source filter. Hence the extra headache :) |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
sub filter { |
52
|
2
|
|
|
2
|
1
|
449
|
my ($self) = @_; |
53
|
2
|
|
|
|
|
3
|
my $status; |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
# read the whole source at once, accumulate it in $_ |
56
|
2
|
|
|
|
|
6
|
do { |
57
|
3
|
|
|
|
|
24
|
$status = filter_read(); |
58
|
|
|
|
|
|
|
} until ($status == 0); |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
# TODO: croak here, or let Filter::Util::Call croak for us? |
61
|
2
|
50
|
|
|
|
6
|
croak "source filter error: $!" |
62
|
|
|
|
|
|
|
if ($status < 0); |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
# special case: empty doc. nothing to do. |
65
|
2
|
100
|
|
|
|
2786
|
return 0 if (length($_) == 0); |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
# comment out python decorators since they are not parsable perl |
68
|
|
|
|
|
|
|
# and append a magic keyword (here '#DECORATOR:') in front of |
69
|
|
|
|
|
|
|
# them. we later remove all those magic keywords. this is to |
70
|
|
|
|
|
|
|
# avoid commenting out valid perl code by misstake... |
71
|
1
|
|
|
|
|
4
|
while (s/^(\@\w+(\(.+\))?\s*)(\#.*)?$/\#DECORATOR:$1/gm) {} |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
# parse the whole source with PPI |
74
|
1
|
|
33
|
|
|
20
|
my $doc = PPI::Document->new(\$_) || |
75
|
|
|
|
|
|
|
croak "failed to parse source with PPI:".PPI::Document::errstr; |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
# do not look for subs recursively: skip any anonymous sub declared within a sub. |
78
|
|
|
|
|
|
|
my $subs = $doc->find( sub { |
79
|
1
|
50
|
33
|
1
|
|
33
|
ref $_[1] ne '' && $_[1]->parent == $_[0] && $_[1]->isa('PPI::Statement::Sub'); |
80
|
1
|
|
|
|
|
671
|
}); |
81
|
|
|
|
|
|
|
|
82
|
1
|
50
|
|
|
|
42
|
if (ref $subs eq '') { |
83
|
|
|
|
|
|
|
# no subs declared in the source |
84
|
1
|
|
|
|
|
8
|
return 1; |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
# foreach sub declaration in the source file |
88
|
0
|
|
|
|
|
|
foreach my $esub (@$subs) { |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
# find out the 'sub' keyword and the subroutine's name |
91
|
0
|
|
|
|
|
|
my @words = @{$esub->find('PPI::Token::Word')}; |
|
0
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
|
93
|
0
|
0
|
|
|
|
|
confess "expected keyword 'sub'" |
94
|
|
|
|
|
|
|
if ($words[0]->content ne 'sub'); |
95
|
|
|
|
|
|
|
|
96
|
0
|
|
|
|
|
|
my $token_sub = $words[0]; |
97
|
0
|
|
|
|
|
|
my $token_name = $words[1]; |
98
|
0
|
|
|
|
|
|
my $subname = $token_name->content; |
99
|
|
|
|
|
|
|
|
100
|
0
|
0
|
0
|
|
|
|
confess "failed to parse sub name" |
101
|
|
|
|
|
|
|
if (!defined $subname || $subname eq ""); |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
# look at lines just above the sub declaration: they might be |
104
|
|
|
|
|
|
|
# decorators |
105
|
0
|
|
|
|
|
|
my $prev = $esub->previous_token; |
106
|
0
|
|
|
|
|
|
my $before_sub = ""; |
107
|
0
|
|
|
|
|
|
my $after_sub = ""; |
108
|
|
|
|
|
|
|
|
109
|
0
|
|
0
|
|
|
|
while (ref $prev eq 'PPI::Token::Comment' && $prev->content =~ /\#DECORATOR:/) { |
110
|
0
|
|
|
|
|
|
my $c = $prev->content; |
111
|
|
|
|
|
|
|
|
112
|
0
|
0
|
|
|
|
|
if ($c =~ /^\#DECORATOR:\@(\w+)\s*$/) { |
|
|
0
|
|
|
|
|
|
113
|
|
|
|
|
|
|
# previous line is a decorator that takes no arguments |
114
|
0
|
|
|
|
|
|
$before_sub = $1."(".$before_sub; |
115
|
0
|
|
|
|
|
|
$after_sub .= ")"; |
116
|
|
|
|
|
|
|
} elsif ($c =~ /^\#DECORATOR:\@(\w+\(.+\))\s*$/) { |
117
|
|
|
|
|
|
|
# previous line is a decorator that takes arguments |
118
|
0
|
|
|
|
|
|
$before_sub = $1."->(".$before_sub; |
119
|
0
|
|
|
|
|
|
$after_sub .= ")"; |
120
|
|
|
|
|
|
|
} else { |
121
|
|
|
|
|
|
|
# previous line looks like a decorator but is not... |
122
|
0
|
|
|
|
|
|
croak "invalid decorator syntax"; |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
# remove the commented decorator but keep the newline to |
126
|
|
|
|
|
|
|
# avoid messing up line-numbers in the source |
127
|
0
|
|
|
|
|
|
$prev->set_content("\n"); |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
# move up to previous line |
130
|
0
|
|
|
|
|
|
$prev = $prev->previous_token; |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
# skip this sub if it has no decorators |
134
|
0
|
0
|
|
|
|
|
next if ($after_sub eq ""); |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
# now comes some source text manipulation by way of PPI. |
137
|
|
|
|
|
|
|
# we replace 'sub foo [...]' with something like: |
138
|
|
|
|
|
|
|
# |
139
|
|
|
|
|
|
|
# '{ no strict "refs"; *{__PACKAGE__."::foo"} = bar(bob(babe(sub [...] )))); }' |
140
|
|
|
|
|
|
|
# |
141
|
|
|
|
|
|
|
# the 'no strict "refs"' is needed for the symbol table |
142
|
|
|
|
|
|
|
# assignment '*{__PACKAGE__::foo} =' to work in a 'use strict' |
143
|
|
|
|
|
|
|
# environment. |
144
|
|
|
|
|
|
|
# |
145
|
|
|
|
|
|
|
# all those edits must fit on one line to avoid messing up the |
146
|
|
|
|
|
|
|
# linking between errors and line number. |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
# remove the sub's name |
149
|
0
|
|
|
|
|
|
$token_name->set_content(""); |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
# replace the keyword 'sub' with the string below: |
152
|
0
|
|
|
|
|
|
$token_sub->set_content("{ no strict \"refs\"; *{__PACKAGE__.\"::".$subname."\"} = ".$before_sub." sub"); |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
# find the PPI block that contains the body of the subroutine |
155
|
0
|
|
|
|
|
|
my @blocks = @{ $esub->find( sub { |
156
|
0
|
0
|
0
|
0
|
|
|
ref $_[1] ne '' && $_[1]->parent == $_[0] && $_[1]->isa('PPI::Structure::Block'); |
157
|
0
|
|
|
|
|
|
}) }; |
158
|
|
|
|
|
|
|
|
159
|
0
|
0
|
|
|
|
|
croak "found no or more than 1 sub block for sub ".$self->subname |
160
|
|
|
|
|
|
|
if (scalar @blocks != 1); |
161
|
|
|
|
|
|
|
|
162
|
0
|
|
|
|
|
|
my $subbody = $blocks[0]; |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
# replace the sub's last '}' with '} $after_sub; }' |
165
|
0
|
|
|
|
|
|
my $brace = $subbody->finish; |
166
|
0
|
0
|
|
|
|
|
confess "expected a '}' at the end of sub ".$subname |
167
|
|
|
|
|
|
|
if ($brace->content ne "}"); |
168
|
0
|
|
|
|
|
|
$brace->set_content("} $after_sub; }"); |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
# serialize back the modified source tree |
172
|
0
|
|
|
|
|
|
$_ = $doc->serialize; |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
# remove left over '#DECORATOR:'s |
175
|
0
|
|
|
|
|
|
while (s/^(\#DECORATOR:\@)/\@/gm) {} |
176
|
|
|
|
|
|
|
|
177
|
0
|
0
|
|
|
|
|
print "Python::Decorator filtered the source into:\n-------------------------------\n".$_."-------------------------------\n" |
178
|
|
|
|
|
|
|
if ($self->{debug}); |
179
|
|
|
|
|
|
|
|
180
|
0
|
|
|
|
|
|
return 1; |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
1; |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
__END__ |