lib/strictures.pm

   1 package strictures;
   2
   3 use strict;
   4 use warnings FATAL => 'all';
   5
   6 BEGIN {
   7   *_PERL_LT_5_8_4 = ($] < 5.008004) ? sub(){1} : sub(){0};
   8 }
   9
  10 our $VERSION = '2.000000';
  11 $VERSION = eval $VERSION;
  12
  13 our @WARNING_CATEGORIES = grep { exists $warnings::Offsets{$_} } qw(
  14   closure
  15   deprecated
  16   exiting
  17   experimental
  18     experimental::autoderef
  19     experimental::const_attr
  20     experimental::lexical_subs
  21     experimental::lexical_topic
  22     experimental::postderef
  23     experimental::re_strict
  24     experimental::refaliasing
  25     experimental::regex_sets
  26     experimental::signatures
  27     experimental::smartmatch
  28     experimental::win32_perlio
  29   glob
  30   imprecision
  31   io
  32     closed
  33     exec
  34     layer
  35     newline
  36     pipe
  37     syscalls
  38     unopened
  39   locale
  40   misc
  41   missing
  42   numeric
  43   once
  44   overflow
  45   pack
  46   portable
  47   recursion
  48   redefine
  49   redundant
  50   regexp
  51   severe
  52     debugging
  53     inplace
  54     internal
  55     malloc
  56   signal
  57   substr
  58   syntax
  59     ambiguous
  60     bareword
  61     digit
  62     illegalproto
  63     parenthesis
  64     precedence
  65     printf
  66     prototype
  67     qw
  68     reserved
  69     semicolon
  70   taint
  71   threads
  72   uninitialized
  73   unpack
  74   untie
  75   utf8
  76     non_unicode
  77     nonchar
  78     surrogate
  79   void
  80   void_unusual
  81   y2k
  82 );
  83
  84 sub VERSION {
  85   no warnings;
  86   local $@;
  87   if (defined $_[1] && eval { $_[0]->UNIVERSAL::VERSION($_[1]); 1}) {
  88     $^H |= 0x20000
  89       unless _PERL_LT_5_8_4;
  90     $^H{strictures_enable} = int $_[1];
  91   }
  92   goto &UNIVERSAL::VERSION;
  93 }
  94
  95 our %extra_load_states;
  96
  97 our $Smells_Like_VCS;
  98
  99 sub import {
 100   my $class = shift;
 101   my %opts = ref $_[0] ? %{$_[0]} : @_;
 102   if (!exists $opts{version}) {
 103     $opts{version}
 104       = exists $^H{strictures_enable} ? delete $^H{strictures_enable}
 105       : int $VERSION;
 106   }
 107   $opts{file} = (caller)[1];
 108   $class->_enable(\%opts);
 109 }
 110
 111 sub _enable {
 112   my ($class, $opts) = @_;
 113   my $version = $opts->{version};
 114   $version = 'undef'
 115     if !defined $version;
 116   my $method = "_enable_$version";
 117   if (!$class->can($method)) {
 118     require Carp;
 119     Carp::croak("Major version specified as $version - not supported!");
 120   }
 121   $class->$method($opts);
 122 }
 123
 124 sub _enable_1 {
 125   my ($class, $opts) = @_;
 126   strict->import;
 127   warnings->import(FATAL => 'all');
 128
 129   if (_want_extra($opts->{file})) {
 130     _load_extras(qw(indirect multidimensional bareword::filehandles));
 131     indirect->unimport(':fatal')
 132       if $extra_load_states{indirect};
 133     multidimensional->unimport
 134       if $extra_load_states{multidimensional};
 135     bareword::filehandles->unimport
 136       if $extra_load_states{'bareword::filehandles'};
 137   }
 138 }
 139
 140 our @V2_NONFATAL = grep { exists $warnings::Offsets{$_} } (
 141   'exec',         # not safe to catch
 142   'recursion',    # will be caught by other mechanisms
 143   'internal',     # not safe to catch
 144   'malloc',       # not safe to catch
 145   'newline',      # stat on nonexistent file with a newline in it
 146   'experimental', # no reason for these to be fatal
 147   'deprecated',   # unfortunately can't make these fatal
 148   'portable',     # everything worked fine here, just may not elsewhere
 149 );
 150 our @V2_DISABLE = grep { exists $warnings::Offsets{$_} } (
 151   'once'          # triggers inconsistently, can't be fatalized
 152 );
 153
 154 sub _enable_2 {
 155   my ($class, $opts) = @_;
 156   strict->import;
 157   warnings->import;
 158   warnings->import(FATAL => @WARNING_CATEGORIES);
 159   warnings->unimport(FATAL => @V2_NONFATAL);
 160   warnings->import(@V2_NONFATAL);
 161   warnings->unimport(@V2_DISABLE);
 162
 163   if (_want_extra($opts->{file})) {
 164     _load_extras(qw(indirect multidimensional bareword::filehandles));
 165     indirect->unimport(':fatal')
 166       if $extra_load_states{indirect};
 167     multidimensional->unimport
 168       if $extra_load_states{multidimensional};
 169     bareword::filehandles->unimport
 170       if $extra_load_states{'bareword::filehandles'};
 171   }
 172 }
 173
 174 sub _want_extra_env {
 175   if (exists $ENV{PERL_STRICTURES_EXTRA}) {
 176     if (_PERL_LT_5_8_4 and $ENV{PERL_STRICTURES_EXTRA}) {
 177       die 'PERL_STRICTURES_EXTRA checks are not available on perls older'
 178         . "than 5.8.4: please unset \$ENV{PERL_STRICTURES_EXTRA}\n";
 179     }
 180     return $ENV{PERL_STRICTURES_EXTRA} ? 1 : 0;
 181   }
 182   return undef;
 183 }
 184
 185 sub _want_extra {
 186   my $file = shift;
 187   my $want_env = _want_extra_env();
 188   return $want_env
 189     if defined $want_env;
 190   return (
 191     !_PERL_LT_5_8_4
 192     and $file =~ /^(?:t|xt|lib|blib)[\\\/]/
 193     and defined $Smells_Like_VCS ? $Smells_Like_VCS
 194       : ( $Smells_Like_VCS = !!(
 195         -e '.git' || -e '.svn' || -e '.hg'
 196         || (-e '../../dist.ini'
 197           && (-e '../../.git' || -e '../../.svn' || -e '../../.hg' ))
 198       ))
 199   );
 200 }
 201
 202 sub _load_extras {
 203   my @extras = @_;
 204   my @failed;
 205   foreach my $mod (@extras) {
 206     next
 207       if exists $extra_load_states{$mod};
 208
 209     $extra_load_states{$mod} = eval "require $mod; 1;" or do {
 210       push @failed, $mod;
 211
 212       #work around 5.8 require bug
 213       (my $file = $mod) =~ s|::|/|g;
 214       delete $INC{"${file}.pm"};
 215     };
 216   }
 217
 218   if (@failed) {
 219     my $failed = join ' ', @failed;
 220     my $extras = join ' ', @extras;
 221     print STDERR <<EOE;
 222 strictures.pm extra testing active but couldn't load all modules. Missing were:
 223
 224   $failed
 225
 226 Extra testing is auto-enabled in checkouts only, so if you're the author
 227 of a strictures-using module you need to run:
 228
 229   cpan $extras
 230
 231 but these modules are not required by your users.
 232 EOE
 233   }
 234 }
 235
 236 1;
 237
 238 __END__
 239 =head1 NAME
 240
 241 strictures - turn on strict and make all warnings fatal
 242
 243 =head1 SYNOPSIS
 244
 245   use strictures 2;
 246
 247 is equivalent to
 248
 249   use strict;
 250   use warnings FATAL => 'all';
 251   use warnings NONFATAL => qw(
 252     exec
 253     recursion
 254     internal
 255     malloc
 256     newline
 257     experimental
 258     deprecated
 259     portable
 260   );
 261   no warnings 'once';
 262
 263 except when called from a file which matches:
 264
 265   (caller)[1] =~ /^(?:t|xt|lib|blib)[\\\/]/
 266
 267 and when either C<.git>, C<.svn>, or C<.hg> is present in the current directory
 268 (with the intention of only forcing extra tests on the author side) -- or when
 269 C<.git>, C<.svn>, or C<.hg> is present two directories up along with
 270 C<dist.ini> (which would indicate we are in a C<dzil test> operation, via
 271 L<Dist::Zilla>) -- or when the C<PERL_STRICTURES_EXTRA> environment variable is
 272 set, in which case it also does the equivalent of
 273
 274   no indirect 'fatal';
 275   no multidimensional;
 276   no bareword::filehandles;
 277
 278 Note that C<PERL_STRICTURES_EXTRA> may at some point add even more tests, with
 279 only a minor version increase, but any changes to the effect of C<use
 280 strictures> in normal mode will involve a major version bump.
 281
 282 If any of the extra testing modules are not present, L<strictures> will
 283 complain loudly, once, via C<warn()>, and then shut up. But you really
 284 should consider installing them, they're all great anti-footgun tools.
 285
 286 =head1 DESCRIPTION
 287
 288 I've been writing the equivalent of this module at the top of my code for
 289 about a year now. I figured it was time to make it shorter.
 290
 291 Things like the importer in C<use Moose> don't help me because they turn
 292 warnings on but don't make them fatal -- which from my point of view is
 293 useless because I want an exception to tell me my code isn't warnings-clean.
 294
 295 Any time I see a warning from my code, that indicates a mistake.
 296
 297 Any time my code encounters a mistake, I want a crash -- not spew to STDERR
 298 and then unknown (and probably undesired) subsequent behaviour.
 299
 300 I also want to ensure that obvious coding mistakes, like indirect object
 301 syntax (and not so obvious mistakes that cause things to accidentally compile
 302 as such) get caught, but not at the cost of an XS dependency and not at the
 303 cost of blowing things up on another machine.
 304
 305 Therefore, L<strictures> turns on additional checking, but only when it thinks
 306 it's running in a test file in a VCS checkout -- although if this causes
 307 undesired behaviour this can be overridden by setting the
 308 C<PERL_STRICTURES_EXTRA> environment variable.
 309
 310 If additional useful author side checks come to mind, I'll add them to the
 311 C<PERL_STRICTURES_EXTRA> code path only -- this will result in a minor version
 312 increase (e.g. 1.000000 to 1.001000 (1.1.0) or similar). Any fixes only to the
 313 mechanism of this code will result in a sub-version increase (e.g. 1.000000 to
 314 1.000001 (1.0.1)).
 315
 316 =head1 VERSIONS
 317
 318 Depending on the version of strictures requested, different warnings will be
 319 enabled.  If no specific version is requested, the current version's behavior
 320 will be used.  Versions can be requested using perl's standard mechanism:
 321
 322   use strictures 2;
 323
 324 Or, by passing in a C<version> option:
 325
 326   use strictures version => 2;
 327
 328 =head2 VERSION 2
 329
 330 Equivalent to:
 331
 332   use strict;
 333   use warnings FATAL => 'all';
 334   use warnings NONFATAL => 'deprecated', 'experimental';
 335   # and if in dev mode:
 336   no indirect 'fatal';
 337   no multidimensional;
 338   no bareword::filehandles;
 339
 340 =head2 VERSION 1
 341
 342 Equivalent to:
 343
 344   use strict;
 345   use warnings FATAL => 'all';
 346   # and if in dev mode:
 347   no indirect 'fatal';
 348   no multidimensional;
 349   no bareword::filehandles;
 350
 351 =head1 METHODS
 352
 353 =head2 import
 354
 355 This method does the setup work described above in L</DESCRIPTION>.  Optionally
 356 accepts a C<version> option to request a specific version's behavior.
 357
 358 =head2 VERSION
 359
 360 This method traps the C<< strictures->VERSION(1) >> call produced by a use line
 361 with a version number on it and does the version check.
 362
 363 =head1 EXTRA TESTING RATIONALE
 364
 365 Every so often, somebody complains that they're deploying via C<git pull>
 366 and that they don't want L<strictures> to enable itself in this case -- and that
 367 setting C<PERL_STRICTURES_EXTRA> to 0 isn't acceptable (additional ways to
 368 disable extra testing would be welcome but the discussion never seems to get
 369 that far).
 370
 371 In order to allow us to skip a couple of stages and get straight to a
 372 productive conversation, here's my current rationale for turning the
 373 extra testing on via a heuristic:
 374
 375 The extra testing is all stuff that only ever blows up at compile time;
 376 this is intentional. So the oft-raised concern that it's different code being
 377 tested is only sort of the case -- none of the modules involved affect the
 378 final optree to my knowledge, so the author gets some additional compile
 379 time crashes which he/she then fixes, and the rest of the testing is
 380 completely valid for all environments.
 381
 382 The point of the extra testing -- especially C<no indirect> -- is to catch
 383 mistakes that newbie users won't even realise are mistakes without
 384 help. For example,
 385
 386   foo { ... };
 387
 388 where foo is an & prototyped sub that you forgot to import -- this is
 389 pernicious to track down since all I<seems> fine until it gets called
 390 and you get a crash. Worse still, you can fail to have imported it due
 391 to a circular require, at which point you have a load order dependent
 392 bug which I've seen before now I<only> show up in production due to tiny
 393 differences between the production and the development environment. I wrote
 394 L<http://shadow.cat/blog/matt-s-trout/indirect-but-still-fatal/> to explain
 395 this particular problem before L<strictures> itself existed.
 396
 397 As such, in my experience so far L<strictures>' extra testing has
 398 I<avoided> production versus development differences, not caused them.
 399
 400 Additionally, L<strictures>' policy is very much "try and provide as much
 401 protection as possible for newbies -- who won't think about whether there's
 402 an option to turn on or not" -- so having only the environment variable
 403 is not sufficient to achieve that (I get to explain that you need to add
 404 C<use strict> at least once a week on freenode #perl -- newbies sometimes
 405 completely skip steps because they don't understand that that step
 406 is important).
 407
 408 I make no claims that the heuristic is perfect -- it's already been evolved
 409 significantly over time, especially for 1.004 where we changed things to
 410 ensure it only fires on files in your checkout (rather than L<strictures>-using
 411 modules you happened to have installed, which was just silly). However, I
 412 hope the above clarifies why a heuristic approach is not only necessary but
 413 desirable from a point of view of providing new users with as much safety as
 414 possible, and will allow any future discussion on the subject to focus on "how
 415 do we minimise annoyance to people deploying from checkouts intentionally".
 416
 417 =head1 SEE ALSO
 418
 419 =over 4
 420
 421 =item *
 422
 423 L<indirect>
 424
 425 =item *
 426
 427 L<multidimensional>
 428
 429 =item *
 430
 431 L<bareword::filehandles>
 432
 433 =back
 434
 435 =head1 COMMUNITY AND SUPPORT
 436
 437 =head2 IRC channel
 438
 439 irc.perl.org #toolchain
 440
 441 (or bug 'mst' in query on there or freenode)
 442
 443 =head2 Git repository
 444
 445 Gitweb is on http://git.shadowcat.co.uk/ and the clone URL is:
 446
 447   git clone git://git.shadowcat.co.uk/p5sagit/strictures.git
 448
 449 The web interface to the repository is at:
 450
 451   http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/strictures.git
 452
 453 =head1 AUTHOR
 454
 455 mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
 456
 457 =head1 CONTRIBUTORS
 458
 459 Karen Etheridge (cpan:ETHER) <ether@cpan.org>
 460
 461 Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@gmail.com>
 462
 463 haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
 464
 465 =head1 COPYRIGHT
 466
 467 Copyright (c) 2010 the strictures L</AUTHOR> and L</CONTRIBUTORS>
 468 as listed above.
 469
 470 =head1 LICENSE
 471
 472 This library is free software and may be distributed under the same terms
 473 as perl itself.
 474
 475 =cut