This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
76bc9fd02362c0174f53b1ca80dc2843ed5fd07d
[perl5.git] / ext / B-Lint / lib / B / Lint.pm
1 package B::Lint;
2
3 our $VERSION = '1.11';    ## no critic
4
5 =head1 NAME
6
7 B::Lint - Perl lint
8
9 =head1 SYNOPSIS
10
11 perl -MO=Lint[,OPTIONS] foo.pl
12
13 =head1 DESCRIPTION
14
15 The B::Lint module is equivalent to an extended version of the B<-w>
16 option of B<perl>. It is named after the program F<lint> which carries
17 out a similar process for C programs.
18
19 =head1 OPTIONS AND LINT CHECKS
20
21 Option words are separated by commas (not whitespace) and follow the
22 usual conventions of compiler backend options. Following any options
23 (indicated by a leading B<->) come lint check arguments. Each such
24 argument (apart from the special B<all> and B<none> options) is a
25 word representing one possible lint check (turning on that check) or
26 is B<no-foo> (turning off that check). Before processing the check
27 arguments, a standard list of checks is turned on. Later options
28 override earlier ones. Available options are:
29
30 =over 8
31
32 =item B<magic-diamond>
33
34 Produces a warning whenever the magic C<E<lt>E<gt>> readline is
35 used. Internally it uses perl's two-argument open which itself treats
36 filenames with special characters specially. This could allow
37 interestingly named files to have unexpected effects when reading.
38
39   % touch 'rm *|'
40   % perl -pe 1
41
42 The above creates a file named C<rm *|>. When perl opens it with
43 C<E<lt>E<gt>> it actually executes the shell program C<rm *>. This
44 makes C<E<lt>E<gt>> dangerous to use carelessly.
45
46 =item B<context>
47
48 Produces a warning whenever an array is used in an implicit scalar
49 context. For example, both of the lines
50
51     $foo = length(@bar);
52     $foo = @bar;
53
54 will elicit a warning. Using an explicit B<scalar()> silences the
55 warning. For example,
56
57     $foo = scalar(@bar);
58
59 =item B<implicit-read> and B<implicit-write>
60
61 These options produce a warning whenever an operation implicitly
62 reads or (respectively) writes to one of Perl's special variables.
63 For example, B<implicit-read> will warn about these:
64
65     /foo/;
66
67 and B<implicit-write> will warn about these:
68
69     s/foo/bar/;
70
71 Both B<implicit-read> and B<implicit-write> warn about this:
72
73     for (@a) { ... }
74
75 =item B<bare-subs>
76
77 This option warns whenever a bareword is implicitly quoted, but is also
78 the name of a subroutine in the current package. Typical mistakes that it will
79 trap are:
80
81     use constant foo => 'bar';
82     @a = ( foo => 1 );
83     $b{foo} = 2;
84
85 Neither of these will do what a naive user would expect.
86
87 =item B<dollar-underscore>
88
89 This option warns whenever C<$_> is used either explicitly anywhere or
90 as the implicit argument of a B<print> statement.
91
92 =item B<private-names>
93
94 This option warns on each use of any variable, subroutine or
95 method name that lives in a non-current package but begins with
96 an underscore ("_"). Warnings aren't issued for the special case
97 of the single character name "_" by itself (e.g. C<$_> and C<@_>).
98
99 =item B<undefined-subs>
100
101 This option warns whenever an undefined subroutine is invoked.
102 This option will only catch explicitly invoked subroutines such
103 as C<foo()> and not indirect invocations such as C<&$subref()>
104 or C<$obj-E<gt>meth()>. Note that some programs or modules delay
105 definition of subs until runtime by means of the AUTOLOAD
106 mechanism.
107
108 =item B<regexp-variables>
109
110 This option warns whenever one of the regexp variables C<$`>, C<$&> or C<$'>
111 is used. Any occurrence of any of these variables in your
112 program can slow your whole program down. See L<perlre> for
113 details.
114
115 =item B<all>
116
117 Turn all warnings on.
118
119 =item B<none>
120
121 Turn all warnings off.
122
123 =back
124
125 =head1 NON LINT-CHECK OPTIONS
126
127 =over 8
128
129 =item B<-u Package>
130
131 Normally, Lint only checks the main code of the program together
132 with all subs defined in package main. The B<-u> option lets you
133 include other package names whose subs are then checked by Lint.
134
135 =back
136
137 =head1 EXTENDING LINT
138
139 Lint can be extended by with plugins. Lint uses L<Module::Pluggable>
140 to find available plugins. Plugins are expected but not required to
141 inform Lint of which checks they are adding.
142
143 The C<< B::Lint->register_plugin( MyPlugin => \@new_checks ) >> method
144 adds the list of C<@new_checks> to the list of valid checks. If your
145 module wasn't loaded by L<Module::Pluggable> then your class name is
146 added to the list of plugins.
147
148 You must create a C<match( \%checks )> method in your plugin class or one
149 of its parents. It will be called on every op as a regular method call
150 with a hash ref of checks as its parameter.
151
152 The class methods C<< B::Lint->file >> and C<< B::Lint->line >> contain
153 the current filename and line number.
154
155   package Sample;
156   use B::Lint;
157   B::Lint->register_plugin( Sample => [ 'good_taste' ] );
158   
159   sub match {
160       my ( $op, $checks_href ) = shift @_;
161       if ( $checks_href->{good_taste} ) {
162           ...
163       }
164   }
165
166 =head1 TODO
167
168 =over
169
170 =item while(<FH>) stomps $_
171
172 =item strict oo
173
174 =item unchecked system calls
175
176 =item more tests, validate against older perls
177
178 =back
179
180 =head1 BUGS
181
182 This is only a very preliminary version.
183
184 =head1 AUTHOR
185
186 Malcolm Beattie, mbeattie@sable.ox.ac.uk.
187
188 =head1 ACKNOWLEDGEMENTS
189
190 Sebastien Aperghis-Tramoni - bug fixes
191
192 =cut
193
194 use strict;
195 use B qw( walkoptree_slow
196     main_root main_cv walksymtable parents
197     OPpOUR_INTRO
198     OPf_WANT_VOID OPf_WANT_LIST OPf_WANT OPf_STACKED SVf_POK );
199 use Carp 'carp';
200
201 # The current M::P doesn't know about .pmc files.
202 use Module::Pluggable ( require => 1 );
203
204 use List::Util 'first';
205 ## no critic Prototypes
206 sub any (&@) { my $test = shift @_; $test->() and return 1 for @_; return 0 }
207
208 BEGIN {
209
210     # Import or create some constants from B. B doesn't provide
211     # everything I need so some things like OPpCONST_BARE are defined
212     # here.
213     for my $sym ( qw( begin_av check_av init_av end_av ),
214         [ 'OPpCONST_BARE' => 64 ] )
215     {
216         my $val;
217         ( $sym, $val ) = @$sym if ref $sym;
218
219         if ( any { $sym eq $_ } @B::EXPORT_OK, @B::EXPORT ) {
220             B->import($sym);
221         }
222         else {
223             require constant;
224             constant->import( $sym => $val );
225         }
226     }
227 }
228
229 my $file     = "unknown";    # shadows current filename
230 my $line     = 0;            # shadows current line number
231 my $curstash = "main";       # shadows current stash
232 my $curcv;                   # shadows current B::CV for pad lookups
233
234 sub file     {$file}
235 sub line     {$line}
236 sub curstash {$curstash}
237 sub curcv    {$curcv}
238
239 # Lint checks
240 my %check;
241 my %implies_ok_context;
242
243 map( $implies_ok_context{$_}++,
244     qw(scalar av2arylen aelem aslice helem hslice
245         keys values hslice defined undef delete) );
246
247 # Lint checks turned on by default
248 my @default_checks
249     = qw(context magic_diamond undefined_subs regexp_variables);
250
251 my %valid_check;
252
253 # All valid checks
254 for my $check (
255     qw(context implicit_read implicit_write dollar_underscore
256     private_names bare_subs undefined_subs regexp_variables
257     magic_diamond )
258     )
259 {
260     $valid_check{$check} = __PACKAGE__;
261 }
262
263 # Debugging options
264 my ($debug_op);
265
266 my %done_cv;           # used to mark which subs have already been linted
267 my @extra_packages;    # Lint checks mainline code and all subs which are
268                        # in main:: or in one of these packages.
269
270 sub warning {
271     my $format = ( @_ < 2 ) ? "%s" : shift @_;
272     warn sprintf( "$format at %s line %d\n", @_, $file, $line );
273     return undef;      ## no critic undef
274 }
275
276 # This gimme can't cope with context that's only determined
277 # at runtime via dowantarray().
278 sub gimme {
279     my $op    = shift @_;
280     my $flags = $op->flags;
281     if ( $flags & OPf_WANT ) {
282         return ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ? 1 : 0 );
283     }
284     return undef;      ## no critic undef
285 }
286
287 my @plugins = __PACKAGE__->plugins;
288
289 sub inside_grepmap {
290
291     # A boolean function to be used while inside a B::walkoptree_slow
292     # call. If we are in the EXPR part of C<grep EXPR, ...> or C<grep
293     # { EXPR } ...>, this returns true.
294     return any { $_->name =~ m/\A(?:grep|map)/xms } @{ parents() };
295 }
296
297 sub inside_foreach_modifier {
298
299     # TODO: use any()
300
301     # A boolean function to be used while inside a B::walkoptree_slow
302     # call. If we are in the EXPR part of C<EXPR foreach ...> this
303     # returns true.
304     for my $ancestor ( @{ parents() } ) {
305         next unless $ancestor->name eq 'leaveloop';
306
307         my $first = $ancestor->first;
308         next unless $first->name eq 'enteriter';
309
310         next if $first->redoop->name =~ m/\A(?:next|db|set)state\z/xms;
311
312         return 1;
313     }
314     return 0;
315 }
316
317 for (
318     [qw[ B::PADOP::gv_harder gv padix]],
319     [qw[ B::SVOP::sv_harder  sv targ]],
320     [qw[ B::SVOP::gv_harder gv padix]]
321     )
322 {
323
324     # I'm generating some functions here because they're mostly
325     # similar. It's all for compatibility with threaded
326     # perl. Perhaps... this code should inspect $Config{usethreads}
327     # and generate a *specific* function. I'm leaving it generic for
328     # the moment.
329     #
330     # In threaded perl SVs and GVs aren't used directly in the optrees
331     # like they are in non-threaded perls. The ops that would use a SV
332     # or GV keep an index into the subroutine's scratchpad. I'm
333     # currently ignoring $cv->DEPTH and that might be at my peril.
334
335     my ( $subname, $attr, $pad_attr ) = @$_;
336     my $target = do {    ## no critic strict
337         no strict 'refs';
338         \*$subname;
339     };
340     *$target = sub {
341         my ($op) = @_;
342
343         my $elt;
344         if ( not $op->isa('B::PADOP') ) {
345             $elt = $op->$attr;
346         }
347         return $elt if eval { $elt->isa('B::SV') };
348
349         my $ix         = $op->$pad_attr;
350         my @entire_pad = $curcv->PADLIST->ARRAY;
351         my @elts       = map +( $_->ARRAY )[$ix], @entire_pad;
352         ($elt) = first {
353             eval { $_->isa('B::SV') } ? $_ : ();
354         }
355         @elts[ 0, reverse 1 .. $#elts ];
356         return $elt;
357     };
358 }
359
360 sub B::OP::lint {
361     my ($op) = @_;
362
363     # This is a fallback ->lint for all the ops where I haven't
364     # defined something more specific. Nothing happens here.
365
366     # Call all registered plugins
367     my $m;
368     $m = $_->can('match'), $op->$m( \%check ) for @plugins;
369     return;
370 }
371
372 sub B::COP::lint {
373     my ($op) = @_;
374
375     # nextstate ops sit between statements. Whenever I see one I
376     # update the current info on file, line, and stash. This code also
377     # updates it when it sees a dbstate or setstate op. I have no idea
378     # what those are but having seen them mentioned together in other
379     # parts of the perl I think they're kind of equivalent.
380     if ( $op->name =~ m/\A(?:next|db|set)state\z/ ) {
381         $file     = $op->file;
382         $line     = $op->line;
383         $curstash = $op->stash->NAME;
384     }
385
386     # Call all registered plugins
387     my $m;
388     $m = $_->can('match'), $op->$m( \%check ) for @plugins;
389     return;
390 }
391
392 sub B::UNOP::lint {
393     my ($op) = @_;
394
395     my $opname = $op->name;
396
397 CONTEXT: {
398
399         # Check arrays and hashes in scalar or void context where
400         # scalar() hasn't been used.
401
402         next
403             unless $check{context}
404             and $opname =~ m/\Arv2[ah]v\z/xms
405             and not gimme($op);
406
407         my ( $parent, $gparent ) = @{ parents() }[ 0, 1 ];
408         my $pname = $parent->name;
409
410         next if $implies_ok_context{$pname};
411
412         # Three special cases to deal with: "foreach (@foo)", "delete
413         # $a{$b}", and "exists $a{$b}" null out the parent so we have to
414         # check for a parent of pp_null and a grandparent of
415         # pp_enteriter, pp_delete, pp_exists
416
417         next
418             if $pname eq "null"
419             and $gparent->name =~ m/\A(?:delete|enteriter|exists)\z/xms;
420
421         # our( @bar ); would also trigger this error so I exclude
422         # that.
423         next
424             if $op->private & OPpOUR_INTRO
425             and ( $op->flags & OPf_WANT ) == OPf_WANT_VOID;
426
427         warning 'Implicit scalar context for %s in %s',
428             $opname eq "rv2av" ? "array" : "hash", $parent->desc;
429     }
430
431 PRIVATE_NAMES: {
432
433         # Looks for calls to methods with names that begin with _ and
434         # that aren't visible within the current package. Maybe this
435         # should look at @ISA.
436         next
437             unless $check{private_names}
438             and $opname =~ m/\Amethod/xms;
439
440         my $methop = $op->first;
441         next unless $methop->name eq "const";
442
443         my $method = $methop->sv_harder->PV;
444         next
445             unless $method =~ m/\A_/xms
446             and not defined &{"$curstash\::$method"};
447
448         warning q[Illegal reference to private method name '%s'], $method;
449     }
450
451     # Call all registered plugins
452     my $m;
453     $m = $_->can('match'), $op->$m( \%check ) for @plugins;
454     return;
455 }
456
457 sub B::PMOP::lint {
458     my ($op) = @_;
459
460 IMPLICIT_READ: {
461
462         # Look for /.../ that doesn't use =~ to bind to something.
463         next
464             unless $check{implicit_read}
465             and $op->name eq "match"
466             and not( $op->flags & OPf_STACKED
467             or inside_grepmap() );
468         warning 'Implicit match on $_';
469     }
470
471 IMPLICIT_WRITE: {
472
473         # Look for s/.../.../ that doesn't use =~ to bind to
474         # something.
475         next
476             unless $check{implicit_write}
477             and $op->name eq "subst"
478             and not $op->flags & OPf_STACKED;
479         warning 'Implicit substitution on $_';
480     }
481
482     # Call all registered plugins
483     my $m;
484     $m = $_->can('match'), $op->$m( \%check ) for @plugins;
485     return;
486 }
487
488 sub B::LOOP::lint {
489     my ($op) = @_;
490
491 IMPLICIT_FOO: {
492
493         # Look for C<for ( ... )>.
494         next
495             unless ( $check{implicit_read} or $check{implicit_write} )
496             and $op->name eq "enteriter";
497
498         my $last = $op->last;
499         next
500             unless $last->name         eq "gv"
501             and $last->gv_harder->NAME eq "_"
502             and $op->redoop->name =~ m/\A(?:next|db|set)state\z/xms;
503
504         warning 'Implicit use of $_ in foreach';
505     }
506
507     # Call all registered plugins
508     my $m;
509     $m = $_->can('match'), $op->$m( \%check ) for @plugins;
510     return;
511 }
512
513 # In threaded vs non-threaded perls you'll find that threaded perls
514 # use PADOP in place of SVOPs so they can do lookups into the
515 # scratchpad to find things. I suppose this is so a optree can be
516 # shared between threads and all symbol table muckery will just get
517 # written to a scratchpad.
518 *B::PADOP::lint = *B::PADOP::lint = \&B::SVOP::lint;
519
520 sub B::SVOP::lint {
521     my ($op) = @_;
522
523 MAGIC_DIAMOND: {
524         next
525             unless $check{magic_diamond}
526             and parents()->[0]->name eq 'readline'
527             and $op->gv_harder->NAME eq 'ARGV';
528
529         warning 'Use of <>';
530     }
531
532 BARE_SUBS: {
533         next
534             unless $check{bare_subs}
535             and $op->name eq 'const'
536             and $op->private & OPpCONST_BARE;
537
538         my $sv = $op->sv_harder;
539         next unless $sv->FLAGS & SVf_POK;
540
541         my $sub     = $sv->PV;
542         my $subname = "$curstash\::$sub";
543
544         # I want to skip over things that were declared with the
545         # constant pragma. Well... sometimes. Hmm. I want to ignore
546         # C<<use constant FOO => ...>> but warn on C<<FOO => ...>>
547         # later. The former is typical declaration syntax and the
548         # latter would be an error.
549         #
550         # Skipping over both could be handled by looking if
551         # $constant::declared{$subname} is true.
552
553         # Check that it's a function.
554         next
555             unless exists &{"$curstash\::$sub"};
556
557         warning q[Bare sub name '%s' interpreted as string], $sub;
558     }
559
560 PRIVATE_NAMES: {
561         next unless $check{private_names};
562
563         my $opname = $op->name;
564         if ( $opname =~ m/\Agv(?:sv)?\z/xms ) {
565
566             # Looks for uses of variables and stuff that are named
567             # private and we're not in the same package.
568             my $gv   = $op->gv_harder;
569             my $name = $gv->NAME;
570             next
571                 unless $name =~ m/\A_./xms
572                 and $gv->STASH->NAME ne $curstash;
573
574             warning q[Illegal reference to private name '%s'], $name;
575         }
576         elsif ( $opname eq "method_named" ) {
577             my $method = $op->sv_harder->PV;
578             next unless $method =~ m/\A_./xms;
579
580             warning q[Illegal reference to private method name '%s'], $method;
581         }
582     }
583
584 DOLLAR_UNDERSCORE: {
585
586         # Warn on uses of $_ with a few exceptions. I'm not warning on
587         # $_ inside grep, map, or statement modifer foreach because
588         # they localize $_ and it'd be impossible to use these
589         # features without getting warnings.
590
591         next
592             unless $check{dollar_underscore}
593             and $op->name            eq "gvsv"
594             and $op->gv_harder->NAME eq "_"
595             and not( inside_grepmap
596             or inside_foreach_modifier );
597
598         warning 'Use of $_';
599     }
600
601 REGEXP_VARIABLES: {
602
603         # Look for any uses of $`, $&, or $'.
604         next
605             unless $check{regexp_variables}
606             and $op->name eq "gvsv";
607
608         my $name = $op->gv_harder->NAME;
609         next unless $name =~ m/\A[\&\'\`]\z/xms;
610
611         warning 'Use of regexp variable $%s', $name;
612     }
613
614 UNDEFINED_SUBS: {
615
616         # Look for calls to functions that either don't exist or don't
617         # have a definition.
618         next
619             unless $check{undefined_subs}
620             and $op->name       eq "gv"
621             and $op->next->name eq "entersub";
622
623         my $gv      = $op->gv_harder;
624         my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
625
626         no strict 'refs';    ## no critic strict
627         if ( not exists &$subname ) {
628             $subname =~ s/\Amain:://;
629             warning q[Nonexistant subroutine '%s' called], $subname;
630         }
631         elsif ( not defined &$subname ) {
632             $subname =~ s/\A\&?main:://;
633             warning q[Undefined subroutine '%s' called], $subname;
634         }
635     }
636
637     # Call all registered plugins
638     my $m;
639     $m = $_->can('match'), $op->$m( \%check ) for @plugins;
640     return;
641 }
642
643 sub B::GV::lintcv {
644
645     # Example: B::svref_2object( \ *A::Glob )->lintcv
646
647     my $gv = shift @_;
648     my $cv = $gv->CV;
649     return unless $cv->can('lintcv');
650     $cv->lintcv;
651     return;
652 }
653
654 sub B::CV::lintcv {
655
656     # Example: B::svref_2object( \ &foo )->lintcv
657
658     # Write to the *global* $
659     $curcv = shift @_;
660
661     #warn sprintf("lintcv: %s::%s (done=%d)\n",
662     #            $gv->STASH->NAME, $gv->NAME, $done_cv{$$curcv});#debug
663     return unless ref($curcv) and $$curcv and not $done_cv{$$curcv}++;
664     my $root = $curcv->ROOT;
665
666     #warn "    root = $root (0x$$root)\n";#debug
667     walkoptree_slow( $root, "lint" ) if $$root;
668     return;
669 }
670
671 sub do_lint {
672     my %search_pack;
673
674     # Copy to the global $curcv for use in pad lookups.
675     $curcv = main_cv;
676     walkoptree_slow( main_root, "lint" ) if ${ main_root() };
677
678     # Do all the miscellaneous non-sub blocks.
679     for my $av ( begin_av, init_av, check_av, end_av ) {
680         next unless eval { $av->isa('B::AV') };
681         for my $cv ( $av->ARRAY ) {
682             next unless ref($cv) and $cv->FILE eq $0;
683             $cv->lintcv;
684         }
685     }
686
687     walksymtable(
688         \%main::,
689         sub {
690             if ( $_[0]->FILE eq $0 ) { $_[0]->lintcv }
691         },
692         sub {1}
693     );
694     return;
695 }
696
697 sub compile {
698     my @options = @_;
699
700     # Turn on default lint checks
701     for my $opt (@default_checks) {
702         $check{$opt} = 1;
703     }
704
705 OPTION:
706     while ( my $option = shift @options ) {
707         my ( $opt, $arg );
708         unless ( ( $opt, $arg ) = $option =~ m/\A-(.)(.*)/xms ) {
709             unshift @options, $option;
710             last OPTION;
711         }
712
713         if ( $opt eq "-" && $arg eq "-" ) {
714             shift @options;
715             last OPTION;
716         }
717         elsif ( $opt eq "D" ) {
718             $arg ||= shift @options;
719             foreach my $arg ( split //, $arg ) {
720                 if ( $arg eq "o" ) {
721                     B->debug(1);
722                 }
723                 elsif ( $arg eq "O" ) {
724                     $debug_op = 1;
725                 }
726             }
727         }
728         elsif ( $opt eq "u" ) {
729             $arg ||= shift @options;
730             push @extra_packages, $arg;
731         }
732     }
733
734     foreach my $opt ( @default_checks, @options ) {
735         $opt =~ tr/-/_/;
736         if ( $opt eq "all" ) {
737             %check = %valid_check;
738         }
739         elsif ( $opt eq "none" ) {
740             %check = ();
741         }
742         else {
743             if ( $opt =~ s/\Ano_//xms ) {
744                 $check{$opt} = 0;
745             }
746             else {
747                 $check{$opt} = 1;
748             }
749             carp "No such check: $opt"
750                 unless defined $valid_check{$opt};
751         }
752     }
753
754     # Remaining arguments are things to check. So why aren't I
755     # capturing them or something? I don't know.
756
757     return \&do_lint;
758 }
759
760 sub register_plugin {
761     my ( undef, $plugin, $new_checks ) = @_;
762
763     # Allow the user to be lazy and not give us a name.
764     $plugin = caller unless defined $plugin;
765
766     # Register the plugin's named checks, if any.
767     for my $check ( eval {@$new_checks} ) {
768         if ( not defined $check ) {
769             carp 'Undefined value in checks.';
770             next;
771         }
772         if ( exists $valid_check{$check} ) {
773             carp
774                 "$check is already registered as a $valid_check{$check} feature.";
775             next;
776         }
777
778         $valid_check{$check} = $plugin;
779     }
780
781     # Register a non-Module::Pluggable loaded module. @plugins already
782     # contains whatever M::P found on disk. The user might load a
783     # plugin manually from some arbitrary namespace and ask for it to
784     # be registered.
785     if ( not any { $_ eq $plugin } @plugins ) {
786         push @plugins, $plugin;
787     }
788
789     return;
790 }
791
792 1;