File Coverage

blib/lib/Acme/ReturnValue.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2             package Acme::ReturnValue;
3              
4 3     3   1692903 use 5.010;
  3         12  
  3         115  
5 3     3   17 use strict;
  3         6  
  3         93  
6 3     3   16 use warnings;
  3         10  
  3         164  
7             our $VERSION = '1.001';
8              
9             # ABSTRACT: report interesting return values
10              
11 3     3   4095 use PPI;
  3         564303  
  3         135  
12 3     3   33 use File::Find;
  3         6  
  3         241  
13 3     3   4261 use Parse::CPAN::Packages;
  0            
  0            
14             use Path::Class qw();
15             use File::Temp qw(tempdir);
16             use File::Path;
17             use File::Copy;
18             use Archive::Any;
19             use Data::Dumper;
20             use JSON;
21             use Encode;
22             use Moose;
23             with qw(MooseX::Getopt);
24             use MooseX::Types::Path::Class;
25              
26             has 'interesting' => (is=>'rw',isa=>'ArrayRef',default=>sub {[]});
27             has 'bad' => (is=>'rw',isa=>'ArrayRef',default=>sub {[]});
28             has 'failed' => (is=>'rw',isa=>'ArrayRef',default=>sub {[]});
29              
30             has 'quiet' => (is=>'ro',isa=>'Bool',default=>0);
31             has 'inc' => (is=>'ro',isa=>'Bool',default=>0);
32             has 'dir' => (is=>'ro',isa=>'Path::Class::Dir',coerce=>1);
33             has 'file' => (is=>'ro',isa=>'Path::Class::File',coerce=>1);
34             has 'cpan' => (is=>'ro',isa=>'Path::Class::Dir',coerce=>1);
35             has 'dump_to' => (is=>'ro',isa=>'Path::Class::Dir',coerce=>1,default=>'returnvalues');
36              
37             has 'json_encoder' => (is=>'ro',lazy_build=>1);
38             sub _build_json_encoder {
39             return JSON->new->pretty;
40             }
41              
42              
43              
44             sub run {
45             my $self = shift;
46              
47             if ($self->inc) {
48             $self->in_INC;
49             }
50             elsif ($self->dir) {
51             $self->in_dir($self->dir);
52             }
53             elsif ($self->file) {
54             $self->in_file($self->file);
55             }
56             elsif ($self->cpan) {
57             $self->in_CPAN($self->cpan,$self->dump_to);
58             exit;
59             }
60             else {
61             $self->in_dir('.');
62             }
63              
64             my $interesting=$self->interesting;
65             if (@$interesting > 0) {
66             foreach my $cool (@$interesting) {
67             say $cool->{package} .': '.$cool->{value};
68             }
69             }
70             else {
71             say "boring!";
72             }
73             }
74              
75              
76             sub waste_some_cycles {
77             my ($self, $filename) = @_;
78              
79             my $doc = PPI::Document->new($filename);
80              
81             eval { # I don't care if that fails...
82             $doc->prune('PPI::Token::Comment');
83             $doc->prune('PPI::Token::Pod');
84             };
85              
86             my @packages=$doc->find('PPI::Statement::Package');
87             my $this_package;
88              
89             foreach my $node ($packages[0][0]->children) {
90             if ($node->isa('PPI::Token::Word')) {
91             $this_package = $node->content;
92             }
93             }
94              
95             my @significant = grep { _is_code($_) } $doc->schildren();
96             my $match = $significant[-1];
97             my $rv=$match->content;
98             $rv=~s/\s*;$//;
99             $rv=~s/^return //gi;
100              
101             return if $rv eq 1;
102             return if $rv eq '__PACKAGE__';
103             return if $rv =~ /^__PACKAGE__->meta->make_immutable/;
104              
105             $rv = decode_utf8($rv);
106              
107             my $data = {
108             'file' => $filename,
109             'package' => $this_package,
110             'PPI' => ref $match,
111             };
112              
113             my @bad = map { 'PPI::Statement::'.$_} qw(Sub Variable Compound Package Scheduled Include Sub);
114              
115             if (ref($match) ~~ @bad) {
116             $data->{'bad'}=$rv;
117             push(@{$self->bad},$data);
118             }
119             elsif ($rv =~ /^('|"|\d|qw|qq|q|!|~)/) {
120             $data->{'value'}=$rv;
121             push(@{$self->interesting},$data);
122             }
123             else {
124             $data->{'bad'}=$rv;
125             $data->{'PPI'}.=" (but very likely crap)";
126             push(@{$self->bad},$data);
127             }
128             }
129              
130              
131             sub _is_code {
132             my $elem = shift;
133             return ! ( $elem->isa('PPI::Statement::End')
134             || $elem->isa('PPI::Statement::Data'));
135             }
136              
137              
138             sub in_CPAN {
139             my ($self,$cpan,$out)=@_;
140              
141             my $p=Parse::CPAN::Packages->new($cpan->file(qw(modules 02packages.details.txt.gz))->stringify);
142              
143             if (!-d $out) {
144             $out->mkpath || die "cannot make dir $out";
145             }
146              
147             # get all old data files so we can later delete non-current
148             my %old_files;
149             while (my $file = $out->next) {
150             next unless $file =~ /\.json/;
151             $old_files{$file->basename}=1;
152             }
153              
154             # analyse cpan
155             foreach my $dist (sort {$a->dist cmp $b->dist} $p->latest_distributions) {
156             delete $old_files{$dist->distvname.'.json'};
157             next if (-e $out->file($dist->distvname.'.json'));
158              
159             my $data;
160             my $distfile = $cpan->file('authors','id',$dist->prefix);
161             $data->{file}=$distfile;
162             my $dir;
163             eval {
164             $dir = tempdir('/var/tmp/arv_XXXXXX');
165             my $archive=Archive::Any->new($distfile->stringify) || die $!;
166             $archive->extract($dir);
167              
168             $self->in_dir($dir,$dist->distvname);
169             };
170             if ($@) {
171             say $@;
172             }
173             rmtree($dir);
174             }
175              
176             # remove old data files
177             foreach my $del (keys %old_files) {
178             unlink($out->file($del)) || die $!;
179             }
180              
181             }
182              
183              
184             sub in_INC {
185             my $self=shift;
186             foreach my $dir (@INC) {
187             $self->in_dir($dir,"INC_$dir");
188             }
189             }
190              
191              
192             sub in_dir {
193             my ($self,$dir,$dumpname)=@_;
194             $dumpname ||= $dir;
195             $dumpname=~s/\//_/g;
196              
197             say $dumpname unless $self->quiet;
198              
199             $self->interesting([]);
200             $self->bad([]);
201             my @pms;
202             find(sub {
203             return unless /\.pm\z/;
204             return if $File::Find::name=~/\/x?t\//;
205             return if $File::Find::name=~/\/inc\//;
206             push(@pms,$File::Find::name);
207             },$dir);
208              
209             foreach my $pm (@pms) {
210             $self->in_file($pm);
211             }
212              
213             my $dump=Path::Class::Dir->new($self->dump_to)->file($dumpname.".json");
214             if ($self->interesting && @{$self->interesting}) {
215             $dump->spew(iomode => '>:encoding(UTF-8)', $self->json_encoder->encode($self->interesting));
216             }
217             elsif ($self->bad && @{$self->bad}) {
218             $dump->spew(iomode => '>:encoding(UTF-8)', $self->json_encoder->encode($self->bad));
219             }
220             else {
221             $dump->spew('{"is_boring":"1"}');
222             }
223             }
224              
225              
226             sub in_file {
227             my ($self,$file)=@_;
228              
229             eval { $self->waste_some_cycles($file) };
230             if ($@) {
231             push (@{$self->failed},{file=>$file,error=>$@});
232             }
233             }
234              
235             "let's return a strange value";
236              
237             __END__
238              
239             =pod
240              
241             =head1 NAME
242              
243             Acme::ReturnValue - report interesting return values
244              
245             =head1 VERSION
246              
247             version 1.001
248              
249             =head1 SYNOPSIS
250              
251             use Acme::ReturnValue;
252             my $rvs = Acme::ReturnValue->new;
253             $rvs->in_INC;
254             foreach (@{$rvs->interesting}) {
255             say $_->{package} . ' returns ' . $_->{value};
256             }
257              
258             =head1 DESCRIPTION
259              
260             C<Acme::ReturnValue> will list 'interesting' return values of modules.
261             'Interesting' means something other than '1'.
262              
263             See L<http://returnvalues.useperl.at|http://returnvalues.useperl.at> for the results of running Acme::ReturnValue on the whole CPAN.
264              
265             =head2 METHODS
266              
267             =head3 run
268              
269             run from the commandline (via F<acme_returnvalue.pl>
270              
271             =head3 waste_some_cycles
272              
273             my $data = $arv->waste_some_cycles( '/some/module.pm' );
274              
275             C<waste_some_cycles> parses the passed in file using PPI. It tries to
276             get the last statement and extract it's value.
277              
278             C<waste_some_cycles> returns a hash with following keys
279              
280             =over
281              
282             =item * file
283              
284             The file
285              
286             =item * package
287              
288             The package defintion (the first one encountered in the file
289              
290             =item * value
291              
292             The return value of that file
293              
294             =back
295              
296             C<waste_some_cycles> will also put this data structure into
297             L<interesting> or L<boring>.
298              
299             You might want to pack calls to C<waste_some_cycles> into an C<eval>
300             because PPI dies on parse errors.
301              
302             =head4 _is_code
303              
304             Stolen directly from Perl::Critic::Policy::Modules::RequireEndWithOne
305             as suggested by Chris Dolan.
306              
307             Thanks!
308              
309             =head3 in_CPAN
310              
311             Analyse CPAN. Needs a local CPAN mirror
312              
313             =head3 in_INC
314              
315             $arv->in_INC;
316              
317             Collect return values from all F<*.pm> files in C<< @INC >>.
318              
319             =head3 in_dir
320              
321             $arv->in_dir( $some_dir );
322              
323             Collect return values from all F<*.pm> files in C<< $dir >>.
324              
325             =head3 in_file
326              
327             $arv->in_file( $some_file );
328              
329             Collect return value from the passed in file.
330              
331             If L<waste_some_cycles> failed, puts information on the failing file into L<failed>.
332              
333             =head3 interesting
334              
335             Returns an ARRAYREF containing 'interesting' modules.
336              
337             =head3 boring
338              
339             Returns an ARRAYREF containing 'boring' modules.
340              
341             =head3 failed
342              
343             Returns an ARRAYREF containing unparsable modules.
344              
345             =head1 BUGS
346              
347             Probably many, because I'm not sure I master PPI yet.
348              
349             =head1 AUTHOR
350              
351             Thomas Klausner <domm@cpan.org>
352              
353             =head1 COPYRIGHT AND LICENSE
354              
355             This software is copyright (c) 2013 by Thomas Klausner.
356              
357             This is free software; you can redistribute it and/or modify it under
358             the same terms as the Perl 5 programming language system itself.
359              
360             =cut