From: Slaven Rezic <slaven@rezic.de>
Date: Sat, 17 Aug 2002 21:58:03 +0000 (+0200)
Subject: Re: [PATCH] Storable and CODE references
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=464b080a310708e7a2a4f76cfdc5ca4039ba758d;p=p5sagit%2Fp5-mst-13.2.git

Re: [PATCH] Storable and CODE references
Message-id: <87bs812r78.fsf@vran.herceg.de>

p4raw-id: //depot/perl@17741
---

diff --git a/MANIFEST b/MANIFEST
index 3839ad2..36dafce 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -611,6 +611,7 @@ ext/Storable/Storable.pm	Storable extension
 ext/Storable/Storable.xs	Storable extension
 ext/Storable/t/blessed.t	See if Storable works
 ext/Storable/t/canonical.t	See if Storable works
+ext/Storable/t/code.t		See if Storable works
 ext/Storable/t/compat06.t	See if Storable works
 ext/Storable/t/croak.t		See if Storable works
 ext/Storable/t/dclone.t		See if Storable works
diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs
index 98e3059..48d05f9 100644
--- a/ext/Storable/Storable.xs
+++ b/ext/Storable/Storable.xs
@@ -149,7 +149,8 @@ typedef double NV;			/* Older perls lack the NV type */
 #define SX_UTF8STR	C(23)	/* UTF-8 string forthcoming (small) */
 #define SX_LUTF8STR	C(24)	/* UTF-8 string forthcoming (large) */
 #define SX_FLAG_HASH	C(25)	/* Hash with flags forthcoming (size, flags, key/flags/value triplet list) */
-#define SX_ERROR	C(26)	/* Error */
+#define SX_CODE         C(26)   /* Code references as perl source code */
+#define SX_ERROR	C(27)	/* Error */
 
 /*
  * Those are only used to retrieve "old" pre-0.6 binary images.
@@ -289,6 +290,8 @@ typedef struct stcxt {
 	int netorder;		/* true if network order used */
 	int s_tainted;		/* true if input source is tainted, at retrieve time */
 	int forgive_me;		/* whether to be forgiving... */
+	int deparse;        /* whether to deparse code refs */
+	SV *eval;           /* whether to eval source code */
 	int canonical;		/* whether to store hashes sorted by key */
 #ifndef HAS_RESTRICTED_HASHES
         int derestrict;         /* whether to downgrade restrcted hashes */
@@ -628,7 +631,8 @@ static stcxt_t *Context_ptr = NULL;
 #define svis_HASH		3
 #define svis_TIED		4
 #define svis_TIED_ITEM	5
-#define svis_OTHER		6
+#define svis_CODE		6
+#define svis_OTHER		7
 
 /*
  * Flags for SX_HOOK.
@@ -756,7 +760,7 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0};
 #endif
 
 #define STORABLE_BIN_MAJOR	2		/* Binary major "version" */
-#define STORABLE_BIN_MINOR	5		/* Binary minor "version" */
+#define STORABLE_BIN_MINOR	6		/* Binary minor "version" */
 
 /* If we aren't 5.7.3 or later, we won't be writing out files that use the
  * new flagged hash introdued in 2.5, so put 2.4 in the binary header to
@@ -770,7 +774,7 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0};
  * As of perl 5.7.3, utf8 hash key is introduced.
  * So this must change -- dankogai
 */
-#define STORABLE_BIN_WRITE_MINOR	5
+#define STORABLE_BIN_WRITE_MINOR	6
 #endif /* (PATCHLEVEL <= 6) */
 
 /*
@@ -964,6 +968,7 @@ static int store_array(stcxt_t *cxt, AV *av);
 static int store_hash(stcxt_t *cxt, HV *hv);
 static int store_tied(stcxt_t *cxt, SV *sv);
 static int store_tied_item(stcxt_t *cxt, SV *sv);
+static int store_code(stcxt_t *cxt, CV *cv);
 static int store_other(stcxt_t *cxt, SV *sv);
 static int store_blessed(stcxt_t *cxt, SV *sv, int type, HV *pkg);
 
@@ -974,6 +979,7 @@ static int (*sv_store[])(stcxt_t *cxt, SV *sv) = {
 	(int (*)(stcxt_t *cxt, SV *sv)) store_hash,		/* svis_HASH */
 	store_tied,										/* svis_TIED */
 	store_tied_item,								/* svis_TIED_ITEM */
