File Coverage

lib/Python/Decorator.pm
Criterion Covered Total %
statement 42 81 51.8
branch 7 32 21.8
condition 3 18 16.6
subroutine 11 12 91.6
pod 1 1 100.0
total 64 144 44.4


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__