In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/bb85b28a6da36a76a3909c40a8a5f0a80a04163c?hp=4d0a25002d260ca3ae716f2f0be258eb5d040c74>
- Log ----------------------------------------------------------------- commit bb85b28a6da36a76a3909c40a8a5f0a80a04163c Author: Nicholas Clark <[email protected]> Date: Sat Aug 8 15:28:31 2009 +0100 Merge gv_IOadd() into gv_add_by_type(). M embed.fnc M embed.h M gv.c M gv.h M mathoms.c M proto.h commit 85dca89a8f321bc581a3d365d95ab0c56368ed78 Author: Nicholas Clark <[email protected]> Date: Sat Aug 8 15:01:48 2009 +0100 Perl_newIO() can become a mathom by making newIO() a wrapper around newSV_type() and tweaking Perl_sv_upgrade(). M embed.fnc M embed.h M gv.c M mathoms.c M proto.h M sv.c M sv.h commit d5713896ecd1399c9c6c4076514a33eb2880d8c3 Author: Nicholas Clark <[email protected]> Date: Sat Aug 8 12:05:40 2009 +0100 Merge gv_AVadd(), gv_HVadd() and gv_SVadd() into gv_add_by_type(). The "short" names become macro wrappers, and the Perl_* versions become mathoms. M embed.fnc M embed.h M global.sym M gv.c M gv.h M mathoms.c M proto.h M t/pod/diag.t commit 1776cbe8523bf67a0626da7b721abaf9f0f8870a Author: Nicholas Clark <[email protected]> Date: Sat Aug 8 10:20:40 2009 +0100 Move the "types are equal" early return ahead of the COW-removal. M sv.c ----------------------------------------------------------------------- Summary of changes: embed.fnc | 11 +++--- embed.h | 12 +----- global.sym | 1 + gv.c | 110 +++++++++++++++++----------------------------------------- gv.h | 5 +++ mathoms.c | 33 +++++++++++++++++ proto.h | 25 ++++--------- sv.c | 31 ++++++++++++++-- sv.h | 3 ++ t/pod/diag.t | 2 +- 10 files changed, 117 insertions(+), 116 deletions(-) diff --git a/embed.fnc b/embed.fnc index 54389d5..0f554e5 100644 --- a/embed.fnc +++ b/embed.fnc @@ -339,9 +339,10 @@ p |char* |getenv_len |NN const char *env_elem|NN unsigned long *len pox |void |get_db_sub |NULLOK SV **svp|NN CV *cv Ap |void |gp_free |NULLOK GV* gv Ap |GP* |gp_ref |NULLOK GP* gp -Ap |GV* |gv_AVadd |NN GV* gv -Ap |GV* |gv_HVadd |NN GV* gv -Ap |GV* |gv_IOadd |NULLOK GV* gv +Ap |GV* |gv_add_by_type |NULLOK GV *gv|svtype type +Apmb |GV* |gv_AVadd |NULLOK GV *gv +Apmb |GV* |gv_HVadd |NULLOK GV *gv +Apmb |GV* |gv_IOadd |NULLOK GV* gv ApR |GV* |gv_autoload4 |NULLOK HV* stash|NN const char* name|STRLEN len|I32 method Ap |void |gv_check |NN const HV* stash Ap |void |gv_efullname |NN SV* sv|NN const GV* gv @@ -681,7 +682,7 @@ Apa |OP* |newGVREF |I32 type|NULLOK OP* o ApaR |OP* |newHVREF |NN OP* o AmdbR |HV* |newHV ApaR |HV* |newHVhv |NULLOK HV *hv -Apa |IO* |newIO +Apabm |IO* |newIO Apa |OP* |newLISTOP |I32 type|I32 flags|NULLOK OP* first|NULLOK OP* last #ifdef USE_ITHREADS Apa |OP* |newPADOP |I32 type|I32 flags|NN SV* sv @@ -2081,7 +2082,7 @@ p |void |dump_sv_child |NN SV *sv #endif #ifdef PERL_DONT_CREATE_GVSV -Ap |GV* |gv_SVadd |NN GV* gv +Apbm |GV* |gv_SVadd |NULLOK GV *gv #endif Apo |bool |ckwarn |U32 w Apo |bool |ckwarn_d |U32 w diff --git a/embed.h b/embed.h index 0847c63..b042886 100644 --- a/embed.h +++ b/embed.h @@ -268,9 +268,7 @@ #endif #define gp_free Perl_gp_free #define gp_ref Perl_gp_ref -#define gv_AVadd Perl_gv_AVadd -#define gv_HVadd Perl_gv_HVadd -#define gv_IOadd Perl_gv_IOadd +#define gv_add_by_type Perl_gv_add_by_type #define gv_autoload4 Perl_gv_autoload4 #define gv_check Perl_gv_check #define gv_efullname Perl_gv_efullname @@ -571,7 +569,6 @@ #define newGVREF Perl_newGVREF #define newHVREF Perl_newHVREF #define newHVhv Perl_newHVhv -#define newIO Perl_newIO #define newLISTOP Perl_newLISTOP #ifdef USE_ITHREADS #define newPADOP Perl_newPADOP @@ -1877,7 +1874,6 @@ #endif #endif #ifdef PERL_DONT_CREATE_GVSV -#define gv_SVadd Perl_gv_SVadd #endif #ifdef PERL_CORE #define offer_nice_chunk Perl_offer_nice_chunk @@ -2599,9 +2595,7 @@ #endif #define gp_free(a) Perl_gp_free(aTHX_ a) #define gp_ref(a) Perl_gp_ref(aTHX_ a) -#define gv_AVadd(a) Perl_gv_AVadd(aTHX_ a) -#define gv_HVadd(a) Perl_gv_HVadd(aTHX_ a) -#define gv_IOadd(a) Perl_gv_IOadd(aTHX_ a) +#define gv_add_by_type(a,b) Perl_gv_add_by_type(aTHX_ a,b) #define gv_autoload4(a,b,c,d) Perl_gv_autoload4(aTHX_ a,b,c,d) #define gv_check(a) Perl_gv_check(aTHX_ a) #define gv_efullname(a,b) Perl_gv_efullname(aTHX_ a,b) @@ -2910,7 +2904,6 @@ #define newGVREF(a,b) Perl_newGVREF(aTHX_ a,b) #define newHVREF(a) Perl_newHVREF(aTHX_ a) #define newHVhv(a) Perl_newHVhv(aTHX_ a) -#define newIO() Perl_newIO(aTHX) #define newLISTOP(a,b,c,d) Perl_newLISTOP(aTHX_ a,b,c,d) #ifdef USE_ITHREADS #define newPADOP(a,b,c) Perl_newPADOP(aTHX_ a,b,c) @@ -4228,7 +4221,6 @@ #endif #endif #ifdef PERL_DONT_CREATE_GVSV -#define gv_SVadd(a) Perl_gv_SVadd(aTHX_ a) #endif #if defined(PERL_CORE) || defined(PERL_EXT) #endif diff --git a/global.sym b/global.sym index de14a7b..115490a 100644 --- a/global.sym +++ b/global.sym @@ -126,6 +126,7 @@ Perl_vform Perl_free_tmps Perl_gp_free Perl_gp_ref +Perl_gv_add_by_type Perl_gv_AVadd Perl_gv_HVadd Perl_gv_IOadd diff --git a/gv.c b/gv.c index f16e0ac..c97d99c 100644 --- a/gv.c +++ b/gv.c @@ -40,70 +40,45 @@ Perl stores its global variables. static const char S_autoload[] = "AUTOLOAD"; static const STRLEN S_autolen = sizeof(S_autoload)-1; - -#ifdef PERL_DONT_CREATE_GVSV -GV * -Perl_gv_SVadd(pTHX_ GV *gv) -{ - PERL_ARGS_ASSERT_GV_SVADD; - - if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) - Perl_croak(aTHX_ "Bad symbol for scalar"); - if (!GvSV(gv)) - GvSV(gv) = newSV(0); - return gv; -} -#endif - -GV * -Perl_gv_AVadd(pTHX_ register GV *gv) -{ - PERL_ARGS_ASSERT_GV_AVADD; - - if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) - Perl_croak(aTHX_ "Bad symbol for array"); - if (!GvAV(gv)) - GvAV(gv) = newAV(); - return gv; -} - -GV * -Perl_gv_HVadd(pTHX_ register GV *gv) -{ - PERL_ARGS_ASSERT_GV_HVADD; - - if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) - Perl_croak(aTHX_ "Bad symbol for hash"); - if (!GvHV(gv)) - GvHV(gv) = newHV(); - return gv; -} - GV * -Perl_gv_IOadd(pTHX_ register GV *gv) +Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) { - dVAR; + SV **where; if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) { - - /* - * if it walks like a dirhandle, then let's assume that - * this is a dirhandle. - */ - const char * const fh = - PL_op->op_type == OP_READDIR || - PL_op->op_type == OP_TELLDIR || - PL_op->op_type == OP_SEEKDIR || - PL_op->op_type == OP_REWINDDIR || - PL_op->op_type == OP_CLOSEDIR ? - "dirhandle" : "filehandle"; - /* diag_listed_as: Bad symbol for filehandle */ - Perl_croak(aTHX_ "Bad symbol for %s", fh); + const char *what; + if (type == SVt_PVIO) { + /* + * if it walks like a dirhandle, then let's assume that + * this is a dirhandle. + */ + what = PL_op->op_type == OP_READDIR || + PL_op->op_type == OP_TELLDIR || + PL_op->op_type == OP_SEEKDIR || + PL_op->op_type == OP_REWINDDIR || + PL_op->op_type == OP_CLOSEDIR ? + "dirhandle" : "filehandle"; + /* diag_listed_as: Bad symbol for filehandle */ + } else if (type == SVt_PVHV) { + what = "hash"; + } else { + what = type == SVt_PVAV ? "array" : "scalar"; + } + Perl_croak(aTHX_ "Bad symbol for %s", what); } - if (!GvIOp(gv)) { - GvIOp(gv) = newIO(); + if (type == SVt_PVHV) { + where = (SV **)&GvHV(gv); + } else if (type == SVt_PVAV) { + where = (SV **)&GvAV(gv); + } else if (type == SVt_PVIO) { + where = (SV **)&GvIOp(gv); + } else { + where = &GvSV(gv); } + + if (!*where) + *where = newSV_type(type); return gv; } @@ -1501,27 +1476,6 @@ Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain gv_fullname4(sv, egv ? egv : gv, prefix, keepmain); } -IO * -Perl_newIO(pTHX) -{ - dVAR; - GV *iogv; - IO * const io = MUTABLE_IO(newSV_type(SVt_PVIO)); - /* This used to read SvREFCNT(io) = 1; - It's not clear why the reference count needed an explicit reset. NWC - */ - assert (SvREFCNT(io) == 1); - SvOBJECT_on(io); - /* Clear the stashcache because a new IO could overrule a package name */ - hv_clear(PL_stashcache); - iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV); - /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */ - if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv)))) - iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV); - SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); - return io; -} - void Perl_gv_check(pTHX_ const HV *stash) { diff --git a/gv.h b/gv.h index 8344997..caef3da 100644 --- a/gv.h +++ b/gv.h @@ -207,6 +207,11 @@ Return the SV from the GV. #define gv_efullname3(sv,gv,prefix) gv_efullname4(sv,gv,prefix,TRUE) #define gv_fetchmethod(stash, name) gv_fetchmethod_autoload(stash, name, TRUE) +#define gv_AVadd(gv) gv_add_by_type((gv), SVt_PVAV) +#define gv_HVadd(gv) gv_add_by_type((gv), SVt_PVHV) +#define gv_IOadd(gv) gv_add_by_type((gv), SVt_PVIO) +#define gv_SVadd(gv) gv_add_by_type((gv), SVt_NULL) + /* * Local variables: * c-indentation-style: bsd diff --git a/mathoms.c b/mathoms.c index 7eae87e..108b762 100644 --- a/mathoms.c +++ b/mathoms.c @@ -76,6 +76,7 @@ PERL_CALLCONV int Perl_printf_nocontext(const char *format, ...); PERL_CALLCONV int Perl_magic_setglob(pTHX_ SV* sv, MAGIC* mg); PERL_CALLCONV AV * Perl_newAV(pTHX); PERL_CALLCONV HV * Perl_newHV(pTHX); +PERL_CALLCONV IO * Perl_newIO(pTHX); /* ref() is now a macro using Perl_doref; * this version provided for binary compatibility only. @@ -1473,6 +1474,38 @@ Perl_save_op(pTHX) save_op(); } +#ifdef PERL_DONT_CREATE_GVSV +GV * +Perl_gv_SVadd(pTHX_ GV *gv) +{ + return gv_SVadd(gv); +} +#endif + +GV * +Perl_gv_AVadd(pTHX_ GV *gv) +{ + return gv_AVadd(gv); +} + +GV * +Perl_gv_HVadd(pTHX_ register GV *gv) +{ + return gv_HVadd(gv); +} + +GV * +Perl_gv_IOadd(pTHX_ register GV *gv) +{ + return gv_IOadd(gv); +} + +IO * +Perl_newIO(pTHX) +{ + return MUTABLE_IO(newSV_type(SVt_PVIO)); +} + #endif /* NO_MATHOMS */ /* diff --git a/proto.h b/proto.h index 8241132..4e47b8c 100644 --- a/proto.h +++ b/proto.h @@ -832,17 +832,10 @@ PERL_CALLCONV void Perl_get_db_sub(pTHX_ SV **svp, CV *cv) PERL_CALLCONV void Perl_gp_free(pTHX_ GV* gv); PERL_CALLCONV GP* Perl_gp_ref(pTHX_ GP* gp); -PERL_CALLCONV GV* Perl_gv_AVadd(pTHX_ GV* gv) - __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_GV_AVADD \ - assert(gv) - -PERL_CALLCONV GV* Perl_gv_HVadd(pTHX_ GV* gv) - __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_GV_HVADD \ - assert(gv) - -PERL_CALLCONV GV* Perl_gv_IOadd(pTHX_ GV* gv); +PERL_CALLCONV GV* Perl_gv_add_by_type(pTHX_ GV *gv, svtype type); +/* PERL_CALLCONV GV* Perl_gv_AVadd(pTHX_ GV *gv); */ +/* PERL_CALLCONV GV* Perl_gv_HVadd(pTHX_ GV *gv); */ +/* PERL_CALLCONV GV* Perl_gv_IOadd(pTHX_ GV* gv); */ PERL_CALLCONV GV* Perl_gv_autoload4(pTHX_ HV* stash, const char* name, STRLEN len, I32 method) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_2); @@ -2118,9 +2111,9 @@ PERL_CALLCONV HV* Perl_newHVhv(pTHX_ HV *hv) __attribute__malloc__ __attribute__warn_unused_result__; -PERL_CALLCONV IO* Perl_newIO(pTHX) +/* PERL_CALLCONV IO* Perl_newIO(pTHX) __attribute__malloc__ - __attribute__warn_unused_result__; + __attribute__warn_unused_result__; */ PERL_CALLCONV OP* Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP* first, OP* last) __attribute__malloc__ @@ -6342,11 +6335,7 @@ PERL_CALLCONV void Perl_dump_sv_child(pTHX_ SV *sv) #endif #ifdef PERL_DONT_CREATE_GVSV -PERL_CALLCONV GV* Perl_gv_SVadd(pTHX_ GV* gv) - __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_GV_SVADD \ - assert(gv) - +/* PERL_CALLCONV GV* Perl_gv_SVadd(pTHX_ GV *gv); */ #endif PERL_CALLCONV bool Perl_ckwarn(pTHX_ U32 w); PERL_CALLCONV bool Perl_ckwarn_d(pTHX_ U32 w); diff --git a/sv.c b/sv.c index a22316c..b8daf81 100644 --- a/sv.c +++ b/sv.c @@ -1185,13 +1185,22 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) PERL_ARGS_ASSERT_SV_UPGRADE; + if (old_type == new_type) + return; + + /* This clause was purposefully added ahead of the early return above to + the shared string hackery for (sort {$a <=> $b} keys %hash), with the + inference by Nick I-S that it would fix other troublesome cases. See + changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent) + + Given that shared hash key scalars are no longer PVIV, but PV, there is + no longer need to unshare so as to free up the IVX slot for its proper + purpose. So it's safe to move the early return earlier. */ + if (new_type != SVt_PV && SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); } - if (old_type == new_type) - return; - old_body = SvANY(sv); /* Copying structures onto other structures that have been neatly zeroed @@ -1421,8 +1430,22 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) SvNV_set(sv, 0); #endif - if (new_type == SVt_PVIO) + if (new_type == SVt_PVIO) { + IO * const io = MUTABLE_IO(sv); + GV *iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV); + + SvOBJECT_on(io); + /* Clear the stashcache because a new IO could overrule a package + name */ + hv_clear(PL_stashcache); + + /* unless exists($main::{FileHandle}) and + defined(%main::FileHandle::) */ + if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv)))) + iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV); + SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); IoPAGE_LEN(sv) = 60; + } if (old_type < SVt_PV) { /* referant will be NULL unless the old type was SVt_IV emulating SVt_RV */ diff --git a/sv.h b/sv.h index 0d275d2..90771a4 100644 --- a/sv.h +++ b/sv.h @@ -2016,6 +2016,9 @@ Evaluates I<sv> more than once. Sets I<len> to 0 if C<SvOOK(sv)> is false. } \ } STMT_END #endif + +#define newIO() MUTABLE_IO(newSV_type(SVt_PVIO)) + /* * Local variables: * c-indentation-style: bsd diff --git a/t/pod/diag.t b/t/pod/diag.t index 5f378ae..cfe572f 100644 --- a/t/pod/diag.t +++ b/t/pod/diag.t @@ -191,7 +191,7 @@ Attempt to free unreferenced scalar: SV 0x%x Attempt to reload %s aborted. Compilation failed in require av_reify called on tied array Bad name after %s%s -Bad symbol for scalar +Bad symbol for %s bad top format reference Bizarre copy of %s Bizarre SvTYPE [%d] -- Perl5 Master Repository
