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