+	(int (*)(stcxt_t *cxt, SV *sv)) store_code,		/* svis_CODE */
 	store_other,									/* svis_OTHER */
 };
 
@@ -1027,6 +1033,7 @@ static SV *(*sv_old_retrieve[])(stcxt_t *cxt, char *cname) = {
 	retrieve_other,			/* SX_UTF8STR not supported */
 	retrieve_other,			/* SX_LUTF8STR not supported */
 	retrieve_other,			/* SX_FLAG_HASH not supported */
+	retrieve_other,			/* SX_CODE not supported */
 	retrieve_other,			/* SX_ERROR */
 };
 
@@ -1042,6 +1049,7 @@ static SV *retrieve_overloaded(stcxt_t *cxt, char *cname);
 static SV *retrieve_tied_key(stcxt_t *cxt, char *cname);
 static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname);
 static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname);
+static SV *retrieve_code(stcxt_t *cxt, char *cname);
 
 static SV *(*sv_retrieve[])(stcxt_t *cxt, char *cname) = {
 	0,			/* SX_OBJECT -- entry unused dynamically */
@@ -1070,6 +1078,7 @@ static SV *(*sv_retrieve[])(stcxt_t *cxt, char *cname) = {
 	retrieve_utf8str,		/* SX_UTF8STR  */
 	retrieve_lutf8str,		/* SX_LUTF8STR */
 	retrieve_flag_hash,		/* SX_HASH */
+	retrieve_code,			/* SX_CODE */
 	retrieve_other,			/* SX_ERROR */
 };
 
@@ -1122,6 +1131,8 @@ static void init_store_context(
 
 	cxt->netorder = network_order;
 	cxt->forgive_me = -1;			/* Fetched from perl if needed */
+	cxt->deparse = -1;				/* Idem */
+	cxt->eval = NULL;				/* Idem */
 	cxt->canonical = -1;			/* Idem */
 	cxt->tagnum = -1;				/* Reset tag numbers */
 	cxt->classnum = -1;				/* Reset class numbers */
@@ -1268,6 +1279,11 @@ static void clean_store_context(stcxt_t *cxt)
 	}
 
 	cxt->forgive_me = -1;			/* Fetched from perl if needed */
+	cxt->deparse = -1;				/* Idem */
+	if (cxt->eval) {
+	    SvREFCNT_dec(cxt->eval);
+	}
+	cxt->eval = NULL;				/* Idem */
 	cxt->canonical = -1;			/* Idem */
 
 	reset_context(cxt);
@@ -2340,6 +2356,109 @@ out:
 }
 
 /*
+ * store_code
+ *
+ * Store a code reference.
+ *
+ * Layout is SX_CODE <length> followed by a scalar containing the perl
+ * source code of the code reference.
+ */
+static int store_code(stcxt_t *cxt, CV *cv)
+{
+#if PERL_VERSION < 6
+    /*
+	 * retrieve_code does not work with perl 5.005 or less
+	 */
+	return store_other(cxt, (SV*)cv);
+#else
+	dSP;
+	I32 len;
+	int ret, count, reallen;
+	SV *text, *bdeparse;
+
+	TRACEME(("store_code (0x%"UVxf")", PTR2UV(cv)));
+
+	if (
+		cxt->deparse == 0 ||
+		(cxt->deparse < 0 && !(cxt->deparse =
+			SvTRUE(perl_get_sv("Storable::Deparse", TRUE)) ? 1 : 0))
+	) {
+		return store_other(cxt, (SV*)cv);
+	}
+
+	/*
+	 * Require B::Deparse. At least B::Deparse 0.61 is needed for
+	 * blessed code references.
+	 */
+	/* XXX sv_2mortal seems to be evil here. why? */
+	load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("B::Deparse",10), newSVnv(0.61));
+
+	ENTER;
+	SAVETMPS;
+
+	/*
+	 * create the B::Deparse object
+	 */
+
+	PUSHMARK(sp);
+	XPUSHs(sv_2mortal(newSVpvn("B::Deparse",10)));
+	PUTBACK;
+	count = call_method("new", G_SCALAR);
+	SPAGAIN;
+	if (count != 1)
+		CROAK(("Unexpected return value from B::Deparse::new\n"));
+	bdeparse = POPs;
+
+	/*
+	 * call the coderef2text method
+	 */
+
+	PUSHMARK(sp);
+	XPUSHs(bdeparse); /* XXX is this already mortal? */
+	XPUSHs(sv_2mortal(newRV_inc((SV*)cv)));
+	PUTBACK;
+	count = call_method("coderef2text", G_SCALAR);
+	SPAGAIN;
+	if (count != 1)
+		CROAK(("Unexpected return value from B::Deparse::coderef2text\n"));
+
+	text = POPs;
+	len = SvLEN(text);
+	reallen = strlen(SvPV(text,PL_na));
+
+	/*
+	 * Empty code references or XS functions are deparsed as
+	 * "(prototype) ;" or ";".
+	 */
+
+	if (len == 0 || *(SvPV(text,PL_na)+reallen-1) == ';') {
+	    CROAK(("The result of B::Deparse::coderef2text was empty - maybe you're trying to serialize an XS function?\n"));
+	}
+
+	/* 
+	 * Signal code by emitting SX_CODE.
+	 */
+
+	PUTMARK(SX_CODE);
+	TRACEME(("size = %d", len));
+	TRACEME(("code = %s", SvPV(text,PL_na)));
+
+	/*
+	 * Now store the source code.
+	 */
+
+	STORE_SCALAR(SvPV(text,PL_na), len);
+
+	FREETMPS;
+	LEAVE;
+
+	TRACEME(("ok (code)"));
+
+	return 0;
+#endif
+}
+
+/*
  * store_tied
  *
  * When storing a tied object (be it a tied scalar, array or hash), we lay out
@@ -3073,6 +3192,8 @@ static int sv_type(SV *sv)
 		if (SvRMAGICAL(sv) && (mg_find(sv, 'P')))
 			return svis_TIED;
 		return svis_HASH;
+	case SVt_PVCV:
+		return svis_CODE;
 	default:
 		break;
 	}
@@ -3105,7 +3226,7 @@ static int store(stcxt_t *cxt, SV *sv)
 	 *
 	 * NOTA BENE, for 64-bit machines: the "*svh" below does not yield a
 	 * real pointer, rather a tag number (watch the insertion code below).
-	 * That means it pobably safe to assume it is well under the 32-bit limit,
+	 * That means it probably safe to assume it is well under the 32-bit limit,
 	 * and makes the truncation safe.
 	 *		-- RAM, 14/09/1999
 	 */
