Change 17741 by [EMAIL PROTECTED] on 2002/08/20 14:20:16
Subject: Re: [PATCH] Storable and CODE references
From: Slaven Rezic <[EMAIL PROTECTED]>
Date: 17 Aug 2002 21:58:03 +0200
Message-id: <[EMAIL PROTECTED]>
Affected files ...
.... //depot/perl/MANIFEST#929 edit
.... //depot/perl/ext/Storable/Storable.xs#60 edit
.... //depot/perl/ext/Storable/t/code.t#1 add
.... //depot/perl/ext/Storable/t/forgive.t#6 edit
.... //depot/perl/ext/Storable/t/malice.t#16 edit
Differences ...
==== //depot/perl/MANIFEST#929 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#928~17732~ Sat Aug 17 19:11:49 2002
+++ perl/MANIFEST Tue Aug 20 07:20:16 2002
@@ -611,6 +611,7 @@
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
==== //depot/perl/ext/Storable/Storable.xs#60 (text) ====
Index: perl/ext/Storable/Storable.xs
--- perl/ext/Storable/Storable.xs#59~17494~ Thu Jul 11 14:00:31 2002
+++ perl/ext/Storable/Storable.xs Tue Aug 20 07:20:16 2002
@@ -149,7 +149,8 @@
#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 @@
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 @@
#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 @@
#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 @@
* 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_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 @@
(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 @@
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_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 @@
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 @@
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 @@
}
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 @@
}
/*
+ * 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 @@
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 @@
*
* 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
*/
@@ -4800,6 +4921,107 @@
TRACEME(("ok (retrieve_hash at 0x%"UVxf")", PTR2UV(hv)));
return (SV *) hv;
+}
+
+/*
+ * 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
}
/*
==== //depot/perl/ext/Storable/t/code.t#1 (text) ====
Index: perl/ext/Storable/t/code.t
--- /dev/null Tue May 5 13:32:27 1998
+++ perl/ext/Storable/t/code.t Tue Aug 20 07:20:16 2002
@@ -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]));
+ }
+}
+
==== //depot/perl/ext/Storable/t/forgive.t#6 (text) ====
Index: perl/ext/Storable/t/forgive.t
--- perl/ext/Storable/t/forgive.t#5~16953~ Fri May 31 20:20:52 2002
+++ perl/ext/Storable/t/forgive.t Tue Aug 20 07:20:16 2002
@@ -34,7 +34,8 @@
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')};
==== //depot/perl/ext/Storable/t/malice.t#16 (text) ====
Index: perl/ext/Storable/t/malice.t
--- perl/ext/Storable/t/malice.t#15~17175~ Mon Jun 10 16:24:42 2002
+++ perl/ext/Storable/t/malice.t Tue Aug 20 07:20:16 2002
@@ -35,8 +35,8 @@
$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 @@
# 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:
{
End of Patch.
