X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=2bb9ccbef3ca8f59004691b3c0abe70b4f54aab4;hb=404c68920bc89ad702536fbd16b3bceafd287acb;hp=c7ab061f4f02ef989bb208020bcc0e96372e9d90;hpb=be2597dfdde55c276ac6c4b68dadc448c601d0cc;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index c7ab061..2bb9ccb 100644 --- a/gv.c +++ b/gv.c @@ -1,7 +1,7 @@ /* gv.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -105,7 +105,7 @@ GV * Perl_gv_fetchfile(pTHX_ const char *name) { dVAR; - char smallbuf[256]; + char smallbuf[128]; char *tmpbuf; STRLEN tmplen; GV *gv; @@ -113,22 +113,22 @@ Perl_gv_fetchfile(pTHX_ const char *name) if (!PL_defstash) return NULL; - tmplen = strlen(name) + 2; - if (tmplen < sizeof smallbuf) + tmplen = strlen(name); + if (tmplen + 2 <= sizeof smallbuf) tmpbuf = smallbuf; else - Newx(tmpbuf, tmplen + 1, char); + Newx(tmpbuf, tmplen, char); /* This is where the debugger's %{"::_<$filename"} hash is created */ tmpbuf[0] = '_'; tmpbuf[1] = '<'; - memcpy(tmpbuf + 2, name, tmplen - 1); - gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE); + memcpy(tmpbuf + 2, name, tmplen); + gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen + 2, TRUE); if (!isGV(gv)) { - gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); + gv_init(gv, PL_defstash, tmpbuf, tmplen + 2, FALSE); #ifdef PERL_DONT_CREATE_GVSV - GvSV(gv) = newSVpvn(name, tmplen - 2); + GvSV(gv) = newSVpvn(name, tmplen); #else - sv_setpvn(GvSV(gv), name, tmplen - 2); + sv_setpvn(GvSV(gv), name, tmplen); #endif if (PERLDB_LINE) hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile); @@ -161,7 +161,8 @@ GP * Perl_newGP(pTHX_ GV *const gv) { GP *gp; - const char *const file = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : ""; + const char *const file + = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : ""; STRLEN len = strlen(file); U32 hash; @@ -170,10 +171,10 @@ Perl_newGP(pTHX_ GV *const gv) Newxz(gp, 1, GP); #ifndef PERL_DONT_CREATE_GVSV - gp->gv_sv = newSV(0); + gp->gp_sv = newSV(0); #endif - gp->gp_line = CopLINE(PL_curcop); + gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0; /* XXX Ideally this cast would be replaced with a change to const char* in the struct. */ gp->gp_file_hek = share_hek(file, len, hash); @@ -324,7 +325,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) /* UNIVERSAL methods should be callable without a stash */ if (!stash) { level = -1; /* probably appropriate */ - if(!(stash = gv_stashpvs("UNIVERSAL", FALSE))) + if(!(stash = gv_stashpvs("UNIVERSAL", 0))) return 0; } @@ -370,7 +371,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) HV* basestash; packlen -= 7; - basestash = gv_stashpvn(hvname, packlen, TRUE); + basestash = gv_stashpvn(hvname, packlen, GV_ADD); gvp = (GV**)hv_fetchs(basestash, "ISA", FALSE); if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { gvp = (GV**)hv_fetchs(stash, "ISA", TRUE); @@ -390,7 +391,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) I32 items = AvFILLp(av) + 1; while (items--) { SV* const sv = *svp++; - HV* const basestash = gv_stashsv(sv, FALSE); + HV* const basestash = gv_stashsv(sv, 0); if (!basestash) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA", @@ -407,7 +408,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) /* if at top level, try UNIVERSAL */ if (level == 0 || level == -1) { - lastchance = gv_stashpvs("UNIVERSAL", FALSE); + lastchance = gv_stashpvs("UNIVERSAL", 0); if (lastchance) { if ((gv = gv_fetchmeth(lastchance, name, len, @@ -539,20 +540,20 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", CopSTASHPV(PL_curcop))); /* __PACKAGE__::SUPER stash should be autovivified */ - stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE); + stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), GV_ADD); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", origname, HvNAME_get(stash), name) ); } else { /* don't autovifify if ->NoSuchStash::method */ - stash = gv_stashpvn(origname, nsplit - origname, FALSE); + stash = gv_stashpvn(origname, nsplit - origname, 0); /* however, explicit calls to Pkg::SUPER::method may happen, and may require autovivification to work */ if (!stash && (nsplit - origname) >= 7 && strnEQ(nsplit - 7, "::SUPER", 7) && - gv_stashpvn(origname, nsplit - origname - 7, FALSE)) - stash = gv_stashpvn(origname, nsplit - origname, TRUE); + gv_stashpvn(origname, nsplit - origname - 7, 0)) + stash = gv_stashpvn(origname, nsplit - origname, GV_ADD); } ostash = stash; } @@ -681,7 +682,7 @@ STATIC HV* S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags) { dVAR; - HV* stash = gv_stashsv(namesv, FALSE); + HV* stash = gv_stashsv(namesv, 0); if (!stash || !(gv_fetchmethod(stash, methpv))) { SV *module = newSVsv(namesv); @@ -693,13 +694,13 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methp Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); LEAVE; SPAGAIN; - stash = gv_stashsv(namesv, FALSE); + stash = gv_stashsv(namesv, 0); if (!stash) Perl_croak( aTHX_ "panic: Can't use %%%s because %"SVf" is not available", - varpv, module); + varpv, SVfARG(module)); else if (!gv_fetchmethod(stash, methpv)) Perl_croak( aTHX_ "panic: Can't use %%%s because %"SVf" does not support method %s", - varpv, module, methpv); + varpv, SVfARG(module), methpv); } return stash; } @@ -707,10 +708,8 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methp /* =for apidoc gv_stashpv -Returns a pointer to the stash for a specified package. C should -be a valid UTF-8 string and must be null-terminated. If C is set -then the package will be created if it does not already exist. If C -is not set and the package does not exist then NULL is returned. +Returns a pointer to the stash for a specified package. Uses C to +determine the length of C. =cut */ @@ -724,36 +723,37 @@ Perl_gv_stashpv(pTHX_ const char *name, I32 create) /* =for apidoc gv_stashpvn -Returns a pointer to the stash for a specified package. C should -be a valid UTF-8 string. The C parameter indicates the length of -the C, in bytes. If C is set then the package will be -created if it does not already exist. If C is not set and the -package does not exist then NULL is returned. +Returns a pointer to the stash for a specified package. The C +parameter indicates the length of the C, in bytes. C is passed +to C, so if set to C then the package will be +created if it does not already exist. If the package does not exist and +C is 0 (or any other setting that does not create packages) then NULL +is returned. + =cut */ HV* -Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create) +Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) { char smallbuf[128]; char *tmpbuf; HV *stash; GV *tmpgv; - if (namelen + 3 < sizeof smallbuf) + if (namelen + 2 <= sizeof smallbuf) tmpbuf = smallbuf; else - Newx(tmpbuf, namelen + 3, char); + Newx(tmpbuf, namelen + 2, char); Copy(name,tmpbuf,namelen,char); tmpbuf[namelen++] = ':'; tmpbuf[namelen++] = ':'; - tmpbuf[namelen] = '\0'; - tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, create, SVt_PVHV); + tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, flags, SVt_PVHV); if (tmpbuf != smallbuf) Safefree(tmpbuf); if (!tmpgv) - return 0; + return NULL; if (!GvHV(tmpgv)) GvHV(tmpgv) = newHV(); stash = GvHV(tmpgv); @@ -765,18 +765,17 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create) /* =for apidoc gv_stashsv -Returns a pointer to the stash for a specified package, which must be a -valid UTF-8 string. See C. +Returns a pointer to the stash for a specified package. See C. =cut */ HV* -Perl_gv_stashsv(pTHX_ SV *sv, I32 create) +Perl_gv_stashsv(pTHX_ SV *sv, I32 flags) { STRLEN len; const char * const ptr = SvPV_const(sv,len); - return gv_stashpvn(ptr, len, create); + return gv_stashpvn(ptr, len, flags); } @@ -805,8 +804,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, HV *stash = NULL; const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT); const I32 no_expand = flags & GV_NOEXPAND; - const I32 add = - flags & ~SVf_UTF8 & ~GV_NOADD_NOINIT & ~GV_NOEXPAND & ~GV_NOTQUAL; + const I32 add = flags & ~GV_NOADD_MASK; const char *const name_end = nambeg + full_len; const char *const name_em1 = name_end - 1; @@ -836,14 +834,13 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, char smallbuf[128]; char *tmpbuf; - if (len + 3 < (I32)sizeof (smallbuf)) + if (len + 2 <= (I32)sizeof (smallbuf)) tmpbuf = smallbuf; else - Newx(tmpbuf, len+3, char); + Newx(tmpbuf, len+2, char); Copy(name, tmpbuf, len, char); tmpbuf[len++] = ':'; tmpbuf[len++] = ':'; - tmpbuf[len] = '\0'; gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); gv = gvp ? *gvp : NULL; if (gv && gv != (GV*)&PL_sv_undef) { @@ -1056,15 +1053,15 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, { const char *pname; av_push(av, newSVpvn(pname = "NDBM_File",9)); - gv_stashpvn(pname, 9, TRUE); + gv_stashpvn(pname, 9, GV_ADD); av_push(av, newSVpvn(pname = "DB_File",7)); - gv_stashpvn(pname, 7, TRUE); + gv_stashpvn(pname, 7, GV_ADD); av_push(av, newSVpvn(pname = "GDBM_File",9)); - gv_stashpvn(pname, 9, TRUE); + gv_stashpvn(pname, 9, GV_ADD); av_push(av, newSVpvn(pname = "SDBM_File",9)); - gv_stashpvn(pname, 9, TRUE); + gv_stashpvn(pname, 9, GV_ADD); av_push(av, newSVpvn(pname = "ODBM_File",9)); - gv_stashpvn(pname, 9, TRUE); + gv_stashpvn(pname, 9, GV_ADD); } } break; @@ -1109,10 +1106,16 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (strEQ(name2, "NCODING")) goto magicalize; break; + case '\015': /* $^MATCH */ + if (strEQ(name2, "ATCH")) + goto ro_magicalize; case '\017': /* $^OPEN */ if (strEQ(name2, "PEN")) goto magicalize; break; + case '\020': /* $^PREMATCH $^POSTMATCH */ + if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH")) + goto ro_magicalize; case '\024': /* ${^TAINT} */ if (strEQ(name2, "AINT")) goto ro_magicalize; @@ -1199,7 +1202,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, HV *const hv_tie = newHV(); SV *tie = newRV_noinc((SV*)hv_tie); - sv_bless(tie, gv_stashsv(stashname,1)); + sv_bless(tie, gv_stashsv(stashname,GV_ADD)); hv_magic(hv, (GV*)tie, PERL_MAGIC_tied); sv_magic((SV*)av, (plus ? (SV*)av : NULL), PERL_MAGIC_regdata, NULL, 0); sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);