view release on metacpan or  search on metacpan

lib/strictures.pm  view on Meta::CPAN

    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"};
    };
  }