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