[p5sagit/p5-mst-13.2.git] / ext / Storable / t / code.t

#!./perl
#
#  Copyright (c) 2002 Slaven Rezic
#
#  You may redistribute only under the same terms as Perl 5, as specified
#  in the README file that comes with the distribution.
#

sub BEGIN {
    if ($ENV{PERL_CORE}){
	chdir('t') if -d 't';
	@INC = ('.', '../lib');
    } else {
	unshift @INC, 't';
    }
    require Config; import Config;
    if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
        print "1..0 # Skip: Storable was not built\n";
        exit 0;
    }
}

use strict;
BEGIN {
    if (!eval q{
	use Test;
	use B::Deparse 0.61;
	use 5.006;
	1;
    }) {
	print "1..0 # skip: tests only work with B::Deparse 0.61 and at least perl 5.6.0\n";
	exit;
    }
    require File::Spec;
    if ($File::Spec::VERSION < 0.8) {
	print "1..0 # Skip: newer File::Spec needed\n";
	exit 0;
    }
}

BEGIN { plan tests => 49 }

use Storable qw(retrieve store nstore freeze nfreeze thaw dclone);
use Safe;

#$Storable::DEBUGME = 1;

use vars qw($freezed $thawed @obj @res $blessed_code);

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

local *FOO;

@obj =
    ([\&code,                   # code reference
      sub { 6*7 },
      $blessed_code,            # blessed code reference
      \&Another::Package::foo,  # code in another package
      sub ($$;$) { 0 },         # prototypes
      sub { print "test\n" },
      \&Test::ok,               # large scalar
     ],

     {"a" => sub { "srt" }, "b" => \&code},

     sub { ord("a")-ord("7") },

     \&code,

     \&dclone,                 # XS function

     sub { open FOO, "/" },
    );

$Storable::Deparse = 1;
$Storable::Eval    = 1;

######################################################################
# Test freeze & thaw

$freezed = freeze $obj[0];
$thawed  = thaw $freezed;

ok($thawed->[0]->(), "JAPH");
ok($thawed->[1]->(), 42);
ok($thawed->[2]->(), "blessed");
ok($thawed->[3]->(), "Another::Package");
ok(prototype($thawed->[4]), prototype($obj[0]->[4]));

######################################################################

$freezed = freeze $obj[1];
$thawed  = thaw $freezed;

ok($thawed->{"a"}->(), "srt");
ok($thawed->{"b"}->(), "JAPH");

######################################################################

$freezed = freeze $obj[2];
$thawed  = thaw $freezed;

ok($thawed->(), 42);

######################################################################

$freezed = freeze $obj[3];
$thawed  = thaw $freezed;

ok($thawed->(), "JAPH");

######################################################################

eval { $freezed = freeze $obj[4] };
ok($@ =~ /The result of B::Deparse::coderef2text was empty/);

######################################################################
# Test dclone

my $new_sub = dclone($obj[2]);
ok($new_sub->(), $obj[2]->());

######################################################################
# Test retrieve & store

store $obj[0], 'store';
$thawed = retrieve 'store';

ok($thawed->[0]->(), "JAPH");
ok($thawed->[1]->(), 42);
ok($thawed->[2]->(), "blessed");
ok($thawed->[3]->(), "Another::Package");
ok(prototype($thawed->[4]), prototype($obj[0]->[4]));

######################################################################

nstore $obj[0], 'store';
$thawed = retrieve 'store';
unlink 'store';

ok($thawed->[0]->(), "JAPH");
ok($thawed->[1]->(), 42);
ok($thawed->[2]->(), "blessed");
ok($thawed->[3]->(), "Another::Package");
ok(prototype($thawed->[4]), prototype($obj[0]->[4]));

######################################################################
# Security with
#   $Storable::Eval
#   $Storable::Deparse