@@ -4803,6 +4924,107 @@ static SV *retrieve_flag_hash(stcxt_t *cxt, char *cname)
 }
 
 /*
+ * retrieve_code
+ *
+ * Return a code reference.
+ */
+static SV *retrieve_code(stcxt_t *cxt, char *cname)
+{
+#if PERL_VERSION < 6
+    CROAK(("retrieve_code does not work with perl 5.005 or less\n"));
+#else
+	dSP;
+	int type, count;
+	SV *cv;
+	SV *sv, *text, *sub, *errsv;
+
+	TRACEME(("retrieve_code (#%d)", cxt->tagnum));
+
+	/*
+	 * Retrieve the source of the code reference
+	 * as a small or large scalar
+	 */
+
+	GETMARK(type);
+	switch (type) {
+	case SX_SCALAR:
+		text = retrieve_scalar(cxt, cname);
+		break;
+	case SX_LSCALAR:
+		text = retrieve_lscalar(cxt, cname);
+		break;
+	default:
+		CROAK(("Unexpected type %d in retrieve_code\n", type));
+	}
+
+	/*
+	 * prepend "sub " to the source
+	 */
+
+	sub = newSVpvn("sub ", 4);
+	sv_catpv(sub, SvPV(text, PL_na)); //XXX no sv_catsv!
+	SvREFCNT_dec(text);
+
+	/*
+	 * evaluate the source to a code reference and use the CV value
+	 */
+
+	if (cxt->eval == NULL) {
+		cxt->eval = perl_get_sv("Storable::Eval", TRUE);
+		SvREFCNT_inc(cxt->eval);
+	}
+	if (!SvTRUE(cxt->eval)) {
+		if (
+			cxt->forgive_me == 0 ||
+			(cxt->forgive_me < 0 && !(cxt->forgive_me =
+				SvTRUE(perl_get_sv("Storable::forgive_me", TRUE)) ? 1 : 0))
+		) {
+			CROAK(("Can't eval, please set $Storable::Eval to a true value"));
+		} else {
+			sv = newSVsv(sub);
+			return sv;
+		}
+	}
+
+	ENTER;
+	SAVETMPS;
+
+	if (SvROK(cxt->eval) && SvTYPE(SvRV(cxt->eval)) == SVt_PVCV) {
+		SV* errsv = get_sv("@", TRUE);
+		sv_setpv(errsv, "");					/* clear $@ */
+		PUSHMARK(sp);
+		XPUSHs(sv_2mortal(newSVsv(sub)));
+		PUTBACK;
+		count = call_sv(cxt->eval, G_SCALAR);
+		SPAGAIN;
+		if (count != 1)
+			CROAK(("Unexpected return value from $Storable::Eval callback\n"));
+		cv = POPs;
+		if (SvTRUE(errsv)) {
+			CROAK(("code %s caused an error: %s", SvPV(sub, PL_na), SvPV(errsv, PL_na)));
+		}
+		PUTBACK;
+	} else {
+		cv = eval_pv(SvPV(sub, PL_na), TRUE);
+	}
+	if (cv && SvROK(cv) && SvTYPE(SvRV(cv)) == SVt_PVCV) {
+	    sv = SvRV(cv);
+	} else {
+	    CROAK(("code %s did not evaluate to a subroutine reference\n", SvPV(sub, PL_na)));
+	}
+
+	SvREFCNT_inc(sv); /* XXX seems to be necessary */
+	SvREFCNT_dec(sub);
+
+	FREETMPS;
+	LEAVE;
+
+	SEEN(sv, cname);
+	return sv;
+#endif
+}
+
+/*
  * old_retrieve_array
  *
  * Retrieve a whole array in pre-0.6 binary format.
diff --git a/ext/Storable/t/code.t b/ext/Storable/t/code.t
new file mode 100644
index 0000000..079a11b
--- /dev/null
+++ b/ext/Storable/t/code.t
@@ -0,0 +1,273 @@
+#!./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.6.0;
+	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 => 47 }
+
+use Storable qw(retrieve store nstore freeze nfreeze thaw dclone);
+use Safe;
+
+#$Storable::DEBUGME = 1;
+
+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__ } }
+
+@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::Safe
+#   $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;
+    $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]->[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/);
+    }
+}
+
+{
+    {
+	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]));
+    }
+}
+
diff --git a/ext/Storable/t/forgive.t b/ext/Storable/t/forgive.t
index 206f2ad..3110ac4 100644
--- a/ext/Storable/t/forgive.t
+++ b/ext/Storable/t/forgive.t
@@ -34,7 +34,8 @@ use Storable qw(store retrieve);
 print "1..8\n";
 
 my $test = 1;
-my $bad = ['foo', sub { 1 },  'bar'];
+*GLOB = *GLOB; # peacify -w
+my $bad = ['foo', \*GLOB,  'bar'];
 my $result;
 
 eval {$result = store ($bad , 'store')};
diff --git a/ext/Storable/t/malice.t b/ext/Storable/t/malice.t
index 405fd3d..b4951da 100644
--- a/ext/Storable/t/malice.t
+++ b/ext/Storable/t/malice.t
@@ -35,8 +35,8 @@ $file_magic_str = 'pst0';
 $other_magic = 7 + length $byteorder;
 $network_magic = 2;
 $major = 2;
-$minor = 5;
-$minor_write = $] > 5.007 ? 5 : 4;
+$minor = 6;
+$minor_write = $] > 5.007 ? 6 : 4;
 
 use Test::More;
 
@@ -241,7 +241,7 @@ sub test_things {
   # local $Storable::DEBUGME = 1;
   # This is the delayed croak
   test_corrupt ($copy, $sub,
-                "/^Storable binary image v$header->{major}.$minor4 contains data of type 255. This Storable is v$header->{major}.$minor and can only handle data types up to 25/",
+                "/^Storable binary image v$header->{major}.$minor4 contains data of type 255. This Storable is v$header->{major}.$minor and can only handle data types up to 26/",
                 "bogus tag, minor plus 4");
   # And check again that this croak is not delayed:
   {