File Coverage

blib/lib/strictures.pm

Criterion	Covered	Total	%
statement	74	74	100.0
branch	42	44	95.4
condition	5	6	83.3
subroutine	12	12	100.0
pod	1	1	100.0
total	134	137	97.8

package strictures;

use strict;
use warnings FATAL => 'all';

BEGIN {
  *_PERL_LT_5_8_4 = ($] < 5.008004) ? sub(){1} : sub(){0};
  # goto &UNIVERSAL::VERSION usually works on 5.8, but fails on some ARM
  # machines.  Seems to always work on 5.10 though.
  *_CAN_GOTO_VERSION = ($] >= 5.010000) ? sub(){1} : sub(){0};
}

our $VERSION = '2.000003';
$VERSION = eval $VERSION;

our @WARNING_CATEGORIES = grep { exists $warnings::Offsets{$_} } qw(
  closure
  chmod
  deprecated
  exiting
  experimental
    experimental::autoderef
    experimental::bitwise
    experimental::const_attr
    experimental::lexical_subs
    experimental::lexical_topic
    experimental::postderef
    experimental::re_strict
    experimental::refaliasing
    experimental::regex_sets
    experimental::signatures
    experimental::smartmatch
    experimental::win32_perlio
  glob
  imprecision
  io
    closed
    exec
    layer
    newline
    pipe
    syscalls
    unopened
  locale
  misc
  missing
  numeric
  once
  overflow
  pack
  portable
  recursion
  redefine
  redundant
  regexp
  severe
    debugging
    inplace
    internal
    malloc
  signal
  substr
  syntax
    ambiguous
    bareword
    digit
    illegalproto
    parenthesis
    precedence
    printf
    prototype
    qw
    reserved
    semicolon
  taint
  threads
  uninitialized
  umask
  unpack
  untie
  utf8
    non_unicode
    nonchar
    surrogate
  void
  void_unusual
  y2k
);

sub VERSION {
  {
    no warnings;
    local $@;
    if (defined $_[1] && eval { &UNIVERSAL::VERSION; 1}) {
      $^H |= 0x20000
        unless _PERL_LT_5_8_4;
      $^H{strictures_enable} = int $_[1];
    }
  }
  _CAN_GOTO_VERSION ? goto &UNIVERSAL::VERSION : &UNIVERSAL::VERSION;
}

our %extra_load_states;

our $Smells_Like_VCS;

sub import {
  my $class = shift;
  my %opts = @_ == 1 ? %{$_[0]} : @_;
  if (!exists $opts{version}) {
    $opts{version}
      = exists $^H{strictures_enable} ? delete $^H{strictures_enable}
      : int $VERSION;
  }
  $opts{file} = (caller)[1];
  $class->_enable(\%opts);
}

sub _enable {
  my ($class, $opts) = @_;
  my $version = $opts->{version};
  $version = 'undef'
    if !defined $version;
  my $method = "_enable_$version";
  if (!$class->can($method)) {
    require Carp;
    Carp::croak("Major version specified as $version - not supported!");
  }
  $class->$method($opts);
}

sub _enable_1 {
  my ($class, $opts) = @_;
  strict->import;
  warnings->import(FATAL => 'all');

  if (_want_extra($opts->{file})) {
    _load_extras(qw(indirect multidimensional bareword::filehandles));
    indirect->unimport(':fatal')
      if $extra_load_states{indirect};
    multidimensional->unimport
      if $extra_load_states{multidimensional};
    bareword::filehandles->unimport
      if $extra_load_states{'bareword::filehandles'};
  }
}

our @V2_NONFATAL = grep { exists $warnings::Offsets{$_} } (
  'exec',         # not safe to catch
  'recursion',    # will be caught by other mechanisms
  'internal',     # not safe to catch
  'malloc',       # not safe to catch
  'newline',      # stat on nonexistent file with a newline in it
  'experimental', # no reason for these to be fatal
  'deprecated',   # unfortunately can't make these fatal
  'portable',     # everything worked fine here, just may not elsewhere
);
our @V2_DISABLE = grep { exists $warnings::Offsets{$_} } (
  'once'          # triggers inconsistently, can't be fatalized
);

sub _enable_2 {
  my ($class, $opts) = @_;
  strict->import;
  warnings->import;
  warnings->import(FATAL => @WARNING_CATEGORIES);
  warnings->unimport(FATAL => @V2_NONFATAL);
  warnings->import(@V2_NONFATAL);
  warnings->unimport(@V2_DISABLE);

  if (_want_extra($opts->{file})) {
    _load_extras(qw(indirect multidimensional bareword::filehandles));
    indirect->unimport(':fatal')
      if $extra_load_states{indirect};
    multidimensional->unimport
      if $extra_load_states{multidimensional};
    bareword::filehandles->unimport
      if $extra_load_states{'bareword::filehandles'};
  }
}

sub _want_extra_env {
  if (exists $ENV{PERL_STRICTURES_EXTRA}) {
    if (_PERL_LT_5_8_4 and $ENV{PERL_STRICTURES_EXTRA}) {
      die 'PERL_STRICTURES_EXTRA checks are not available on perls older'
        . "than 5.8.4: please unset \$ENV{PERL_STRICTURES_EXTRA}\n";
    }
    return $ENV{PERL_STRICTURES_EXTRA} ? 1 : 0;
  }
  return undef;
}

sub _want_extra {
  my $file = shift;
  my $want_env = _want_extra_env();
  return $want_env
    if defined $want_env;
  return (
    !_PERL_LT_5_8_4
    and $file =~ /^(?:t|xt|lib|blib)[\\\/]/
    and defined $Smells_Like_VCS ? $Smells_Like_VCS
      : ( $Smells_Like_VCS = !!(
        -e '.git' || -e '.svn' || -e '.hg' || -e '.bzr'
        || (-e '../../dist.ini'
          && (-e '../../.git' || -e '../../.svn' || -e '../../.hg' || -e '../../.bzr' ))
      ))
  );
}

sub _load_extras {
  my @extras = @_;
  my @failed;
  foreach my $mod (@extras) {
    next
      if exists $extra_load_states{$mod};

    $extra_load_states{$mod} = eval "require $mod; 1;" or do {
      push @failed, $mod;

      #work around 5.8 require bug
      (my $file = $mod) =~ s|::|/|g;
      delete $INC{"${file}.pm"};
    };
  }

  if (@failed) {
    my $failed = join ' ', @failed;
    my $extras = join ' ', @extras;
    print STDERR <
strictures.pm extra testing active but couldn't load all modules. Missing were:

  $failed

Extra testing is auto-enabled in checkouts only, so if you're the author
of a strictures-using module you need to run:

  cpan $extras

but these modules are not required by your users.
EOE
  }
}

1;

__END__