This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Bumping versions for B-Lint and B-Deparse per Porting/cmpVERSION.pl
[perl5.git] / dist / B-Lint / lib / B / Lint.pm
CommitLineData
a798dbf2
MB
1package B::Lint;
2
0c784221 3our $VERSION = '1.13'; ## no critic
28b605d8 4
a798dbf2
MB
5=head1 NAME
6
7B::Lint - Perl lint
8
9=head1 SYNOPSIS
10
11perl -MO=Lint[,OPTIONS] foo.pl
12
13=head1 DESCRIPTION
14
15The B::Lint module is equivalent to an extended version of the B<-w>
c00253d5 16option of B<perl>. It is named after the program F<lint> which carries
a798dbf2
MB
17out a similar process for C programs.
18
19=head1 OPTIONS AND LINT CHECKS
20
21Option words are separated by commas (not whitespace) and follow the
22usual conventions of compiler backend options. Following any options
23(indicated by a leading B<->) come lint check arguments. Each such
24argument (apart from the special B<all> and B<none> options) is a
25word representing one possible lint check (turning on that check) or
26is B<no-foo> (turning off that check). Before processing the check
27arguments, a standard list of checks is turned on. Later options
28override earlier ones. Available options are:
29
30=over 8
31
9b494a7e
JJ
32=item B<magic-diamond>
33
34Produces a warning whenever the magic C<E<lt>E<gt>> readline is
35used. Internally it uses perl's two-argument open which itself treats
36filenames with special characters specially. This could allow
37interestingly named files to have unexpected effects when reading.
38
39 % touch 'rm *|'
40 % perl -pe 1
41
42The above creates a file named C<rm *|>. When perl opens it with
43C<E<lt>E<gt>> it actually executes the shell program C<rm *>. This
44makes C<E<lt>E<gt>> dangerous to use carelessly.
45
a798dbf2
MB
46=item B<context>
47
48Produces a warning whenever an array is used in an implicit scalar
49context. For example, both of the lines
50
51 $foo = length(@bar);
52 $foo = @bar;
c00253d5 53
a798dbf2
MB
54will elicit a warning. Using an explicit B<scalar()> silences the
55warning. For example,
56
57 $foo = scalar(@bar);
58
59=item B<implicit-read> and B<implicit-write>
60
61These options produce a warning whenever an operation implicitly
62reads or (respectively) writes to one of Perl's special variables.
63For example, B<implicit-read> will warn about these:
64
65 /foo/;
66
67and B<implicit-write> will warn about these:
68
69 s/foo/bar/;
70
71Both B<implicit-read> and B<implicit-write> warn about this:
72
73 for (@a) { ... }
74
40f1df11
RGS
75=item B<bare-subs>
76
77This option warns whenever a bareword is implicitly quoted, but is also
78the name of a subroutine in the current package. Typical mistakes that it will
79trap are:
80
c00253d5
AL
81 use constant foo => 'bar';
82 @a = ( foo => 1 );
83 $b{foo} = 2;
40f1df11
RGS
84
85Neither of these will do what a naive user would expect.
86
a798dbf2
MB
87=item B<dollar-underscore>
88
c00253d5 89This option warns whenever C<$_> is used either explicitly anywhere or
a798dbf2
MB
90as the implicit argument of a B<print> statement.
91
92=item B<private-names>
93
94This option warns on each use of any variable, subroutine or
95method name that lives in a non-current package but begins with
96an underscore ("_"). Warnings aren't issued for the special case
c00253d5 97of the single character name "_" by itself (e.g. C<$_> and C<@_>).
a798dbf2
MB
98
99=item B<undefined-subs>
100
101This option warns whenever an undefined subroutine is invoked.
102This option will only catch explicitly invoked subroutines such
103as C<foo()> and not indirect invocations such as C<&$subref()>
104or C<$obj-E<gt>meth()>. Note that some programs or modules delay
105definition of subs until runtime by means of the AUTOLOAD
106mechanism.
107
108=item B<regexp-variables>
109
c00253d5
AL
110This option warns whenever one of the regexp variables C<$`>, C<$&> or C<$'>
111is used. Any occurrence of any of these variables in your
a798dbf2
MB
112program can slow your whole program down. See L<perlre> for
113details.
114
115=item B<all>
116
117Turn all warnings on.
118
119=item B<none>
120
121Turn all warnings off.
122
123=back
124
125=head1 NON LINT-CHECK OPTIONS
126
127=over 8
128
129=item B<-u Package>
130
131Normally, Lint only checks the main code of the program together
132with all subs defined in package main. The B<-u> option lets you
133include other package names whose subs are then checked by Lint.
134
135=back
136
ca0b1549
JJ
137=head1 EXTENDING LINT
138
2adc4a42
JJ
139Lint can be extended by with plugins. Lint uses L<Module::Pluggable>
140to find available plugins. Plugins are expected but not required to
141inform Lint of which checks they are adding.
ca0b1549 142
fa75652c 143The C<< B::Lint->register_plugin( MyPlugin => \@new_checks ) >> method
2adc4a42
JJ
144adds the list of C<@new_checks> to the list of valid checks. If your
145module wasn't loaded by L<Module::Pluggable> then your class name is
146added to the list of plugins.
ca0b1549 147
fa75652c
RGS
148You must create a C<match( \%checks )> method in your plugin class or one
149of its parents. It will be called on every op as a regular method call
150with a hash ref of checks as its parameter.
ca0b1549 151
fa75652c
RGS
152The class methods C<< B::Lint->file >> and C<< B::Lint->line >> contain
153the current filename and line number.
ca0b1549 154
fa75652c
RGS
155 package Sample;
156 use B::Lint;
157 B::Lint->register_plugin( Sample => [ 'good_taste' ] );
158
159 sub match {
9b494a7e 160 my ( $op, $checks_href ) = shift @_;
fa75652c
RGS
161 if ( $checks_href->{good_taste} ) {
162 ...
163 }
164 }
ca0b1549 165
9b494a7e
JJ
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
d5e42f17
RGS
178=back
179
a798dbf2
MB
180=head1 BUGS
181
182This is only a very preliminary version.
183
184=head1 AUTHOR
185
186Malcolm Beattie, mbeattie@sable.ox.ac.uk.
187
c97a6147
SP
188=head1 ACKNOWLEDGEMENTS
189
190Sebastien Aperghis-Tramoni - bug fixes
191
a798dbf2
MB
192=cut
193
194use strict;
9b494a7e
JJ
195use 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 );
2adc4a42
JJ
199use Carp 'carp';
200
201# The current M::P doesn't know about .pmc files.
202use Module::Pluggable ( require => 1 );
203
204use List::Util 'first';
205## no critic Prototypes
206sub any (&@) { my $test = shift @_; $test->() and return 1 for @_; return 0 }
a798dbf2 207
9b494a7e 208BEGIN {
2adc4a42
JJ
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.
9b494a7e
JJ
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
2adc4a42 219 if ( any { $sym eq $_ } @B::EXPORT_OK, @B::EXPORT ) {
9b494a7e
JJ
220 B->import($sym);
221 }
222 else {
223 require constant;
224 constant->import( $sym => $val );
225 }
226 }
227}
228
229my $file = "unknown"; # shadows current filename
230my $line = 0; # shadows current line number
231my $curstash = "main"; # shadows current stash
232my $curcv; # shadows current B::CV for pad lookups
a798dbf2 233
9b494a7e
JJ
234sub file {$file}
235sub line {$line}
236sub curstash {$curstash}
237sub curcv {$curcv}
ca0b1549 238
a798dbf2
MB
239# Lint checks
240my %check;
241my %implies_ok_context;
9b494a7e 242
2adc4a42
JJ
243map( $implies_ok_context{$_}++,
244 qw(scalar av2arylen aelem aslice helem hslice
245 keys values hslice defined undef delete) );
a798dbf2
MB
246
247# Lint checks turned on by default
2adc4a42
JJ
248my @default_checks
249 = qw(context magic_diamond undefined_subs regexp_variables);
a798dbf2
MB
250
251my %valid_check;
9b494a7e 252
a798dbf2 253# All valid checks
2adc4a42
JJ
254for 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__;
a798dbf2
MB
261}
262
263# Debugging options
264my ($debug_op);
265
9b494a7e
JJ
266my %done_cv; # used to mark which subs have already been linted
267my @extra_packages; # Lint checks mainline code and all subs which are
268 # in main:: or in one of these packages.
a798dbf2
MB
269
270sub warning {
9b494a7e
JJ
271 my $format = ( @_ < 2 ) ? "%s" : shift @_;
272 warn sprintf( "$format at %s line %d\n", @_, $file, $line );
2adc4a42 273 return undef; ## no critic undef
a798dbf2
MB
274}
275
276# This gimme can't cope with context that's only determined
277# at runtime via dowantarray().
278sub gimme {
9b494a7e 279 my $op = shift @_;
a798dbf2 280 my $flags = $op->flags;
9b494a7e
JJ
281 if ( $flags & OPf_WANT ) {
282 return ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ? 1 : 0 );
a798dbf2 283 }
2adc4a42 284 return undef; ## no critic undef
a798dbf2
MB
285}
286
2adc4a42 287my @plugins = __PACKAGE__->plugins;
ca0b1549 288
9b494a7e
JJ
289sub 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.
2adc4a42 294 return any { $_->name =~ m/\A(?:grep|map)/xms } @{ parents() };
9b494a7e
JJ
295}
296
297sub inside_foreach_modifier {
298
2adc4a42
JJ
299 # TODO: use any()
300
9b494a7e
JJ
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
317for (
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 ) = @$_;
2adc4a42
JJ
336 my $target = do { ## no critic strict
337 no strict 'refs';
338 \*$subname;
339 };
9b494a7e
JJ
340 *$target = sub {
341 my ($op) = @_;
342
343 my $elt;
344 if ( not $op->isa('B::PADOP') ) {
345 $elt = $op->$attr;
346 }
2adc4a42 347 return $elt if eval { $elt->isa('B::SV') };
9b494a7e
JJ
348
349 my $ix = $op->$pad_attr;
350 my @entire_pad = $curcv->PADLIST->ARRAY;
351 my @elts = map +( $_->ARRAY )[$ix], @entire_pad;
2adc4a42
JJ
352 ($elt) = first {
353 eval { $_->isa('B::SV') } ? $_ : ();
c97a6147
SP
354 }
355 @elts[ 0, reverse 1 .. $#elts ];
9b494a7e
JJ
356 return $elt;
357 };
358}
359
ca0b1549 360sub B::OP::lint {
9b494a7e
JJ
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
ca0b1549 367 my $m;
9b494a7e 368 $m = $_->can('match'), $op->$m( \%check ) for @plugins;
ca0b1549
JJ
369 return;
370}
fa75652c 371
a798dbf2 372sub B::COP::lint {
9b494a7e
JJ
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;
a798dbf2 384 }
ca0b1549 385
9b494a7e 386 # Call all registered plugins
ca0b1549 387 my $m;
9b494a7e 388 $m = $_->can('match'), $op->$m( \%check ) for @plugins;
ca0b1549 389 return;
a798dbf2
MB
390}
391
392sub B::UNOP::lint {
9b494a7e
JJ
393 my ($op) = @_;
394
3f872cb9 395 my $opname = $op->name;
9b494a7e
JJ
396
397CONTEXT: {
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;
a798dbf2 429 }
9b494a7e
JJ
430
431PRIVATE_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;
a798dbf2 449 }
ca0b1549 450
9b494a7e 451 # Call all registered plugins
ca0b1549 452 my $m;
9b494a7e 453 $m = $_->can('match'), $op->$m( \%check ) for @plugins;
ca0b1549 454 return;
a798dbf2
MB
455}
456
457sub B::PMOP::lint {
9b494a7e
JJ
458 my ($op) = @_;
459
460IMPLICIT_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 $_';
a798dbf2 469 }
9b494a7e
JJ
470
471IMPLICIT_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 $_';
a798dbf2 480 }
ca0b1549 481
9b494a7e 482 # Call all registered plugins
ca0b1549 483 my $m;
9b494a7e 484 $m = $_->can('match'), $op->$m( \%check ) for @plugins;
ca0b1549 485 return;
a798dbf2
MB
486}
487
488sub B::LOOP::lint {
9b494a7e
JJ
489 my ($op) = @_;
490
491IMPLICIT_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';
a798dbf2 505 }
9b494a7e
JJ
506
507 # Call all registered plugins
ca0b1549 508 my $m;
9b494a7e 509 $m = $_->can('match'), $op->$m( \%check ) for @plugins;
ca0b1549 510 return;
a798dbf2
MB
511}
512
9b494a7e
JJ
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.
c97a6147 518*B::PADOP::lint = *B::PADOP::lint = \&B::SVOP::lint;
2e9e4ed7 519
7934575e 520sub B::SVOP::lint {
9b494a7e
JJ
521 my ($op) = @_;
522
523MAGIC_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 <>';
40f1df11 530 }
9b494a7e
JJ
531
532BARE_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
560PRIVATE_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 }
a798dbf2 582 }
9b494a7e
JJ
583
584DOLLAR_UNDERSCORE: {
585
586 # Warn on uses of $_ with a few exceptions. I'm not warning on
c4a6f826 587 # $_ inside grep, map, or statement modifier foreach because
9b494a7e
JJ
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 $_';
a798dbf2 599 }
9b494a7e
JJ
600
601REGEXP_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;
a798dbf2 612 }
9b494a7e
JJ
613
614UNDEFINED_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
2adc4a42 626 no strict 'refs'; ## no critic strict
9b494a7e
JJ
627 if ( not exists &$subname ) {
628 $subname =~ s/\Amain:://;
74bdedfd 629 warning q[Nonexistent subroutine '%s' called], $subname;
9b494a7e
JJ
630 }
631 elsif ( not defined &$subname ) {
632 $subname =~ s/\A\&?main:://;
633 warning q[Undefined subroutine '%s' called], $subname;
634 }
a798dbf2 635 }
9b494a7e
JJ
636
637 # Call all registered plugins
ca0b1549 638 my $m;
9b494a7e 639 $m = $_->can('match'), $op->$m( \%check ) for @plugins;
ca0b1549 640 return;
a798dbf2
MB
641}
642
643sub B::GV::lintcv {
2adc4a42
JJ
644
645 # Example: B::svref_2object( \ *A::Glob )->lintcv
646
9b494a7e 647 my $gv = shift @_;
a798dbf2 648 my $cv = $gv->CV;
9b494a7e
JJ
649 return unless $cv->can('lintcv');
650 $cv->lintcv;
651 return;
652}
653
654sub B::CV::lintcv {
655
2adc4a42
JJ
656 # Example: B::svref_2object( \ &foo )->lintcv
657
9b494a7e
JJ
658 # Write to the *global* $
659 $curcv = shift @_;
660
a798dbf2 661 #warn sprintf("lintcv: %s::%s (done=%d)\n",
9b494a7e
JJ
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
a798dbf2 666 #warn " root = $root (0x$$root)\n";#debug
9b494a7e
JJ
667 walkoptree_slow( $root, "lint" ) if $$root;
668 return;
a798dbf2
MB
669}
670
671sub do_lint {
672 my %search_pack;
9b494a7e
JJ
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 ) {
2adc4a42 680 next unless eval { $av->isa('B::AV') };
9b494a7e
JJ
681 for my $cv ( $av->ARRAY ) {
682 next unless ref($cv) and $cv->FILE eq $0;
683 $cv->lintcv;
684 }
a798dbf2
MB
685 }
686
9b494a7e
JJ
687 walksymtable(
688 \%main::,
689 sub {
690 if ( $_[0]->FILE eq $0 ) { $_[0]->lintcv }
691 },
692 sub {1}
693 );
694 return;
a798dbf2
MB
695}
696
697sub compile {
698 my @options = @_;
9b494a7e 699
a798dbf2 700 # Turn on default lint checks
9b494a7e
JJ
701 for my $opt (@default_checks) {
702 $check{$opt} = 1;
a798dbf2 703 }
9b494a7e
JJ
704
705OPTION:
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" ) {
a798dbf2 718 $arg ||= shift @options;
9b494a7e
JJ
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 }
a798dbf2 732 }
9b494a7e
JJ
733
734 foreach my $opt ( @default_checks, @options ) {
735 $opt =~ tr/-/_/;
736 if ( $opt eq "all" ) {
2adc4a42 737 %check = %valid_check;
9b494a7e
JJ
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 }
2adc4a42
JJ
749 carp "No such check: $opt"
750 unless defined $valid_check{$opt};
9b494a7e 751 }
a798dbf2 752 }
9b494a7e
JJ
753
754 # Remaining arguments are things to check. So why aren't I
755 # capturing them or something? I don't know.
fa75652c 756
a798dbf2
MB
757 return \&do_lint;
758}
759
ca0b1549
JJ
760sub register_plugin {
761 my ( undef, $plugin, $new_checks ) = @_;
fa75652c 762
2adc4a42
JJ
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;
ca0b1549 779 }
fa75652c 780
2adc4a42
JJ
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 }
fa75652c 788
ca0b1549
JJ
789 return;
790}
791
a798dbf2 7921;