In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/4ad9e498704f6c321c22e3b409602df0ecdeae83?hp=f8c6801b81163debebd01aab796519234a5935d4>
- Log ----------------------------------------------------------------- commit 4ad9e498704f6c321c22e3b409602df0ecdeae83 Author: Father Chrysostomos <[email protected]> Date: Mon Jul 30 22:57:21 2012 -0700 [perl #114338] Misleading prototype in perlapi manpage M perl.h commit e00e3c3ee528907804050611225892b2b5d4cc8d Author: Father Chrysostomos <[email protected]> Date: Mon Jul 30 20:25:20 2012 -0700 [perl #113894] Storable support for vstrings M dist/Storable/Storable.xs M dist/Storable/t/blessed.t M dist/Storable/t/malice.t commit 4ae8bca72003be3124a3f42a3c2bd1ad253dfebc Author: Father Chrysostomos <[email protected]> Date: Mon Jul 30 22:43:06 2012 -0700 Get Storableâs blessed.t passing again in 5.8.1- Back then, sub {} meant sub {wantarray?@_:undef}. M dist/Storable/t/blessed.t commit a137b8e55003972a0592a0447c134e64d67d3423 Author: Father Chrysostomos <[email protected]> Date: Mon Jul 30 16:17:59 2012 -0700 Storable.xs: Add comments to store_scalar concerning utf8 M dist/Storable/Storable.xs commit b846e6a637ab20092fb1d9bc4bb317f92efaf0f0 Author: Father Chrysostomos <[email protected]> Date: Mon Jul 30 15:59:35 2012 -0700 Storable: doc typos M dist/Storable/Storable.pm commit a0dde8d2864f22eb6eb22aa50def3541025c185a Author: Father Chrysostomos <[email protected]> Date: Mon Jul 30 15:53:26 2012 -0700 Increase $Storable::VERSION to 2.38 M dist/Storable/Storable.pm commit a6d7a4ac1ec8155ef7c0c772e5731a362e6d9f3c Author: Father Chrysostomos <[email protected]> Date: Mon Jul 30 14:27:12 2012 -0700 scope.c: Donât stringify globs on scope exit This is a waste: /* Can clear pad variable in place? */ if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) { /* * if a my variable that was made readonly is going out of * scope, we want to remove the readonlyness so that it can * go out of scope quietly */ if (SvPADMY(sv) && !SvFAKE(sv)) SvREADONLY_off(sv); if (SvTHINKFIRST(sv)) sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF); We can simply drop the globness in sv_force_normal instead of flatten- ing globs to strings. The same applies to COWs. The SV_COW_DROP_PV flag accomplishes both. Before and after: $ time ./miniperl -e 'for (1..1000000) { my $x = *foo }' real 0m2.324s user 0m2.316s sys 0m0.006s $ time ./miniperl -e 'for (1..1000000) { my $x = *foo }' real 0m0.848s user 0m0.840s sys 0m0.005s M scope.c ----------------------------------------------------------------------- Summary of changes: dist/Storable/Storable.pm | 6 +- dist/Storable/Storable.xs | 108 +++++++++++++++++++++++++++++++++++++++++++-- dist/Storable/t/blessed.t | 28 +++++++++--- dist/Storable/t/malice.t | 8 ++-- perl.h | 4 +- scope.c | 3 +- 6 files changed, 137 insertions(+), 20 deletions(-) diff --git a/dist/Storable/Storable.pm b/dist/Storable/Storable.pm index 15cb656..c2004f0 100644 --- a/dist/Storable/Storable.pm +++ b/dist/Storable/Storable.pm @@ -21,7 +21,7 @@ package Storable; @ISA = qw(Exporter); use vars qw($canonical $forgive_me $VERSION); -$VERSION = '2.37'; +$VERSION = '2.38'; BEGIN { if (eval { local $SIG{__DIE__}; require Log::Agent; 1 }) { @@ -905,8 +905,8 @@ This returns the file format version as number. It is a string like "2.007". This value is suitable for numeric comparisons. The constant function C<Storable::BIN_VERSION_NV> returns a comparable -number that represent the highest file version number that this -version of Storable fully support (but see discussion of +number that represents the highest file version number that this +version of Storable fully supports (but see discussion of C<$Storable::accept_future_minor> above). The constant C<Storable::BIN_WRITE_VERSION_NV> function returns what file version is written and might be less than C<Storable::BIN_VERSION_NV> in some diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs index 3975ac9..33f6850 100644 --- a/dist/Storable/Storable.xs +++ b/dist/Storable/Storable.xs @@ -148,7 +148,9 @@ #define SX_CODE C(26) /* Code references as perl source code */ #define SX_WEAKREF C(27) /* Weak reference to object forthcoming */ #define SX_WEAKOVERLOAD C(28) /* Overloaded weak reference */ -#define SX_ERROR C(29) /* Error */ +#define SX_VSTRING C(29) /* vstring forthcoming (small) */ +#define SX_LVSTRING C(30) /* vstring forthcoming (large) */ +#define SX_ERROR C(31) /* Error */ /* * Those are only used to retrieve "old" pre-0.6 binary images. @@ -259,6 +261,9 @@ typedef unsigned long stag_t; /* Used by pre-0.6 binary format */ #ifndef SvWEAKREF #define WEAKREF_CROAK() CROAK(("Cannot retrieve weak references in this perl")) #endif +#ifndef SvVOK +#define VSTRING_CROAK() CROAK(("Cannot retrieve vstring in this perl")) +#endif #ifdef HvPLACEHOLDERS #define HAS_RESTRICTED_HASHES @@ -788,15 +793,17 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; #endif #define STORABLE_BIN_MAJOR 2 /* Binary major "version" */ -#define STORABLE_BIN_MINOR 8 /* Binary minor "version" */ +#define STORABLE_BIN_MINOR 9 /* Binary minor "version" */ #if (PATCHLEVEL <= 5) #define STORABLE_BIN_WRITE_MINOR 4 -#else +#elif !defined (SvVOK) /* - * Perl 5.6.0 onwards can do weak references. + * Perl 5.6.0-5.8.0 can do weak references, but not vstring magic. */ #define STORABLE_BIN_WRITE_MINOR 8 +#else +#define STORABLE_BIN_WRITE_MINOR 9 #endif /* (PATCHLEVEL <= 5) */ #if (PATCHLEVEL < 8 || (PATCHLEVEL == 8 && SUBVERSION < 1)) @@ -1128,6 +1135,8 @@ static const sv_retrieve_t sv_old_retrieve[] = { (sv_retrieve_t)retrieve_other, /* SX_CODE not supported */ (sv_retrieve_t)retrieve_other, /* SX_WEAKREF not supported */ (sv_retrieve_t)retrieve_other, /* SX_WEAKOVERLOAD not supported */ + (sv_retrieve_t)retrieve_other, /* SX_VSTRING not supported */ + (sv_retrieve_t)retrieve_other, /* SX_LVSTRING not supported */ (sv_retrieve_t)retrieve_other, /* SX_ERROR */ }; @@ -1146,6 +1155,8 @@ static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname); static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname); static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, const char *cname); static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_vstring(pTHX_ stcxt_t *cxt, const char *cname); +static SV *retrieve_lvstring(pTHX_ stcxt_t *cxt, const char *cname); static const sv_retrieve_t sv_retrieve[] = { 0, /* SX_OBJECT -- entry unused dynamically */ @@ -1177,6 +1188,8 @@ static const sv_retrieve_t sv_retrieve[] = { (sv_retrieve_t)retrieve_code, /* SX_CODE */ (sv_retrieve_t)retrieve_weakref, /* SX_WEAKREF */ (sv_retrieve_t)retrieve_weakoverloaded, /* SX_WEAKOVERLOAD */ + (sv_retrieve_t)retrieve_vstring, /* SX_VSTRING */ + (sv_retrieve_t)retrieve_lvstring, /* SX_LVSTRING */ (sv_retrieve_t)retrieve_other, /* SX_ERROR */ }; @@ -1938,8 +1951,13 @@ static int store_ref(pTHX_ stcxt_t *cxt, SV *sv) * Store a scalar. * * Layout is SX_LSCALAR <length> <data>, SX_SCALAR <length> <data> or SX_UNDEF. + * SX_LUTF8STR and SX_UTF8STR are used for UTF-8 strings. * The <data> section is omitted if <length> is 0. * + * For vstrings, the vstring portion is stored first with + * SX_LVSTRING <length> <data> or SX_VSTRING <length> <data>, followed by + * SX_(L)SCALAR or SX_(L)UTF8STR with the actual PV. + * * If integer or double, the layout is SX_INTEGER <data> or SX_DOUBLE <data>. * Small integers (within [-127, +127]) are stored as SX_BYTE <byte>. */ @@ -2116,6 +2134,9 @@ static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv) TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv)); } else if (flags & (SVp_POK | SVp_NOK | SVp_IOK)) { +#ifdef SvVOK + MAGIC *mg; +#endif I32 wlen; /* For 64-bit machines */ string_readlen: @@ -2127,6 +2148,12 @@ static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv) */ string: +#ifdef SvVOK + if (SvMAGICAL(sv) && (mg = mg_find(sv, 'V'))) + STORE_PV_LEN((const char *)mg->mg_ptr, + mg->mg_len, SX_VSTRING, SX_LVSTRING); +#endif + wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */ if (SvUTF8 (sv)) STORE_UTF8STR(pv, wlen); @@ -4860,6 +4887,79 @@ static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, const char *cname) } /* + * retrieve_vstring + * + * Retrieve a vstring, and then retrieve the stringy scalar following it, + * attaching the vstring to the scalar via magic. + * If we're retrieving a vstring in a perl without vstring magic, croaks. + * + * The vstring layout mirrors an SX_SCALAR string: + * SX_VSTRING <length> <data> with SX_VSTRING already read. + */ +static SV *retrieve_vstring(pTHX_ stcxt_t *cxt, const char *cname) +{ +#ifdef SvVOK + MAGIC *mg; + char s[256]; + int len; + SV *sv; + + GETMARK(len); + TRACEME(("retrieve_vstring (#%d), len = %d", cxt->tagnum, len)); + + READ(s, len); + + sv = retrieve(aTHX_ cxt, cname); + + sv_magic(sv,NULL,PERL_MAGIC_vstring,s,len); + /* 5.10.0 and earlier seem to need this */ + SvRMAGICAL_on(sv); + + TRACEME(("ok (retrieve_vstring at 0x%"UVxf")", PTR2UV(sv))); + return sv; +#else + VSTRING_CROAK(); + return Nullsv; +#endif +} + +/* + * retrieve_lvstring + * + * Like retrieve_vstring, but for longer vstrings. + */ +static SV *retrieve_lvstring(pTHX_ stcxt_t *cxt, const char *cname) +{ +#ifdef SvVOK + MAGIC *mg; + char *s; + I32 len; + SV *sv; + + RLEN(len); + TRACEME(("retrieve_lvstring (#%d), len = %"IVdf, + cxt->tagnum, (IV)len)); + + New(10003, s, len+1, char); + SAFEPVREAD(s, len, s); + + sv = retrieve(aTHX_ cxt, 0); + + sv_magic(sv,NULL,PERL_MAGIC_vstring,s,len); + /* 5.10.0 and earlier seem to need this */ + SvRMAGICAL_on(sv); + + Safefree(s); + + TRACEME(("ok (retrieve_lvstring at 0x%"UVxf")", PTR2UV(sv))); + return sv; +#else + VSTRING_CROAK(); + return Nullsv; +#endif +} + +/* * retrieve_integer * * Retrieve defined integer. diff --git a/dist/Storable/t/blessed.t b/dist/Storable/t/blessed.t index 775592d..7c088e3 100644 --- a/dist/Storable/t/blessed.t +++ b/dist/Storable/t/blessed.t @@ -35,7 +35,7 @@ use Storable qw(freeze thaw store retrieve); } my $test = 12; -my $tests = $test + 23 + (2 * 6 * keys %::immortals) + (2 * keys %::weird_refs); +my $tests = $test + 23 + (2 * 6 * keys %::immortals) + (3 * keys %::weird_refs); plan(tests => $tests); package SHORT_NAME; @@ -271,7 +271,7 @@ is(ref $t, 'STRESS_THE_STACK'); { { package WeirdRefHook; - sub STORABLE_freeze { } + sub STORABLE_freeze { () } $INC{'WeirdRefHook.pm'} = __FILE__; } @@ -282,9 +282,25 @@ is(ref $t, 'STRESS_THE_STACK'); my $success = eval { $frozen = freeze($obj); 1 }; ok($success, "can freeze $weird objects") || diag("freezing failed: $@"); - local $TODO = $weird eq 'VSTRING' - ? "can't store vstrings properly yet" - : undef; - is_deeply(thaw($frozen), $obj, "get the right value back"); + my $thawn = thaw($frozen); + # is_deeply ignores blessings + is ref $thawn, ref $obj, "get the right blessing back for $weird"; + if ($weird eq 'VSTRING') { + # It is not just Storable that did not support vstrings. :-) + # See https://rt.cpan.org/Ticket/Display.html?id=78678 + my $newver = "version"->can("new") + ? sub { "version"->new(shift) } + : sub { "" }; + if (!ok + $$thawn eq $$obj && &$newver($$thawn) eq &$newver($$obj), + "get the right value back" + ) { + diag "$$thawn vs $$obj"; + diag &$newver($$thawn) eq &$newver($$obj) if &$newver(1); + } + } + else { + is_deeply($thawn, $obj, "get the right value back"); + } } } diff --git a/dist/Storable/t/malice.t b/dist/Storable/t/malice.t index 79df2d5..ffc9fcf 100644 --- a/dist/Storable/t/malice.t +++ b/dist/Storable/t/malice.t @@ -34,8 +34,8 @@ $file_magic_str = 'pst0'; $other_magic = 7 + length $byteorder; $network_magic = 2; $major = 2; -$minor = 8; -$minor_write = $] > 5.005_50 ? 8 : 4; +$minor = 9; +$minor_write = $] > 5.008 ? 9 : $] > 5.005_50 ? 8 : 4; use Test::More; @@ -208,7 +208,7 @@ sub test_things { $where = $file_magic + $network_magic; } - # Just the header and a tag 255. As 28 is currently the highest tag, this + # Just the header and a tag 255. As 30 is currently the highest tag, this # is "unexpected" $copy = substr ($contents, 0, $where) . chr 255; @@ -228,7 +228,7 @@ sub test_things { # local $Storable::DEBUGME = 1; # This is the delayed croak test_corrupt ($copy, $sub, - "/^Storable binary image v$header->{major}.$minor6 contains data of type 255. This Storable is v$header->{major}.$minor and can only handle data types up to 28/", + "/^Storable binary image v$header->{major}.$minor6 contains data of type 255. This Storable is v$header->{major}.$minor and can only handle data types up to 30/", "bogus tag, minor plus 4"); # And check again that this croak is not delayed: { diff --git a/perl.h b/perl.h index 614f280..ad8f6a9 100644 --- a/perl.h +++ b/perl.h @@ -2721,12 +2721,12 @@ typedef struct clone_params CLONE_PARAMS; #endif /* -=for apidoc Am|void|PERL_SYS_INIT|int argc|char** argv +=for apidoc Am|void|PERL_SYS_INIT|int *argc|char*** argv Provides system-specific tune up of the C runtime environment necessary to run Perl interpreters. This should be called only once, before creating any Perl interpreters. -=for apidoc Am|void|PERL_SYS_INIT3|int argc|char** argv|char** env +=for apidoc Am|void|PERL_SYS_INIT3|int *argc|char*** argv|char*** env Provides system-specific tune up of the C runtime environment necessary to run Perl interpreters. This should be called only once, before creating any Perl interpreters. diff --git a/scope.c b/scope.c index 2a9b3d5..d42aa80 100644 --- a/scope.c +++ b/scope.c @@ -911,7 +911,8 @@ Perl_leave_scope(pTHX_ I32 base) SvREADONLY_off(sv); if (SvTHINKFIRST(sv)) - sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF); + sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF + |SV_COW_DROP_PV); if (SvTYPE(sv) == SVt_PVHV) Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv)); if (SvMAGICAL(sv)) -- Perl5 Master Repository
