[10723] | 1 | /* gv.c |
---|
| 2 | * |
---|
| 3 | * Copyright (c) 1991-1997, Larry Wall |
---|
| 4 | * |
---|
| 5 | * You may distribute under the terms of either the GNU General Public |
---|
| 6 | * License or the Artistic License, as specified in the README file. |
---|
| 7 | * |
---|
| 8 | */ |
---|
| 9 | |
---|
| 10 | /* |
---|
| 11 | * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure |
---|
| 12 | * of your inquisitiveness, I shall spend all the rest of my days answering |
---|
| 13 | * you. What more do you want to know?' |
---|
| 14 | * 'The names of all the stars, and of all living things, and the whole |
---|
| 15 | * history of Middle-earth and Over-heaven and of the Sundering Seas,' |
---|
| 16 | * laughed Pippin. |
---|
| 17 | */ |
---|
| 18 | |
---|
| 19 | #include "EXTERN.h" |
---|
| 20 | #include "perl.h" |
---|
| 21 | |
---|
| 22 | EXT char rcsid[]; |
---|
| 23 | |
---|
| 24 | GV * |
---|
| 25 | gv_AVadd(gv) |
---|
| 26 | register GV *gv; |
---|
| 27 | { |
---|
| 28 | if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) |
---|
| 29 | croak("Bad symbol for array"); |
---|
| 30 | if (!GvAV(gv)) |
---|
| 31 | GvAV(gv) = newAV(); |
---|
| 32 | return gv; |
---|
| 33 | } |
---|
| 34 | |
---|
| 35 | GV * |
---|
| 36 | gv_HVadd(gv) |
---|
| 37 | register GV *gv; |
---|
| 38 | { |
---|
| 39 | if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) |
---|
| 40 | croak("Bad symbol for hash"); |
---|
| 41 | if (!GvHV(gv)) |
---|
| 42 | GvHV(gv) = newHV(); |
---|
| 43 | return gv; |
---|
| 44 | } |
---|
| 45 | |
---|
| 46 | GV * |
---|
| 47 | gv_IOadd(gv) |
---|
| 48 | register GV *gv; |
---|
| 49 | { |
---|
| 50 | if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) |
---|
| 51 | croak("Bad symbol for filehandle"); |
---|
| 52 | if (!GvIOp(gv)) |
---|
| 53 | GvIOp(gv) = newIO(); |
---|
| 54 | return gv; |
---|
| 55 | } |
---|
| 56 | |
---|
| 57 | GV * |
---|
| 58 | gv_fetchfile(name) |
---|
| 59 | char *name; |
---|
| 60 | { |
---|
| 61 | char smallbuf[256]; |
---|
| 62 | char *tmpbuf; |
---|
| 63 | STRLEN tmplen; |
---|
| 64 | GV *gv; |
---|
| 65 | |
---|
| 66 | tmplen = strlen(name) + 2; |
---|
| 67 | if (tmplen < sizeof smallbuf) |
---|
| 68 | tmpbuf = smallbuf; |
---|
| 69 | else |
---|
| 70 | New(603, tmpbuf, tmplen + 1, char); |
---|
| 71 | tmpbuf[0] = '_'; |
---|
| 72 | tmpbuf[1] = '<'; |
---|
| 73 | strcpy(tmpbuf + 2, name); |
---|
| 74 | gv = *(GV**)hv_fetch(defstash, tmpbuf, tmplen, TRUE); |
---|
| 75 | if (!isGV(gv)) |
---|
| 76 | gv_init(gv, defstash, tmpbuf, tmplen, FALSE); |
---|
| 77 | if (tmpbuf != smallbuf) |
---|
| 78 | Safefree(tmpbuf); |
---|
| 79 | sv_setpv(GvSV(gv), name); |
---|
| 80 | if (*name == '/' && (instr(name, "/lib/") || instr(name, ".pm"))) |
---|
| 81 | GvMULTI_on(gv); |
---|
| 82 | if (PERLDB_LINE) |
---|
| 83 | hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L'); |
---|
| 84 | return gv; |
---|
| 85 | } |
---|
| 86 | |
---|
| 87 | void |
---|
| 88 | gv_init(gv, stash, name, len, multi) |
---|
| 89 | GV *gv; |
---|
| 90 | HV *stash; |
---|
| 91 | char *name; |
---|
| 92 | STRLEN len; |
---|
| 93 | int multi; |
---|
| 94 | { |
---|
| 95 | register GP *gp; |
---|
| 96 | |
---|
| 97 | sv_upgrade((SV*)gv, SVt_PVGV); |
---|
| 98 | if (SvLEN(gv)) |
---|
| 99 | Safefree(SvPVX(gv)); |
---|
| 100 | Newz(602, gp, 1, GP); |
---|
| 101 | GvGP(gv) = gp_ref(gp); |
---|
| 102 | GvSV(gv) = NEWSV(72,0); |
---|
| 103 | GvLINE(gv) = curcop->cop_line; |
---|
| 104 | GvFILEGV(gv) = curcop->cop_filegv; |
---|
| 105 | GvEGV(gv) = gv; |
---|
| 106 | sv_magic((SV*)gv, (SV*)gv, '*', name, len); |
---|
| 107 | GvSTASH(gv) = stash; |
---|
| 108 | GvNAME(gv) = savepvn(name, len); |
---|
| 109 | GvNAMELEN(gv) = len; |
---|
| 110 | if (multi) |
---|
| 111 | GvMULTI_on(gv); |
---|
| 112 | } |
---|
| 113 | |
---|
| 114 | static void |
---|
| 115 | gv_init_sv(gv, sv_type) |
---|
| 116 | GV* gv; |
---|
| 117 | I32 sv_type; |
---|
| 118 | { |
---|
| 119 | switch (sv_type) { |
---|
| 120 | case SVt_PVIO: |
---|
| 121 | (void)GvIOn(gv); |
---|
| 122 | break; |
---|
| 123 | case SVt_PVAV: |
---|
| 124 | (void)GvAVn(gv); |
---|
| 125 | break; |
---|
| 126 | case SVt_PVHV: |
---|
| 127 | (void)GvHVn(gv); |
---|
| 128 | break; |
---|
| 129 | } |
---|
| 130 | } |
---|
| 131 | |
---|
| 132 | GV * |
---|
| 133 | gv_fetchmeth(stash, name, len, level) |
---|
| 134 | HV* stash; |
---|
| 135 | char* name; |
---|
| 136 | STRLEN len; |
---|
| 137 | I32 level; |
---|
| 138 | { |
---|
| 139 | AV* av; |
---|
| 140 | GV* topgv; |
---|
| 141 | GV* gv; |
---|
| 142 | GV** gvp; |
---|
| 143 | CV* cv; |
---|
| 144 | |
---|
| 145 | if (!stash) |
---|
| 146 | return 0; |
---|
| 147 | if ((level > 100) || (level < -100)) |
---|
| 148 | croak("Recursive inheritance detected"); |
---|
| 149 | |
---|
| 150 | DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) ); |
---|
| 151 | |
---|
| 152 | gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); |
---|
| 153 | if (!gvp) |
---|
| 154 | topgv = Nullgv; |
---|
| 155 | else { |
---|
| 156 | topgv = *gvp; |
---|
| 157 | if (SvTYPE(topgv) != SVt_PVGV) |
---|
| 158 | gv_init(topgv, stash, name, len, TRUE); |
---|
| 159 | if (cv = GvCV(topgv)) { |
---|
| 160 | /* If genuine method or valid cache entry, use it */ |
---|
| 161 | if (!GvCVGEN(topgv) || GvCVGEN(topgv) >= sub_generation) |
---|
| 162 | return topgv; |
---|
| 163 | /* Stale cached entry: junk it */ |
---|
| 164 | SvREFCNT_dec(cv); |
---|
| 165 | GvCV(topgv) = cv = Nullcv; |
---|
| 166 | GvCVGEN(topgv) = 0; |
---|
| 167 | } |
---|
| 168 | } |
---|
| 169 | |
---|
| 170 | gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE); |
---|
| 171 | av = (gvp && (gv = *gvp) && gv != (GV*)&sv_undef) ? GvAV(gv) : Nullav; |
---|
| 172 | |
---|
| 173 | /* create and re-create @.*::SUPER::ISA on demand */ |
---|
| 174 | if (!av || !SvMAGIC(av)) { |
---|
| 175 | char* packname = HvNAME(stash); |
---|
| 176 | STRLEN packlen = strlen(packname); |
---|
| 177 | |
---|
| 178 | if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) { |
---|
| 179 | HV* basestash; |
---|
| 180 | |
---|
| 181 | packlen -= 7; |
---|
| 182 | basestash = gv_stashpvn(packname, packlen, TRUE); |
---|
| 183 | gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE); |
---|
| 184 | if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) { |
---|
| 185 | gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE); |
---|
| 186 | if (!gvp || !(gv = *gvp)) |
---|
| 187 | croak("Cannot create %s::ISA", HvNAME(stash)); |
---|
| 188 | if (SvTYPE(gv) != SVt_PVGV) |
---|
| 189 | gv_init(gv, stash, "ISA", 3, TRUE); |
---|
| 190 | SvREFCNT_dec(GvAV(gv)); |
---|
| 191 | GvAV(gv) = (AV*)SvREFCNT_inc(av); |
---|
| 192 | } |
---|
| 193 | } |
---|
| 194 | } |
---|
| 195 | |
---|
| 196 | if (av) { |
---|
| 197 | SV** svp = AvARRAY(av); |
---|
| 198 | I32 items = AvFILL(av) + 1; |
---|
| 199 | while (items--) { |
---|
| 200 | SV* sv = *svp++; |
---|
| 201 | HV* basestash = gv_stashsv(sv, FALSE); |
---|
| 202 | if (!basestash) { |
---|
| 203 | if (dowarn) |
---|
| 204 | warn("Can't locate package %s for @%s::ISA", |
---|
| 205 | SvPVX(sv), HvNAME(stash)); |
---|
| 206 | continue; |
---|
| 207 | } |
---|
| 208 | gv = gv_fetchmeth(basestash, name, len, |
---|
| 209 | (level >= 0) ? level + 1 : level - 1); |
---|
| 210 | if (gv) |
---|
| 211 | goto gotcha; |
---|
| 212 | } |
---|
| 213 | } |
---|
| 214 | |
---|
| 215 | /* if at top level, try UNIVERSAL */ |
---|
| 216 | |
---|
| 217 | if (level == 0 || level == -1) { |
---|
| 218 | HV* lastchance; |
---|
| 219 | |
---|
| 220 | if (lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE)) { |
---|
| 221 | if (gv = gv_fetchmeth(lastchance, name, len, |
---|
| 222 | (level >= 0) ? level + 1 : level - 1)) { |
---|
| 223 | gotcha: |
---|
| 224 | /* |
---|
| 225 | * Cache method in topgv if: |
---|
| 226 | * 1. topgv has no synonyms (else inheritance crosses wires) |
---|
| 227 | * 2. method isn't a stub (else AUTOLOAD fails spectacularly) |
---|
| 228 | */ |
---|
| 229 | if (topgv && |
---|
| 230 | GvREFCNT(topgv) == 1 && |
---|
| 231 | (cv = GvCV(gv)) && |
---|
| 232 | (CvROOT(cv) || CvXSUB(cv))) |
---|
| 233 | { |
---|
| 234 | if (cv = GvCV(topgv)) |
---|
| 235 | SvREFCNT_dec(cv); |
---|
| 236 | GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv)); |
---|
| 237 | GvCVGEN(topgv) = sub_generation; |
---|
| 238 | } |
---|
| 239 | return gv; |
---|
| 240 | } |
---|
| 241 | } |
---|
| 242 | } |
---|
| 243 | |
---|
| 244 | return 0; |
---|
| 245 | } |
---|
| 246 | |
---|
| 247 | GV * |
---|
| 248 | gv_fetchmethod(stash, name) |
---|
| 249 | HV* stash; |
---|
| 250 | char* name; |
---|
| 251 | { |
---|
| 252 | return gv_fetchmethod_autoload(stash, name, TRUE); |
---|
| 253 | } |
---|
| 254 | |
---|
| 255 | GV * |
---|
| 256 | gv_fetchmethod_autoload(stash, name, autoload) |
---|
| 257 | HV* stash; |
---|
| 258 | char* name; |
---|
| 259 | I32 autoload; |
---|
| 260 | { |
---|
| 261 | register char *nend; |
---|
| 262 | char *nsplit = 0; |
---|
| 263 | GV* gv; |
---|
| 264 | |
---|
| 265 | for (nend = name; *nend; nend++) { |
---|
| 266 | if (*nend == '\'') |
---|
| 267 | nsplit = nend; |
---|
| 268 | else if (*nend == ':' && *(nend + 1) == ':') |
---|
| 269 | nsplit = ++nend; |
---|
| 270 | } |
---|
| 271 | if (nsplit) { |
---|
| 272 | char *origname = name; |
---|
| 273 | name = nsplit + 1; |
---|
| 274 | if (*nsplit == ':') |
---|
| 275 | --nsplit; |
---|
| 276 | if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) { |
---|
| 277 | /* ->SUPER::method should really be looked up in original stash */ |
---|
| 278 | SV *tmpstr = sv_2mortal(newSVpvf("%s::SUPER", |
---|
| 279 | HvNAME(curcop->cop_stash))); |
---|
| 280 | stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE); |
---|
| 281 | DEBUG_o( deb("Treating %s as %s::%s\n", |
---|
| 282 | origname, HvNAME(stash), name) ); |
---|
| 283 | } |
---|
| 284 | else |
---|
| 285 | stash = gv_stashpvn(origname, nsplit - origname, TRUE); |
---|
| 286 | } |
---|
| 287 | |
---|
| 288 | gv = gv_fetchmeth(stash, name, nend - name, 0); |
---|
| 289 | if (!gv) { |
---|
| 290 | if (strEQ(name,"import")) |
---|
| 291 | gv = (GV*)&sv_yes; |
---|
| 292 | else if (autoload) |
---|
| 293 | gv = gv_autoload4(stash, name, nend - name, TRUE); |
---|
| 294 | } |
---|
| 295 | else if (autoload) { |
---|
| 296 | CV* cv = GvCV(gv); |
---|
| 297 | if (!CvROOT(cv) && !CvXSUB(cv)) { |
---|
| 298 | GV* stubgv; |
---|
| 299 | GV* autogv; |
---|
| 300 | |
---|
| 301 | if (CvANON(cv)) |
---|
| 302 | stubgv = gv; |
---|
| 303 | else { |
---|
| 304 | stubgv = CvGV(cv); |
---|
| 305 | if (GvCV(stubgv) != cv) /* orphaned import */ |
---|
| 306 | stubgv = gv; |
---|
| 307 | } |
---|
| 308 | autogv = gv_autoload4(GvSTASH(stubgv), |
---|
| 309 | GvNAME(stubgv), GvNAMELEN(stubgv), TRUE); |
---|
| 310 | if (autogv) |
---|
| 311 | gv = autogv; |
---|
| 312 | } |
---|
| 313 | } |
---|
| 314 | |
---|
| 315 | return gv; |
---|
| 316 | } |
---|
| 317 | |
---|
| 318 | GV* |
---|
| 319 | gv_autoload4(stash, name, len, method) |
---|
| 320 | HV* stash; |
---|
| 321 | char* name; |
---|
| 322 | STRLEN len; |
---|
| 323 | I32 method; |
---|
| 324 | { |
---|
| 325 | static char autoload[] = "AUTOLOAD"; |
---|
| 326 | static STRLEN autolen = 8; |
---|
| 327 | GV* gv; |
---|
| 328 | CV* cv; |
---|
| 329 | HV* varstash; |
---|
| 330 | GV* vargv; |
---|
| 331 | SV* varsv; |
---|
| 332 | |
---|
| 333 | if (len == autolen && strnEQ(name, autoload, autolen)) |
---|
| 334 | return Nullgv; |
---|
| 335 | if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE))) |
---|
| 336 | return Nullgv; |
---|
| 337 | cv = GvCV(gv); |
---|
| 338 | |
---|
| 339 | /* |
---|
| 340 | * Inheriting AUTOLOAD for non-methods works ... for now. |
---|
| 341 | */ |
---|
| 342 | if (dowarn && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash)) |
---|
| 343 | warn( |
---|
| 344 | "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", |
---|
| 345 | HvNAME(stash), (int)len, name); |
---|
| 346 | |
---|
| 347 | /* |
---|
| 348 | * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. |
---|
| 349 | * The subroutine's original name may not be "AUTOLOAD", so we don't |
---|
| 350 | * use that, but for lack of anything better we will use the sub's |
---|
| 351 | * original package to look up $AUTOLOAD. |
---|
| 352 | */ |
---|
| 353 | varstash = GvSTASH(CvGV(cv)); |
---|
| 354 | vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); |
---|
| 355 | if (!isGV(vargv)) |
---|
| 356 | gv_init(vargv, varstash, autoload, autolen, FALSE); |
---|
| 357 | varsv = GvSV(vargv); |
---|
| 358 | sv_setpv(varsv, HvNAME(stash)); |
---|
| 359 | sv_catpvn(varsv, "::", 2); |
---|
| 360 | sv_catpvn(varsv, name, len); |
---|
| 361 | SvTAINTED_off(varsv); |
---|
| 362 | return gv; |
---|
| 363 | } |
---|
| 364 | |
---|
| 365 | HV* |
---|
| 366 | gv_stashpv(name,create) |
---|
| 367 | char *name; |
---|
| 368 | I32 create; |
---|
| 369 | { |
---|
| 370 | return gv_stashpvn(name, strlen(name), create); |
---|
| 371 | } |
---|
| 372 | |
---|
| 373 | HV* |
---|
| 374 | gv_stashpvn(name,namelen,create) |
---|
| 375 | char *name; |
---|
| 376 | U32 namelen; |
---|
| 377 | I32 create; |
---|
| 378 | { |
---|
| 379 | char smallbuf[256]; |
---|
| 380 | char *tmpbuf; |
---|
| 381 | HV *stash; |
---|
| 382 | GV *tmpgv; |
---|
| 383 | |
---|
| 384 | if (namelen + 3 < sizeof smallbuf) |
---|
| 385 | tmpbuf = smallbuf; |
---|
| 386 | else |
---|
| 387 | New(606, tmpbuf, namelen + 3, char); |
---|
| 388 | Copy(name,tmpbuf,namelen,char); |
---|
| 389 | tmpbuf[namelen++] = ':'; |
---|
| 390 | tmpbuf[namelen++] = ':'; |
---|
| 391 | tmpbuf[namelen] = '\0'; |
---|
| 392 | tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV); |
---|
| 393 | if (tmpbuf != smallbuf) |
---|
| 394 | Safefree(tmpbuf); |
---|
| 395 | if (!tmpgv) |
---|
| 396 | return 0; |
---|
| 397 | if (!GvHV(tmpgv)) |
---|
| 398 | GvHV(tmpgv) = newHV(); |
---|
| 399 | stash = GvHV(tmpgv); |
---|
| 400 | if (!HvNAME(stash)) |
---|
| 401 | HvNAME(stash) = savepv(name); |
---|
| 402 | return stash; |
---|
| 403 | } |
---|
| 404 | |
---|
| 405 | HV* |
---|
| 406 | gv_stashsv(sv,create) |
---|
| 407 | SV *sv; |
---|
| 408 | I32 create; |
---|
| 409 | { |
---|
| 410 | register char *ptr; |
---|
| 411 | STRLEN len; |
---|
| 412 | ptr = SvPV(sv,len); |
---|
| 413 | return gv_stashpvn(ptr, len, create); |
---|
| 414 | } |
---|
| 415 | |
---|
| 416 | |
---|
| 417 | GV * |
---|
| 418 | gv_fetchpv(nambeg,add,sv_type) |
---|
| 419 | char *nambeg; |
---|
| 420 | I32 add; |
---|
| 421 | I32 sv_type; |
---|
| 422 | { |
---|
| 423 | register char *name = nambeg; |
---|
| 424 | register GV *gv = 0; |
---|
| 425 | GV**gvp; |
---|
| 426 | I32 len; |
---|
| 427 | register char *namend; |
---|
| 428 | HV *stash = 0; |
---|
| 429 | U32 add_gvflags = 0; |
---|
| 430 | char *tmpbuf; |
---|
| 431 | |
---|
| 432 | if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */ |
---|
| 433 | name++; |
---|
| 434 | |
---|
| 435 | for (namend = name; *namend; namend++) { |
---|
| 436 | if ((*namend == '\'' && namend[1]) || |
---|
| 437 | (*namend == ':' && namend[1] == ':')) |
---|
| 438 | { |
---|
| 439 | if (!stash) |
---|
| 440 | stash = defstash; |
---|
| 441 | if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */ |
---|
| 442 | return Nullgv; |
---|
| 443 | |
---|
| 444 | len = namend - name; |
---|
| 445 | if (len > 0) { |
---|
| 446 | New(601, tmpbuf, len+3, char); |
---|
| 447 | Copy(name, tmpbuf, len, char); |
---|
| 448 | tmpbuf[len++] = ':'; |
---|
| 449 | tmpbuf[len++] = ':'; |
---|
| 450 | tmpbuf[len] = '\0'; |
---|
| 451 | gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); |
---|
| 452 | Safefree(tmpbuf); |
---|
| 453 | if (!gvp || *gvp == (GV*)&sv_undef) |
---|
| 454 | return Nullgv; |
---|
| 455 | gv = *gvp; |
---|
| 456 | |
---|
| 457 | if (SvTYPE(gv) == SVt_PVGV) |
---|
| 458 | GvMULTI_on(gv); |
---|
| 459 | else if (!add) |
---|
| 460 | return Nullgv; |
---|
| 461 | else |
---|
| 462 | gv_init(gv, stash, nambeg, namend - nambeg, (add & 2)); |
---|
| 463 | |
---|
| 464 | if (!(stash = GvHV(gv))) |
---|
| 465 | stash = GvHV(gv) = newHV(); |
---|
| 466 | |
---|
| 467 | if (!HvNAME(stash)) |
---|
| 468 | HvNAME(stash) = savepvn(nambeg, namend - nambeg); |
---|
| 469 | } |
---|
| 470 | |
---|
| 471 | if (*namend == ':') |
---|
| 472 | namend++; |
---|
| 473 | namend++; |
---|
| 474 | name = namend; |
---|
| 475 | if (!*name) |
---|
| 476 | return gv ? gv : (GV*)*hv_fetch(defstash, "main::", 6, TRUE); |
---|
| 477 | } |
---|
| 478 | } |
---|
| 479 | len = namend - name; |
---|
| 480 | if (!len) |
---|
| 481 | len = 1; |
---|
| 482 | |
---|
| 483 | /* No stash in name, so see how we can default */ |
---|
| 484 | |
---|
| 485 | if (!stash) { |
---|
| 486 | if (isIDFIRST(*name)) { |
---|
| 487 | bool global = FALSE; |
---|
| 488 | |
---|
| 489 | if (isUPPER(*name)) { |
---|
| 490 | if (*name > 'I') { |
---|
| 491 | if (*name == 'S' && ( |
---|
| 492 | strEQ(name, "SIG") || |
---|
| 493 | strEQ(name, "STDIN") || |
---|
| 494 | strEQ(name, "STDOUT") || |
---|
| 495 | strEQ(name, "STDERR") )) |
---|
| 496 | global = TRUE; |
---|
| 497 | } |
---|
| 498 | else if (*name > 'E') { |
---|
| 499 | if (*name == 'I' && strEQ(name, "INC")) |
---|
| 500 | global = TRUE; |
---|
| 501 | } |
---|
| 502 | else if (*name > 'A') { |
---|
| 503 | if (*name == 'E' && strEQ(name, "ENV")) |
---|
| 504 | global = TRUE; |
---|
| 505 | } |
---|
| 506 | else if (*name == 'A' && ( |
---|
| 507 | strEQ(name, "ARGV") || |
---|
| 508 | strEQ(name, "ARGVOUT") )) |
---|
| 509 | global = TRUE; |
---|
| 510 | } |
---|
| 511 | else if (*name == '_' && !name[1]) |
---|
| 512 | global = TRUE; |
---|
| 513 | |
---|
| 514 | if (global) |
---|
| 515 | stash = defstash; |
---|
| 516 | else if ((COP*)curcop == &compiling) { |
---|
| 517 | stash = curstash; |
---|
| 518 | if (add && (hints & HINT_STRICT_VARS) && |
---|
| 519 | sv_type != SVt_PVCV && |
---|
| 520 | sv_type != SVt_PVGV && |
---|
| 521 | sv_type != SVt_PVFM && |
---|
| 522 | sv_type != SVt_PVIO && |
---|
| 523 | !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) ) |
---|
| 524 | { |
---|
| 525 | gvp = (GV**)hv_fetch(stash,name,len,0); |
---|
| 526 | if (!gvp || |
---|
| 527 | *gvp == (GV*)&sv_undef || |
---|
| 528 | SvTYPE(*gvp) != SVt_PVGV) |
---|
| 529 | { |
---|
| 530 | stash = 0; |
---|
| 531 | } |
---|
| 532 | else if (sv_type == SVt_PV && !GvIMPORTED_SV(*gvp) || |
---|
| 533 | sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp) || |
---|
| 534 | sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp) ) |
---|
| 535 | { |
---|
| 536 | warn("Variable \"%c%s\" is not imported", |
---|
| 537 | sv_type == SVt_PVAV ? '@' : |
---|
| 538 | sv_type == SVt_PVHV ? '%' : '$', |
---|
| 539 | name); |
---|
| 540 | if (GvCVu(*gvp)) |
---|
| 541 | warn("(Did you mean &%s instead?)\n", name); |
---|
| 542 | stash = 0; |
---|
| 543 | } |
---|
| 544 | } |
---|
| 545 | } |
---|
| 546 | else |
---|
| 547 | stash = curcop->cop_stash; |
---|
| 548 | } |
---|
| 549 | else |
---|
| 550 | stash = defstash; |
---|
| 551 | } |
---|
| 552 | |
---|
| 553 | /* By this point we should have a stash and a name */ |
---|
| 554 | |
---|
| 555 | if (!stash) { |
---|
| 556 | if (add) { |
---|
| 557 | warn("Global symbol \"%s\" requires explicit package name", name); |
---|
| 558 | ++error_count; |
---|
| 559 | stash = curstash ? curstash : defstash; /* avoid core dumps */ |
---|
| 560 | add_gvflags = ((sv_type == SVt_PV) ? GVf_IMPORTED_SV |
---|
| 561 | : (sv_type == SVt_PVAV) ? GVf_IMPORTED_AV |
---|
| 562 | : (sv_type == SVt_PVHV) ? GVf_IMPORTED_HV |
---|
| 563 | : 0); |
---|
| 564 | } |
---|
| 565 | else |
---|
| 566 | return Nullgv; |
---|
| 567 | } |
---|
| 568 | |
---|
| 569 | if (!SvREFCNT(stash)) /* symbol table under destruction */ |
---|
| 570 | return Nullgv; |
---|
| 571 | |
---|
| 572 | gvp = (GV**)hv_fetch(stash,name,len,add); |
---|
| 573 | if (!gvp || *gvp == (GV*)&sv_undef) |
---|
| 574 | return Nullgv; |
---|
| 575 | gv = *gvp; |
---|
| 576 | if (SvTYPE(gv) == SVt_PVGV) { |
---|
| 577 | if (add) { |
---|
| 578 | GvMULTI_on(gv); |
---|
| 579 | gv_init_sv(gv, sv_type); |
---|
| 580 | } |
---|
| 581 | return gv; |
---|
| 582 | } |
---|
| 583 | |
---|
| 584 | /* Adding a new symbol */ |
---|
| 585 | |
---|
| 586 | if (add & 4) |
---|
| 587 | warn("Had to create %s unexpectedly", nambeg); |
---|
| 588 | gv_init(gv, stash, name, len, add & 2); |
---|
| 589 | gv_init_sv(gv, sv_type); |
---|
| 590 | GvFLAGS(gv) |= add_gvflags; |
---|
| 591 | |
---|
| 592 | /* set up magic where warranted */ |
---|
| 593 | switch (*name) { |
---|
| 594 | case 'A': |
---|
| 595 | if (strEQ(name, "ARGV")) { |
---|
| 596 | IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; |
---|
| 597 | } |
---|
| 598 | break; |
---|
| 599 | |
---|
| 600 | case 'a': |
---|
| 601 | case 'b': |
---|
| 602 | if (len == 1) |
---|
| 603 | GvMULTI_on(gv); |
---|
| 604 | break; |
---|
| 605 | case 'E': |
---|
| 606 | if (strnEQ(name, "EXPORT", 6)) |
---|
| 607 | GvMULTI_on(gv); |
---|
| 608 | break; |
---|
| 609 | case 'I': |
---|
| 610 | if (strEQ(name, "ISA")) { |
---|
| 611 | AV* av = GvAVn(gv); |
---|
| 612 | GvMULTI_on(gv); |
---|
| 613 | sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0); |
---|
| 614 | if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1) |
---|
| 615 | { |
---|
| 616 | char *pname; |
---|
| 617 | av_push(av, newSVpv(pname = "NDBM_File",0)); |
---|
| 618 | gv_stashpvn(pname, 9, TRUE); |
---|
| 619 | av_push(av, newSVpv(pname = "DB_File",0)); |
---|
| 620 | gv_stashpvn(pname, 7, TRUE); |
---|
| 621 | av_push(av, newSVpv(pname = "GDBM_File",0)); |
---|
| 622 | gv_stashpvn(pname, 9, TRUE); |
---|
| 623 | av_push(av, newSVpv(pname = "SDBM_File",0)); |
---|
| 624 | gv_stashpvn(pname, 9, TRUE); |
---|
| 625 | av_push(av, newSVpv(pname = "ODBM_File",0)); |
---|
| 626 | gv_stashpvn(pname, 9, TRUE); |
---|
| 627 | } |
---|
| 628 | } |
---|
| 629 | break; |
---|
| 630 | #ifdef OVERLOAD |
---|
| 631 | case 'O': |
---|
| 632 | if (strEQ(name, "OVERLOAD")) { |
---|
| 633 | HV* hv = GvHVn(gv); |
---|
| 634 | GvMULTI_on(gv); |
---|
| 635 | sv_magic((SV*)hv, (SV*)gv, 'A', 0, 0); |
---|
| 636 | } |
---|
| 637 | break; |
---|
| 638 | #endif /* OVERLOAD */ |
---|
| 639 | case 'S': |
---|
| 640 | if (strEQ(name, "SIG")) { |
---|
| 641 | HV *hv; |
---|
| 642 | I32 i; |
---|
| 643 | siggv = gv; |
---|
| 644 | GvMULTI_on(siggv); |
---|
| 645 | hv = GvHVn(siggv); |
---|
| 646 | hv_magic(hv, siggv, 'S'); |
---|
| 647 | for(i=1;sig_name[i];i++) { |
---|
| 648 | SV ** init; |
---|
| 649 | init=hv_fetch(hv,sig_name[i],strlen(sig_name[i]),1); |
---|
| 650 | if(init) |
---|
| 651 | sv_setsv(*init,&sv_undef); |
---|
| 652 | psig_ptr[i] = 0; |
---|
| 653 | psig_name[i] = 0; |
---|
| 654 | } |
---|
| 655 | /* initialize signal stack */ |
---|
| 656 | signalstack = newAV(); |
---|
| 657 | AvREAL_off(signalstack); |
---|
| 658 | av_extend(signalstack, 30); |
---|
| 659 | av_fill(signalstack, 0); |
---|
| 660 | } |
---|
| 661 | break; |
---|
| 662 | |
---|
| 663 | case '&': |
---|
| 664 | if (len > 1) |
---|
| 665 | break; |
---|
| 666 | ampergv = gv; |
---|
| 667 | sawampersand = TRUE; |
---|
| 668 | goto ro_magicalize; |
---|
| 669 | |
---|
| 670 | case '`': |
---|
| 671 | if (len > 1) |
---|
| 672 | break; |
---|
| 673 | leftgv = gv; |
---|
| 674 | sawampersand = TRUE; |
---|
| 675 | goto ro_magicalize; |
---|
| 676 | |
---|
| 677 | case '\'': |
---|
| 678 | if (len > 1) |
---|
| 679 | break; |
---|
| 680 | rightgv = gv; |
---|
| 681 | sawampersand = TRUE; |
---|
| 682 | goto ro_magicalize; |
---|
| 683 | |
---|
| 684 | case ':': |
---|
| 685 | if (len > 1) |
---|
| 686 | break; |
---|
| 687 | sv_setpv(GvSV(gv),chopset); |
---|
| 688 | goto magicalize; |
---|
| 689 | |
---|
| 690 | case '?': |
---|
| 691 | if (len > 1) |
---|
| 692 | break; |
---|
| 693 | #ifdef COMPLEX_STATUS |
---|
| 694 | sv_upgrade(GvSV(gv), SVt_PVLV); |
---|
| 695 | #endif |
---|
| 696 | goto magicalize; |
---|
| 697 | |
---|
| 698 | case '#': |
---|
| 699 | case '*': |
---|
| 700 | if (dowarn && len == 1 && sv_type == SVt_PV) |
---|
| 701 | warn("Use of $%s is deprecated", name); |
---|
| 702 | /* FALL THROUGH */ |
---|
| 703 | case '[': |
---|
| 704 | case '!': |
---|
| 705 | case '^': |
---|
| 706 | case '~': |
---|
| 707 | case '=': |
---|
| 708 | case '-': |
---|
| 709 | case '%': |
---|
| 710 | case '.': |
---|
| 711 | case '(': |
---|
| 712 | case ')': |
---|
| 713 | case '<': |
---|
| 714 | case '>': |
---|
| 715 | case ',': |
---|
| 716 | case '\\': |
---|
| 717 | case '/': |
---|
| 718 | case '|': |
---|
| 719 | case '\001': |
---|
| 720 | case '\004': |
---|
| 721 | case '\005': |
---|
| 722 | case '\006': |
---|
| 723 | case '\010': |
---|
| 724 | case '\017': |
---|
| 725 | case '\t': |
---|
| 726 | case '\020': |
---|
| 727 | case '\024': |
---|
| 728 | case '\027': |
---|
| 729 | if (len > 1) |
---|
| 730 | break; |
---|
| 731 | goto magicalize; |
---|
| 732 | |
---|
| 733 | case '+': |
---|
| 734 | case '1': |
---|
| 735 | case '2': |
---|
| 736 | case '3': |
---|
| 737 | case '4': |
---|
| 738 | case '5': |
---|
| 739 | case '6': |
---|
| 740 | case '7': |
---|
| 741 | case '8': |
---|
| 742 | case '9': |
---|
| 743 | case '\023': |
---|
| 744 | ro_magicalize: |
---|
| 745 | SvREADONLY_on(GvSV(gv)); |
---|
| 746 | magicalize: |
---|
| 747 | sv_magic(GvSV(gv), (SV*)gv, 0, name, len); |
---|
| 748 | break; |
---|
| 749 | |
---|
| 750 | case '\014': |
---|
| 751 | if (len > 1) |
---|
| 752 | break; |
---|
| 753 | sv_setpv(GvSV(gv),"\f"); |
---|
| 754 | formfeed = GvSV(gv); |
---|
| 755 | break; |
---|
| 756 | case ';': |
---|
| 757 | if (len > 1) |
---|
| 758 | break; |
---|
| 759 | sv_setpv(GvSV(gv),"\034"); |
---|
| 760 | break; |
---|
| 761 | case ']': |
---|
| 762 | if (len == 1) { |
---|
| 763 | SV *sv = GvSV(gv); |
---|
| 764 | sv_upgrade(sv, SVt_PVNV); |
---|
| 765 | sv_setpv(sv, patchlevel); |
---|
| 766 | (void)sv_2nv(sv); |
---|
| 767 | SvREADONLY_on(sv); |
---|
| 768 | } |
---|
| 769 | break; |
---|
| 770 | } |
---|
| 771 | return gv; |
---|
| 772 | } |
---|
| 773 | |
---|
| 774 | void |
---|
| 775 | gv_fullname3(sv, gv, prefix) |
---|
| 776 | SV *sv; |
---|
| 777 | GV *gv; |
---|
| 778 | char *prefix; |
---|
| 779 | { |
---|
| 780 | HV *hv = GvSTASH(gv); |
---|
| 781 | if (!hv) { |
---|
| 782 | SvOK_off(sv); |
---|
| 783 | return; |
---|
| 784 | } |
---|
| 785 | sv_setpv(sv, prefix ? prefix : ""); |
---|
| 786 | sv_catpv(sv,HvNAME(hv)); |
---|
| 787 | sv_catpvn(sv,"::", 2); |
---|
| 788 | sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); |
---|
| 789 | } |
---|
| 790 | |
---|
| 791 | void |
---|
| 792 | gv_efullname3(sv, gv, prefix) |
---|
| 793 | SV *sv; |
---|
| 794 | GV *gv; |
---|
| 795 | char *prefix; |
---|
| 796 | { |
---|
| 797 | GV *egv = GvEGV(gv); |
---|
| 798 | if (!egv) |
---|
| 799 | egv = gv; |
---|
| 800 | gv_fullname3(sv, egv, prefix); |
---|
| 801 | } |
---|
| 802 | |
---|
| 803 | /* XXX compatibility with versions <= 5.003. */ |
---|
| 804 | void |
---|
| 805 | gv_fullname(sv,gv) |
---|
| 806 | SV *sv; |
---|
| 807 | GV *gv; |
---|
| 808 | { |
---|
| 809 | gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : ""); |
---|
| 810 | } |
---|
| 811 | |
---|
| 812 | /* XXX compatibility with versions <= 5.003. */ |
---|
| 813 | void |
---|
| 814 | gv_efullname(sv,gv) |
---|
| 815 | SV *sv; |
---|
| 816 | GV *gv; |
---|
| 817 | { |
---|
| 818 | gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : ""); |
---|
| 819 | } |
---|
| 820 | |
---|
| 821 | IO * |
---|
| 822 | newIO() |
---|
| 823 | { |
---|
| 824 | IO *io; |
---|
| 825 | GV *iogv; |
---|
| 826 | |
---|
| 827 | io = (IO*)NEWSV(0,0); |
---|
| 828 | sv_upgrade((SV *)io,SVt_PVIO); |
---|
| 829 | SvREFCNT(io) = 1; |
---|
| 830 | SvOBJECT_on(io); |
---|
| 831 | iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV); |
---|
| 832 | if (!iogv) |
---|
| 833 | iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV); |
---|
| 834 | SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv)); |
---|
| 835 | return io; |
---|
| 836 | } |
---|
| 837 | |
---|
| 838 | void |
---|
| 839 | gv_check(stash) |
---|
| 840 | HV* stash; |
---|
| 841 | { |
---|
| 842 | register HE *entry; |
---|
| 843 | register I32 i; |
---|
| 844 | register GV *gv; |
---|
| 845 | HV *hv; |
---|
| 846 | GV *filegv; |
---|
| 847 | |
---|
| 848 | if (!HvARRAY(stash)) |
---|
| 849 | return; |
---|
| 850 | for (i = 0; i <= (I32) HvMAX(stash); i++) { |
---|
| 851 | for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { |
---|
| 852 | if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && |
---|
| 853 | (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv)) |
---|
| 854 | { |
---|
| 855 | if (hv != defstash) |
---|
| 856 | gv_check(hv); /* nested package */ |
---|
| 857 | } |
---|
| 858 | else if (isALPHA(*HeKEY(entry))) { |
---|
| 859 | gv = (GV*)HeVAL(entry); |
---|
| 860 | if (GvMULTI(gv)) |
---|
| 861 | continue; |
---|
| 862 | curcop->cop_line = GvLINE(gv); |
---|
| 863 | filegv = GvFILEGV(gv); |
---|
| 864 | curcop->cop_filegv = filegv; |
---|
| 865 | if (filegv && GvMULTI(filegv)) /* Filename began with slash */ |
---|
| 866 | continue; |
---|
| 867 | warn("Name \"%s::%s\" used only once: possible typo", |
---|
| 868 | HvNAME(stash), GvNAME(gv)); |
---|
| 869 | } |
---|
| 870 | } |
---|
| 871 | } |
---|
| 872 | } |
---|
| 873 | |
---|
| 874 | GV * |
---|
| 875 | newGVgen(pack) |
---|
| 876 | char *pack; |
---|
| 877 | { |
---|
| 878 | return gv_fetchpv(form("%s::_GEN_%ld", pack, (long)gensym++), |
---|
| 879 | TRUE, SVt_PVGV); |
---|
| 880 | } |
---|
| 881 | |
---|
| 882 | /* hopefully this is only called on local symbol table entries */ |
---|
| 883 | |
---|
| 884 | GP* |
---|
| 885 | gp_ref(gp) |
---|
| 886 | GP* gp; |
---|
| 887 | { |
---|
| 888 | gp->gp_refcnt++; |
---|
| 889 | if (gp->gp_cv) { |
---|
| 890 | if (gp->gp_cvgen) { |
---|
| 891 | /* multi-named GPs cannot be used for method cache */ |
---|
| 892 | SvREFCNT_dec(gp->gp_cv); |
---|
| 893 | gp->gp_cv = Nullcv; |
---|
| 894 | gp->gp_cvgen = 0; |
---|
| 895 | } |
---|
| 896 | else { |
---|
| 897 | /* Adding a new name to a subroutine invalidates method cache */ |
---|
| 898 | sub_generation++; |
---|
| 899 | } |
---|
| 900 | } |
---|
| 901 | return gp; |
---|
| 902 | } |
---|
| 903 | |
---|
| 904 | void |
---|
| 905 | gp_free(gv) |
---|
| 906 | GV* gv; |
---|
| 907 | { |
---|
| 908 | GP* gp; |
---|
| 909 | CV* cv; |
---|
| 910 | |
---|
| 911 | if (!gv || !(gp = GvGP(gv))) |
---|
| 912 | return; |
---|
| 913 | if (gp->gp_refcnt == 0) { |
---|
| 914 | warn("Attempt to free unreferenced glob pointers"); |
---|
| 915 | return; |
---|
| 916 | } |
---|
| 917 | if (gp->gp_cv) { |
---|
| 918 | /* Deleting the name of a subroutine invalidates method cache */ |
---|
| 919 | sub_generation++; |
---|
| 920 | } |
---|
| 921 | if (--gp->gp_refcnt > 0) { |
---|
| 922 | if (gp->gp_egv == gv) |
---|
| 923 | gp->gp_egv = 0; |
---|
| 924 | return; |
---|
| 925 | } |
---|
| 926 | |
---|
| 927 | SvREFCNT_dec(gp->gp_sv); |
---|
| 928 | SvREFCNT_dec(gp->gp_av); |
---|
| 929 | SvREFCNT_dec(gp->gp_hv); |
---|
| 930 | SvREFCNT_dec(gp->gp_io); |
---|
| 931 | SvREFCNT_dec(gp->gp_cv); |
---|
| 932 | SvREFCNT_dec(gp->gp_form); |
---|
| 933 | |
---|
| 934 | Safefree(gp); |
---|
| 935 | GvGP(gv) = 0; |
---|
| 936 | } |
---|
| 937 | |
---|
| 938 | #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286)) |
---|
| 939 | #define MICROPORT |
---|
| 940 | #endif |
---|
| 941 | |
---|
| 942 | #ifdef MICROPORT /* Microport 2.4 hack */ |
---|
| 943 | AV *GvAVn(gv) |
---|
| 944 | register GV *gv; |
---|
| 945 | { |
---|
| 946 | if (GvGP(gv)->gp_av) |
---|
| 947 | return GvGP(gv)->gp_av; |
---|
| 948 | else |
---|
| 949 | return GvGP(gv_AVadd(gv))->gp_av; |
---|
| 950 | } |
---|
| 951 | |
---|
| 952 | HV *GvHVn(gv) |
---|
| 953 | register GV *gv; |
---|
| 954 | { |
---|
| 955 | if (GvGP(gv)->gp_hv) |
---|
| 956 | return GvGP(gv)->gp_hv; |
---|
| 957 | else |
---|
| 958 | return GvGP(gv_HVadd(gv))->gp_hv; |
---|
| 959 | } |
---|
| 960 | #endif /* Microport 2.4 hack */ |
---|
| 961 | |
---|
| 962 | #ifdef OVERLOAD |
---|
| 963 | /* Updates and caches the CV's */ |
---|
| 964 | |
---|
| 965 | bool |
---|
| 966 | Gv_AMupdate(stash) |
---|
| 967 | HV* stash; |
---|
| 968 | { |
---|
| 969 | GV** gvp; |
---|
| 970 | HV* hv; |
---|
| 971 | GV* gv; |
---|
| 972 | CV* cv; |
---|
| 973 | MAGIC* mg=mg_find((SV*)stash,'c'); |
---|
| 974 | AMT *amtp=mg ? (AMT*)mg->mg_ptr: NULL; |
---|
| 975 | AMT amt; |
---|
| 976 | |
---|
| 977 | if (mg && amtp->was_ok_am == amagic_generation |
---|
| 978 | && amtp->was_ok_sub == sub_generation) |
---|
| 979 | return AMT_AMAGIC(amtp); |
---|
| 980 | if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */ |
---|
| 981 | int i; |
---|
| 982 | for (i=1; i<NofAMmeth; i++) { |
---|
| 983 | if (amtp->table[i]) { |
---|
| 984 | SvREFCNT_dec(amtp->table[i]); |
---|
| 985 | } |
---|
| 986 | } |
---|
| 987 | } |
---|
| 988 | sv_unmagic((SV*)stash, 'c'); |
---|
| 989 | |
---|
| 990 | DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) ); |
---|
| 991 | |
---|
| 992 | amt.was_ok_am = amagic_generation; |
---|
| 993 | amt.was_ok_sub = sub_generation; |
---|
| 994 | amt.fallback = AMGfallNO; |
---|
| 995 | amt.flags = 0; |
---|
| 996 | |
---|
| 997 | #ifdef OVERLOAD_VIA_HASH |
---|
| 998 | gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */ |
---|
| 999 | if (gvp && ((gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv)))) { |
---|
| 1000 | int filled=0; |
---|
| 1001 | int i; |
---|
| 1002 | char *cp; |
---|
| 1003 | SV* sv; |
---|
| 1004 | SV** svp; |
---|
| 1005 | |
---|
| 1006 | /* Work with "fallback" key, which we assume to be first in AMG_names */ |
---|
| 1007 | |
---|
| 1008 | if (( cp = (char *)AMG_names[0] ) && |
---|
| 1009 | (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) { |
---|
| 1010 | if (SvTRUE(sv)) amt.fallback=AMGfallYES; |
---|
| 1011 | else if (SvOK(sv)) amt.fallback=AMGfallNEVER; |
---|
| 1012 | } |
---|
| 1013 | for (i = 1; i < NofAMmeth; i++) { |
---|
| 1014 | cv = 0; |
---|
| 1015 | cp = (char *)AMG_names[i]; |
---|
| 1016 | |
---|
| 1017 | svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE); |
---|
| 1018 | if (svp && ((sv = *svp) != &sv_undef)) { |
---|
| 1019 | switch (SvTYPE(sv)) { |
---|
| 1020 | default: |
---|
| 1021 | if (!SvROK(sv)) { |
---|
| 1022 | if (!SvOK(sv)) break; |
---|
| 1023 | gv = gv_fetchmethod(stash, SvPV(sv, na)); |
---|
| 1024 | if (gv) cv = GvCV(gv); |
---|
| 1025 | break; |
---|
| 1026 | } |
---|
| 1027 | cv = (CV*)SvRV(sv); |
---|
| 1028 | if (SvTYPE(cv) == SVt_PVCV) |
---|
| 1029 | break; |
---|
| 1030 | /* FALL THROUGH */ |
---|
| 1031 | case SVt_PVHV: |
---|
| 1032 | case SVt_PVAV: |
---|
| 1033 | croak("Not a subroutine reference in overload table"); |
---|
| 1034 | return FALSE; |
---|
| 1035 | case SVt_PVCV: |
---|
| 1036 | cv = (CV*)sv; |
---|
| 1037 | break; |
---|
| 1038 | case SVt_PVGV: |
---|
| 1039 | if (!(cv = GvCVu((GV*)sv))) |
---|
| 1040 | cv = sv_2cv(sv, &stash, &gv, TRUE); |
---|
| 1041 | break; |
---|
| 1042 | } |
---|
| 1043 | if (cv) filled=1; |
---|
| 1044 | else { |
---|
| 1045 | croak("Method for operation %s not found in package %.256s during blessing\n", |
---|
| 1046 | cp,HvNAME(stash)); |
---|
| 1047 | return FALSE; |
---|
| 1048 | } |
---|
| 1049 | } |
---|
| 1050 | #else |
---|
| 1051 | { |
---|
| 1052 | int filled = 0; |
---|
| 1053 | int i; |
---|
| 1054 | const char *cp; |
---|
| 1055 | SV* sv = NULL; |
---|
| 1056 | SV** svp; |
---|
| 1057 | |
---|
| 1058 | /* Work with "fallback" key, which we assume to be first in AMG_names */ |
---|
| 1059 | |
---|
| 1060 | if ( cp = AMG_names[0] ) { |
---|
| 1061 | /* Try to find via inheritance. */ |
---|
| 1062 | gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */ |
---|
| 1063 | if (gv) sv = GvSV(gv); |
---|
| 1064 | |
---|
| 1065 | if (!gv) goto no_table; |
---|
| 1066 | else if (SvTRUE(sv)) amt.fallback=AMGfallYES; |
---|
| 1067 | else if (SvOK(sv)) amt.fallback=AMGfallNEVER; |
---|
| 1068 | } |
---|
| 1069 | |
---|
| 1070 | for (i = 1; i < NofAMmeth; i++) { |
---|
| 1071 | SV *cookie = sv_2mortal(newSVpvf("(%s", cp = AMG_names[i])); |
---|
| 1072 | DEBUG_o( deb("Checking overloading of `%s' in package `%.256s'\n", |
---|
| 1073 | cp, HvNAME(stash)) ); |
---|
| 1074 | /* don't fill the cache while looking up! */ |
---|
| 1075 | gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1); |
---|
| 1076 | cv = 0; |
---|
| 1077 | if(gv && (cv = GvCV(gv))) { |
---|
| 1078 | if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") |
---|
| 1079 | && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) { |
---|
| 1080 | /* GvSV contains the name of the method. */ |
---|
| 1081 | GV *ngv; |
---|
| 1082 | |
---|
| 1083 | DEBUG_o( deb("Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n", |
---|
| 1084 | SvPV(GvSV(gv), na), cp, HvNAME(stash)) ); |
---|
| 1085 | if (!SvPOK(GvSV(gv)) |
---|
| 1086 | || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)), |
---|
| 1087 | FALSE))) |
---|
| 1088 | { |
---|
| 1089 | /* Can be an import stub (created by `can'). */ |
---|
| 1090 | if (GvCVGEN(gv)) { |
---|
| 1091 | croak("Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'", |
---|
| 1092 | (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), |
---|
| 1093 | cp, HvNAME(stash)); |
---|
| 1094 | } else |
---|
| 1095 | croak("Cannot resolve method `%.256s' overloading `%s' in package `%.256s'", |
---|
| 1096 | (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), |
---|
| 1097 | cp, HvNAME(stash)); |
---|
| 1098 | } |
---|
| 1099 | cv = GvCV(gv = ngv); |
---|
| 1100 | } |
---|
| 1101 | DEBUG_o( deb("Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n", |
---|
| 1102 | cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))), |
---|
| 1103 | GvNAME(CvGV(cv))) ); |
---|
| 1104 | filled = 1; |
---|
| 1105 | } |
---|
| 1106 | #endif |
---|
| 1107 | amt.table[i]=(CV*)SvREFCNT_inc(cv); |
---|
| 1108 | } |
---|
| 1109 | if (filled) { |
---|
| 1110 | AMT_AMAGIC_on(&amt); |
---|
| 1111 | sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT)); |
---|
| 1112 | return TRUE; |
---|
| 1113 | } |
---|
| 1114 | } |
---|
| 1115 | /* Here we have no table: */ |
---|
| 1116 | no_table: |
---|
| 1117 | AMT_AMAGIC_off(&amt); |
---|
| 1118 | sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS)); |
---|
| 1119 | return FALSE; |
---|
| 1120 | } |
---|
| 1121 | |
---|
| 1122 | /* During call to this subroutine stack can be reallocated. It is |
---|
| 1123 | * advised to call SPAGAIN macro in your code after call */ |
---|
| 1124 | |
---|
| 1125 | SV* |
---|
| 1126 | amagic_call(left,right,method,flags) |
---|
| 1127 | SV* left; |
---|
| 1128 | SV* right; |
---|
| 1129 | int method; |
---|
| 1130 | int flags; |
---|
| 1131 | { |
---|
| 1132 | MAGIC *mg; |
---|
| 1133 | CV *cv; |
---|
| 1134 | CV **cvp=NULL, **ocvp=NULL; |
---|
| 1135 | AMT *amtp, *oamtp; |
---|
| 1136 | int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0; |
---|
| 1137 | int postpr=0, inc_dec_ass=0, assignshift=assign?1:0; |
---|
| 1138 | HV* stash; |
---|
| 1139 | if (!(AMGf_noleft & flags) && SvAMAGIC(left) |
---|
| 1140 | && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c')) |
---|
| 1141 | && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) |
---|
| 1142 | ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table |
---|
| 1143 | : NULL)) |
---|
| 1144 | && ((cv = cvp[off=method+assignshift]) |
---|
| 1145 | || (assign && amtp->fallback > AMGfallNEVER && /* fallback to |
---|
| 1146 | * usual method */ |
---|
| 1147 | (fl = 1, cv = cvp[off=method])))) { |
---|
| 1148 | lr = -1; /* Call method for left argument */ |
---|
| 1149 | } else { |
---|
| 1150 | if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { |
---|
| 1151 | int logic; |
---|
| 1152 | |
---|
| 1153 | /* look for substituted methods */ |
---|
| 1154 | switch (method) { |
---|
| 1155 | case inc_amg: |
---|
| 1156 | if (((cv = cvp[off=add_ass_amg]) && (inc_dec_ass=1)) |
---|
| 1157 | || ((cv = cvp[off=add_amg]) && (postpr=1))) { |
---|
| 1158 | right = &sv_yes; lr = -1; assign = 1; |
---|
| 1159 | } |
---|
| 1160 | break; |
---|
| 1161 | case dec_amg: |
---|
| 1162 | if (((cv = cvp[off=subtr_ass_amg]) && (inc_dec_ass=1)) |
---|
| 1163 | || ((cv = cvp[off=subtr_amg]) && (postpr=1))) { |
---|
| 1164 | right = &sv_yes; lr = -1; assign = 1; |
---|
| 1165 | } |
---|
| 1166 | break; |
---|
| 1167 | case bool__amg: |
---|
| 1168 | (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); |
---|
| 1169 | break; |
---|
| 1170 | case numer_amg: |
---|
| 1171 | (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); |
---|
| 1172 | break; |
---|
| 1173 | case string_amg: |
---|
| 1174 | (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); |
---|
| 1175 | break; |
---|
| 1176 | case not_amg: |
---|
| 1177 | (void)((cv = cvp[off=bool__amg]) |
---|
| 1178 | || (cv = cvp[off=numer_amg]) |
---|
| 1179 | || (cv = cvp[off=string_amg])); |
---|
| 1180 | postpr = 1; |
---|
| 1181 | break; |
---|
| 1182 | case copy_amg: |
---|
| 1183 | { |
---|
| 1184 | SV* ref=SvRV(left); |
---|
| 1185 | if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) { |
---|
| 1186 | /* |
---|
| 1187 | * Just to be extra cautious. Maybe in some |
---|
| 1188 | * additional cases sv_setsv is safe, too. |
---|
| 1189 | */ |
---|
| 1190 | SV* newref = newSVsv(ref); |
---|
| 1191 | SvOBJECT_on(newref); |
---|
| 1192 | SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(ref)); |
---|
| 1193 | return newref; |
---|
| 1194 | } |
---|
| 1195 | } |
---|
| 1196 | break; |
---|
| 1197 | case abs_amg: |
---|
| 1198 | if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) |
---|
| 1199 | && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { |
---|
| 1200 | SV* nullsv=sv_2mortal(newSViv(0)); |
---|
| 1201 | if (off1==lt_amg) { |
---|
| 1202 | SV* lessp = amagic_call(left,nullsv, |
---|
| 1203 | lt_amg,AMGf_noright); |
---|
| 1204 | logic = SvTRUE(lessp); |
---|
| 1205 | } else { |
---|
| 1206 | SV* lessp = amagic_call(left,nullsv, |
---|
| 1207 | ncmp_amg,AMGf_noright); |
---|
| 1208 | logic = (SvNV(lessp) < 0); |
---|
| 1209 | } |
---|
| 1210 | if (logic) { |
---|
| 1211 | if (off==subtr_amg) { |
---|
| 1212 | right = left; |
---|
| 1213 | left = nullsv; |
---|
| 1214 | lr = 1; |
---|
| 1215 | } |
---|
| 1216 | } else { |
---|
| 1217 | return left; |
---|
| 1218 | } |
---|
| 1219 | } |
---|
| 1220 | break; |
---|
| 1221 | case neg_amg: |
---|
| 1222 | if (cv = cvp[off=subtr_amg]) { |
---|
| 1223 | right = left; |
---|
| 1224 | left = sv_2mortal(newSViv(0)); |
---|
| 1225 | lr = 1; |
---|
| 1226 | } |
---|
| 1227 | break; |
---|
| 1228 | default: |
---|
| 1229 | goto not_found; |
---|
| 1230 | } |
---|
| 1231 | if (!cv) goto not_found; |
---|
| 1232 | } else if (!(AMGf_noright & flags) && SvAMAGIC(right) |
---|
| 1233 | && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c')) |
---|
| 1234 | && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) |
---|
| 1235 | ? (amtp = (AMT*)mg->mg_ptr)->table |
---|
| 1236 | : NULL)) |
---|
| 1237 | && (cv = cvp[off=method])) { /* Method for right |
---|
| 1238 | * argument found */ |
---|
| 1239 | lr=1; |
---|
| 1240 | } else if (((ocvp && oamtp->fallback > AMGfallNEVER |
---|
| 1241 | && (cvp=ocvp) && (lr = -1)) |
---|
| 1242 | || (cvp && amtp->fallback > AMGfallNEVER && (lr=1))) |
---|
| 1243 | && !(flags & AMGf_unary)) { |
---|
| 1244 | /* We look for substitution for |
---|
| 1245 | * comparison operations and |
---|
| 1246 | * concatenation */ |
---|
| 1247 | if (method==concat_amg || method==concat_ass_amg |
---|
| 1248 | || method==repeat_amg || method==repeat_ass_amg) { |
---|
| 1249 | return NULL; /* Delegate operation to string conversion */ |
---|
| 1250 | } |
---|
| 1251 | off = -1; |
---|
| 1252 | switch (method) { |
---|
| 1253 | case lt_amg: |
---|
| 1254 | case le_amg: |
---|
| 1255 | case gt_amg: |
---|
| 1256 | case ge_amg: |
---|
| 1257 | case eq_amg: |
---|
| 1258 | case ne_amg: |
---|
| 1259 | postpr = 1; off=ncmp_amg; break; |
---|
| 1260 | case slt_amg: |
---|
| 1261 | case sle_amg: |
---|
| 1262 | case sgt_amg: |
---|
| 1263 | case sge_amg: |
---|
| 1264 | case seq_amg: |
---|
| 1265 | case sne_amg: |
---|
| 1266 | postpr = 1; off=scmp_amg; break; |
---|
| 1267 | } |
---|
| 1268 | if (off != -1) cv = cvp[off]; |
---|
| 1269 | if (!cv) { |
---|
| 1270 | goto not_found; |
---|
| 1271 | } |
---|
| 1272 | } else { |
---|
| 1273 | not_found: /* No method found, either report or croak */ |
---|
| 1274 | if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ |
---|
| 1275 | notfound = 1; lr = -1; |
---|
| 1276 | } else if (cvp && (cv=cvp[nomethod_amg])) { |
---|
| 1277 | notfound = 1; lr = 1; |
---|
| 1278 | } else { |
---|
| 1279 | SV *msg; |
---|
| 1280 | if (off==-1) off=method; |
---|
| 1281 | msg = sv_2mortal(newSVpvf( |
---|
| 1282 | "Operation `%s': no method found,%sargument %s%s%s%s", |
---|
| 1283 | AMG_names[method + assignshift], |
---|
| 1284 | (flags & AMGf_unary ? " " : "\n\tleft "), |
---|
| 1285 | SvAMAGIC(left)? |
---|
| 1286 | "in overloaded package ": |
---|
| 1287 | "has no overloaded magic", |
---|
| 1288 | SvAMAGIC(left)? |
---|
| 1289 | HvNAME(SvSTASH(SvRV(left))): |
---|
| 1290 | "", |
---|
| 1291 | SvAMAGIC(right)? |
---|
| 1292 | ",\n\tright argument in overloaded package ": |
---|
| 1293 | (flags & AMGf_unary |
---|
| 1294 | ? "" |
---|
| 1295 | : ",\n\tright argument has no overloaded magic"), |
---|
| 1296 | SvAMAGIC(right)? |
---|
| 1297 | HvNAME(SvSTASH(SvRV(right))): |
---|
| 1298 | "")); |
---|
| 1299 | if (amtp && amtp->fallback >= AMGfallYES) { |
---|
| 1300 | DEBUG_o( deb("%s", SvPVX(msg)) ); |
---|
| 1301 | } else { |
---|
| 1302 | croak("%_", msg); |
---|
| 1303 | } |
---|
| 1304 | return NULL; |
---|
| 1305 | } |
---|
| 1306 | } |
---|
| 1307 | } |
---|
| 1308 | if (!notfound) { |
---|
| 1309 | DEBUG_o( deb( |
---|
| 1310 | "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n", |
---|
| 1311 | AMG_names[off], |
---|
| 1312 | method+assignshift==off? "" : |
---|
| 1313 | " (initially `", |
---|
| 1314 | method+assignshift==off? "" : |
---|
| 1315 | AMG_names[method+assignshift], |
---|
| 1316 | method+assignshift==off? "" : "')", |
---|
| 1317 | flags & AMGf_unary? "" : |
---|
| 1318 | lr==1 ? " for right argument": " for left argument", |
---|
| 1319 | flags & AMGf_unary? " for argument" : "", |
---|
| 1320 | HvNAME(stash), |
---|
| 1321 | fl? ",\n\tassignment variant used": "") ); |
---|
| 1322 | /* Since we use shallow copy during assignment, we need |
---|
| 1323 | * to dublicate the contents, probably calling user-supplied |
---|
| 1324 | * version of copy operator |
---|
| 1325 | */ |
---|
| 1326 | if ((method + assignshift==off |
---|
| 1327 | && (assign || method==inc_amg || method==dec_amg)) |
---|
| 1328 | || inc_dec_ass) RvDEEPCP(left); |
---|
| 1329 | } |
---|
| 1330 | { |
---|
| 1331 | dSP; |
---|
| 1332 | BINOP myop; |
---|
| 1333 | SV* res; |
---|
| 1334 | bool oldcatch = CATCH_GET; |
---|
| 1335 | |
---|
| 1336 | CATCH_SET(TRUE); |
---|
| 1337 | Zero(&myop, 1, BINOP); |
---|
| 1338 | myop.op_last = (OP *) &myop; |
---|
| 1339 | myop.op_next = Nullop; |
---|
| 1340 | myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; |
---|
| 1341 | |
---|
| 1342 | ENTER; |
---|
| 1343 | SAVESPTR(op); |
---|
| 1344 | op = (OP *) &myop; |
---|
| 1345 | if (PERLDB_SUB && curstash != debstash) |
---|
| 1346 | op->op_private |= OPpENTERSUB_DB; |
---|
| 1347 | PUTBACK; |
---|
| 1348 | pp_pushmark(); |
---|
| 1349 | |
---|
| 1350 | EXTEND(sp, notfound + 5); |
---|
| 1351 | PUSHs(lr>0? right: left); |
---|
| 1352 | PUSHs(lr>0? left: right); |
---|
| 1353 | PUSHs( lr > 0 ? &sv_yes : ( assign ? &sv_undef : &sv_no )); |
---|
| 1354 | if (notfound) { |
---|
| 1355 | PUSHs( sv_2mortal(newSVpv((char *)AMG_names[method + assignshift],0)) ); |
---|
| 1356 | } |
---|
| 1357 | PUSHs((SV*)cv); |
---|
| 1358 | PUTBACK; |
---|
| 1359 | |
---|
| 1360 | if (op = pp_entersub()) |
---|
| 1361 | runops(); |
---|
| 1362 | LEAVE; |
---|
| 1363 | SPAGAIN; |
---|
| 1364 | |
---|
| 1365 | res=POPs; |
---|
| 1366 | PUTBACK; |
---|
| 1367 | CATCH_SET(oldcatch); |
---|
| 1368 | |
---|
| 1369 | if (postpr) { |
---|
| 1370 | int ans; |
---|
| 1371 | switch (method) { |
---|
| 1372 | case le_amg: |
---|
| 1373 | case sle_amg: |
---|
| 1374 | ans=SvIV(res)<=0; break; |
---|
| 1375 | case lt_amg: |
---|
| 1376 | case slt_amg: |
---|
| 1377 | ans=SvIV(res)<0; break; |
---|
| 1378 | case ge_amg: |
---|
| 1379 | case sge_amg: |
---|
| 1380 | ans=SvIV(res)>=0; break; |
---|
| 1381 | case gt_amg: |
---|
| 1382 | case sgt_amg: |
---|
| 1383 | ans=SvIV(res)>0; break; |
---|
| 1384 | case eq_amg: |
---|
| 1385 | case seq_amg: |
---|
| 1386 | ans=SvIV(res)==0; break; |
---|
| 1387 | case ne_amg: |
---|
| 1388 | case sne_amg: |
---|
| 1389 | ans=SvIV(res)!=0; break; |
---|
| 1390 | case inc_amg: |
---|
| 1391 | case dec_amg: |
---|
| 1392 | SvSetSV(left,res); return left; |
---|
| 1393 | case not_amg: |
---|
| 1394 | ans=!SvOK(res); break; |
---|
| 1395 | } |
---|
| 1396 | return boolSV(ans); |
---|
| 1397 | } else if (method==copy_amg) { |
---|
| 1398 | if (!SvROK(res)) { |
---|
| 1399 | croak("Copy method did not return a reference"); |
---|
| 1400 | } |
---|
| 1401 | return SvREFCNT_inc(SvRV(res)); |
---|
| 1402 | } else { |
---|
| 1403 | return res; |
---|
| 1404 | } |
---|
| 1405 | } |
---|
| 1406 | } |
---|
| 1407 | #endif /* OVERLOAD */ |
---|