[PATCH] Storable and CODE references
Nicholas Clark
> Slaven Rezic wrote:
> >
> > Below is a patch to enable (de)serializing of CODE references. All old
> > Storable tests still work, and so do all CODE variations I can think
> > of.
> >
> > Some points are still open:
> > - Malicious storable files may do bad things because I had to
> > introduce an "eval" to the XS code. Should the tainting mode handle
> > this? Or should there be an global Storable variable to enable the
> > new feature?
>
> Storable ought to be safe. Couldn't use turn the coderef into bytecode
> for storing it, and use some kind of byteloader to restore it? That is,
> store the optree? Yes, I know that the results of this take up more
> space than deparsing it, and it's slower to load bytecode than to parser
> perl source, but it's much safer.
>
> Merely *thawing* a piece of serialized data shouldn't cause potentially
> malicious code to run.
It's already possible to embed malice in a regular Storable file using
just hashes and blessed objects.
I remember a talk given by Jonathan Stowe at YAPC in Amsterdam where he
described how you could modify the binary version of the storable file,
adding the same hash key twice. The first version of the value gets created,
but destroyed when the second key/value pair is found and overwrites it.
So, what big deal?
Well, say you're uploading to a CGI written with CGI.pm, then you could
arrange for the first value to be blessed into package CGITempFile;
Then when the second value is inserted by the Storable file reading XS
code into the hash, the first is destroyed, calling its destructor:
sub DESTROY {
my($self) = @_;
unlink $$self; # get rid of the file
}
which means in this case that a carefully malicious Storable file can delete
arbitrary files that the CGI script could. And there's no way that the caller
of Storable can detect this happening, let alone prevent it, as it all happens
as a side effect of perl API calls used by the Storable file reader.
I don't know what other "interesting" behaviour one can achieve via
destructors available on modules you could expect to find, and I can't
remember Jonathan's other examples, but clearly you don't need CODE
references to be able to be nasty.
Nicholas Clark
--
Even better than the real thing: http://nms-cgi.sourceforge.net/
Jonathan Stowe
>
> Well, say you're uploading to a CGI written with CGI.pm, then you could
> arrange for the first value to be blessed into package CGITempFile;
> Then when the second value is inserted by the Storable file reading XS
> code into the hash, the first is destroyed, calling its destructor:
>
> sub DESTROY {
> my($self) = @_;
> unlink $$self; # get rid of the file
> }
>
> which means in this case that a carefully malicious Storable file can delete
> arbitrary files that the CGI script could. And there's no way that the caller
> of Storable can detect this happening, let alone prevent it, as it all happens
> as a side effect of perl API calls used by the Storable file reader.
>
Infact you don't even need to be explicitly using the file upload features
- simply having 'use CGI' is enough as that is when you get the
CGITempFile destructor defined. This is part of the reason why this thing
is so insidious as you may not even know that it has been defined.
> I don't know what other "interesting" behaviour one can achieve via
> destructors available on modules you could expect to find, and I can't
> remember Jonathan's other examples, but clearly you don't need CODE
> references to be able to be nasty.
>
The point is that if you are accepting untrusted data to be fed to
Storable you need to know the exact runtime behaviour of every
package that is brought into your program to be confident that your life
isn't going to be ruined by this kind of thing. The DESTROY trick is the
only obvious example that springs to mind but anything that happens
automagically when an object is created or destroyed is capable of being
exploited. I have copied Nick Cleaton on this as it was he who pointed
this behaviour out to me in the first place and he may well have more
examples.
You can control Storable's blessing behaviour but as I recall it this has
to be done on a per package basis, and as suggested above there is no
reason why your average programmer would know that they get a CGITempFile
package when they 'use CGI'. I would like to see something similar
to the feature that I suggested to Gisle for Data::DumpXML wherein you can
define a subroutine yourself that does the blessing.
As I see it Storable is not safe to be used unless you have absolute and
unequivocal trust in the data that you are about to unthaw, so I'm with
Nick: adding CODE reference support doesn't really make it any less secure
just insecure in a different way :)
/J\
--
Jonathan Stowe |
<http://www.gellyfish.com> | This space for rent
|
John Peacock
> I would suggest that in addition to this, perl provide an unbless()
> function ... well, either perl itself or some utility module.
>
> I honestly don't see why perl never provided this in the first place.
>
Could you comment on what you expect to happen in these two cases?
$stuff = "1";
bless \$stuff, "class";
unbless $stuff;
and
$stuff = "1";
bless \$stuff, "class";
bless \$stuff, "anotherclass";
unbless $stuff;
I can see returning $stuff to be a scalar PV containing "1" in both cases, but
not being able to recover that it was ever a member of "class" in the second
case. Does this do what you would expect unbless() to do?
John
h...@crypt.org
:Orton, Yves wrote:
:> But, in this case 'object' means 'reference' and not just 'blessed
:> reference'.
:
:But the code we are talking about is where the programmer is _lying_ and
:Perl doesn't know any better (or to be more charitable, Perl cannot return
:something more correct automatically). I think that is a carbon-based
:error, rather than a bug that has to be fixed.
I disagree. An object in perl has two attributes significant in this
context: the class it is in, and the underlying data type. Perl fails
to provide useful mechanisms to distinguish between the two, but they
are nevertheless distinct: there is nothing intrinsically evil about
blessing a hashref into a class called 'ARRAY' except in so far as
perl's deficiencies make that a confusing thing to do.
:p.s. if I happen to stumble across the bless() code, I'll try and produce a
:patch which forbids the reserved classes mentioned...
I would not recommend doing that.
As mentioned elsewhere in this thread, Scalar::Util does provide
means to get at this information:
crypt% perl -MScalar::Util=blessed,reftype -wle '$a=bless{},"ARRAY";print blessed($a); print reftype($a)'
ARRAY
HASH
crypt%
If there is other important information that is difficult to get
at (such as the underlying nature of a qr{}), let's provide the
mechanisms necessary to unravel the confusion rather than trying
to disallow the activities that expose it.
Hugo
John Peacock
> If there is other important information that is difficult to get
> at (such as the underlying nature of a qr{}), let's provide the
> mechanisms necessary to unravel the confusion rather than trying
> to disallow the activities that expose it.
I'll take this as freeing me from having to produce a patch which the pumpking
will inevitably reject. ;~)
John
Slaven Rezic
> Slaven Rezic wrote:
> >
> > Below is a patch to enable (de)serializing of CODE references. All old
> > Storable tests still work, and so do all CODE variations I can think
> > of.
> >
> > Some points are still open:
> >
> > - I would like an expert to go through the patch for a couple of
> > XXX-marked sections. Especially there may be some memory-related
> > issues.
> >
> > - Malicious storable files may do bad things because I had to
> > introduce an "eval" to the XS code. Should the tainting mode handle
> > this? Or should there be an global Storable variable to enable the
> > new feature?
>
> Storable ought to be safe. Couldn't use turn the coderef into bytecode
> for storing it, and use some kind of byteloader to restore it? That is,
> store the optree? Yes, I know that the results of this take up more
> space than deparsing it, and it's slower to load bytecode than to parser
> perl source, but it's much safer.
Is there a way to eval (?) a piece of code through one of the B::*
modules? ByteLoader.pm seems to act only as a filter.
> Merely *thawing* a piece of serialized data shouldn't cause potentially
> malicious code to run.
>
> Anyway, as to your question... *yes*, absolutely -- if the only way of
> (De)serializing coderefs is deparse/eval, you should have a global
> Storable variable to enable the feature. And the feature should be
> *off* by default.
>
> And, in addition, it would be better for you to not use the eval
> function itself, but rather create an instance of Safe.pm, and use
> the reval method. Have a global Storable variable which contains the
> set of ops that the Safe object gets created with. That way, the user
> can trust the serialized data as much or as little as he wants.
>
Well, this means three new global configuration variables for
Storable:
$Deparse --- Use B::Deparse for getting the source code out of a
code reference. If $Deparse is not set to a true value
and Storable hits on a code ref, then the value of
$forgive_me should control further processing.
$Eval --- Turn evaluation of source code in a Storable file on.
If $Eval is not set to a true value and there is
source code in the Storable file, then the value of
$forgive_me should control further processing.
$Safe --- An optional Safe compartment. Source code is
eval'ed using $Safe->reval if $Safe is defined, otherwise
just eval is used.
Maybe $Deparse and $Eval could be put into one config variable, but
then it's nice to share at least the name of one config variable from
Data::Dumper.
Regards,
Slaven
--
Slaven Rezic - slaven...@berlin.de
tksm - Perl/Tk program for searching and replacing in multiple files
http://ptktools.sourceforge.net/#tksm
Slaven Rezic
>
> > Slaven Rezic said on 09 August 2002 21:24
> > "Orton, Yves" <yves....@mciworldcom.de> writes:
> > Well you mentioned it already: there is Scalar::Util::reftype, and
> > it's now in the perl core.
>
> Oh, i hadnt noticed that. Cool. BTW, did the bug in Scalar::Util::readonly()
> get fixed yet? (the one where it says that \\'foo' is not readonly?) I dont
> have a 5.8 handy anymore.
I think it is:
$ perl -MScalar::Util=readonly -e 'warn readonly \\"foo"'
8388608 at -e line 1.
$ perl -MScalar::Util=readonly -e 'warn readonly \\$a'
0 at -e line 1.
>
> > I may take a look on it. Remember, it's implemented in XS, not in
> > perl, so it's slightly more difficult. Maybe it would be better to put
> > a patched B::Deparse on CPAN or in perl 5.6.2.
>
> As I said I sent a patch to the author and he applied it. I dont know about
> the CPAN status as I havent looked.
>
Well, there's no CPAN version of B::Deparse. Maybe it's to dependent
on the internals of perl to have a life outside a perl distribution.
Regards,
Slaven
--
Slaven Rezic - slaven...@berlin.de
BBBike - route planner for cyclists in Berlin
WWW version: http://www.bbbike.de
Perl/Tk version: http://bbbike.sourceforge.net
Tels
Moin,
Slaven worte:
The first two paragraphs don't make sense to me and look like a C&P error
to me.
* What is $forgive_me and where it is explained?
* And In which order are the checked? First Deparse or Eval?
Or I need a Kaffee... :)
Best wishes,
Tels
- --
perl -MDev::Bollocks -e'print Dev::Bollocks->rand(),"\n"'
completely strategize plug-and-play meta-services
http://bloodgate.com/perl My current Perl projects
PGP key available on http://bloodgate.com/tels.asc or via email
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.0.6 (GNU/Linux)
Comment: When cryptography is outlawed, bayl bhgynjf jvyy unir cevinpl.
iQEVAwUBPVWEHHcLPEOTuEwVAQFqNwf/Vgd4WONkDaPEDrcU83jy8dmtSubm728M
nQtNEYIKgcxUc3igXcE0Ic8GmXmZs20xQdo4WcUafT2LMplonxRnARBq0Amt+AHL
Mev3FVVYv/qYuOO8NAK8RWhTeyQ5UqnxyxHXAqSFtXJFnbWnllLAq1RqLPrmpfBo
o+htXDriohrp8FmPjebY4iCzr1BorGG6NPwxbD7cFi2/SEGTo29yFdHT/sBoaUX2
cmIlUG63HAPMX9s+cStpBI4SjXjyy3ONQh7PJRa0ZkPQ8prsCdZMRoxWGhqYv6QL
q+uUcALNiKhUTDfSzBkgZC0thIf+h1QHoEyj2FWm5GwpxY2JnuLTzw==
=TTSa
-----END PGP SIGNATURE-----
Slaven Rezic
$Storable::forgive_me is explained in the BUGS section of the
Storable.pm POD documentation. If $forgive_me is set, then Storable
won't croak on CODE refs, GLOBs etc.
$Deparse will only be used for serializing (because only here
B::Deparse is used), $Eval for deserializing.
Regards,
Slaven
--
Slaven Rezic - slaven...@berlin.de
tktimex - project time manager
http://sourceforge.net/projects/ptktools/
Benjamin Goldberg
>
> Benjamin Goldberg wrote:
> > I would suggest that in addition to this, perl provide an unbless()
> > function ... well, either perl itself or some utility module.
> >
> > I honestly don't see why perl never provided this in the first
> > place.
> >
>
> Could you comment on what you expect to happen in these two cases?
>
> $stuff = "1";
> bless \$stuff, "class";
> unbless $stuff;
>
> and
>
> $stuff = "1";
> bless \$stuff, "class";
> bless \$stuff, "anotherclass";
> unbless $stuff;
>
> I can see returning $stuff to be a scalar PV containing "1" in both
> cases,
Blessing \$stuff never *changed* it from being a scalar PV containing
"1" ... it only changed what ref() and isa() report about it.
> but not being able to recover that it was ever a member of
> "class" in the second case. Does this do what you would expect
> unbless() to do?
First: I would expect unbless to be passed the reference.. eg:
unbless \$stuff;
Second: I wouldn't expect it to return anything at all, except perhaps
the reference itself (just as bless returns the reference itself).
Consider the following function:
sub coretype_and_identityhash {
my $class = ref(my $ref = shift) or return;
my $wasblessed = UNIVERSAL::isa($ref, "UNIVERSAL");
my $coretype = ref( unbless($ref) );
my $as_int = $ref+0;
bless $ref, $class if $wasblessed;
return $coretype, $as_int;
}
--
tr/`4/ /d, print "@{[map --$| ? ucfirst lc : lc, split]},\n" for
pack 'u', pack 'H*', 'ab5cf4021bafd28972030972b00a218eb9720000';
Benjamin Goldberg
Actually, I thought that you *were* planning on having on only one
config variable -- really, there's no need to enable/disable deparsing,
it's eval() that's the real worry.
Also, I think that $Safe shouldn't be a Safe compartment, but a set of
allowed operations, like a string returned by Opcode::opset().
Each time that a piece of code needs to be eval()ed, a new Safe
compartment should be created.
If a user really and truly trusts the source that the stored data is
coming from, he can do:
$Storable::Eval = 1;
$Storable::SafeOpset = Opset::opmask();
John Peacock
> Blessing \$stuff never *changed* it from being a scalar PV containing
> "1" ... it only changed what ref() and isa() report about it.
Actually it does change what $stuff is:
Before blessing:
SV = PV(0x804b7ec) at 0x8056f2c
REFCNT = 1
FLAGS = (POK,pPOK)
PV = 0x8050d70 "1"\0
CUR = 1
LEN = 2
After blessing:
SV = PVMG(0x806b1e0) at 0x8056f2c
REFCNT = 1
FLAGS = (OBJECT,POK,pPOK)
IV = 0
NV = 0
PV = 0x8050d70 "1"\0
CUR = 1
LEN = 2
STASH = 0x8056efc "class"
And I was not being terribly realistic with my example; most modules I've see
don't bless an anonymous reference to a scalar. I'm not even sure if that is
ever a point to doing so either. That may be the thing that is mystifying me
the most about this discussion.
>
> First: I would expect unbless to be passed the reference.. eg:
> unbless \$stuff;
Fair enough; since bless() only works on references, it would only make sense
that unbless() did the same.
>
> Second: I wouldn't expect it to return anything at all, except perhaps
> the reference itself (just as bless returns the reference itself).
I was trying to elicit from you what you thought it should do to the contents,
not what the function itself would return.
>
> Consider the following function:
> sub coretype_and_identityhash {
> my $class = ref(my $ref = shift) or return;
> my $wasblessed = UNIVERSAL::isa($ref, "UNIVERSAL");
> my $coretype = ref( unbless($ref) );
> my $as_int = $ref+0;
> bless $ref, $class if $wasblessed;
> return $coretype, $as_int;
> }
>
What would you expect $coretype to contain in my trivial example above? Should
it be PV or SCALAR? What should coretype return for this example (stolen
shamelessly from Camel 2nd edition):
$rec = {
TEXT => $string,
SEQUENCE => [ @old_values ],
LOOKUP => { %some_table },
THATCODE => \&somefunc,
THISCODE => sub { $_[0] ** $_[1] },
HANDLE => \*STDOUT,
};
bless $rec, $class;
All that bless() does in this case is add a STASH entry in the enclosing PVHV
and sets the OBJ flag. The unbless() call could easily (?) undo that, but there
is no useful information that $coretype or $as_int could return.
John
--
John Peacock
Director of Information Research and Technology
Rowman & Littlefield Publishing Group
4720 Boston Way
Lanham, MD 20706
301-459-3366 x.5010
fax 301-429-5747
Benjamin Goldberg
>
> Benjamin Goldberg wrote:
> > Blessing \$stuff never *changed* it from being a scalar PV
> > containing "1" ... it only changed what ref() and isa() report
> > about it.
>
> Actually it does change what $stuff is:
>
> Before blessing:
>
> SV = PV(0x804b7ec) at 0x8056f2c
> REFCNT = 1
> FLAGS = (POK,pPOK)
> PV = 0x8050d70 "1"\0
> CUR = 1
> LEN = 2
>
> After blessing:
>
> SV = PVMG(0x806b1e0) at 0x8056f2c
> REFCNT = 1
> FLAGS = (OBJECT,POK,pPOK)
> IV = 0
> NV = 0
> PV = 0x8050d70 "1"\0
> CUR = 1
> LEN = 2
> STASH = 0x8056efc "class"
Huh... I hadn't realized that this happened.
> And I was not being terribly realistic with my example; most modules
> I've see don't bless an anonymous reference to a scalar. I'm not even
> sure if that is ever a point to doing so either. That may be the
> thing that is mystifying me the most about this discussion.
>
> >
> > First: I would expect unbless to be passed the reference.. eg:
> > unbless \$stuff;
>
> Fair enough; since bless() only works on references, it would only
> make sense that unbless() did the same.
>
> > Second: I wouldn't expect it to return anything at all, except
> > perhaps the reference itself (just as bless returns the reference
> > itself).
>
> I was trying to elicit from you what you thought it should do to the
> contents, not what the function itself would return.
Ok, I see.
> > Consider the following function:
> > sub coretype_and_identityhash {
> > my $class = ref(my $ref = shift) or return;
> > my $wasblessed = UNIVERSAL::isa($ref, "UNIVERSAL");
> > my $coretype = ref( unbless($ref) );
> > my $as_int = $ref+0;
> > bless $ref, $class if $wasblessed;
> > return $coretype, $as_int;
> > }
> >
>
> What would you expect $coretype to contain in my trivial example
> above? Should it be PV or SCALAR?
SCALAR, of course. After all, ref() never returns "PV".
> What should coretype return for this example (stolen
> shamelessly from Camel 2nd edition):
>
> $rec = {
> TEXT => $string,
> SEQUENCE => [ @old_values ],
> LOOKUP => { %some_table },
> THATCODE => \&somefunc,
> THISCODE => sub { $_[0] ** $_[1] },
> HANDLE => \*STDOUT,
> };
>
> bless $rec, $class;
>
> All that bless() does in this case is add a STASH entry in the
> enclosing PVHV and sets the OBJ flag. The unbless() call could easily
> (?) undo that, but there is no useful information that $coretype or
> $as_int could return.
$coretype would be "HASH", and $as_int would be the same type of number
as you would get from doing print \$foo; The point of the $as_int is if
you want to get a unique number corresponding to the reference, and
don't want it to be messed up by overloaded '+0' or '""' ops.
John Peacock
>>What would you expect $coretype to contain in my trivial example
>>above? Should it be PV or SCALAR?
>
>
> SCALAR, of course. After all, ref() never returns "PV".
So all you expect is to know REF, SCALAR, ARRAY, HASH, CODE, or GLOB, and
nothing deeper than that. That seems doable, though I don't think that we need
to create an unbless() to do it, unless that has some other purpose. See below.
>
> $coretype would be "HASH", and $as_int would be the same type of number
> as you would get from doing print \$foo; The point of the $as_int is if
> you want to get a unique number corresponding to the reference, and
> don't want it to be messed up by overloaded '+0' or '""' ops.
>
Here you go then:
sub class_coretype_and_identityhash {
return split /[=()]/, sprintf("%s",shift);
}
@array = (1,2,3,4);
bless \@array, "myclass";
print join "\t", class_coretype_and_identityhash(\@array);
__END__
myclass ARRAY 0x8056fc8
HTH
John
p.s. I'm always amazed at how much smarter Perl is than I am
Graham Barr
> Orton, Yves wrote:
> [snip]
> > For instance forbidding objects to be blessed into the classes
> > qw(SCALAR GLOB ARRAY HASH IO CODE) would prevent this type of stuff.
> > Of course i suppose this an example of "Perl provides the rope,
> > hopefully you provide the brains"
>
> I would suggest that in addition to this, perl provide an unbless()
> function ... well, either perl itself or some utility module.
>
> I honestly don't see why perl never provided this in the first place.
Looking in the list archives shows this has been discussed amny times
before. You can find Larrys response at
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/9609/msg00596.html
Graham.
John Peacock
> Here you go then:
>
> sub class_coretype_and_identityhash {
> return split /[=()]/, sprintf("%s",shift);
> }
>
As Benjamin helpfully pointed out in a private e-mail, this is too simplistic
for classes that overload the stringify operator. But, in my defense, I have to
say that clearly the code exists to output the required information; there is
just a problem trying to gain access to it sometimes.
What is really needed is a ref() which ignores the STASH contents temporarily,
but doesn't really unbless the object (for the reasons given in Larry's comment
that Graham cited). How about if ref() is called in array context, it returns
the three element array CLASS, TYPE, ADDRESS, much like my simple code above
will do for non-overloaded classes?
John
Nick Ing-Simmons
>
>$rec = {
> TEXT => $string,
> SEQUENCE => [ @old_values ],
> LOOKUP => { %some_table },
> THATCODE => \&somefunc,
> THISCODE => sub { $_[0] ** $_[1] },
> HANDLE => \*STDOUT,
>};
>
>bless $rec, $class;
>
>All that bless() does in this case is add a STASH entry in the enclosing PVHV
>and sets the OBJ flag. The unbless() call could easily (?) undo that, but there
>is no useful information that $coretype or $as_int could return.
$coretype would be 'HASH' (and $as_int the address of the HV?) - just as
if it had never been blessed in the first place.
>
>John
--
Nick Ing-Simmons
http://www.ni-s.u-net.com/
Yves Orton
> Here you go then:
>
> sub class_coretype_and_identityhash {
> return split /[=()]/, sprintf("%s",shift);
> }
Uhm, thats another of those mistakes like saying ref($foo) eq "TYPE". :-)
Unfortunately overload means you cant rely on normal stringification of a
reference to find out what it is....
package Ouch;
use overload qw("" pain);
sub pain {
return "SCALAR=ARRAY(HASH)GLOB=IO(CODE)";
}
package main;
sub class_coretype_and_identityhash {
return split /[=()]/, sprintf("%s",shift);
}
sub nopain {
return split /[=()]/, overload::StrVal(shift);
}
$,="\n";
$\="\n\n";
print class_coretype_and_identityhash(bless {},'Ouch');
print nopain(bless {},'Ouch');
__END__
;-)
Cheers,
Yves
Yves Orton
> If there is other important information that is difficult to get
> at (such as the underlying nature of a qr{}), let's provide the
> mechanisms necessary to unravel the confusion rather than trying
> to disallow the activities that expose it.
Id love a way to do this! And id love even more to put it into Data::Dumper!
Yves
John Peacock
>
> Uhm, thats another of those mistakes like saying ref($foo) eq "TYPE". :-)
> Unfortunately overload means you cant rely on normal stringification of a
> reference to find out what it is....
>
At least Benjamin was nice enough to point that out in a private e-mail. ;~)
I have some idea of how to do it, but the question is more one of how to return
the information. My initial suggestion was to make ref() return the additional
information in array context only.
I haven't had the chance to test it, but it looks like sv_2pv_flags() can
generate the string 'class=TYPE(xDEADBEEF)' rather than the overloaded
stringified representation (by supressing the mg_get). Then, I just need to
learn how to parse that string and create an AV from it...
Yves Orton
> is too simplistic
> for classes that overload the stringify operator. But, in my
Doh, i should have read further before posting my earlier reply...
Apologies.
:-)
> What is really needed is a ref() which ignores the STASH
> contents temporarily, but doesn't really unbless the object (for the
reasons given
> in Larry's comment that Graham cited). How about if ref() is called in
array
> context, it returns the three element array CLASS, TYPE, ADDRESS, much
like my
> simple code above will do for non-overloaded classes?
The only thing is this approach is probably too simplistic to make that much
difference (and as you have demonstrated can easily be written by the end
user). First off, what about globs? Not globrefs, but globs proper?
Without taking a ref to them they are indistinguishable from an unblessed
scalar. Also scalar references are problematic too. There are at least
(that i know of) three usefully different forms of a scalar ref (SCALAR REF
and Regexp) as well as one that is in fact a scalar reference but is
reported differently: CODE. In the end for a module I was working on I
ended up with one function that returned:
$id,$var_type,$reftype,$class_or_name
Where $id was the $id parsed from StrVal.
$var_type was one of "SCALAR HASH ARRAY GLOB CODE"
$reftype was one of "UNDEF SCALAR REF REGEX CODE ARRAY HASH GLOB" or "" if
the object was not a reference.
$class_or_name was in the case of a blessed reference the name of the class
or the name of the glob if it was a glob (not globref).
So for instance putting a normal scalar would return:
undef,'SCALAR',undef,undef
the glob *FOO
undef,'GLOB',undef,'*main::FOO'
a qr//
0xdeadbeef,'SCALAR','REGEX',undef
a globreference blessed into class 'foo'
0xbadfeede,'GLOB','GLOB','foo'
This provided a single interface to be able to provide more or less
everything useful about a given variable. Note it also handled silently
turning the "Regexp" that is reported by ref() for qr//'s into "REGEX" and
treated it as a "type".
(Actually I tell a minor lie, my routine also returned if the item was
readonly)
Cheers guys,
Yves
Ps the following code may give food for thought:
use overload;
my $qr=qr/its a regex!/;
my $ref=\$qr;
my $value="Value";
my $scalar=\$value;
our $dynamic='Dynamic';
my $hash={};
my $array=[];
foreach ($qr, $ref,$scalar, $value, $dynamic, *dynamic,
\*dynamic,$hash,$array) {
print
"'",join("'\t'",ref($_),split(/[=()]/,overload::StrVal($_))),"'\n";
}
John Peacock
> If there is other important information that is difficult to get
> at (such as the underlying nature of a qr{}), let's provide the
> mechanisms necessary to unravel the confusion rather than trying
> to disallow the activities that expose it.
OK, I patched sv_2pv_flags so that the AMAGIC is not retrieved if flags==0 and
indeed, when I call it with a string overloaded object I can see the underlying
class=HASH(0xdeadbeef) instead of the stringified representation. Then I
patched pp_ref to use sv_2pv_flags() exclusively instead of sv_reftype(). If
GIMME == G_SCALAR, I then returned the first word of whatever it was that
sv_2pv_flags returned (which will be the class if present or the datatype if
not). This all works great.
Now the problem is, I can see how to create and fill an AV, but I don't know how
to store it on the stack to return all three values if ref() is called in list
context. :~( Do I do something like this (found in pp_splice)?
MARK = ORIGMARK + 1;
if (GIMME == G_ARRAY) { /* copy return vals to stack */
MEXTEND(MARK, length);
Copy(AvARRAY(ary)+offset, MARK, length, SV*);
if (AvREAL(ary)) {
EXTEND_MORTAL(length);
for (i = length, dst = MARK; i; i--) {
sv_2mortal(*dst); /* free them eventualy */
dst++;
}
}
MARK += length - 1;
}
There doesn't seem to be an example in pp.c that is a simple case (AFAICT); in
the case of splice, there is already an array on the stack. I want the
equivalent of PUSHav(av)...
Nick Ing-Simmons
>
>Now the problem is, I can see how to create and fill an AV,
You don't really want an AV - perl does not return arrays it returns lists.
So you just want SVs for the values, make 'em mortal EXTEND the
stack as required and PUSHs them. The tricky bit is letting
caller know how many values you returned - ops are different from XS
code in this - I suspect all the MARK twiddling is related to that.
It _may_ be as simple as just using MEXTEND() rather than EXTEND().
>but I don't know how
>to store it on the stack to return all three values if ref() is called in list
>context. :~( Do I do something like this (found in pp_splice)?
"like" yes, copy/paste no. Suggest you trawl through other ops
returning lists.
John Peacock
> You don't really want an AV - perl does not return arrays it returns lists.
> So you just want SVs for the values, make 'em mortal EXTEND the
> stack as required and PUSHs them. The tricky bit is letting
> caller know how many values you returned - ops are different from XS
> code in this - I suspect all the MARK twiddling is related to that.
> It _may_ be as simple as just using MEXTEND() rather than EXTEND().
That's what I realized this morning, though the MEXTEND() is a novel concept.
Pity it isn't documented or used by more than pp_repeat and pp_splice, so I can
see what it is all about. Happily, there is some discusion in perlxs.pod about
how to return a list, so I can use the PPCODE generation to create my code for
me. ;~)
Nick Ing-Simmons
>Nick Ing-Simmons wrote:
>> You don't really want an AV - perl does not return arrays it returns lists.
>> So you just want SVs for the values, make 'em mortal EXTEND the
>> stack as required and PUSHs them. The tricky bit is letting
>> caller know how many values you returned - ops are different from XS
>> code in this - I suspect all the MARK twiddling is related to that.
>> It _may_ be as simple as just using MEXTEND() rather than EXTEND().
>
>That's what I realized this morning, though the MEXTEND() is a novel concept.
>Pity it isn't documented or used by more than pp_repeat and pp_splice,
You can look in pp_hot.c, pp_ctl.c, pp_sys.c and pp_sort.c as well
as pp.c you know...
>so I can
>see what it is all about. Happily, there is some discusion in perlxs.pod about
>how to return a list, so I can use the PPCODE generation to create my code for
>me. ;~)
I don't think you can. OPs and XS are different in this area (I think).
>
>John
h...@crypt.org
:> h...@crypt.org wrote on 10 August 2002 00:18
Patches welcome.
Hugo
h...@crypt.org
:Well, this means three new global configuration variables for
:Storable:
:
: $Deparse --- Use B::Deparse for getting the source code out of a
: code reference. If $Deparse is not set to a true value
: and Storable hits on a code ref, then the value of
: $forgive_me should control further processing.
: $Eval --- Turn evaluation of source code in a Storable file on.
: If $Eval is not set to a true value and there is
: source code in the Storable file, then the value of
: $forgive_me should control further processing.
: $Safe --- An optional Safe compartment. Source code is
: eval'ed using $Safe->reval if $Safe is defined, otherwise
: just eval is used.
I'd suggest losing $Safe, and defining $Eval to accept a boolean
or a coderef - if a coderef, it is a callback to use instead of
eval(). That gives the caller the full flexibility to use Safe
if needed, but may also be useful for other things (such as
diagnostics).
Hugo
Slaven Rezic
Sounds reasonable. OK, here's a new patch with $Eval and $Safe. Passes
all Storable tests on FreeBSD and Linux.
diff --new-file --exclude RCS -ur /usr/local/src/bleedperl/ext/Storable/Storable.xs ./Storable.xs
--- /usr/local/src/bleedperl/ext/Storable/Storable.xs Fri Jul 12 00:04:28 2002
+++ ./Storable.xs Sat Aug 17 21:49:53 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
}
/*
diff --new-file --exclude RCS -ur /usr/local/src/bleedperl/ext/Storable/t/code.t ./t/code.t
--- /usr/local/src/bleedperl/ext/Storable/t/code.t Thu Jan 1 01:00:00 1970
+++ ./t/code.t Sat Aug 17 21:51:18 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]));
+ }
+}
+
diff --new-file --exclude RCS -ur /usr/local/src/bleedperl/ext/Storable/t/forgive.t ./t/forgive.t
--- /usr/local/src/bleedperl/ext/Storable/t/forgive.t Sat Jun 1 06:26:44 2002
+++ ./t/forgive.t Sat Aug 17 21:54:50 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')};
diff --new-file --exclude RCS -ur /usr/local/src/bleedperl/ext/Storable/t/malice.t ./t/malice.t
--- /usr/local/src/bleedperl/ext/Storable/t/malice.t Tue Jun 11 02:28:47 2002
+++ ./t/malice.t Fri Aug 9 14:28:27 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:
{
--
Slaven Rezic - slaven...@berlin.de
tksm - Perl/Tk program for searching and replacing in multiple files
http://ptktools.sourceforge.net/#tksm
Brian Ingerson
> h...@crypt.org writes:
>
> > Slaven Rezic <slaven...@berlin.de> wrote:
> > :Well, this means three new global configuration variables for
> > :Storable:
> > :
> > : $Deparse --- Use B::Deparse for getting the source code out of a
> > : code reference. If $Deparse is not set to a true value
> > : and Storable hits on a code ref, then the value of
> > : $forgive_me should control further processing.
> > : $Eval --- Turn evaluation of source code in a Storable file on.
> > : If $Eval is not set to a true value and there is
> > : source code in the Storable file, then the value of
> > : $forgive_me should control further processing.
YAML has done code refs with deparse for quite a while.
YAML uses the config variables:
- $DumpCode - Serialize code refs
- $LoadCode - Deserialize code refs
- $UseCode - Do both
I used generic names so that you could potentially specify your own
formats, like say, base64 encoded op trees. You code set these
variables to a subroutine ref. Deparse is the default. I suppose its a
little naive to think people might actually take the trouble to do it.
I was just trying to be flexible. I'll probably switch my variables
over to these.
> > : $Safe --- An optional Safe compartment. Source code is
> > : eval'ed using $Safe->reval if $Safe is defined, otherwise
> > : just eval is used.
> >
> > I'd suggest losing $Safe, and defining $Eval to accept a boolean
> > or a coderef - if a coderef, it is a callback to use instead of
> > eval(). That gives the caller the full flexibility to use Safe
> > if needed, but may also be useful for other things (such as
> > diagnostics).
Good idea here. I guess my interface is good for that reason as well.
h...@crypt.org
:Sounds reasonable. OK, here's a new patch with $Eval and $Safe. Passes
:all Storable tests on FreeBSD and Linux.
Thanks, applied as #17741.
Hugo