From: Jarkko Hietaniemi Date: Sat, 17 Feb 2001 16:56:58 +0000 (+0000) Subject: Upgrade to Storable 1.0.10, from Raphael Manfredi. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b12202d0e682a0edaf2713362a68d442277d4f6f;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Storable 1.0.10, from Raphael Manfredi. p4raw-id: //depot/perl@8816 --- diff --git a/ext/Storable/ChangeLog b/ext/Storable/ChangeLog index 92789b5..1e33d73 100644 --- a/ext/Storable/ChangeLog +++ b/ext/Storable/ChangeLog @@ -1,3 +1,34 @@ +Sat Feb 17 13:35:00 MET 2001 Raphael Manfredi + +. Description: + + Version 1.0.8, binary format 2.4. + + Fixed incorrect error message. + + Now bless objects ASAP at retrieve time, which is meant to fix + two bugs: + + * Indirect references to overloaded object were not able to + restore overloading if the object was not blessed yet, + which was possible since blessing occurred only after the + recursive retrieval. + + * Storable hooks asking for serialization of blessed ref could + get un-blessed refs at retrieval time, for the very same + reason. + + The fix implemented here was suggested by Nick Ing-Simmons. + + Added support for blessed ref to tied structures. This is the + cause for the binary format change. + + Added EBCDIC version of the compatibility test with 0.6.11, + from Peter Prymmer + + Added tests for the new features, and to make sure the bugs they + are meant to fix are indeed fixed. + Wed Jan 3 10:43:18 MET 2001 Raphael Manfredi . Description: diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm index 06c05d4..85ecd13 100644 --- a/ext/Storable/Storable.pm +++ b/ext/Storable/Storable.pm @@ -1,4 +1,4 @@ -;# $Id: Storable.pm,v 1.0.1.7 2001/01/03 09:39:02 ram Exp $ +;# $Id: Storable.pm,v 1.0.1.8 2001/02/17 12:24:37 ram Exp $ ;# ;# Copyright (c) 1995-2000, Raphael Manfredi ;# @@ -6,6 +6,9 @@ ;# in the README file that comes with the distribution. ;# ;# $Log: Storable.pm,v $ +;# Revision 1.0.1.8 2001/02/17 12:24:37 ram +;# patch8: fixed incorrect error message +;# ;# Revision 1.0.1.7 2001/01/03 09:39:02 ram ;# patch7: added CAN_FLOCK to determine whether we can flock() or not ;# @@ -148,7 +151,7 @@ sub _store { my $self = shift; my ($file, $use_locking) = @_; logcroak "not a reference" unless ref($self); - logcroak "too many arguments" unless @_ == 2; # No @foo in arglist + logcroak "wrong argument number" unless @_ == 2; # No @foo in arglist local *FILE; open(FILE, ">$file") || logcroak "can't create $file: $!"; binmode FILE; # Archaic systems... diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index 9378001..197c428 100644 --- a/ext/Storable/Storable.xs +++ b/ext/Storable/Storable.xs @@ -3,7 +3,7 @@ */ /* - * $Id: Storable.xs,v 1.0.1.6 2001/01/03 09:40:40 ram Exp $ + * $Id: Storable.xs,v 1.0.1.7 2001/02/17 12:25:26 ram Exp $ * * Copyright (c) 1995-2000, Raphael Manfredi * @@ -11,6 +11,10 @@ * in the README file that comes with the distribution. * * $Log: Storable.xs,v $ + * Revision 1.0.1.7 2001/02/17 12:25:26 ram + * patch8: now bless objects ASAP at retrieve time + * patch8: added support for blessed ref to tied structures + * * Revision 1.0.1.6 2001/01/03 09:40:40 ram * patch7: prototype and casting cleanup * patch7: trace offending package when overloading cannot be restored @@ -554,12 +558,21 @@ static stcxt_t *Context_ptr = &Context; #define SHF_HAS_LIST 0x80 /* - * Types for SX_HOOK (2 bits). + * Types for SX_HOOK (last 2 bits in flags). */ #define SHT_SCALAR 0 #define SHT_ARRAY 1 #define SHT_HASH 2 +#define SHT_EXTRA 3 /* Read extra byte for type */ + +/* + * The following are held in the "extra byte"... + */ + +#define SHT_TSCALAR 4 /* 4 + 0 -- tied scalar */ +#define SHT_TARRAY 5 /* 4 + 1 -- tied array */ +#define SHT_THASH 6 /* 4 + 2 -- tied hash */ /* * Before 0.6, the magic string was "perl-store" (binary version number 0). @@ -581,7 +594,7 @@ static char old_magicstr[] = "perl-store"; /* Magic number before 0.6 */ static char magicstr[] = "pst0"; /* Used as a magic number */ #define STORABLE_BIN_MAJOR 2 /* Binary major "version" */ -#define STORABLE_BIN_MINOR 3 /* Binary minor "version" */ +#define STORABLE_BIN_MINOR 4 /* Binary minor "version" */ /* * Useful store shortcuts... @@ -723,14 +736,28 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ * given tag 'tagnum', has been retrieved. Next time we see an SX_OBJECT marker, * we'll therefore know where it has been retrieved and will be able to * share the same reference, as in the original stored memory image. + * + * We also need to bless objects ASAP for hooks (which may compute "ref $x" + * on the objects given to STORABLE_thaw and expect that to be defined), and + * also for overloaded objects (for which we might not find the stash if the + * object is not blessed yet--this might occur for overloaded objects that + * refer to themselves indirectly: if we blessed upon return from a sub + * retrieve(), the SX_OBJECT marker we'd found could not have overloading + * restored on it because the underlying object would not be blessed yet!). + * + * To achieve that, the class name of the last retrieved object is passed down + * recursively, and the first SEEN() call for which the class name is not NULL + * will bless the object. */ -#define SEEN(y) do { \ +#define SEEN(y,c) do { \ if (!y) \ return (SV *) 0; \ if (av_store(cxt->aseen, cxt->tagnum++, SvREFCNT_inc(y)) == 0) \ return (SV *) 0; \ TRACEME(("aseen(#%d) = 0x%"UVxf" (refcnt=%d)", cxt->tagnum-1, \ - PTR2UV(y), SvREFCNT(y)-1)); \ + PTR2UV(y), SvREFCNT(y)-1)); \ + if (c) \ + BLESS((SV *) (y), c); \ } while (0) /* @@ -748,7 +775,7 @@ static char magicstr[] = "pst0"; /* Used as a magic number */ } while (0) static int store(); -static SV *retrieve(); +static SV *retrieve(stcxt_t *cxt, char *cname); /* * Dynamic dispatching table for SV store. @@ -779,24 +806,24 @@ static int (*sv_store[])(stcxt_t *cxt, SV *sv) = { * Dynamic dispatching tables for SV retrieval. */ -static SV *retrieve_lscalar(stcxt_t *cxt); -static SV *retrieve_lutf8str(stcxt_t *cxt); -static SV *old_retrieve_array(stcxt_t *cxt); -static SV *old_retrieve_hash(stcxt_t *cxt); -static SV *retrieve_ref(stcxt_t *cxt); -static SV *retrieve_undef(stcxt_t *cxt); -static SV *retrieve_integer(stcxt_t *cxt); -static SV *retrieve_double(stcxt_t *cxt); -static SV *retrieve_byte(stcxt_t *cxt); -static SV *retrieve_netint(stcxt_t *cxt); -static SV *retrieve_scalar(stcxt_t *cxt); -static SV *retrieve_utf8str(stcxt_t *cxt); -static SV *retrieve_tied_array(stcxt_t *cxt); -static SV *retrieve_tied_hash(stcxt_t *cxt); -static SV *retrieve_tied_scalar(stcxt_t *cxt); -static SV *retrieve_other(stcxt_t *cxt); - -static SV *(*sv_old_retrieve[])(stcxt_t *cxt) = { +static SV *retrieve_lscalar(stcxt_t *cxt, char *cname); +static SV *retrieve_lutf8str(stcxt_t *cxt, char *cname); +static SV *old_retrieve_array(stcxt_t *cxt, char *cname); +static SV *old_retrieve_hash(stcxt_t *cxt, char *cname); +static SV *retrieve_ref(stcxt_t *cxt, char *cname); +static SV *retrieve_undef(stcxt_t *cxt, char *cname); +static SV *retrieve_integer(stcxt_t *cxt, char *cname); +static SV *retrieve_double(stcxt_t *cxt, char *cname); +static SV *retrieve_byte(stcxt_t *cxt, char *cname); +static SV *retrieve_netint(stcxt_t *cxt, char *cname); +static SV *retrieve_scalar(stcxt_t *cxt, char *cname); +static SV *retrieve_utf8str(stcxt_t *cxt, char *cname); +static SV *retrieve_tied_array(stcxt_t *cxt, char *cname); +static SV *retrieve_tied_hash(stcxt_t *cxt, char *cname); +static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname); +static SV *retrieve_other(stcxt_t *cxt, char *cname); + +static SV *(*sv_old_retrieve[])(stcxt_t *cxt, char *cname) = { 0, /* SX_OBJECT -- entry unused dynamically */ retrieve_lscalar, /* SX_LSCALAR */ old_retrieve_array, /* SX_ARRAY -- for pre-0.6 binaries */ @@ -825,19 +852,19 @@ static SV *(*sv_old_retrieve[])(stcxt_t *cxt) = { retrieve_other, /* SX_ERROR */ }; -static SV *retrieve_array(stcxt_t *cxt); -static SV *retrieve_hash(stcxt_t *cxt); -static SV *retrieve_sv_undef(stcxt_t *cxt); -static SV *retrieve_sv_yes(stcxt_t *cxt); -static SV *retrieve_sv_no(stcxt_t *cxt); -static SV *retrieve_blessed(stcxt_t *cxt); -static SV *retrieve_idx_blessed(stcxt_t *cxt); -static SV *retrieve_hook(stcxt_t *cxt); -static SV *retrieve_overloaded(stcxt_t *cxt); -static SV *retrieve_tied_key(stcxt_t *cxt); -static SV *retrieve_tied_idx(stcxt_t *cxt); - -static SV *(*sv_retrieve[])(stcxt_t *cxt) = { +static SV *retrieve_array(stcxt_t *cxt, char *cname); +static SV *retrieve_hash(stcxt_t *cxt, char *cname); +static SV *retrieve_sv_undef(stcxt_t *cxt, char *cname); +static SV *retrieve_sv_yes(stcxt_t *cxt, char *cname); +static SV *retrieve_sv_no(stcxt_t *cxt, char *cname); +static SV *retrieve_blessed(stcxt_t *cxt, char *cname); +static SV *retrieve_idx_blessed(stcxt_t *cxt, char *cname); +static SV *retrieve_hook(stcxt_t *cxt, char *cname); +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 *(*sv_retrieve[])(stcxt_t *cxt, char *cname) = { 0, /* SX_OBJECT -- entry unused dynamically */ retrieve_lscalar, /* SX_LSCALAR */ retrieve_array, /* SX_ARRAY */ @@ -2065,6 +2092,16 @@ static int store_tied_item(stcxt_t *cxt, SV *sv) * that same header being repeated between serialized objects obtained through * recursion, until we reach flags indicating no recursion, at which point * we know we've resynchronized with a single layout, after . + * + * When storing a blessed ref to a tied variable, the following format is + * used: + * + * SX_HOOK ... [ ] + * + * The first indication carries an object of type SHT_EXTRA, and the + * real object type is held in the flag. At the very end of the + * serialization stream, the underlying magic object is serialized, just like + * any other tied variable. */ static int store_hook( stcxt_t *cxt, @@ -2088,6 +2125,8 @@ static int store_hook( I32 classnum; int ret; int clone = cxt->optype & ST_CLONE; + char mtype; /* for blessed ref to tied structures */ + unsigned char eflags; /* used when object type is SHT_EXTRA */ TRACEME(("store_hook, class \"%s\", tagged #%d", HvNAME(pkg), cxt->tagnum)); @@ -2105,6 +2144,36 @@ static int store_hook( case svis_HASH: obj_type = SHT_HASH; break; + case svis_TIED: + /* + * Produced by a blessed ref to a tied data structure, $o in the + * following Perl code. + * + * my %h; + * tie %h, 'FOO'; + * my $o = bless \%h, 'BAR'; + * + * Signal the tie-ing magic by setting the object type as SHT_EXTRA + * (since we have only 2 bits in to store the type), and an + * byte flag will be emitted after the FIRST in the + * stream, carrying what we put in `eflags'. + */ + obj_type = SHT_EXTRA; + switch (SvTYPE(sv)) { + case SVt_PVHV: + eflags = (unsigned char) SHT_THASH; + mtype = 'P'; + break; + case SVt_PVAV: + eflags = (unsigned char) SHT_TARRAY; + mtype = 'P'; + break; + default: + eflags = (unsigned char) SHT_TSCALAR; + mtype = 'q'; + break; + } + break; default: CROAK(("Unexpected object type (%d) in store_hook()", type)); } @@ -2214,10 +2283,14 @@ static int store_hook( * others, in case those would point back at that object. */ - /* [SX_HOOK] */ - if (!recursed++) + /* [SX_HOOK] [] */ + if (!recursed++) { PUTMARK(SX_HOOK); - PUTMARK(flags); + PUTMARK(flags); + if (obj_type == SHT_EXTRA) + PUTMARK(eflags); + } else + PUTMARK(flags); if (ret = store(cxt, xsv)) /* Given by hook for us to store */ return ret; @@ -2305,10 +2378,14 @@ static int store_hook( "class=%"IVdf" len=%"IVdf" len2=%"IVdf" len3=%d", recursed, flags, (IV)classnum, (IV)len, (IV)len2, count-1)); - /* SX_HOOK */ - if (!recursed) + /* SX_HOOK [] */ + if (!recursed) { PUTMARK(SX_HOOK); - PUTMARK(flags); + PUTMARK(flags); + if (obj_type == SHT_EXTRA) + PUTMARK(eflags); + } else + PUTMARK(flags); /* or */ if (flags & SHF_IDX_CLASSNAME) { @@ -2371,6 +2448,31 @@ static int store_hook( av_undef(av); sv_free((SV *) av); + /* + * If object was tied, need to insert serialization of the magic object. + */ + + if (obj_type == SHT_EXTRA) { + MAGIC *mg; + + if (!(mg = mg_find(sv, mtype))) { + int svt = SvTYPE(sv); + CROAK(("No magic '%c' found while storing ref to tied %s with hook", + mtype, (svt == SVt_PVHV) ? "hash" : + (svt == SVt_PVAV) ? "array" : "scalar")); + } + + TRACEME(("handling the magic object 0x%"UVxf" part of 0x%"UVxf, + PTR2UV(mg->mg_obj), PTR2UV(sv))); + + /* + * [] + */ + + if (ret = store(cxt, mg->mg_obj)) + return ret; + } + return 0; } @@ -2927,7 +3029,7 @@ SV *net_mstore(SV *sv) * Return an error via croak, since it is not possible that we get here * under normal conditions, when facing a file produced via pstore(). */ -static SV *retrieve_other(stcxt_t *cxt) +static SV *retrieve_other(stcxt_t *cxt, char *cname) { if ( cxt->ver_major != STORABLE_BIN_MAJOR && @@ -2952,7 +3054,7 @@ static SV *retrieve_other(stcxt_t *cxt) * Layout is SX_IX_BLESS with SX_IX_BLESS already read. * can be coded on either 1 or 5 bytes. */ -static SV *retrieve_idx_blessed(stcxt_t *cxt) +static SV *retrieve_idx_blessed(stcxt_t *cxt, char *cname) { I32 idx; char *class; @@ -2960,6 +3062,7 @@ static SV *retrieve_idx_blessed(stcxt_t *cxt) SV *sv; TRACEME(("retrieve_idx_blessed (#%d)", cxt->tagnum)); + ASSERT(!cname, ("no bless-into class given here, got %s", cname)); GETMARK(idx); /* Index coded on a single char? */ if (idx & 0x80) @@ -2981,9 +3084,7 @@ static SV *retrieve_idx_blessed(stcxt_t *cxt) * Retrieve object and bless it. */ - sv = retrieve(cxt); - if (sv) - BLESS(sv, class); + sv = retrieve(cxt, class); /* First SV which is SEEN will be blessed */ return sv; } @@ -2994,7 +3095,7 @@ static SV *retrieve_idx_blessed(stcxt_t *cxt) * Layout is SX_BLESS with SX_BLESS already read. * can be coded on either 1 or 5 bytes. */ -static SV *retrieve_blessed(stcxt_t *cxt) +static SV *retrieve_blessed(stcxt_t *cxt, char *cname) { I32 len; SV *sv; @@ -3002,6 +3103,7 @@ static SV *retrieve_blessed(stcxt_t *cxt) char *class = buf; TRACEME(("retrieve_blessed (#%d)", cxt->tagnum)); + ASSERT(!cname, ("no bless-into class given here, got %s", cname)); /* * Decode class name length and read that name. @@ -3023,6 +3125,8 @@ static SV *retrieve_blessed(stcxt_t *cxt) * It's a new classname, otherwise it would have been an SX_IX_BLESS. */ + TRACEME(("new class name \"%s\" will bear ID = %d", class, cxt->classnum)); + if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(class, len))) return (SV *) 0; @@ -3030,12 +3134,9 @@ static SV *retrieve_blessed(stcxt_t *cxt) * Retrieve object and bless it. */ - sv = retrieve(cxt); - if (sv) { - BLESS(sv, class); - if (class != buf) - Safefree(class); - } + sv = retrieve(cxt, class); /* First SV which is SEEN will be blessed */ + if (class != buf) + Safefree(class); return sv; } @@ -3049,8 +3150,18 @@ static SV *retrieve_blessed(stcxt_t *cxt) * When recursion was involved during serialization of the object, there * is an unknown amount of serialized objects after the SX_HOOK mark. Until * we reach a marker with the recursion bit cleared. + * + * If the first byte contains a type of SHT_EXTRA, then the real type + * is held in the byte, and if the object is tied, the serialized + * magic object comes at the very end: + * + * SX_HOOK ... [ ] + * + * This means the STORABLE_thaw hook will NOT get a tied variable during its + * processing (since we won't have seen the magic object by the time the hook + * is called). See comments below for why it was done that way. */ -static SV *retrieve_hook(stcxt_t *cxt) +static SV *retrieve_hook(stcxt_t *cxt, char *cname) { I32 len; char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */ @@ -3066,8 +3177,11 @@ static SV *retrieve_hook(stcxt_t *cxt) int obj_type; I32 classname; int clone = cxt->optype & ST_CLONE; + char mtype = '\0'; + unsigned int extra_type = 0; TRACEME(("retrieve_hook (#%d)", cxt->tagnum)); + ASSERT(!cname, ("no bless-into class given here, got %s", cname)); /* * Read flags, which tell us about the type, and whether we need to recurse. @@ -3094,10 +3208,33 @@ static SV *retrieve_hook(stcxt_t *cxt) case SHT_HASH: sv = (SV *) newHV(); break; + case SHT_EXTRA: + /* + * Read flag to know the type of the object. + * Record associated magic type for later. + */ + GETMARK(extra_type); + switch (extra_type) { + case SHT_TSCALAR: + sv = newSV(0); + mtype = 'q'; + break; + case SHT_TARRAY: + sv = (SV *) newAV(); + mtype = 'P'; + break; + case SHT_THASH: + sv = (SV *) newHV(); + mtype = 'P'; + break; + default: + return retrieve_other(cxt, 0); /* Let it croak */ + } + break; default: - return retrieve_other(cxt); /* Let it croak */ + return retrieve_other(cxt, 0); /* Let it croak */ } - SEEN(sv); + SEEN(sv, 0); /* Don't bless yet */ /* * Whilst flags tell us to recurse, do so. @@ -3109,7 +3246,7 @@ static SV *retrieve_hook(stcxt_t *cxt) while (flags & SHF_NEED_RECURSE) { TRACEME(("retrieve_hook recursing...")); - rv = retrieve(cxt); + rv = retrieve(cxt, 0); if (!rv) return (SV *) 0; TRACEME(("retrieve_hook back with rv=0x%"UVxf, @@ -3321,6 +3458,62 @@ static SV *retrieve_hook(stcxt_t *cxt) if (!(flags & SHF_IDX_CLASSNAME) && class != buf) Safefree(class); + /* + * If we had an type, then the object was not as simple, and + * we need to restore extra magic now. + */ + + if (!extra_type) + return sv; + + TRACEME(("retrieving magic object for 0x%"UVxf"...", PTR2UV(sv))); + + rv = retrieve(cxt, 0); /* Retrieve */ + + TRACEME(("restoring the magic object 0x%"UVxf" part of 0x%"UVxf, + PTR2UV(rv), PTR2UV(sv))); + + switch (extra_type) { + case SHT_TSCALAR: + sv_upgrade(sv, SVt_PVMG); + break; + case SHT_TARRAY: + sv_upgrade(sv, SVt_PVAV); + AvREAL_off((AV *)sv); + break; + case SHT_THASH: + sv_upgrade(sv, SVt_PVHV); + break; + default: + CROAK(("Forgot to deal with extra type %d", extra_type)); + break; + } + + /* + * Adding the magic only now, well after the STORABLE_thaw hook was called + * means the hook cannot know it deals with an object whose variable is + * tied. But this is happening when retrieving $o in the following case: + * + * my %h; + * tie %h, 'FOO'; + * my $o = bless \%h, 'BAR'; + * + * The 'BAR' class is NOT the one where %h is tied into. Therefore, as + * far as the 'BAR' class is concerned, the fact that %h is not a REAL + * hash but a tied one should not matter at all, and remain transparent. + * This means the magic must be restored by Storable AFTER the hook is + * called. + * + * That looks very reasonable to me, but then I've come up with this + * after a bug report from David Nesting, who was trying to store such + * an object and caused Storable to fail. And unfortunately, it was + * also the easiest way to retrofit support for blessed ref to tied objects + * into the existing design. -- RAM, 17/02/2001 + */ + + sv_magic(sv, rv, mtype, Nullch, 0); + SvREFCNT_dec(rv); /* Undo refcnt inc from sv_magic() */ + return sv; } @@ -3330,7 +3523,7 @@ static SV *retrieve_hook(stcxt_t *cxt) * Retrieve reference to some other scalar. * Layout is SX_REF , with SX_REF already read. */ -static SV *retrieve_ref(stcxt_t *cxt) +static SV *retrieve_ref(stcxt_t *cxt, char *cname) { SV *rv; SV *sv; @@ -3347,8 +3540,8 @@ static SV *retrieve_ref(stcxt_t *cxt) */ rv = NEWSV(10002, 0); - SEEN(rv); /* Will return if rv is null */ - sv = retrieve(cxt); /* Retrieve */ + SEEN(rv, cname); /* Will return if rv is null */ + sv = retrieve(cxt, 0); /* Retrieve */ if (!sv) return (SV *) 0; /* Failed */ @@ -3384,7 +3577,7 @@ static SV *retrieve_ref(stcxt_t *cxt) * Retrieve reference to some other scalar with overloading. * Layout is SX_OVERLOAD , with SX_OVERLOAD already read. */ -static SV *retrieve_overloaded(stcxt_t *cxt) +static SV *retrieve_overloaded(stcxt_t *cxt, char *cname) { SV *rv; SV *sv; @@ -3397,8 +3590,8 @@ static SV *retrieve_overloaded(stcxt_t *cxt) */ rv = NEWSV(10002, 0); - SEEN(rv); /* Will return if rv is null */ - sv = retrieve(cxt); /* Retrieve */ + SEEN(rv, cname); /* Will return if rv is null */ + sv = retrieve(cxt, 0); /* Retrieve */ if (!sv) return (SV *) 0; /* Failed */ @@ -3434,7 +3627,7 @@ static SV *retrieve_overloaded(stcxt_t *cxt) * Retrieve tied array * Layout is SX_TIED_ARRAY , with SX_TIED_ARRAY already read. */ -static SV *retrieve_tied_array(stcxt_t *cxt) +static SV *retrieve_tied_array(stcxt_t *cxt, char *cname) { SV *tv; SV *sv; @@ -3442,8 +3635,8 @@ static SV *retrieve_tied_array(stcxt_t *cxt) TRACEME(("retrieve_tied_array (#%d)", cxt->tagnum)); tv = NEWSV(10002, 0); - SEEN(tv); /* Will return if tv is null */ - sv = retrieve(cxt); /* Retrieve */ + SEEN(tv, cname); /* Will return if tv is null */ + sv = retrieve(cxt, 0); /* Retrieve */ if (!sv) return (SV *) 0; /* Failed */ @@ -3463,7 +3656,7 @@ static SV *retrieve_tied_array(stcxt_t *cxt) * Retrieve tied hash * Layout is SX_TIED_HASH , with SX_TIED_HASH already read. */ -static SV *retrieve_tied_hash(stcxt_t *cxt) +static SV *retrieve_tied_hash(stcxt_t *cxt, char *cname) { SV *tv; SV *sv; @@ -3471,8 +3664,8 @@ static SV *retrieve_tied_hash(stcxt_t *cxt) TRACEME(("retrieve_tied_hash (#%d)", cxt->tagnum)); tv = NEWSV(10002, 0); - SEEN(tv); /* Will return if tv is null */ - sv = retrieve(cxt); /* Retrieve */ + SEEN(tv, cname); /* Will return if tv is null */ + sv = retrieve(cxt, 0); /* Retrieve */ if (!sv) return (SV *) 0; /* Failed */ @@ -3491,8 +3684,7 @@ static SV *retrieve_tied_hash(stcxt_t *cxt) * Retrieve tied scalar * Layout is SX_TIED_SCALAR , with SX_TIED_SCALAR already read. */ -static SV *retrieve_tied_scalar(cxt) -stcxt_t *cxt; +static SV *retrieve_tied_scalar(stcxt_t *cxt, char *cname) { SV *tv; SV *sv; @@ -3500,8 +3692,8 @@ stcxt_t *cxt; TRACEME(("retrieve_tied_scalar (#%d)", cxt->tagnum)); tv = NEWSV(10002, 0); - SEEN(tv); /* Will return if rv is null */ - sv = retrieve(cxt); /* Retrieve */ + SEEN(tv, cname); /* Will return if rv is null */ + sv = retrieve(cxt, 0); /* Retrieve */ if (!sv) return (SV *) 0; /* Failed */ @@ -3520,7 +3712,7 @@ stcxt_t *cxt; * Retrieve reference to value in a tied hash. * Layout is SX_TIED_KEY , with SX_TIED_KEY already read. */ -static SV *retrieve_tied_key(stcxt_t *cxt) +static SV *retrieve_tied_key(stcxt_t *cxt, char *cname) { SV *tv; SV *sv; @@ -3529,12 +3721,12 @@ static SV *retrieve_tied_key(stcxt_t *cxt) TRACEME(("retrieve_tied_key (#%d)", cxt->tagnum)); tv = NEWSV(10002, 0); - SEEN(tv); /* Will return if tv is null */ - sv = retrieve(cxt); /* Retrieve */ + SEEN(tv, cname); /* Will return if tv is null */ + sv = retrieve(cxt, 0); /* Retrieve */ if (!sv) return (SV *) 0; /* Failed */ - key = retrieve(cxt); /* Retrieve */ + key = retrieve(cxt, 0); /* Retrieve */ if (!key) return (SV *) 0; /* Failed */ @@ -3552,7 +3744,7 @@ static SV *retrieve_tied_key(stcxt_t *cxt) * Retrieve reference to value in a tied array. * Layout is SX_TIED_IDX , with SX_TIED_IDX already read. */ -static SV *retrieve_tied_idx(stcxt_t *cxt) +static SV *retrieve_tied_idx(stcxt_t *cxt, char *cname) { SV *tv; SV *sv; @@ -3561,8 +3753,8 @@ static SV *retrieve_tied_idx(stcxt_t *cxt) TRACEME(("retrieve_tied_idx (#%d)", cxt->tagnum)); tv = NEWSV(10002, 0); - SEEN(tv); /* Will return if tv is null */ - sv = retrieve(cxt); /* Retrieve */ + SEEN(tv, cname); /* Will return if tv is null */ + sv = retrieve(cxt, 0); /* Retrieve */ if (!sv) return (SV *) 0; /* Failed */ @@ -3585,7 +3777,7 @@ static SV *retrieve_tied_idx(stcxt_t *cxt) * The scalar is "long" in that is larger than LG_SCALAR so it * was not stored on a single byte. */ -static SV *retrieve_lscalar(stcxt_t *cxt) +static SV *retrieve_lscalar(stcxt_t *cxt, char *cname) { I32 len; SV *sv; @@ -3598,7 +3790,7 @@ static SV *retrieve_lscalar(stcxt_t *cxt) */ sv = NEWSV(10002, len); - SEEN(sv); /* Associate this new scalar with tag "tagnum" */ + SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */ /* * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation. @@ -3631,7 +3823,7 @@ static SV *retrieve_lscalar(stcxt_t *cxt) * The scalar is "short" so is single byte. If it is 0, there * is no section. */ -static SV *retrieve_scalar(stcxt_t *cxt) +static SV *retrieve_scalar(stcxt_t *cxt, char *cname) { int len; SV *sv; @@ -3644,7 +3836,7 @@ static SV *retrieve_scalar(stcxt_t *cxt) */ sv = NEWSV(10002, len); - SEEN(sv); /* Associate this new scalar with tag "tagnum" */ + SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */ /* * WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation. @@ -3686,13 +3878,13 @@ static SV *retrieve_scalar(stcxt_t *cxt) * Like retrieve_scalar(), but tag result as utf8. * If we're retrieving UTF8 data in a non-UTF8 perl, croaks. */ -static SV *retrieve_utf8str(stcxt_t *cxt) +static SV *retrieve_utf8str(stcxt_t *cxt, char *cname) { SV *sv; TRACEME(("retrieve_utf8str")); - sv = retrieve_scalar(cxt); + sv = retrieve_scalar(cxt, cname); if (sv) SvUTF8_on(sv); @@ -3705,13 +3897,13 @@ static SV *retrieve_utf8str(stcxt_t *cxt) * Like retrieve_lscalar(), but tag result as utf8. * If we're retrieving UTF8 data in a non-UTF8 perl, croaks. */ -static SV *retrieve_lutf8str(stcxt_t *cxt) +static SV *retrieve_lutf8str(stcxt_t *cxt, char *cname) { SV *sv; TRACEME(("retrieve_lutf8str")); - sv = retrieve_lscalar(cxt); + sv = retrieve_lscalar(cxt, cname); if (sv) SvUTF8_on(sv); @@ -3724,7 +3916,7 @@ static SV *retrieve_lutf8str(stcxt_t *cxt) * Retrieve defined integer. * Layout is SX_INTEGER , whith SX_INTEGER already read. */ -static SV *retrieve_integer(stcxt_t *cxt) +static SV *retrieve_integer(stcxt_t *cxt, char *cname) { SV *sv; IV iv; @@ -3733,7 +3925,7 @@ static SV *retrieve_integer(stcxt_t *cxt) READ(&iv, sizeof(iv)); sv = newSViv(iv); - SEEN(sv); /* Associate this new scalar with tag "tagnum" */ + SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */ TRACEME(("integer %"IVdf, iv)); TRACEME(("ok (retrieve_integer at 0x%"UVxf")", PTR2UV(sv))); @@ -3747,7 +3939,7 @@ static SV *retrieve_integer(stcxt_t *cxt) * Retrieve defined integer in network order. * Layout is SX_NETINT , whith SX_NETINT already read. */ -static SV *retrieve_netint(stcxt_t *cxt) +static SV *retrieve_netint(stcxt_t *cxt, char *cname) { SV *sv; I32 iv; @@ -3762,7 +3954,7 @@ static SV *retrieve_netint(stcxt_t *cxt) sv = newSViv(iv); TRACEME(("network integer (as-is) %d", iv)); #endif - SEEN(sv); /* Associate this new scalar with tag "tagnum" */ + SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */ TRACEME(("ok (retrieve_netint at 0x%"UVxf")", PTR2UV(sv))); @@ -3775,7 +3967,7 @@ static SV *retrieve_netint(stcxt_t *cxt) * Retrieve defined double. * Layout is SX_DOUBLE , whith SX_DOUBLE already read. */ -static SV *retrieve_double(stcxt_t *cxt) +static SV *retrieve_double(stcxt_t *cxt, char *cname) { SV *sv; NV nv; @@ -3784,7 +3976,7 @@ static SV *retrieve_double(stcxt_t *cxt) READ(&nv, sizeof(nv)); sv = newSVnv(nv); - SEEN(sv); /* Associate this new scalar with tag "tagnum" */ + SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */ TRACEME(("double %"NVff, nv)); TRACEME(("ok (retrieve_double at 0x%"UVxf")", PTR2UV(sv))); @@ -3798,7 +3990,7 @@ static SV *retrieve_double(stcxt_t *cxt) * Retrieve defined byte (small integer within the [-128, +127] range). * Layout is SX_BYTE , whith SX_BYTE already read. */ -static SV *retrieve_byte(stcxt_t *cxt) +static SV *retrieve_byte(stcxt_t *cxt, char *cname) { SV *sv; int siv; @@ -3808,7 +4000,7 @@ static SV *retrieve_byte(stcxt_t *cxt) GETMARK(siv); TRACEME(("small integer read as %d", (unsigned char) siv)); sv = newSViv((unsigned char) siv - 128); - SEEN(sv); /* Associate this new scalar with tag "tagnum" */ + SEEN(sv, cname); /* Associate this new scalar with tag "tagnum" */ TRACEME(("byte %d", (unsigned char) siv - 128)); TRACEME(("ok (retrieve_byte at 0x%"UVxf")", PTR2UV(sv))); @@ -3821,14 +4013,14 @@ static SV *retrieve_byte(stcxt_t *cxt) * * Return the undefined value. */ -static SV *retrieve_undef(stcxt_t *cxt) +static SV *retrieve_undef(stcxt_t *cxt, char *cname) { SV* sv; TRACEME(("retrieve_undef")); sv = newSV(0); - SEEN(sv); + SEEN(sv, cname); return sv; } @@ -3838,13 +4030,13 @@ static SV *retrieve_undef(stcxt_t *cxt) * * Return the immortal undefined value. */ -static SV *retrieve_sv_undef(stcxt_t *cxt) +static SV *retrieve_sv_undef(stcxt_t *cxt, char *cname) { SV *sv = &PL_sv_undef; TRACEME(("retrieve_sv_undef")); - SEEN(sv); + SEEN(sv, cname); return sv; } @@ -3853,13 +4045,13 @@ static SV *retrieve_sv_undef(stcxt_t *cxt) * * Return the immortal yes value. */ -static SV *retrieve_sv_yes(stcxt_t *cxt) +static SV *retrieve_sv_yes(stcxt_t *cxt, char *cname) { SV *sv = &PL_sv_yes; TRACEME(("retrieve_sv_yes")); - SEEN(sv); + SEEN(sv, cname); return sv; } @@ -3868,13 +4060,13 @@ static SV *retrieve_sv_yes(stcxt_t *cxt) * * Return the immortal no value. */ -static SV *retrieve_sv_no(stcxt_t *cxt) +static SV *retrieve_sv_no(stcxt_t *cxt, char *cname) { SV *sv = &PL_sv_no; TRACEME(("retrieve_sv_no")); - SEEN(sv); + SEEN(sv, cname); return sv; } @@ -3887,7 +4079,7 @@ static SV *retrieve_sv_no(stcxt_t *cxt) * * When we come here, SX_ARRAY has been read already. */ -static SV *retrieve_array(stcxt_t *cxt) +static SV *retrieve_array(stcxt_t *cxt, char *cname) { I32 len; I32 i; @@ -3903,7 +4095,7 @@ static SV *retrieve_array(stcxt_t *cxt) RLEN(len); TRACEME(("size = %d", len)); av = newAV(); - SEEN(av); /* Will return if array not allocated nicely */ + SEEN(av, cname); /* Will return if array not allocated nicely */ if (len) av_extend(av, len); else @@ -3915,7 +4107,7 @@ static SV *retrieve_array(stcxt_t *cxt) for (i = 0; i < len; i++) { TRACEME(("(#%d) item", i)); - sv = retrieve(cxt); /* Retrieve item */ + sv = retrieve(cxt, 0); /* Retrieve item */ if (!sv) return (SV *) 0; if (av_store(av, i, sv) == 0) @@ -3938,7 +4130,7 @@ static SV *retrieve_array(stcxt_t *cxt) * * When we come here, SX_HASH has been read already. */ -static SV *retrieve_hash(stcxt_t *cxt) +static SV *retrieve_hash(stcxt_t *cxt, char *cname) { I32 len; I32 size; @@ -3956,7 +4148,7 @@ static SV *retrieve_hash(stcxt_t *cxt) RLEN(len); TRACEME(("size = %d", len)); hv = newHV(); - SEEN(hv); /* Will return if table not allocated properly */ + SEEN(hv, cname); /* Will return if table not allocated properly */ if (len == 0) return (SV *) hv; /* No data follow if table empty */ @@ -3970,7 +4162,7 @@ static SV *retrieve_hash(stcxt_t *cxt) */ TRACEME(("(#%d) value", i)); - sv = retrieve(cxt); + sv = retrieve(cxt, 0); if (!sv) return (SV *) 0; @@ -4011,7 +4203,7 @@ static SV *retrieve_hash(stcxt_t *cxt) * * When we come here, SX_ARRAY has been read already. */ -static SV *old_retrieve_array(stcxt_t *cxt) +static SV *old_retrieve_array(stcxt_t *cxt, char *cname) { I32 len; I32 i; @@ -4028,7 +4220,7 @@ static SV *old_retrieve_array(stcxt_t *cxt) RLEN(len); TRACEME(("size = %d", len)); av = newAV(); - SEEN(av); /* Will return if array not allocated nicely */ + SEEN(av, 0); /* Will return if array not allocated nicely */ if (len) av_extend(av, len); else @@ -4045,9 +4237,9 @@ static SV *old_retrieve_array(stcxt_t *cxt) continue; /* av_extend() already filled us with undef */ } if (c != SX_ITEM) - (void) retrieve_other((stcxt_t *) 0); /* Will croak out */ + (void) retrieve_other((stcxt_t *) 0, 0); /* Will croak out */ TRACEME(("(#%d) item", i)); - sv = retrieve(cxt); /* Retrieve item */ + sv = retrieve(cxt, 0); /* Retrieve item */ if (!sv) return (SV *) 0; if (av_store(av, i, sv) == 0) @@ -4071,7 +4263,7 @@ static SV *old_retrieve_array(stcxt_t *cxt) * * When we come here, SX_HASH has been read already. */ -static SV *old_retrieve_hash(stcxt_t *cxt) +static SV *old_retrieve_hash(stcxt_t *cxt, char *cname) { I32 len; I32 size; @@ -4090,7 +4282,7 @@ static SV *old_retrieve_hash(stcxt_t *cxt) RLEN(len); TRACEME(("size = %d", len)); hv = newHV(); - SEEN(hv); /* Will return if table not allocated properly */ + SEEN(hv, 0); /* Will return if table not allocated properly */ if (len == 0) return (SV *) hv; /* No data follow if table empty */ @@ -4116,11 +4308,11 @@ static SV *old_retrieve_hash(stcxt_t *cxt) sv = SvREFCNT_inc(sv_h_undef); } else if (c == SX_VALUE) { TRACEME(("(#%d) value", i)); - sv = retrieve(cxt); + sv = retrieve(cxt, 0); if (!sv) return (SV *) 0; } else - (void) retrieve_other((stcxt_t *) 0); /* Will croak out */ + (void) retrieve_other((stcxt_t *) 0, 0); /* Will croak out */ /* * Get key. @@ -4131,7 +4323,7 @@ static SV *old_retrieve_hash(stcxt_t *cxt) GETMARK(c); if (c != SX_KEY) - (void) retrieve_other((stcxt_t *) 0); /* Will croak out */ + (void) retrieve_other((stcxt_t *) 0, 0); /* Will croak out */ RLEN(size); /* Get key size */ KBUFCHK(size); /* Grow hash key read pool if needed */ if (size) @@ -4292,7 +4484,7 @@ magic_ok: * root SV (which may be an AV or an HV for what we care). * Returns null if there is a problem. */ -static SV *retrieve(stcxt_t *cxt) +static SV *retrieve(stcxt_t *cxt, char *cname) { int type; SV **svh; @@ -4387,7 +4579,7 @@ first_time: /* Will disappear when support for old format is dropped */ * Okay, first time through for this one. */ - sv = RETRIEVE(cxt, type)(cxt); + sv = RETRIEVE(cxt, type)(cxt, cname); if (!sv) return (SV *) 0; /* Failed */ @@ -4532,7 +4724,7 @@ static SV *do_retrieve( ASSERT(is_retrieving(), ("within retrieve operation")); - sv = retrieve(cxt); /* Recursively retrieve object, get root SV */ + sv = retrieve(cxt, 0); /* Recursively retrieve object, get root SV */ /* * Final cleanup. diff --git a/t/lib/st-06compat.t b/t/lib/st-06compat.t index 8512974..b18aed0 100644 --- a/t/lib/st-06compat.t +++ b/t/lib/st-06compat.t @@ -1,6 +1,6 @@ #!./perl -# $Id: compat-0.6.t,v 1.0 2000/09/01 19:40:41 ram Exp $ +# $Id: compat-0.6.t,v 1.0.1.1 2001/02/17 12:26:21 ram Exp $ # # Copyright (c) 1995-2000, Raphael Manfredi # @@ -8,6 +8,9 @@ # in the README file that comes with the distribution. # # $Log: compat-0.6.t,v $ +# Revision 1.0.1.1 2001/02/17 12:26:21 ram +# patch8: added EBCDIC version of the test, from Peter Prymmer +# # Revision 1.0 2000/09/01 19:40:41 ram # Baseline for first official release. # @@ -86,30 +89,29 @@ sub obj { $_[0]->{obj} } package main; -my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0; - +my $is_EBCDIC = (ord('A') == 193) ? 1 : 0; + my $r = ROOT->make; my $data = ''; -if (!$Is_EBCDIC) { +if (!$is_EBCDIC) { # ASCII machine while () { - next if /^#/; + next if /^#/; $data .= unpack("u", $_); } -} -else { +} else { while () { - next if /^#$/; # skip comments - next if /^#\s+/; # skip comments - next if /^[^#]/; # skip uuencoding for ASCII machines - s/^#//; # prepare uuencoded data for EBCDIC machines - $data .= unpack("u", $_); + next if /^#$/; # skip comments + next if /^#\s+/; # skip comments + next if /^[^#]/; # skip uuencoding for ASCII machines + s/^#//; # prepare uuencoded data for EBCDIC machines + $data .= unpack("u", $_); } } -my $expected_length = $Is_EBCDIC ? 217 : 278; +my $expected_length = $is_EBCDIC ? 217 : 278; ok 1, length $data == $expected_length; - + my $y = thaw($data); ok 2, 1; ok 3, ref $y eq 'ROOT'; @@ -153,3 +155,12 @@ M!`(````!"(188@9324U03$586%A8`````V]B:@0,!``````*6%A8`````W)E #M```!R`H#]$OU`````Y6DE`0"````!001!N+)U-?3Q0(````!"(`$$@("```` #M`0B!!!("`@````$(@@02`@(````!"(,$$@("`````0B$`````Y:"D00````` #E!`````&(!`(````#"@:BHYF)E8<$``````0$```````````!@0`` +# +# using Storable-0.6@11, output of: print '#' . pack("u", nfreeze(ROOT->make)); +# on OS/390 (cp 1047) original size: 217 bytes +# +#M!0,1!-G6UN,#````!00,!!$)X\G%Q&W(P>+(`P````(*!*6!D_$````$DH6H +#M\0H$I8&3\@````22A:CR`````YF%A@0"````!@B!"(`(?0H(8/-+\?3Q]?D) +#M```!R`H#]$OU`````Y6DE`0"````!001!N+)U-?3Q0(````!"(`$$@("```` +#M`0B!!!("`@````$(@@02`@(````!"(,$$@("`````0B$`````Y:"D00````` +#E!`````&(!`(````#"@:BHYF)E8<$``````0$```````````!@0`` diff --git a/t/lib/st-overload.t b/t/lib/st-overload.t index 8224a05..6d1e581 100644 --- a/t/lib/st-overload.t +++ b/t/lib/st-overload.t @@ -1,6 +1,6 @@ #!./perl -# $Id: overload.t,v 1.0 2000/09/01 19:40:42 ram Exp $ +# $Id: overload.t,v 1.0.1.1 2001/02/17 12:27:22 ram Exp $ # # Copyright (c) 1995-2000, Raphael Manfredi # @@ -8,6 +8,9 @@ # in the README file that comes with the distribution. # # $Log: overload.t,v $ +# Revision 1.0.1.1 2001/02/17 12:27:22 ram +# patch8: added test for structures with indirect ref to overloaded +# # Revision 1.0 2000/09/01 19:40:42 ram # Baseline for first official release. # @@ -28,7 +31,7 @@ sub ok; use Storable qw(freeze thaw); -print "1..7\n"; +print "1..12\n"; package OVERLOADED; @@ -53,3 +56,42 @@ ok 6, "$d->[0]" eq "77"; $d->[0][0]++; ok 7, "$d->[1]" eq "78"; +package REF_TO_OVER; + +sub make { + my $self = bless {}, shift; + my ($over) = @_; + $self->{over} = $over; + return $self; +} + +package OVER; + +use overload + '+' => \&plus, + '""' => sub { ref $_[0] }; + +sub plus { + return 314; +} + +sub make { + my $self = bless {}, shift; + my $ref = REF_TO_OVER->make($self); + $self->{ref} = $ref; + return $self; +} + +package main; + +$a = OVER->make(); +$b = thaw freeze $a; + +ok 8, ref $b eq 'OVER'; +ok 9, $a + $a == 314; +ok 10, ref $b->{ref} eq 'REF_TO_OVER'; +ok 11, "$b->{ref}->{over}" eq "$b"; +ok 12, $b + $b == 314; + +1; + diff --git a/t/lib/st-recurse.t b/t/lib/st-recurse.t index b429747..e3afc9c 100644 --- a/t/lib/st-recurse.t +++ b/t/lib/st-recurse.t @@ -1,6 +1,6 @@ #!./perl -# $Id: recurse.t,v 1.0.1.2 2000/11/05 17:22:05 ram Exp ram $ +# $Id: recurse.t,v 1.0.1.3 2001/02/17 12:28:33 ram Exp $ # # Copyright (c) 1995-2000, Raphael Manfredi # @@ -8,6 +8,9 @@ # in the README file that comes with the distribution. # # $Log: recurse.t,v $ +# Revision 1.0.1.3 2001/02/17 12:28:33 ram +# patch8: ensure blessing occurs ASAP, specially designed for hooks +# # Revision 1.0.1.2 2000/11/05 17:22:05 ram # patch6: stress hook a little more with refs to lexicals # @@ -36,7 +39,7 @@ sub ok; use Storable qw(freeze thaw dclone); -print "1..28\n"; +print "1..32\n"; package OBJ_REAL; @@ -241,3 +244,57 @@ ok 26, ref($bar->{b}[1]) eq 'Foo'; ok 27, ref($bar2->{b}[0]) eq 'Foo'; ok 28, ref($bar2->{b}[1]) eq 'Foo'; +# +# The following attempts to make sure blessed objects are blessed ASAP +# at retrieve time. +# + +package CLASS_1; + +sub make { + my $self = bless {}, shift; + return $self; +} + +package CLASS_2; + +sub make { + my $self = bless {}, shift; + my ($o) = @_; + $self->{c1} = CLASS_1->make(); + $self->{o} = $o; + $self->{c3} = bless CLASS_1->make(), "CLASS_3"; + $o->set_c2($self); + return $self; +} + +sub STORABLE_freeze { + my($self, $clonning) = @_; + return "", $self->{c1}, $self->{c3}, $self->{o}; +} + +sub STORABLE_thaw { + my($self, $clonning, $frozen, $c1, $c3, $o) = @_; + main::ok 29, ref $self eq "CLASS_2"; + main::ok 30, ref $c1 eq "CLASS_1"; + main::ok 31, ref $c3 eq "CLASS_3"; + main::ok 32, ref $o eq "CLASS_OTHER"; + $self->{c1} = $c1; + $self->{c3} = $c3; +} + +package CLASS_OTHER; + +sub make { + my $self = bless {}, shift; + return $self; +} + +sub set_c2 { $_[0]->{c2} = $_[1] } + +package main; + +my $o = CLASS_OTHER->make(); +my $c2 = CLASS_2->make($o); +my $so = thaw freeze $o; + diff --git a/t/lib/st-tiedhook.t b/t/lib/st-tiedhook.t index 455cb05..46805cf 100644 --- a/t/lib/st-tiedhook.t +++ b/t/lib/st-tiedhook.t @@ -1,6 +1,6 @@ #!./perl -# $Id: tied_hook.t,v 1.0 2000/09/01 19:40:42 ram Exp $ +# $Id: tied_hook.t,v 1.0.1.1 2001/02/17 12:29:01 ram Exp $ # # Copyright (c) 1995-2000, Raphael Manfredi # @@ -8,6 +8,9 @@ # in the README file that comes with the distribution. # # $Log: tied_hook.t,v $ +# Revision 1.0.1.1 2001/02/17 12:29:01 ram +# patch8: added test for blessed ref to tied hash +# # Revision 1.0 2000/09/01 19:40:42 ram # Baseline for first official release. # @@ -28,7 +31,7 @@ sub ok; use Storable qw(freeze thaw); -print "1..21\n"; +print "1..25\n"; ($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0); @@ -213,3 +216,39 @@ ok 19, ($scalar_hook1 && $scalar_hook2); ok 20, ($array_hook1 && $array_hook2); ok 21, ($hash_hook1 && $hash_hook2); +# +# And now for the "blessed ref to tied hash" with "store hook" test... +# + +my $bc = bless \%hash, 'FOO'; # FOO does not exist -> no hook +my $bx = thaw freeze $bc; + +ok 22, ref $bx eq 'FOO'; +my $old_hash_fetch = $hash_fetch; +my $v = $bx->{attribute}; +ok 23, $hash_fetch == $old_hash_fetch + 1; # Still tied + +package TIED_HASH_REF; + + +sub STORABLE_freeze { + my ($self, $cloning) = @_; + return if $cloning; + return('ref lost'); +} + +sub STORABLE_thaw { + my ($self, $cloning, $data) = @_; + return if $cloning; +} + +package main; + +$bc = bless \%hash, 'TIED_HASH_REF'; +$bx = thaw freeze $bc; + +ok 24, ref $bx eq 'TIED_HASH_REF'; +$old_hash_fetch = $hash_fetch; +$v = $bx->{attribute}; +ok 25, $hash_fetch == $old_hash_fetch + 1; # Still tied +