{
    local $Storable::Eval = 0;

    for my $i (0 .. 1) {
	$freezed = freeze $obj[$i];
	$@ = "";
	eval { $thawed  = thaw $freezed };
	ok($@ =~ /Can\'t eval/);
    }
}

{

    local $Storable::Deparse = 0;
    for my $i (0 .. 1) {
	$@ = "";
	eval { $freezed = freeze $obj[$i] };
	ok($@ =~ /Can\'t store CODE items/);
    }
}

{
    local $Storable::Eval = 0;
    local $Storable::forgive_me = 1;
    for my $i (0 .. 4) {
	$freezed = freeze $obj[0]->[$i];
	$@ = "";
	eval { $thawed  = thaw $freezed };
	ok($@, "");
	ok($$thawed =~ /^sub/);
    }
}

{
    local $Storable::Deparse = 0;
    local $Storable::forgive_me = 1;

    my $devnull = File::Spec->devnull;

    open(SAVEERR, ">&STDERR");
    open(STDERR, ">$devnull") or
	( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );

    eval { $freezed = freeze $obj[0]->[0] };

    open(STDERR, ">&SAVEERR");

    ok($@, "");
    ok($freezed ne '');
}

{
    my $safe = new Safe;
    local $Storable::Eval = sub { $safe->reval(shift) };

    $freezed = freeze $obj[0]->[0];
    $@ = "";
    eval { $thawed = thaw $freezed };
    ok($@, "");
    ok($thawed->(), "JAPH");

    $freezed = freeze $obj[0]->[6];
    eval { $thawed = thaw $freezed };
    ok($@ =~ /trapped/);

    if (0) {
	# Disable or fix this test if the internal representation of Storable
	# changes.
	skip("no malicious storable file check", 1);
    } else {
	# Construct malicious storable code
	$freezed = nfreeze $obj[0]->[0];
	my $bad_code = ';open FOO, "/badfile"';
	# 5th byte is (short) length of scalar
	my $len = ord(substr($freezed, 4, 1));
	substr($freezed, 4, 1, chr($len+length($bad_code)));
	substr($freezed, -1, 0, $bad_code);
	$@ = "";
	eval { $thawed = thaw $freezed };
	ok($@ =~ /trapped/);
    }
}

{
    my $safe = new Safe;
    # because of opcodes used in "use strict":
    $safe->permit(qw(:default require));
    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 }
	sub reval {
	    my $source = $_[1];
	    # Here you can apply some nifty regexpes to ensure the
	    # safeness of the source code.
	    my $coderef = eval $source;
	    $coderef;
	}
    }

    my $safe = new MySafe;
    local $Storable::Eval = sub { $safe->reval($_[0]) };

    $freezed = freeze $obj[0];
    eval { $thawed  = thaw $freezed };
    ok($@, "");

    if ($@ ne "") {
        ok(0) for (1..5);
    } else {
	ok($thawed->[0]->(), "JAPH");
	ok($thawed->[1]->(), 42);
	ok($thawed->[2]->(), "blessed");
	ok($thawed->[3]->(), "Another::Package");
	ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
    }
}
Commit	Line	Data
464b080a	1	#!./perl
	2	#
	3	# Copyright (c) 2002 Slaven Rezic
	4	#
	5	# You may redistribute only under the same terms as Perl 5, as specified
	6	# in the README file that comes with the distribution.
	7	#
	8
	9	sub BEGIN {
	10	if ($ENV{PERL_CORE}){
	11	chdir('t') if -d 't';
	12	@INC = ('.', '../lib');
	13	} else {
	14	unshift @INC, 't';
	15	}
	16	require Config; import Config;
	17	if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
	18	print "1..0 # Skip: Storable was not built\n";
	19	exit 0;
	20	}
	21	}
	22
	23	use strict;
	24	BEGIN {
	25	if (!eval q{
	26	use Test;
	27	use B::Deparse 0.61;
9820b33a	28	use 5.006;
464b080a	29	1;
	30	}) {
	31	print "1..0 # skip: tests only work with B::Deparse 0.61 and at least perl 5.6.0\n";
	32	exit;
	33	}
	34	require File::Spec;
	35	if ($File::Spec::VERSION < 0.8) {
	36	print "1..0 # Skip: newer File::Spec needed\n";
	37	exit 0;
	38	}
	39	}
	40
