From: Graham Knop <haarg@haarg.org>
Date: Mon, 6 Jan 2014 12:07:39 +0000 (-0500)
Subject: strictures 2, disabling fatal warnings on some categories
X-Git-Tag: v1.999_001~1^2~14
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=23c0b85d1580eb07a49da0096e4913debc21e8fa;p=p5sagit%2Fstrictures.git

strictures 2, disabling fatal warnings on some categories
---

diff --git a/lib/strictures.pm b/lib/strictures.pm
index 64ddd44..85ea622 100644
--- a/lib/strictures.pm
+++ b/lib/strictures.pm
@@ -7,9 +7,68 @@ BEGIN {
   *_PERL_LT_5_8_4 = ($] < 5.008004) ? sub(){1} : sub(){0};
 }
 
-our $VERSION = '1.005006';
+our $VERSION = '2.000000';
 $VERSION = eval $VERSION;
 
+our @WARNING_CATEGORIES = grep { exists $warnings::Offsets{$_} } qw(
+  closure
+  deprecated
+  exiting
+  experimental
+    experimental::lexical_subs
+    experimental::lexical_topic
+    experimental::regex_sets
+    experimental::smartmatch
+  glob
+  imprecision
+  io
+    closed
+    exec
+    layer
+    newline
+    pipe
+    unopened
+  misc
+  numeric
+  once
+  overflow
+  pack
+  portable
+  recursion
+  redefine
+  regexp
+  severe
+    debugging
+    inplace
+    internal
+    malloc
+  signal
+  substr
+  syntax
+    ambiguous
+    bareword
+    digit
+    illegalproto
+    parenthesis
+    precedence
+    printf
+    prototype
+    qw
+    reserved
+    semicolon
+  taint
+  threads
+  uninitialized
+  unpack
+  untie
+  utf8
+    non_unicode
+    nonchar
+    surrogate
+  void
+  y2k
+);
+
 sub VERSION {
   no warnings;
   local $@;
@@ -66,6 +125,39 @@ sub _enable_1 {
   }
 }
 
+our @V2_NONFATAL = grep { exists $warnings::Offsets{$_} } qw(
+  exec
+  recursion
+  internal
+  malloc
+  newline
+  experimental
+  deprecated
+  portable
+);
+our @V2_DISABLE = grep { exists $warnings::Offsets{$_} } qw(
+  once
+);
+
+sub _enable_2 {
+  my ($class, $opts) = @_;
+  strict->import;
+  warnings->import;
+  warnings->import(FATAL => @WARNING_CATEGORIES);
+  warnings->import(NONFATAL => @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}) {
diff --git a/t/strictures.t b/t/strictures.t
index 41d39a5..8312e71 100644
--- a/t/strictures.t
+++ b/t/strictures.t
@@ -30,8 +30,24 @@ sub test_hints {
   BEGIN { test_hints "version 1" }
 }
 
+{
+  use strict;
+  BEGIN {
+    warnings->import('all');
+    warnings->import(FATAL => @strictures::WARNING_CATEGORIES);
+    warnings->import(NONFATAL => @strictures::V2_NONFATAL);
+    warnings->unimport(@strictures::V2_DISABLE);
+  }
+  BEGIN { capture_hints }
+}
+
+{
+  use strictures 2;
+  BEGIN { test_hints "version 2" }
+}
+
 my $v;
 eval { $v = strictures->VERSION; 1 } or diag $@;
 is $v, $strictures::VERSION, '->VERSION returns version correctly';
 
-ok(!eval q{use strictures 2; 1; }, "Can't use strictures 2 (this is version 1)");
+ok(!eval q{use strictures 3; 1; }, "Can't use strictures 3 (this is version 2)");