[perl5.git] / dist / 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 {
    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::More;
	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 => 63 }

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::More::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;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

is($thawed->[0]->(), "JAPH");
is($thawed->[1]->(), 42);
is($thawed->[2]->(), "blessed");
is($thawed->[3]->(), "Another::Package");
is(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 };
	like($@, qr/Can\'t eval/);
    }
}

{

    local $Storable::Deparse = 0;
    for my $i (0 .. 1) {
	$@ = "";
	eval { $freezed = freeze $obj[$i] };
	like($@, qr/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 };
	is($@, "");
	like($$thawed, qr/^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");

    is($@, "");
    isnt($freezed, '');
}

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

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

    $freezed = freeze $obj[0]->[6];
    eval { $thawed = thaw $freezed };
    # The "Code sub ..." error message only appears if Log::Agent is installed
    like($@, qr/(trapped|Code sub)/);

    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 };
	like($@, qr/(trapped|Code sub)/);
    }
}

{
    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 };
    is($@, "");
    is($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 };
    is($@, "");

    if ($@ ne "") {
        fail() for (1..5);
    } else {
	is($thawed->[0]->(), "JAPH");
	is($thawed->[1]->(), 42);
	is($thawed->[2]->(), "blessed");
	is($thawed->[3]->(), "Another::Package");
	is(prototype($thawed->[4]), prototype($obj[0]->[4]));
    }
}

{
    # Check internal "seen" code
    my $short_sub = sub { "short sub" }; # for SX_SCALAR
    # for SX_LSCALAR
    my $long_sub_code = 'sub { "' . "x"x255 . '" }';
    my $long_sub = eval $long_sub_code; die $@ if $@;
    my $sclr = \1;

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

    for my $sub ($short_sub, $long_sub) {
	my $res;

	$res = thaw freeze [$sub, $sub];
	is(int($res->[0]), int($res->[1]));

	$res = thaw freeze [$sclr, $sub, $sub, $sclr];
	is(int($res->[0]), int($res->[3]));
	is(int($res->[1]), int($res->[2]));

	$res = thaw freeze [$sub, $sub, $sclr, $sclr];
	is(int($res->[0]), int($res->[1]));
	is(int($res->[2]), int($res->[3]));
    }

}

{
    my @text = ("hello", "\x{a3}", "\x{a3} \x{2234}", "\x{2234}\x{2234}");

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