197b90bc	41	BEGIN { plan tests => 49 }
464b080a	42
	43	use Storable qw(retrieve store nstore freeze nfreeze thaw dclone);
	44	use Safe;
	45
	46	#$Storable::DEBUGME = 1;
	47
	48	use vars qw($freezed $thawed @obj @res $blessed_code);
	49
464b080a	50	$blessed_code = bless sub { "blessed" }, "Some::Package";
	51	{ package Another::Package; sub foo { __PACKAGE__ } }
	52
197b90bc	53	{
	54	no strict; # to make the life for Safe->reval easier
	55	sub code { "JAPH" }
	56	}
	57
9820b33a	58	local *FOO;
9820b33a	59
464b080a	60	@obj =
	61	([\&code, # code reference
	62	sub { 6*7 },
	63	$blessed_code, # blessed code reference
	64	\&Another::Package::foo, # code in another package
	65	sub ($$;$) { 0 }, # prototypes
	66	sub { print "test\n" },
	67	\&Test::ok, # large scalar
	68	],
	69
	70	{"a" => sub { "srt" }, "b" => \&code},
	71
	72	sub { ord("a")-ord("7") },
	73
	74	\&code,
	75
	76	\&dclone, # XS function
	77
	78	sub { open FOO, "/" },
	79	);
	80
	81	$Storable::Deparse = 1;
	82	$Storable::Eval = 1;
	83
	84	######################################################################
	85	# Test freeze & thaw
	86
	87	$freezed = freeze $obj[0];
	88	$thawed = thaw $freezed;
	89
	90	ok($thawed->[0]->(), "JAPH");
	91	ok($thawed->[1]->(), 42);
	92	ok($thawed->[2]->(), "blessed");
	93	ok($thawed->[3]->(), "Another::Package");
	94	ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
	95
	96	######################################################################
	97
	98	$freezed = freeze $obj[1];
	99	$thawed = thaw $freezed;
	100
	101	ok($thawed->{"a"}->(), "srt");
	102	ok($thawed->{"b"}->(), "JAPH");
	103
	104	######################################################################
	105
	106	$freezed = freeze $obj[2];
	107	$thawed = thaw $freezed;
	108
	109	ok($thawed->(), 42);
	110
	111	######################################################################
	112
	113	$freezed = freeze $obj[3];
	114	$thawed = thaw $freezed;
	115
	116	ok($thawed->(), "JAPH");
	117
	118	######################################################################
	119
	120	eval { $freezed = freeze $obj[4] };
	121	ok($@ =~ /The result of B::Deparse::coderef2text was empty/);
	122
	123	######################################################################
