EXT char rcsid[];
GV *
-gv_AVadd(gv)
-register GV *gv;
+gv_AVadd(register GV *gv)
{
if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
croak("Bad symbol for array");
}
GV *
-gv_HVadd(gv)
-register GV *gv;
+gv_HVadd(register GV *gv)
{
if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
croak("Bad symbol for hash");
}
GV *
-gv_IOadd(gv)
-register GV *gv;
+gv_IOadd(register GV *gv)
{
if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
croak("Bad symbol for filehandle");
}
GV *
-gv_fetchfile(name)
-char *name;
+gv_fetchfile(char *name)
{
- char tmpbuf[1200];
+ dTHR;
+ char smallbuf[256];
+ char *tmpbuf;
STRLEN tmplen;
GV *gv;
- sprintf(tmpbuf, "_<%s", name);
- tmplen = strlen(tmpbuf);
+ tmplen = strlen(name) + 2;
+ if (tmplen < sizeof smallbuf)
+ tmpbuf = smallbuf;
+ else
+ New(603, tmpbuf, tmplen + 1, char);
+ tmpbuf[0] = '_';
+ tmpbuf[1] = '<';
+ strcpy(tmpbuf + 2, name);
gv = *(GV**)hv_fetch(defstash, tmpbuf, tmplen, TRUE);
if (!isGV(gv))
gv_init(gv, defstash, tmpbuf, tmplen, FALSE);
+ if (tmpbuf != smallbuf)
+ Safefree(tmpbuf);
sv_setpv(GvSV(gv), name);
if (*name == '/' && (instr(name, "/lib/") || instr(name, ".pm")))
GvMULTI_on(gv);
- if (perldb)
+ if (PERLDB_LINE)
hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
return gv;
}
void
-gv_init(gv, stash, name, len, multi)
-GV *gv;
-HV *stash;
-char *name;
-STRLEN len;
-int multi;
+gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi)
{
+ dTHR;
register GP *gp;
+ bool doproto = SvTYPE(gv) > SVt_NULL;
+ char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
sv_upgrade((SV*)gv, SVt_PVGV);
- if (SvLEN(gv))
- Safefree(SvPVX(gv));
+ if (SvLEN(gv)) {
+ if (proto) {
+ SvPVX(gv) = NULL;
+ SvLEN(gv) = 0;
+ SvPOK_off(gv);
+ } else
+ Safefree(SvPVX(gv));
+ }
Newz(602, gp, 1, GP);
GvGP(gv) = gp_ref(gp);
GvSV(gv) = NEWSV(72,0);
GvFILEGV(gv) = curcop->cop_filegv;
GvEGV(gv) = gv;
sv_magic((SV*)gv, (SV*)gv, '*', name, len);
- GvSTASH(gv) = stash;
+ GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
GvNAME(gv) = savepvn(name, len);
GvNAMELEN(gv) = len;
if (multi)
GvMULTI_on(gv);
+ if (doproto) { /* Replicate part of newSUB here. */
+ ENTER;
+ start_subparse(0,0); /* Create CV in compcv. */
+ GvCV(gv) = compcv;
+ LEAVE;
+
+ GvCVGEN(gv) = 0;
+ sub_generation++;
+ CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv);
+ CvFILEGV(GvCV(gv)) = curcop->cop_filegv;
+ CvSTASH(GvCV(gv)) = curstash;
+#ifdef USE_THREADS
+ CvOWNER(GvCV(gv)) = 0;
+ New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(GvCV(gv)));
+#endif /* USE_THREADS */
+ if (proto) {
+ sv_setpv((SV*)GvCV(gv), proto);
+ Safefree(proto);
+ }
+ }
}
static void
-gv_init_sv(gv, sv_type)
-GV* gv;
-I32 sv_type;
+gv_init_sv(GV *gv, I32 sv_type)
{
switch (sv_type) {
case SVt_PVIO:
}
GV *
-gv_fetchmeth(stash, name, len, level)
-HV* stash;
-char* name;
-STRLEN len;
-I32 level;
+gv_fetchmeth(HV *stash, char *name, STRLEN len, I32 level)
{
AV* av;
GV* topgv;
gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
av = (gvp && (gv = *gvp) && gv != (GV*)&sv_undef) ? GvAV(gv) : Nullav;
- /* create @.*::SUPER::ISA on demand */
- if (!av) {
+ /* create and re-create @.*::SUPER::ISA on demand */
+ if (!av || !SvMAGIC(av)) {
char* packname = HvNAME(stash);
STRLEN packlen = strlen(packname);
basestash = gv_stashpvn(packname, packlen, TRUE);
gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
+ dTHR; /* just for SvREFCNT_dec */
gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
if (!gvp || !(gv = *gvp))
croak("Cannot create %s::ISA", HvNAME(stash));
if (av) {
SV** svp = AvARRAY(av);
- I32 items = AvFILL(av) + 1;
+ /* NOTE: No support for tied ISA */
+ I32 items = AvFILLp(av) + 1;
while (items--) {
SV* sv = *svp++;
HV* basestash = gv_stashsv(sv, FALSE);
}
GV *
-gv_fetchmethod(stash, name)
-HV* stash;
-char* name;
+gv_fetchmethod(HV *stash, char *name)
{
return gv_fetchmethod_autoload(stash, name, TRUE);
}
GV *
-gv_fetchmethod_autoload(stash, name, autoload)
-HV* stash;
-char* name;
-I32 autoload;
+gv_fetchmethod_autoload(HV *stash, char *name, I32 autoload)
{
+ dTHR;
register char *nend;
char *nsplit = 0;
GV* gv;
--nsplit;
if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
/* ->SUPER::method should really be looked up in original stash */
- SV *tmpstr = sv_2mortal(newSVpv(HvNAME(curcop->cop_stash), 0));
- sv_catpvn(tmpstr, "::SUPER", 7);
+ SV *tmpstr = sv_2mortal(newSVpvf("%s::SUPER",
+ HvNAME(curcop->cop_stash)));
stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
DEBUG_o( deb("Treating %s as %s::%s\n",
origname, HvNAME(stash), name) );
}
GV*
-gv_autoload4(stash, name, len, method)
-HV* stash;
-char* name;
-STRLEN len;
-I32 method;
+gv_autoload4(HV *stash, char *name, STRLEN len, I32 method)
{
static char autoload[] = "AUTOLOAD";
static STRLEN autolen = 8;
}
HV*
-gv_stashpv(name,create)
-char *name;
-I32 create;
+gv_stashpv(char *name, I32 create)
{
return gv_stashpvn(name, strlen(name), create);
}
HV*
-gv_stashpvn(name,namelen,create)
-char *name;
-U32 namelen;
-I32 create;
+gv_stashpvn(char *name, U32 namelen, I32 create)
{
- char tmpbuf[1203];
+ char smallbuf[256];
+ char *tmpbuf;
HV *stash;
GV *tmpgv;
- if (namelen > 1200) {
- namelen = 1200;
-#ifdef VMS
- warn("Weird package name \"%s\" truncated", name);
-#else
- warn("Weird package name \"%.*s...\" truncated", (int)namelen, name);
-#endif
- }
+ if (namelen + 3 < sizeof smallbuf)
+ tmpbuf = smallbuf;
+ else
+ New(606, tmpbuf, namelen + 3, char);
Copy(name,tmpbuf,namelen,char);
tmpbuf[namelen++] = ':';
tmpbuf[namelen++] = ':';
tmpbuf[namelen] = '\0';
- tmpgv = gv_fetchpv(tmpbuf,create, SVt_PVHV);
+ tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
+ if (tmpbuf != smallbuf)
+ Safefree(tmpbuf);
if (!tmpgv)
return 0;
if (!GvHV(tmpgv))
}
HV*
-gv_stashsv(sv,create)
-SV *sv;
-I32 create;
+gv_stashsv(SV *sv, I32 create)
{
register char *ptr;
STRLEN len;
GV *
-gv_fetchpv(nambeg,add,sv_type)
-char *nambeg;
-I32 add;
-I32 sv_type;
+gv_fetchpv(char *nambeg, I32 add, I32 sv_type)
{
+ dTHR;
register char *name = nambeg;
register GV *gv = 0;
GV**gvp;
register char *namend;
HV *stash = 0;
U32 add_gvflags = 0;
- char *tmpbuf;
if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
name++;
len = namend - name;
if (len > 0) {
- New(601, tmpbuf, len+3, char);
+ char *tmpbuf;
+ char autobuf[64];
+
+ if (len < sizeof(autobuf) - 2)
+ tmpbuf = autobuf;
+ else
+ New(601, tmpbuf, len+3, char);
Copy(name, tmpbuf, len, char);
tmpbuf[len++] = ':';
tmpbuf[len++] = ':';
tmpbuf[len] = '\0';
gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
- Safefree(tmpbuf);
- if (!gvp || *gvp == (GV*)&sv_undef)
- return Nullgv;
- gv = *gvp;
-
- if (SvTYPE(gv) == SVt_PVGV)
- GvMULTI_on(gv);
- else if (!add)
+ gv = gvp ? *gvp : Nullgv;
+ if (gv && gv != (GV*)&sv_undef) {
+ if (SvTYPE(gv) != SVt_PVGV)
+ gv_init(gv, stash, tmpbuf, len, (add & 2));
+ else
+ GvMULTI_on(gv);
+ }
+ if (tmpbuf != autobuf)
+ Safefree(tmpbuf);
+ if (!gv || gv == (GV*)&sv_undef)
return Nullgv;
- else
- gv_init(gv, stash, nambeg, namend - nambeg, (add & 2));
if (!(stash = GvHV(gv)))
stash = GvHV(gv) = newHV();
/* By this point we should have a stash and a name */
if (!stash) {
- if (add) {
- warn("Global symbol \"%s\" requires explicit package name", name);
- ++error_count;
- stash = curstash ? curstash : defstash; /* avoid core dumps */
- add_gvflags = ((sv_type == SVt_PV) ? GVf_IMPORTED_SV
- : (sv_type == SVt_PVAV) ? GVf_IMPORTED_AV
- : (sv_type == SVt_PVHV) ? GVf_IMPORTED_HV
- : 0);
- }
- else
+ if (!add)
return Nullgv;
+ if (add & ~2) {
+ char sv_type_char = ((sv_type == SVt_PV) ? '$'
+ : (sv_type == SVt_PVAV) ? '@'
+ : (sv_type == SVt_PVHV) ? '%'
+ : 0);
+ if (sv_type_char)
+ warn("Global symbol \"%c%s\" requires explicit package name",
+ sv_type_char, name);
+ else
+ warn("Global symbol \"%s\" requires explicit package name",
+ name);
+ }
+ ++error_count;
+ stash = curstash ? curstash : defstash; /* avoid core dumps */
+ add_gvflags = ((sv_type == SVt_PV) ? GVf_IMPORTED_SV
+ : (sv_type == SVt_PVAV) ? GVf_IMPORTED_AV
+ : (sv_type == SVt_PVHV) ? GVf_IMPORTED_HV
+ : 0);
}
if (!SvREFCNT(stash)) /* symbol table under destruction */
gv_init_sv(gv, sv_type);
}
return gv;
+ } else if (add & GV_NOINIT) {
+ return gv;
}
/* Adding a new symbol */
- if (add & 4)
+ if (add & GV_ADDWARN)
warn("Had to create %s unexpectedly", nambeg);
- gv_init(gv, stash, name, len, add & 2);
+ gv_init(gv, stash, name, len, add & GV_ADDMULTI);
gv_init_sv(gv, sv_type);
GvFLAGS(gv) |= add_gvflags;
AV* av = GvAVn(gv);
GvMULTI_on(gv);
sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
- if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1)
+ /* NOTE: No support for tied ISA */
+ if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
+ && AvFILLp(av) == -1)
{
char *pname;
av_push(av, newSVpv(pname = "NDBM_File",0));
if (strEQ(name, "OVERLOAD")) {
HV* hv = GvHVn(gv);
GvMULTI_on(gv);
- sv_magic((SV*)hv, (SV*)gv, 'A', 0, 0);
+ hv_magic(hv, gv, 'A');
}
break;
#endif /* OVERLOAD */
psig_ptr[i] = 0;
psig_name[i] = 0;
}
- /* initialize signal stack */
- signalstack = newAV();
- AvREAL_off(signalstack);
- av_extend(signalstack, 30);
- av_fill(signalstack, 0);
}
break;
#endif
goto magicalize;
+ case '!':
+ if(len > 1)
+ break;
+ if(sv_type > SVt_PV) {
+ HV* stash = gv_stashpvn("Errno",5,FALSE);
+ if(!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
+ dSP;
+ PUTBACK;
+ perl_require_pv("Errno.pm");
+ SPAGAIN;
+ stash = gv_stashpvn("Errno",5,FALSE);
+ if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
+ croak("Can't use %%! because Errno.pm is not avaliable");
+ }
+ }
+ goto magicalize;
case '#':
case '*':
if (dowarn && len == 1 && sv_type == SVt_PV)
warn("Use of $%s is deprecated", name);
/* FALL THROUGH */
case '[':
- case '!':
case '^':
case '~':
case '=':
case '7':
case '8':
case '9':
+ case '\023':
ro_magicalize:
SvREADONLY_on(GvSV(gv));
magicalize:
}
void
-gv_fullname3(sv, gv, prefix)
-SV *sv;
-GV *gv;
-char *prefix;
+gv_fullname3(SV *sv, GV *gv, char *prefix)
{
HV *hv = GvSTASH(gv);
if (!hv) {
}
void
-gv_efullname3(sv, gv, prefix)
-SV *sv;
-GV *gv;
-char *prefix;
+gv_efullname3(SV *sv, GV *gv, char *prefix)
{
GV *egv = GvEGV(gv);
if (!egv)
/* XXX compatibility with versions <= 5.003. */
void
-gv_fullname(sv,gv)
-SV *sv;
-GV *gv;
+gv_fullname(SV *sv, GV *gv)
{
gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
}
/* XXX compatibility with versions <= 5.003. */
void
-gv_efullname(sv,gv)
-SV *sv;
-GV *gv;
+gv_efullname(SV *sv, GV *gv)
{
gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
}
IO *
-newIO()
+newIO(void)
{
+ dTHR;
IO *io;
GV *iogv;
sv_upgrade((SV *)io,SVt_PVIO);
SvREFCNT(io) = 1;
SvOBJECT_on(io);
- iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
+ iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
+ if (!iogv)
+ iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
return io;
}
void
-gv_check(stash)
-HV* stash;
+gv_check(HV *stash)
{
+ dTHR;
register HE *entry;
register I32 i;
register GV *gv;
}
else if (isALPHA(*HeKEY(entry))) {
gv = (GV*)HeVAL(entry);
- if (GvMULTI(gv))
+ if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
continue;
curcop->cop_line = GvLINE(gv);
filegv = GvFILEGV(gv);
}
GV *
-newGVgen(pack)
-char *pack;
+newGVgen(char *pack)
{
- (void)sprintf(tokenbuf,"%s::_GEN_%ld",pack,(long)gensym++);
- return gv_fetchpv(tokenbuf,TRUE, SVt_PVGV);
+ return gv_fetchpv(form("%s::_GEN_%ld", pack, (long)gensym++),
+ TRUE, SVt_PVGV);
}
/* hopefully this is only called on local symbol table entries */
GP*
-gp_ref(gp)
-GP* gp;
+gp_ref(GP *gp)
{
gp->gp_refcnt++;
if (gp->gp_cv) {
}
void
-gp_free(gv)
-GV* gv;
+gp_free(GV *gv)
{
GP* gp;
CV* cv;
/* Updates and caches the CV's */
bool
-Gv_AMupdate(stash)
-HV* stash;
+Gv_AMupdate(HV *stash)
{
+ dTHR;
GV** gvp;
HV* hv;
GV* gv;
CV* cv;
MAGIC* mg=mg_find((SV*)stash,'c');
- AMT *amtp=mg ? (AMT*)mg->mg_ptr: NULL;
+ AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
AMT amt;
if (mg && amtp->was_ok_am == amagic_generation
}
for (i = 1; i < NofAMmeth; i++) {
- cv = 0;
- cp = AMG_names[i];
-
- *buf = '('; /* A cookie: "(". */
- strcpy(buf + 1, cp);
+ SV *cookie = sv_2mortal(newSVpvf("(%s", cp = AMG_names[i]));
DEBUG_o( deb("Checking overloading of `%s' in package `%.256s'\n",
cp, HvNAME(stash)) );
- gv = gv_fetchmeth(stash, buf, strlen(buf), -1); /* no filling stash! */
+ /* don't fill the cache while looking up! */
+ gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
+ cv = 0;
if(gv && (cv = GvCV(gv))) {
- char *name = buf;
if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
&& strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
/* GvSV contains the name of the method. */
(SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ),
cp, HvNAME(stash));
}
- name = SvPVX(GvSV(gv));
cv = GvCV(gv = ngv);
}
DEBUG_o( deb("Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
return FALSE;
}
-/* During call to this subroutine stack can be reallocated. It is
- * advised to call SPAGAIN macro in your code after call */
-
SV*
-amagic_call(left,right,method,flags)
-SV* left;
-SV* right;
-int method;
-int flags;
+amagic_call(SV *left, SV *right, int method, int flags)
{
+ dTHR;
MAGIC *mg;
CV *cv;
CV **cvp=NULL, **ocvp=NULL;
&& (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
&& (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
- : NULL))
+ : (CV **) NULL))
&& ((cv = cvp[off=method+assignshift])
|| (assign && amtp->fallback > AMGfallNEVER && /* fallback to
* usual method */
case copy_amg:
{
SV* ref=SvRV(left);
- if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) { /* Just to be
- * extra
- * causious,
- * maybe in some
- * additional
- * cases sv_setsv
- * is safe too */
+ if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) {
+ /*
+ * Just to be extra cautious. Maybe in some
+ * additional cases sv_setsv is safe, too.
+ */
SV* newref = newSVsv(ref);
SvOBJECT_on(newref);
SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(ref));
&& (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
&& (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
? (amtp = (AMT*)mg->mg_ptr)->table
- : NULL))
+ : (CV **) NULL))
&& (cv = cvp[off=method])) { /* Method for right
* argument found */
lr=1;
&& !(flags & AMGf_unary)) {
/* We look for substitution for
* comparison operations and
- * concatendation */
+ * concatenation */
if (method==concat_amg || method==concat_ass_amg
|| method==repeat_amg || method==repeat_ass_amg) {
return NULL; /* Delegate operation to string conversion */
} else if (cvp && (cv=cvp[nomethod_amg])) {
notfound = 1; lr = 1;
} else {
+ SV *msg;
if (off==-1) off=method;
- sprintf(buf,
- "Operation `%s': no method found,%sargument %s%.256s%s%.256s",
+ msg = sv_2mortal(newSVpvf(
+ "Operation `%s': no method found,%sargument %s%s%s%s",
AMG_names[method + assignshift],
(flags & AMGf_unary ? " " : "\n\tleft "),
SvAMAGIC(left)?
: ",\n\tright argument has no overloaded magic"),
SvAMAGIC(right)?
HvNAME(SvSTASH(SvRV(right))):
- "");
+ ""));
if (amtp && amtp->fallback >= AMGfallYES) {
- DEBUG_o( deb(buf) );
+ DEBUG_o( deb("%s", SvPVX(msg)) );
} else {
- croak(buf);
+ croak("%_", msg);
}
return NULL;
}
}
if (!notfound) {
DEBUG_o( deb(
- "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n",
+ "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
AMG_names[off],
method+assignshift==off? "" :
" (initially `",
myop.op_next = Nullop;
myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
+ PUSHSTACK(SI_OVERLOAD);
ENTER;
- SAVESPTR(op);
+ SAVEOP();
op = (OP *) &myop;
- if (perldb && curstash != debstash)
+ if (PERLDB_SUB && curstash != debstash)
op->op_private |= OPpENTERSUB_DB;
PUTBACK;
- pp_pushmark();
+ pp_pushmark(ARGS);
- EXTEND(sp, notfound + 5);
+ EXTEND(SP, notfound + 5);
PUSHs(lr>0? right: left);
PUSHs(lr>0? left: right);
PUSHs( lr > 0 ? &sv_yes : ( assign ? &sv_undef : &sv_no ));
PUSHs((SV*)cv);
PUTBACK;
- if (op = pp_entersub())
+ if (op = pp_entersub(ARGS))
runops();
LEAVE;
SPAGAIN;
res=POPs;
- PUTBACK;
+ POPSTACK();
CATCH_SET(oldcatch);
if (postpr) {
}
}
#endif /* OVERLOAD */
+