Re: Not OK 17969

Message-Id: <87lm5fn5c5.fsf@vran.herceg.de>

p4raw-id: //depot/perl@17971

5 files changed, 58 insertions, 26 deletions

diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm
index 4fba6b1462..1283b7983e 100644
--- a/ext/Storable/Storable.pm
+++ b/ext/Storable/Storable.pm
@@ -521,6 +521,10 @@ to a subroutine reference which would be used instead of C<eval>. See
 below for an example using a L<Safe> compartment for deserialization
 of CODE references.
 
+If C<$Storable::Deparse> and/or C<$Storable::Eval> are set to false
+values, then the value of C<$Storable::forgive_me> (see below) is
+respected while serializing and deserializing.
+
 =head1 FORWARD COMPATIBILITY
 
 This release of Storable can be used on a newer version of Perl to
@@ -799,17 +803,24 @@ which prints (on my machine):
 Serialization of CODE references and deserialization in a safe
 compartment:
 
+=for example begin
+
 	use Storable qw(freeze thaw);
 	use Safe;
 	use strict;
 	my $safe = new Safe;
-	# permitting the "require" opcode is necessary when using "use strict"
-	$safe->permit(qw(:default require));
+        # because of opcodes used in "use strict":
+	$safe->permit(qw(:default require caller));
 	local $Storable::Deparse = 1;
 	local $Storable::Eval = sub { $safe->reval($_[0]) };
-	my $serialized = freeze(sub { print "42\n" });
+	my $serialized = freeze(sub { 42 });
 	my $code = thaw($serialized);
-	$code->(); # prints 42
+	$code->() == 42;
+
+=for example end
+
+=for example_testing
+        is( $code->(), 42 );
 
 =head1 WARNING
 
@@ -839,9 +850,9 @@ your data.  There is no slowdown on retrieval.
 
 =head1 BUGS
 
-You can't store GLOB, CODE, FORMLINE, etc.... If you can define
-semantics for those operations, feel free to enhance Storable so that
-it can deal with them.
+You can't store GLOB, FORMLINE, etc.... If you can define semantics
+for those operations, feel free to enhance Storable so that it can
+deal with them.
 
 The store functions will C<croak> if they run into such references
 unless you set C<$Storable::forgive_me> to some C<TRUE> value. In that
diff --git a/ext/Storable/t/code.t b/ext/Storable/t/code.t
index 3a6d1a49a0..1912cd047e 100644
--- a/ext/Storable/t/code.t
+++ b/ext/Storable/t/code.t
@@ -38,7 +38,7 @@ BEGIN {
     }
 }
 
-BEGIN { plan tests => 47 }
+BEGIN { plan tests => 49 }
 
 use Storable qw(retrieve store nstore freeze nfreeze thaw dclone);
 use Safe;
@@ -47,10 +47,14 @@ use Safe;
 
 use vars qw($freezed $thawed @obj @res $blessed_code);
 
-sub code { "JAPH" }
 $blessed_code = bless sub { "blessed" }, "Some::Package";
 { package Another::Package; sub foo { __PACKAGE__ } }
 
+{
+    no strict; # to make the life for Safe->reval easier
+    sub code { "JAPH" }
+}
+
 @obj =
     ([\&code,                   # code reference
       sub { 6*7 },
@@ -202,20 +206,13 @@ ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
 
 {
     my $safe = new Safe;
-    $safe->permit(qw(:default require));
     local $Storable::Eval = sub { $safe->reval(shift) };
 
-    for my $def ([0 => "JAPH",
-		  1 => 42,
-		 ]
-		) {
-	my($i, $res) = @$def;
-	$freezed = freeze $obj[0]->[$i];
-	$@ = "";
-	eval { $thawed = thaw $freezed };
-	ok($@, "");
-	ok($thawed->(), $res);
-    }
+    $freezed = freeze $obj[0]->[0];
+    $@ = "";
+    eval { $thawed = thaw $freezed };
+    ok($@, "");
+    ok($thawed->(), "JAPH");
 
     $freezed = freeze $obj[0]->[6];
     eval { $thawed = thaw $freezed };
@@ -240,6 +237,19 @@ ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
 }
 
 {
+    my $safe = new Safe;
+    # because of opcodes used in "use strict":
+    $safe->permit(qw(:default require caller));
+    local $Storable::Eval = sub { $safe->reval(shift) };
+
+    $freezed = freeze $obj[0]->[1];
+    $@ = "";
+    eval { $thawed = thaw $freezed };
+    ok($@, "");
+    ok($thawed->(), 42);
+}
+
+{
     {
 	package MySafe;
 	sub new { bless {}, shift }
diff --git a/ext/Storable/t/downgrade.t b/ext/Storable/t/downgrade.t
index 5b884753be..2274dc9003 100644
--- a/ext/Storable/t/downgrade.t
+++ b/ext/Storable/t/downgrade.t
@@ -9,6 +9,13 @@
 # I ought to keep this test easily backwards compatible to 5.004, so no
 # qr//;
 
+BEGIN {
+    if ($] < 5.005) {
+	print "1..0 # Skip: usage of qr//\n";
+	exit 0;
+    }
+}
+
 # This test checks downgrade behaviour on pre-5.8 perls when new 5.8 features
 # are encountered.
 
diff --git a/ext/Storable/t/forgive.t b/ext/Storable/t/forgive.t
index 3110ac4fa5..65a2e4ccc1 100644
--- a/ext/Storable/t/forgive.t
+++ b/ext/Storable/t/forgive.t
@@ -16,11 +16,6 @@ sub BEGIN {
     } else {
 	unshift @INC, 't';
     }
-    require File::Spec;
-    if ($File::Spec::VERSION < 0.8) {
-	print "1..0 # Skip: newer File::Spec needed\n";
-	exit 0;
-    }
     require Config; import Config;
     if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
         print "1..0 # Skip: Storable was not built\n";
@@ -30,6 +25,11 @@ sub BEGIN {
 
 use Storable qw(store retrieve);
 
+# problems with 5.00404 when in an BEGIN block, so this is defined here
+if (eval { require File::Spec; 1 } || $File::Spec::VERSION < 0.8) {
+    print "1..0 # Skip: File::Spec 0.8 needed\n";
+    exit 0;
+}
 
 print "1..8\n";
 
diff --git a/ext/Storable/t/malice.t b/ext/Storable/t/malice.t
index b4951da144..6d21776683 100644
--- a/ext/Storable/t/malice.t
+++ b/ext/Storable/t/malice.t
@@ -23,6 +23,10 @@ sub BEGIN {
         print "1..0 # Skip: Storable was not built\n";
         exit 0;
     }
+    if ($] < 5.005) {
+        print "1..0 # Skip: Config{ptrsize} not defined\n";
+        exit 0;
+    }
 }
 
 use strict;