124	# Test dclone
125
126	my $new_sub = dclone($obj[2]);
127	ok($new_sub->(), $obj[2]->());
128
129	######################################################################
130	# Test retrieve & store
131
132	store $obj[0], 'store';
133	$thawed = retrieve 'store';
134
135	ok($thawed->[0]->(), "JAPH");
136	ok($thawed->[1]->(), 42);
137	ok($thawed->[2]->(), "blessed");
138	ok($thawed->[3]->(), "Another::Package");
139	ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
140
141	######################################################################
142
143	nstore $obj[0], 'store';
144	$thawed = retrieve 'store';
145	unlink 'store';
146
147	ok($thawed->[0]->(), "JAPH");
148	ok($thawed->[1]->(), 42);
149	ok($thawed->[2]->(), "blessed");
150	ok($thawed->[3]->(), "Another::Package");
151	ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
152
153	######################################################################
154	# Security with
155	# $Storable::Eval
464b080a	156	# $Storable::Deparse
	157
	158	{
	159	local $Storable::Eval = 0;
	160
	161	for my $i (0 .. 1) {
	162	$freezed = freeze $obj[$i];
	163	$@ = "";
	164	eval { $thawed = thaw $freezed };
	165	ok($@ =~ /Can\'t eval/);
	166	}
	167	}
	168
	169	{
	170
	171	local $Storable::Deparse = 0;
	172	for my $i (0 .. 1) {
	173	$@ = "";
	174	eval { $freezed = freeze $obj[$i] };
	175	ok($@ =~ /Can\'t store CODE items/);
	176	}
	177	}
	178
	179	{
	180	local $Storable::Eval = 0;
	181	local $Storable::forgive_me = 1;
	182	for my $i (0 .. 4) {
	183	$freezed = freeze $obj[0]->[$i];
	184	$@ = "";
	185	eval { $thawed = thaw $freezed };
	186	ok($@, "");
	187	ok($$thawed =~ /^sub/);
	188	}
	189	}
	190
	191	{
	192	local $Storable::Deparse = 0;
	193	local $Storable::forgive_me = 1;
	194
	195	my $devnull = File::Spec->devnull;
	196
	197	open(SAVEERR, ">&STDERR");
	198	open(STDERR, ">$devnull") or
	199	( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
	200
	201	eval { $freezed = freeze $obj[0]->[0] };
	202
	203	open(STDERR, ">&SAVEERR");
	204
	205	ok($@, "");
	206	ok($freezed ne '');
	207	}
	208
	209	{
	210	my $safe = new Safe;
464b080a	211	local $Storable::Eval = sub { $safe->reval(shift) };
464b080a	212
197b90bc	213	$freezed = freeze $obj[0]->[0];
	214	$@ = "";
	215	eval { $thawed = thaw $freezed };
	216	ok($@, "");
	217	ok($thawed->(), "JAPH");
464b080a	218
	219	$freezed = freeze $obj[0]->[6];
	220	eval { $thawed = thaw $freezed };
	221	ok($@ =~ /trapped/);
	222
	223	if (0) {
	224	# Disable or fix this test if the internal representation of Storable
	225	# changes.
	226	skip("no malicious storable file check", 1);
	227	} else {
	228	# Construct malicious storable code
	229	$freezed = nfreeze $obj[0]->[0];
	230	my $bad_code = ';open FOO, "/badfile"';
	231	# 5th byte is (short) length of scalar
	232	my $len = ord(substr($freezed, 4, 1));
	233	substr($freezed, 4, 1, chr($len+length($bad_code)));
	234	substr($freezed, -1, 0, $bad_code);
	235	$@ = "";
	236	eval { $thawed = thaw $freezed };
	237	ok($@ =~ /trapped/);
	238	}
	239	}
	240
	241	{
197b90bc	242	my $safe = new Safe;
197b90bc	243	# because of opcodes used in "use strict":
e279cb0b	244	$safe->permit(qw(:default require));
197b90bc	245	local $Storable::Eval = sub { $safe->reval(shift) };
	246
	247	$freezed = freeze $obj[0]->[1];
	248	$@ = "";
	249	eval { $thawed = thaw $freezed };
	250	ok($@, "");
	251	ok($thawed->(), 42);
	252	}
	253
	254	{
464b080a	255	{
	256	package MySafe;
	257	sub new { bless {}, shift }
	258	sub reval {
	259	my $source = $_[1];
	260	# Here you can apply some nifty regexpes to ensure the
	261	# safeness of the source code.
	262	my $coderef = eval $source;
	263	$coderef;
	264	}
	265	}
	266
	267	my $safe = new MySafe;
	268	local $Storable::Eval = sub { $safe->reval($_[0]) };
	269
	270	$freezed = freeze $obj[0];
	271	eval { $thawed = thaw $freezed };
	272	ok($@, "");
	273
	274	if ($@ ne "") {
	275	ok(0) for (1..5);
	276	} else {
	277	ok($thawed->[0]->(), "JAPH");
	278	ok($thawed->[1]->(), 42);
	279	ok($thawed->[2]->(), "blessed");
	280	ok($thawed->[3]->(), "Another::Package");
	281	ok(prototype($thawed->[4]), prototype($obj[0]->[4]));
	282	}
	283	}
	284