gv.c

   1 /*    gv.c
   2  *
   3  *    Copyright (c) 1991-2000, 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 #define PERL_IN_GV_C
  21 #include "perl.h"
  22
  23 GV *
  24 Perl_gv_AVadd(pTHX_ register GV *gv)
  25 {
  26     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  27         Perl_croak(aTHX_ "Bad symbol for array");
  28     if (!GvAV(gv))
  29         GvAV(gv) = newAV();
  30     return gv;
  31 }
  32
  33 GV *
  34 Perl_gv_HVadd(pTHX_ register GV *gv)
  35 {
  36     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  37         Perl_croak(aTHX_ "Bad symbol for hash");
  38     if (!GvHV(gv))
  39         GvHV(gv) = newHV();
  40     return gv;
  41 }
  42
  43 GV *
  44 Perl_gv_IOadd(pTHX_ register GV *gv)
  45 {
  46     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
  47         Perl_croak(aTHX_ "Bad symbol for filehandle");
  48     if (!GvIOp(gv))
  49         GvIOp(gv) = newIO();
  50     return gv;
  51 }
  52
  53 GV *
  54 Perl_gv_fetchfile(pTHX_ const char *name)
  55 {
  56     char smallbuf[256];
  57     char *tmpbuf;
  58     STRLEN tmplen;
  59     GV *gv;
  60
  61     if (!PL_defstash)
  62         return Nullgv;
  63
  64     tmplen = strlen(name) + 2;
  65     if (tmplen < sizeof smallbuf)
  66         tmpbuf = smallbuf;
  67     else
  68         New(603, tmpbuf, tmplen + 1, char);
  69     tmpbuf[0] = '_';
  70     tmpbuf[1] = '<';
  71     strcpy(tmpbuf + 2, name);
  72     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
  73     if (!isGV(gv)) {
  74         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
  75         sv_setpv(GvSV(gv), name);
  76         if (PERLDB_LINE)
  77             hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, 'L');
  78     }
  79     if (tmpbuf != smallbuf)
  80         Safefree(tmpbuf);
  81     return gv;
  82 }
  83
  84 void
  85 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
  86 {
  87     register GP *gp;
  88     bool doproto = SvTYPE(gv) > SVt_NULL;
  89     char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
  90
  91     sv_upgrade((SV*)gv, SVt_PVGV);
  92     if (SvLEN(gv)) {
  93         if (proto) {
  94             SvPVX(gv) = NULL;
  95             SvLEN(gv) = 0;
  96             SvPOK_off(gv);
  97         } else
  98             Safefree(SvPVX(gv));
  99     }
 100     Newz(602, gp, 1, GP);
 101     GvGP(gv) = gp_ref(gp);
 102     GvSV(gv) = NEWSV(72,0);
 103     GvLINE(gv) = CopLINE(PL_curcop);
 104     GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
 105     GvCVGEN(gv) = 0;
 106     GvEGV(gv) = gv;
 107     sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0);
 108     GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
 109     GvNAME(gv) = savepvn(name, len);
 110     GvNAMELEN(gv) = len;
 111     if (multi || doproto)              /* doproto means it _was_ mentioned */
 112         GvMULTI_on(gv);
 113     if (doproto) {                      /* Replicate part of newSUB here. */
 114         SvIOK_off(gv);
 115         ENTER;
 116         /* XXX unsafe for threads if eval_owner isn't held */
 117         start_subparse(0,0);            /* Create CV in compcv. */
 118         GvCV(gv) = PL_compcv;
 119         LEAVE;
 120
 121         PL_sub_generation++;
 122         CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv);
 123         CvFILE(GvCV(gv)) = CopFILE(PL_curcop);
 124         CvSTASH(GvCV(gv)) = PL_curstash;
 125 #ifdef USE_THREADS
 126         CvOWNER(GvCV(gv)) = 0;
 127         if (!CvMUTEXP(GvCV(gv))) {
 128             New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
 129             MUTEX_INIT(CvMUTEXP(GvCV(gv)));
 130         }
 131 #endif /* USE_THREADS */
 132         if (proto) {
 133             sv_setpv((SV*)GvCV(gv), proto);
 134             Safefree(proto);
 135         }
 136     }
 137 }
 138
 139 STATIC void
 140 S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
 141 {
 142     switch (sv_type) {
 143     case SVt_PVIO:
 144         (void)GvIOn(gv);
 145         break;
 146     case SVt_PVAV:
 147         (void)GvAVn(gv);
 148         break;
 149     case SVt_PVHV:
 150         (void)GvHVn(gv);
 151         break;
 152     }
 153 }
 154
 155 /*
 156 =for apidoc gv_fetchmeth
 157
 158 Returns the glob with the given C<name> and a defined subroutine or
 159 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
 160 accessible via @ISA and @UNIVERSAL.
 161
 162 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
 163 side-effect creates a glob with the given C<name> in the given C<stash>
 164 which in the case of success contains an alias for the subroutine, and sets
 165 up caching info for this glob.  Similarly for all the searched stashes.
 166
 167 This function grants C<"SUPER"> token as a postfix of the stash name. The
 168 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
 169 visible to Perl code.  So when calling C<call_sv>, you should not use
 170 the GV directly; instead, you should use the method's CV, which can be
 171 obtained from the GV with the C<GvCV> macro.
 172
 173 =cut
 174 */
 175
 176 GV *
 177 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 178 {
 179     AV* av;
 180     GV* topgv;
 181     GV* gv;
 182     GV** gvp;
 183     CV* cv;
 184
 185     if (!stash)
 186         return 0;
 187     if ((level > 100) || (level < -100))
 188         Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
 189               name, HvNAME(stash));
 190
 191     DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
 192
 193     gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
 194     if (!gvp)
 195         topgv = Nullgv;
 196     else {
 197         topgv = *gvp;
 198         if (SvTYPE(topgv) != SVt_PVGV)
 199             gv_init(topgv, stash, name, len, TRUE);
 200         if ((cv = GvCV(topgv))) {
 201             /* If genuine method or valid cache entry, use it */
 202             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
 203                 return topgv;
 204             /* Stale cached entry: junk it */
 205             SvREFCNT_dec(cv);
 206             GvCV(topgv) = cv = Nullcv;
 207             GvCVGEN(topgv) = 0;
 208         }
 209         else if (GvCVGEN(topgv) == PL_sub_generation)
 210             return 0;  /* cache indicates sub doesn't exist */
 211     }
 212
 213     gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
 214     av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
 215
 216     /* create and re-create @.*::SUPER::ISA on demand */
 217     if (!av || !SvMAGIC(av)) {
 218         char* packname = HvNAME(stash);
 219         STRLEN packlen = strlen(packname);
 220
 221         if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
 222             HV* basestash;
 223
 224             packlen -= 7;
 225             basestash = gv_stashpvn(packname, packlen, TRUE);
 226             gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
 227             if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
 228                 gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
 229                 if (!gvp || !(gv = *gvp))
 230                     Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
 231                 if (SvTYPE(gv) != SVt_PVGV)
 232                     gv_init(gv, stash, "ISA", 3, TRUE);
 233                 SvREFCNT_dec(GvAV(gv));
 234                 GvAV(gv) = (AV*)SvREFCNT_inc(av);
 235             }
 236         }
 237     }
 238
 239     if (av) {
 240         SV** svp = AvARRAY(av);
 241         /* NOTE: No support for tied ISA */
 242         I32 items = AvFILLp(av) + 1;
 243         while (items--) {
 244             SV* sv = *svp++;
 245             HV* basestash = gv_stashsv(sv, FALSE);
 246             if (!basestash) {
 247                 if (ckWARN(WARN_MISC))
 248                     Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA",
 249                         SvPVX(sv), HvNAME(stash));
 250                 continue;
 251             }
 252             gv = gv_fetchmeth(basestash, name, len,
 253                               (level >= 0) ? level + 1 : level - 1);
 254             if (gv)
 255                 goto gotcha;
 256         }
 257     }
 258
 259     /* if at top level, try UNIVERSAL */
 260
 261     if (level == 0 || level == -1) {
 262         HV* lastchance;
 263
 264         if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
 265             if ((gv = gv_fetchmeth(lastchance, name, len,
 266                                   (level >= 0) ? level + 1 : level - 1)))
 267             {
 268           gotcha:
 269                 /*
 270                  * Cache method in topgv if:
 271                  *  1. topgv has no synonyms (else inheritance crosses wires)
 272                  *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
 273                  */
 274                 if (topgv &&
 275                     GvREFCNT(topgv) == 1 &&
 276                     (cv = GvCV(gv)) &&
 277                     (CvROOT(cv) || CvXSUB(cv)))
 278                 {
 279                     if ((cv = GvCV(topgv)))
 280                         SvREFCNT_dec(cv);
 281                     GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
 282                     GvCVGEN(topgv) = PL_sub_generation;
 283                 }
 284                 return gv;
 285             }
 286             else if (topgv && GvREFCNT(topgv) == 1) {
 287                 /* cache the fact that the method is not defined */
 288                 GvCVGEN(topgv) = PL_sub_generation;
 289             }
 290         }
 291     }
 292
 293     return 0;
 294 }
 295
 296 /*
 297 =for apidoc gv_fetchmethod
 298
 299 See L<gv_fetchmethod_autoload>.
 300
 301 =cut
 302 */
 303
 304 GV *
 305 Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name)
 306 {
 307     return gv_fetchmethod_autoload(stash, name, TRUE);
 308 }
 309
 310 /*
 311 =for apidoc gv_fetchmethod_autoload
 312
 313 Returns the glob which contains the subroutine to call to invoke the method
 314 on the C<stash>.  In fact in the presence of autoloading this may be the
 315 glob for "AUTOLOAD".  In this case the corresponding variable $AUTOLOAD is
 316 already setup.
 317
 318 The third parameter of C<gv_fetchmethod_autoload> determines whether
 319 AUTOLOAD lookup is performed if the given method is not present: non-zero
 320 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
 321 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
 322 with a non-zero C<autoload> parameter.
 323
 324 These functions grant C<"SUPER"> token as a prefix of the method name. Note
 325 that if you want to keep the returned glob for a long time, you need to
 326 check for it being "AUTOLOAD", since at the later time the call may load a
 327 different subroutine due to $AUTOLOAD changing its value. Use the glob
 328 created via a side effect to do this.
 329
 330 These functions have the same side-effects and as C<gv_fetchmeth> with
 331 C<level==0>.  C<name> should be writable if contains C<':'> or C<'
 332 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
 333 C<call_sv> apply equally to these functions.
 334
 335 =cut
 336 */
 337
 338 GV *
 339 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 340 {
 341     register const char *nend;
 342     const char *nsplit = 0;
 343     GV* gv;
 344
 345     for (nend = name; *nend; nend++) {
 346         if (*nend == '\'')
 347             nsplit = nend;
 348         else if (*nend == ':' && *(nend + 1) == ':')
 349             nsplit = ++nend;
 350     }
 351     if (nsplit) {
 352         const char *origname = name;
 353         name = nsplit + 1;
 354         if (*nsplit == ':')
 355             --nsplit;
 356         if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
 357             /* ->SUPER::method should really be looked up in original stash */
 358             SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
 359                                                   CopSTASHPV(PL_curcop)));
 360             stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
 361             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
 362                          origname, HvNAME(stash), name) );
 363         }
 364         else
 365             stash = gv_stashpvn(origname, nsplit - origname, TRUE);
 366     }
 367
 368     gv = gv_fetchmeth(stash, name, nend - name, 0);
 369     if (!gv) {
 370         if (strEQ(name,"import") || strEQ(name,"unimport"))
 371             gv = (GV*)&PL_sv_yes;
 372         else if (autoload)
 373             gv = gv_autoload4(stash, name, nend - name, TRUE);
 374     }
 375     else if (autoload) {
 376         CV* cv = GvCV(gv);
 377         if (!CvROOT(cv) && !CvXSUB(cv)) {
 378             GV* stubgv;
 379             GV* autogv;
 380
 381             if (CvANON(cv))
 382                 stubgv = gv;
 383             else {
 384                 stubgv = CvGV(cv);
 385                 if (GvCV(stubgv) != cv)         /* orphaned import */
 386                     stubgv = gv;
 387             }
 388             autogv = gv_autoload4(GvSTASH(stubgv),
 389                                   GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
 390             if (autogv)
 391                 gv = autogv;
 392         }
 393     }
 394
 395     return gv;
 396 }
 397
 398 GV*
 399 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 400 {
 401     static char autoload[] = "AUTOLOAD";
 402     static STRLEN autolen = 8;
 403     GV* gv;
 404     CV* cv;
 405     HV* varstash;
 406     GV* vargv;
 407     SV* varsv;
 408
 409     if (len == autolen && strnEQ(name, autoload, autolen))
 410         return Nullgv;
 411     if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
 412         return Nullgv;
 413     cv = GvCV(gv);
 414
 415     if (!CvROOT(cv))
 416         return Nullgv;
 417
 418     /*
 419      * Inheriting AUTOLOAD for non-methods works ... for now.
 420      */
 421     if (ckWARN(WARN_DEPRECATED) && !method &&
 422         (GvCVGEN(gv) || GvSTASH(gv) != stash))
 423         Perl_warner(aTHX_ WARN_DEPRECATED,
 424           "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
 425              HvNAME(stash), (int)len, name);
 426
 427     /*
 428      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
 429      * The subroutine's original name may not be "AUTOLOAD", so we don't
 430      * use that, but for lack of anything better we will use the sub's
 431      * original package to look up $AUTOLOAD.
 432      */
 433     varstash = GvSTASH(CvGV(cv));
 434     vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
 435     ENTER;
 436
 437 #ifdef USE_THREADS
 438     sv_lock((SV *)varstash);
 439 #endif
 440     if (!isGV(vargv))
 441         gv_init(vargv, varstash, autoload, autolen, FALSE);
 442     LEAVE;
 443     varsv = GvSV(vargv);
 444 #ifdef USE_THREADS
 445     sv_lock(varsv);
 446 #endif
 447     sv_setpv(varsv, HvNAME(stash));
 448     sv_catpvn(varsv, "::", 2);
 449     sv_catpvn(varsv, name, len);
 450     SvTAINTED_off(varsv);
 451     return gv;
 452 }
 453
 454 /*
 455 =for apidoc gv_stashpv
 456
 457 Returns a pointer to the stash for a specified package.  C<name> should
 458 be a valid UTF-8 string.  If C<create> is set then the package will be
 459 created if it does not already exist.  If C<create> is not set and the
 460 package does not exist then NULL is returned.
 461
 462 =cut
 463 */
 464
 465 HV*
 466 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
 467 {
 468     return gv_stashpvn(name, strlen(name), create);
 469 }
 470
 471 HV*
 472 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
 473 {
 474     char smallbuf[256];
 475     char *tmpbuf;
 476     HV *stash;
 477     GV *tmpgv;
 478
 479     if (namelen + 3 < sizeof smallbuf)
 480         tmpbuf = smallbuf;
 481     else
 482         New(606, tmpbuf, namelen + 3, char);
 483     Copy(name,tmpbuf,namelen,char);
 484     tmpbuf[namelen++] = ':';
 485     tmpbuf[namelen++] = ':';
 486     tmpbuf[namelen] = '\0';
 487     tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
 488     if (tmpbuf != smallbuf)
 489         Safefree(tmpbuf);
 490     if (!tmpgv)
 491         return 0;
 492     if (!GvHV(tmpgv))
 493         GvHV(tmpgv) = newHV();
 494     stash = GvHV(tmpgv);
 495     if (!HvNAME(stash))
 496         HvNAME(stash) = savepv(name);
 497     return stash;
 498 }
 499
 500 /*
 501 =for apidoc gv_stashsv
 502
 503 Returns a pointer to the stash for a specified package, which must be a
 504 valid UTF-8 string.  See C<gv_stashpv>.
 505
 506 =cut
 507 */
 508
 509 HV*
 510 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
 511 {
 512     register char *ptr;
 513     STRLEN len;
 514     ptr = SvPV(sv,len);
 515     return gv_stashpvn(ptr, len, create);
 516 }
 517
 518
 519 GV *
 520 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 521 {
 522     register const char *name = nambeg;
 523     register GV *gv = 0;
 524     GV**gvp;
 525     I32 len;
 526     register const char *namend;
 527     HV *stash = 0;
 528
 529     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
 530         name++;
 531
 532     for (namend = name; *namend; namend++) {
 533         if ((*namend == ':' && namend[1] == ':')
 534             || (*namend == '\'' && namend[1]))
 535         {
 536             if (!stash)
 537                 stash = PL_defstash;
 538             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
 539                 return Nullgv;
 540
 541             len = namend - name;
 542             if (len > 0) {
 543                 char smallbuf[256];
 544                 char *tmpbuf;
 545
 546                 if (len + 3 < sizeof smallbuf)
 547                     tmpbuf = smallbuf;
 548                 else
 549                     New(601, tmpbuf, len+3, char);
 550                 Copy(name, tmpbuf, len, char);
 551                 tmpbuf[len++] = ':';
 552                 tmpbuf[len++] = ':';
 553                 tmpbuf[len] = '\0';
 554                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
 555                 gv = gvp ? *gvp : Nullgv;
 556                 if (gv && gv != (GV*)&PL_sv_undef) {
 557                     if (SvTYPE(gv) != SVt_PVGV)
 558                         gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
 559                     else
 560                         GvMULTI_on(gv);
 561                 }
 562                 if (tmpbuf != smallbuf)
 563                     Safefree(tmpbuf);
 564                 if (!gv || gv == (GV*)&PL_sv_undef)
 565                     return Nullgv;
 566
 567                 if (!(stash = GvHV(gv)))
 568                     stash = GvHV(gv) = newHV();
 569
 570                 if (!HvNAME(stash))
 571                     HvNAME(stash) = savepvn(nambeg, namend - nambeg);
 572             }
 573
 574             if (*namend == ':')
 575                 namend++;
 576             namend++;
 577             name = namend;
 578             if (!*name)
 579                 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
 580         }
 581     }
 582     len = namend - name;
 583     if (!len)
 584         len = 1;
 585
 586     /* No stash in name, so see how we can default */
 587
 588     if (!stash) {
 589         if (isIDFIRST_lazy(name)) {
 590             bool global = FALSE;
 591
 592             if (isUPPER(*name)) {
 593                 if (*name == 'S' && (
 594                     strEQ(name, "SIG") ||
 595                     strEQ(name, "STDIN") ||
 596                     strEQ(name, "STDOUT") ||
 597                     strEQ(name, "STDERR")))
 598                     global = TRUE;
 599                 else if (*name == 'I' && strEQ(name, "INC"))
 600                     global = TRUE;
 601                 else if (*name == 'E' && strEQ(name, "ENV"))
 602                     global = TRUE;
 603                 else if (*name == 'A' && (
 604                   strEQ(name, "ARGV") ||
 605                   strEQ(name, "ARGVOUT")))
 606                     global = TRUE;
 607             }
 608             else if (*name == '_' && !name[1])
 609                 global = TRUE;
 610
 611             if (global)
 612                 stash = PL_defstash;
 613             else if ((COP*)PL_curcop == &PL_compiling) {
 614                 stash = PL_curstash;
 615                 if (add && (PL_hints & HINT_STRICT_VARS) &&
 616                     sv_type != SVt_PVCV &&
 617                     sv_type != SVt_PVGV &&
 618                     sv_type != SVt_PVFM &&
 619                     sv_type != SVt_PVIO &&
 620                     !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
 621                 {
 622                     gvp = (GV**)hv_fetch(stash,name,len,0);
 623                     if (!gvp ||
 624                         *gvp == (GV*)&PL_sv_undef ||
 625                         SvTYPE(*gvp) != SVt_PVGV)
 626                     {
 627                         stash = 0;
 628                     }
 629                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
 630                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
 631                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
 632                     {
 633                         Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
 634                             sv_type == SVt_PVAV ? '@' :
 635                             sv_type == SVt_PVHV ? '%' : '$',
 636                             name);
 637                         if (GvCVu(*gvp))
 638                             Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
 639                         stash = 0;
 640                     }
 641                 }
 642             }
 643             else
 644                 stash = CopSTASH(PL_curcop);
 645         }
 646         else
 647             stash = PL_defstash;
 648     }
 649
 650     /* By this point we should have a stash and a name */
 651
 652     if (!stash) {
 653         if (add) {
 654             qerror(Perl_mess(aTHX_
 655                  "Global symbol \"%s%s\" requires explicit package name",
 656                  (sv_type == SVt_PV ? "$"
 657                   : sv_type == SVt_PVAV ? "@"
 658                   : sv_type == SVt_PVHV ? "%"
 659                   : ""), name));
 660             stash = PL_nullstash;
 661         }
 662         else
 663             return Nullgv;
 664     }
 665
 666     if (!SvREFCNT(stash))       /* symbol table under destruction */
 667         return Nullgv;
 668
 669     gvp = (GV**)hv_fetch(stash,name,len,add);
 670     if (!gvp || *gvp == (GV*)&PL_sv_undef)
 671         return Nullgv;
 672     gv = *gvp;
 673     if (SvTYPE(gv) == SVt_PVGV) {
 674         if (add) {
 675             GvMULTI_on(gv);
 676             gv_init_sv(gv, sv_type);
 677         }
 678         return gv;
 679     } else if (add & GV_NOINIT) {
 680         return gv;
 681     }
 682
 683     /* Adding a new symbol */
 684
 685     if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
 686         Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg);
 687     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
 688     gv_init_sv(gv, sv_type);
 689
 690     if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE))
 691         GvMULTI_on(gv) ;
 692
 693     /* set up magic where warranted */
 694     switch (*name) {
 695     case 'A':
 696         if (strEQ(name, "ARGV")) {
 697             IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
 698         }
 699         break;
 700     case 'E':
 701         if (strnEQ(name, "EXPORT", 6))
 702             GvMULTI_on(gv);
 703         break;
 704     case 'I':
 705         if (strEQ(name, "ISA")) {
 706             AV* av = GvAVn(gv);
 707             GvMULTI_on(gv);
 708             sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
 709             /* NOTE: No support for tied ISA */
 710             if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
 711                 && AvFILLp(av) == -1)
 712             {
 713                 char *pname;
 714                 av_push(av, newSVpvn(pname = "NDBM_File",9));
 715                 gv_stashpvn(pname, 9, TRUE);
 716                 av_push(av, newSVpvn(pname = "DB_File",7));
 717                 gv_stashpvn(pname, 7, TRUE);
 718                 av_push(av, newSVpvn(pname = "GDBM_File",9));
 719                 gv_stashpvn(pname, 9, TRUE);
 720                 av_push(av, newSVpvn(pname = "SDBM_File",9));
 721                 gv_stashpvn(pname, 9, TRUE);
 722                 av_push(av, newSVpvn(pname = "ODBM_File",9));
 723                 gv_stashpvn(pname, 9, TRUE);
 724             }
 725         }
 726         break;
 727     case 'O':
 728         if (strEQ(name, "OVERLOAD")) {
 729             HV* hv = GvHVn(gv);
 730             GvMULTI_on(gv);
 731             hv_magic(hv, Nullgv, 'A');
 732         }
 733         break;
 734     case 'S':
 735         if (strEQ(name, "SIG")) {
 736             HV *hv;
 737             I32 i;
 738             if (!PL_psig_ptr) {
 739                 int sig_num[] = { SIG_NUM };
 740                 New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
 741                 New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
 742             }
 743             GvMULTI_on(gv);
 744             hv = GvHVn(gv);
 745             hv_magic(hv, Nullgv, 'S');
 746             for (i = 1; PL_sig_name[i]; i++) {
 747                 SV ** init;
 748                 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
 749                 if (init)
 750                     sv_setsv(*init, &PL_sv_undef);
 751                 PL_psig_ptr[i] = 0;
 752                 PL_psig_name[i] = 0;
 753             }
 754         }
 755         break;
 756     case 'V':
 757         if (strEQ(name, "VERSION"))
 758             GvMULTI_on(gv);
 759         break;
 760
 761     case '&':
 762         if (len > 1)
 763             break;
 764         PL_sawampersand = TRUE;
 765         goto ro_magicalize;
 766
 767     case '`':
 768         if (len > 1)
 769             break;
 770         PL_sawampersand = TRUE;
 771         goto ro_magicalize;
 772
 773     case '\'':
 774         if (len > 1)
 775             break;
 776         PL_sawampersand = TRUE;
 777         goto ro_magicalize;
 778
 779     case ':':
 780         if (len > 1)
 781             break;
 782         sv_setpv(GvSV(gv),PL_chopset);
 783         goto magicalize;
 784
 785     case '?':
 786         if (len > 1)
 787             break;
 788 #ifdef COMPLEX_STATUS
 789         (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
 790 #endif
 791         goto magicalize;
 792
 793     case '!':
 794         if (len > 1)
 795             break;
 796         if (sv_type > SVt_PV && PL_curcop != &PL_compiling) {
 797             HV* stash = gv_stashpvn("Errno",5,FALSE);
 798             if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
 799                 dSP;
 800                 PUTBACK;
 801                 require_pv("Errno.pm");
 802                 SPAGAIN;
 803                 stash = gv_stashpvn("Errno",5,FALSE);
 804                 if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
 805                     Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
 806             }
 807         }
 808         goto magicalize;
 809     case '-':
 810         if (len > 1)
 811             break;
 812         else {
 813             AV* av = GvAVn(gv);
 814             sv_magic((SV*)av, Nullsv, 'D', Nullch, 0);
 815             SvREADONLY_on(av);
 816         }
 817         goto magicalize;
 818     case '#':
 819     case '*':
 820         if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
 821             Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
 822         /* FALL THROUGH */
 823     case '[':
 824     case '^':
 825     case '~':
 826     case '=':
 827     case '%':
 828     case '.':
 829     case '(':
 830     case ')':
 831     case '<':
 832     case '>':
 833     case ',':
 834     case '\\':
 835     case '/':
 836     case '\001':        /* $^A */
 837     case '\003':        /* $^C */
 838     case '\004':        /* $^D */
 839     case '\005':        /* $^E */
 840     case '\006':        /* $^F */
 841     case '\010':        /* $^H */
 842     case '\011':        /* $^I, NOT \t in EBCDIC */
 843     case '\020':        /* $^P */
 844     case '\024':        /* $^T */
 845         if (len > 1)
 846             break;
 847         goto magicalize;
 848     case '|':
 849         if (len > 1)
 850             break;
 851         sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
 852         goto magicalize;
 853     case '\017':        /* $^O & $^OPEN */
 854         if (len > 1 && strNE(name, "\017PEN"))
 855             break;
 856         goto magicalize;
 857     case '\023':        /* $^S */
 858         if (len > 1)
 859             break;
 860         goto ro_magicalize;
 861     case '\027':        /* $^W & $^WARNING_BITS */
 862         if (len > 1 && strNE(name, "\027ARNING_BITS")
 863             && strNE(name, "\027IDE_SYSTEM_CALLS"))
 864             break;
 865         goto magicalize;
 866
 867     case '+':
 868         if (len > 1)
 869             break;
 870         else {
 871             AV* av = GvAVn(gv);
 872             sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0);
 873             SvREADONLY_on(av);
 874         }
 875         /* FALL THROUGH */
 876     case '1':
 877     case '2':
 878     case '3':
 879     case '4':
 880     case '5':
 881     case '6':
 882     case '7':
 883     case '8':
 884     case '9':
 885       ro_magicalize:
 886         SvREADONLY_on(GvSV(gv));
 887       magicalize:
 888         sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
 889         break;
 890
 891     case '\014':        /* $^L */
 892         if (len > 1)
 893             break;
 894         sv_setpv(GvSV(gv),"\f");
 895         PL_formfeed = GvSV(gv);
 896         break;
 897     case ';':
 898         if (len > 1)
 899             break;
 900         sv_setpv(GvSV(gv),"\034");
 901         break;
 902     case ']':
 903         if (len == 1) {
 904             SV *sv = GvSV(gv);
 905             (void)SvUPGRADE(sv, SVt_PVNV);
 906             Perl_sv_setpvf(aTHX_ sv,
 907 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
 908                             "%8.6"
 909 #else
 910                             "%5.3"
 911 #endif
 912                             NVff,
 913                             SvNVX(PL_patchlevel));
 914             SvNVX(sv) = SvNVX(PL_patchlevel);
 915             SvNOK_on(sv);
 916             SvREADONLY_on(sv);
 917         }
 918         break;
 919     case '\026':        /* $^V */
 920         if (len == 1) {
 921             SV *sv = GvSV(gv);
 922             GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
 923             SvREFCNT_dec(sv);
 924         }
 925         break;
 926     }
 927     return gv;
 928 }
 929
 930 void
 931 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
 932 {
 933     HV *hv = GvSTASH(gv);
 934     if (!hv) {
 935         (void)SvOK_off(sv);
 936         return;
 937     }
 938     sv_setpv(sv, prefix ? prefix : "");
 939     if (keepmain || strNE(HvNAME(hv), "main")) {
 940         sv_catpv(sv,HvNAME(hv));
 941         sv_catpvn(sv,"::", 2);
 942     }
 943     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
 944 }
 945
 946 void
 947 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
 948 {
 949     HV *hv = GvSTASH(gv);
 950     if (!hv) {
 951         (void)SvOK_off(sv);
 952         return;
 953     }
 954     sv_setpv(sv, prefix ? prefix : "");
 955     sv_catpv(sv,HvNAME(hv));
 956     sv_catpvn(sv,"::", 2);
 957     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
 958 }
 959
 960 void
 961 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
 962 {
 963     GV *egv = GvEGV(gv);
 964     if (!egv)
 965         egv = gv;
 966     gv_fullname4(sv, egv, prefix, keepmain);
 967 }
 968
 969 void
 970 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
 971 {
 972     GV *egv = GvEGV(gv);
 973     if (!egv)
 974         egv = gv;
 975     gv_fullname3(sv, egv, prefix);
 976 }
 977
 978 /* XXX compatibility with versions <= 5.003. */
 979 void
 980 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
 981 {
 982     gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
 983 }
 984
 985 /* XXX compatibility with versions <= 5.003. */
 986 void
 987 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
 988 {
 989     gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
 990 }
 991
 992 IO *
 993 Perl_newIO(pTHX)
 994 {
 995     IO *io;
 996     GV *iogv;
 997
 998     io = (IO*)NEWSV(0,0);
 999     sv_upgrade((SV *)io,SVt_PVIO);
1000     SvREFCNT(io) = 1;
1001     SvOBJECT_on(io);
1002     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1003     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1004     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1005       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1006     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1007     return io;
1008 }
1009
1010 void
1011 Perl_gv_check(pTHX_ HV *stash)
1012 {
1013     register HE *entry;
1014     register I32 i;
1015     register GV *gv;
1016     HV *hv;
1017
1018     if (!HvARRAY(stash))
1019         return;
1020     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1021         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1022             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1023                 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
1024             {
1025                 if (hv != PL_defstash && hv != stash)
1026                      gv_check(hv);              /* nested package */
1027             }
1028             else if (isALPHA(*HeKEY(entry))) {
1029                 char *file;
1030                 gv = (GV*)HeVAL(entry);
1031                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1032                     continue;
1033                 file = GvFILE(gv);
1034                 /* performance hack: if filename is absolute and it's a standard
1035                  * module, don't bother warning */
1036                 if (file
1037                     && PERL_FILE_IS_ABSOLUTE(file)
1038                     && (instr(file, "/lib/") || instr(file, ".pm")))
1039                 {
1040                     continue;
1041                 }
1042                 CopLINE_set(PL_curcop, GvLINE(gv));
1043 #ifdef USE_ITHREADS
1044                 CopFILE(PL_curcop) = file;      /* set for warning */
1045 #else
1046                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1047 #endif
1048                 Perl_warner(aTHX_ WARN_ONCE,
1049                         "Name \"%s::%s\" used only once: possible typo",
1050                         HvNAME(stash), GvNAME(gv));
1051             }
1052         }
1053     }
1054 }
1055
1056 GV *
1057 Perl_newGVgen(pTHX_ char *pack)
1058 {
1059     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1060                       TRUE, SVt_PVGV);
1061 }
1062
1063 /* hopefully this is only called on local symbol table entries */
1064
1065 GP*
1066 Perl_gp_ref(pTHX_ GP *gp)
1067 {
1068     if (!gp)
1069         return (GP*)NULL;
1070     gp->gp_refcnt++;
1071     if (gp->gp_cv) {
1072         if (gp->gp_cvgen) {
1073             /* multi-named GPs cannot be used for method cache */
1074             SvREFCNT_dec(gp->gp_cv);
1075             gp->gp_cv = Nullcv;
1076             gp->gp_cvgen = 0;
1077         }
1078         else {
1079             /* Adding a new name to a subroutine invalidates method cache */
1080             PL_sub_generation++;
1081         }
1082     }
1083     return gp;
1084 }
1085
1086 void
1087 Perl_gp_free(pTHX_ GV *gv)
1088 {
1089     GP* gp;
1090
1091     if (!gv || !(gp = GvGP(gv)))
1092         return;
1093     if (gp->gp_refcnt == 0) {
1094         if (ckWARN_d(WARN_INTERNAL))
1095             Perl_warner(aTHX_ WARN_INTERNAL,
1096                         "Attempt to free unreferenced glob pointers");
1097         return;
1098     }
1099     if (gp->gp_cv) {
1100         /* Deleting the name of a subroutine invalidates method cache */
1101         PL_sub_generation++;
1102     }
1103     if (--gp->gp_refcnt > 0) {
1104         if (gp->gp_egv == gv)
1105             gp->gp_egv = 0;
1106         return;
1107     }
1108
1109     SvREFCNT_dec(gp->gp_sv);
1110     SvREFCNT_dec(gp->gp_av);
1111     SvREFCNT_dec(gp->gp_hv);
1112     SvREFCNT_dec(gp->gp_io);
1113     SvREFCNT_dec(gp->gp_cv);
1114     SvREFCNT_dec(gp->gp_form);
1115
1116     Safefree(gp);
1117     GvGP(gv) = 0;
1118 }
1119
1120 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
1121 #define MICROPORT
1122 #endif
1123
1124 #ifdef  MICROPORT       /* Microport 2.4 hack */
1125 AV *GvAVn(gv)
1126 register GV *gv;
1127 {
1128     if (GvGP(gv)->gp_av)
1129         return GvGP(gv)->gp_av;
1130     else
1131         return GvGP(gv_AVadd(gv))->gp_av;
1132 }
1133
1134 HV *GvHVn(gv)
1135 register GV *gv;
1136 {
1137     if (GvGP(gv)->gp_hv)
1138         return GvGP(gv)->gp_hv;
1139     else
1140         return GvGP(gv_HVadd(gv))->gp_hv;
1141 }
1142 #endif                  /* Microport 2.4 hack */
1143
1144 /* Updates and caches the CV's */
1145
1146 bool
1147 Perl_Gv_AMupdate(pTHX_ HV *stash)
1148 {
1149   GV* gv;
1150   CV* cv;
1151   MAGIC* mg=mg_find((SV*)stash,'c');
1152   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1153   AMT amt;
1154   STRLEN n_a;
1155
1156   if (mg && amtp->was_ok_am == PL_amagic_generation
1157       && amtp->was_ok_sub == PL_sub_generation)
1158       return AMT_OVERLOADED(amtp);
1159   if (amtp && AMT_AMAGIC(amtp)) {       /* Have table. */
1160     int i;
1161     for (i=1; i<NofAMmeth; i++) {
1162       if (amtp->table[i]) {
1163         SvREFCNT_dec(amtp->table[i]);
1164       }
1165     }
1166   }
1167   sv_unmagic((SV*)stash, 'c');
1168
1169   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1170
1171   amt.was_ok_am = PL_amagic_generation;
1172   amt.was_ok_sub = PL_sub_generation;
1173   amt.fallback = AMGfallNO;
1174   amt.flags = 0;
1175
1176   {
1177     int filled = 0, have_ovl = 0;
1178     int i, lim = 1;
1179     const char *cp;
1180     SV* sv = NULL;
1181
1182     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1183
1184     /* Try to find via inheritance. */
1185     gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1186     if (gv)
1187         sv = GvSV(gv);
1188
1189     if (!gv)
1190         lim = DESTROY_amg;              /* Skip overloading entries. */
1191     else if (SvTRUE(sv))
1192         amt.fallback=AMGfallYES;
1193     else if (SvOK(sv))
1194         amt.fallback=AMGfallNEVER;
1195
1196     for (i = 1; i < lim; i++)
1197         amt.table[i] = Nullcv;
1198     for (; i < NofAMmeth; i++) {
1199         char *cooky = (char*)PL_AMG_names[i];
1200         /* Human-readable form, for debugging: */
1201         char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1202         STRLEN l = strlen(cooky);
1203
1204         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1205                      cp, HvNAME(stash)) );
1206         /* don't fill the cache while looking up! */
1207         gv = gv_fetchmeth(stash, cooky, l, -1);
1208         cv = 0;
1209         if (gv && (cv = GvCV(gv))) {
1210             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1211                 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1212                 /* GvSV contains the name of the method. */
1213                 GV *ngv;
1214
1215                 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1216                              SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1217                 if (!SvPOK(GvSV(gv))
1218                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1219                                                        FALSE)))
1220                 {
1221                     /* Can be an import stub (created by `can'). */
1222                     if (GvCVGEN(gv)) {
1223                         Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1224                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1225                               cp, HvNAME(stash));
1226                     } else
1227                         Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1228                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1229                               cp, HvNAME(stash));
1230                 }
1231                 cv = GvCV(gv = ngv);
1232             }
1233             DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1234                          cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1235                          GvNAME(CvGV(cv))) );
1236             filled = 1;
1237             if (i < DESTROY_amg)
1238                 have_ovl = 1;
1239         }
1240         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1241     }
1242     if (filled) {
1243       AMT_AMAGIC_on(&amt);
1244       if (have_ovl)
1245           AMT_OVERLOADED_on(&amt);
1246       sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1247       return have_ovl;
1248     }
1249   }
1250   /* Here we have no table: */
1251  no_table:
1252   AMT_AMAGIC_off(&amt);
1253   sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1254   return FALSE;
1255 }
1256
1257
1258 CV*
1259 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1260 {
1261     dTHR;
1262     MAGIC *mg = mg_find((SV*)stash,'c');
1263     AMT *amtp;
1264
1265     if (!mg) {
1266       do_update:
1267         Gv_AMupdate(stash);
1268         mg = mg_find((SV*)stash,'c');
1269     }
1270     amtp = (AMT*)mg->mg_ptr;
1271     if ( amtp->was_ok_am != PL_amagic_generation
1272          || amtp->was_ok_sub != PL_sub_generation )
1273         goto do_update;
1274     if (AMT_AMAGIC(amtp))
1275         return amtp->table[id];
1276     return Nullcv;
1277 }
1278
1279
1280 SV*
1281 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1282 {
1283   MAGIC *mg;
1284   CV *cv;
1285   CV **cvp=NULL, **ocvp=NULL;
1286   AMT *amtp, *oamtp;
1287   int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1288   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1289   HV* stash;
1290   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1291       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1292       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1293                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1294                         : (CV **) NULL))
1295       && ((cv = cvp[off=method+assignshift])
1296           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1297                                                           * usual method */
1298                   (fl = 1, cv = cvp[off=method])))) {
1299     lr = -1;                    /* Call method for left argument */
1300   } else {
1301     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1302       int logic;
1303
1304       /* look for substituted methods */
1305       /* In all the covered cases we should be called with assign==0. */
1306          switch (method) {
1307          case inc_amg:
1308            force_cpy = 1;
1309            if ((cv = cvp[off=add_ass_amg])
1310                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1311              right = &PL_sv_yes; lr = -1; assign = 1;
1312            }
1313            break;
1314          case dec_amg:
1315            force_cpy = 1;
1316            if ((cv = cvp[off = subtr_ass_amg])
1317                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1318              right = &PL_sv_yes; lr = -1; assign = 1;
1319            }
1320            break;
1321          case bool__amg:
1322            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1323            break;
1324          case numer_amg:
1325            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1326            break;
1327          case string_amg:
1328            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1329            break;
1330  case not_amg:
1331    (void)((cv = cvp[off=bool__amg])
1332           || (cv = cvp[off=numer_amg])
1333           || (cv = cvp[off=string_amg]));
1334    postpr = 1;
1335    break;
1336          case copy_amg:
1337            {
1338              /*
1339                   * SV* ref causes confusion with the interpreter variable of
1340                   * the same name
1341                   */
1342              SV* tmpRef=SvRV(left);
1343              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1344                 /*
1345                  * Just to be extra cautious.  Maybe in some
1346                  * additional cases sv_setsv is safe, too.
1347                  */
1348                 SV* newref = newSVsv(tmpRef);
1349                 SvOBJECT_on(newref);
1350                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1351                 return newref;
1352              }
1353            }
1354            break;
1355          case abs_amg:
1356            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1357                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1358              SV* nullsv=sv_2mortal(newSViv(0));
1359              if (off1==lt_amg) {
1360                SV* lessp = amagic_call(left,nullsv,
1361                                        lt_amg,AMGf_noright);
1362                logic = SvTRUE(lessp);
1363              } else {
1364                SV* lessp = amagic_call(left,nullsv,
1365                                        ncmp_amg,AMGf_noright);
1366                logic = (SvNV(lessp) < 0);
1367              }
1368              if (logic) {
1369                if (off==subtr_amg) {
1370                  right = left;
1371                  left = nullsv;
1372                  lr = 1;
1373                }
1374              } else {
1375                return left;
1376              }
1377            }
1378            break;
1379          case neg_amg:
1380            if ((cv = cvp[off=subtr_amg])) {
1381              right = left;
1382              left = sv_2mortal(newSViv(0));
1383              lr = 1;
1384            }
1385            break;
1386          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1387              /* FAIL safe */
1388              return NULL;       /* Delegate operation to standard mechanisms. */
1389              break;
1390          case to_sv_amg:
1391          case to_av_amg:
1392          case to_hv_amg:
1393          case to_gv_amg:
1394          case to_cv_amg:
1395              /* FAIL safe */
1396              return left;       /* Delegate operation to standard mechanisms. */
1397              break;
1398          default:
1399            goto not_found;
1400          }
1401          if (!cv) goto not_found;
1402     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1403                && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1404                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1405                           ? (amtp = (AMT*)mg->mg_ptr)->table
1406                           : (CV **) NULL))
1407                && (cv = cvp[off=method])) { /* Method for right
1408                                              * argument found */
1409       lr=1;
1410     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1411                  && (cvp=ocvp) && (lr = -1))
1412                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1413                && !(flags & AMGf_unary)) {
1414                                 /* We look for substitution for
1415                                  * comparison operations and
1416                                  * concatenation */
1417       if (method==concat_amg || method==concat_ass_amg
1418           || method==repeat_amg || method==repeat_ass_amg) {
1419         return NULL;            /* Delegate operation to string conversion */
1420       }
1421       off = -1;
1422       switch (method) {
1423          case lt_amg:
1424          case le_amg:
1425          case gt_amg:
1426          case ge_amg:
1427          case eq_amg:
1428          case ne_amg:
1429            postpr = 1; off=ncmp_amg; break;
1430          case slt_amg:
1431          case sle_amg:
1432          case sgt_amg:
1433          case sge_amg:
1434          case seq_amg:
1435          case sne_amg:
1436            postpr = 1; off=scmp_amg; break;
1437          }
1438       if (off != -1) cv = cvp[off];
1439       if (!cv) {
1440         goto not_found;
1441       }
1442     } else {
1443     not_found:                  /* No method found, either report or croak */
1444       switch (method) {
1445          case to_sv_amg:
1446          case to_av_amg:
1447          case to_hv_amg:
1448          case to_gv_amg:
1449          case to_cv_amg:
1450              /* FAIL safe */
1451              return left;       /* Delegate operation to standard mechanisms. */
1452              break;
1453       }
1454       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1455         notfound = 1; lr = -1;
1456       } else if (cvp && (cv=cvp[nomethod_amg])) {
1457         notfound = 1; lr = 1;
1458       } else {
1459         SV *msg;
1460         if (off==-1) off=method;
1461         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1462                       "Operation `%s': no method found,%sargument %s%s%s%s",
1463                       AMG_id2name(method + assignshift),
1464                       (flags & AMGf_unary ? " " : "\n\tleft "),
1465                       SvAMAGIC(left)?
1466                         "in overloaded package ":
1467                         "has no overloaded magic",
1468                       SvAMAGIC(left)?
1469                         HvNAME(SvSTASH(SvRV(left))):
1470                         "",
1471                       SvAMAGIC(right)?
1472                         ",\n\tright argument in overloaded package ":
1473                         (flags & AMGf_unary
1474                          ? ""
1475                          : ",\n\tright argument has no overloaded magic"),
1476                       SvAMAGIC(right)?
1477                         HvNAME(SvSTASH(SvRV(right))):
1478                         ""));
1479         if (amtp && amtp->fallback >= AMGfallYES) {
1480           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1481         } else {
1482           Perl_croak(aTHX_ "%"SVf, msg);
1483         }
1484         return NULL;
1485       }
1486       force_cpy = force_cpy || assign;
1487     }
1488   }
1489   if (!notfound) {
1490     DEBUG_o( Perl_deb(aTHX_
1491   "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1492                  AMG_id2name(off),
1493                  method+assignshift==off? "" :
1494                              " (initially `",
1495                  method+assignshift==off? "" :
1496                              AMG_id2name(method+assignshift),
1497                  method+assignshift==off? "" : "')",
1498                  flags & AMGf_unary? "" :
1499                    lr==1 ? " for right argument": " for left argument",
1500                  flags & AMGf_unary? " for argument" : "",
1501                  HvNAME(stash),
1502                  fl? ",\n\tassignment variant used": "") );
1503   }
1504     /* Since we use shallow copy during assignment, we need
1505      * to dublicate the contents, probably calling user-supplied
1506      * version of copy operator
1507      */
1508     /* We need to copy in following cases:
1509      * a) Assignment form was called.
1510      *          assignshift==1,  assign==T, method + 1 == off
1511      * b) Increment or decrement, called directly.
1512      *          assignshift==0,  assign==0, method + 0 == off
1513      * c) Increment or decrement, translated to assignment add/subtr.
1514      *          assignshift==0,  assign==T,
1515      *          force_cpy == T
1516      * d) Increment or decrement, translated to nomethod.
1517      *          assignshift==0,  assign==0,
1518      *          force_cpy == T
1519      * e) Assignment form translated to nomethod.
1520      *          assignshift==1,  assign==T, method + 1 != off
1521      *          force_cpy == T
1522      */
1523     /*  off is method, method+assignshift, or a result of opcode substitution.
1524      *  In the latter case assignshift==0, so only notfound case is important.
1525      */
1526   if (( (method + assignshift == off)
1527         && (assign || (method == inc_amg) || (method == dec_amg)))
1528       || force_cpy)
1529     RvDEEPCP(left);
1530   {
1531     dSP;
1532     BINOP myop;
1533     SV* res;
1534     bool oldcatch = CATCH_GET;
1535
1536     CATCH_SET(TRUE);
1537     Zero(&myop, 1, BINOP);
1538     myop.op_last = (OP *) &myop;
1539     myop.op_next = Nullop;
1540     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1541
1542     PUSHSTACKi(PERLSI_OVERLOAD);
1543     ENTER;
1544     SAVEOP();
1545     PL_op = (OP *) &myop;
1546     if (PERLDB_SUB && PL_curstash != PL_debstash)
1547         PL_op->op_private |= OPpENTERSUB_DB;
1548     PUTBACK;
1549     pp_pushmark();
1550
1551     EXTEND(SP, notfound + 5);
1552     PUSHs(lr>0? right: left);
1553     PUSHs(lr>0? left: right);
1554     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1555     if (notfound) {
1556       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1557     }
1558     PUSHs((SV*)cv);
1559     PUTBACK;
1560
1561     if ((PL_op = Perl_pp_entersub(aTHX)))
1562       CALLRUNOPS(aTHX);
1563     LEAVE;
1564     SPAGAIN;
1565
1566     res=POPs;
1567     PUTBACK;
1568     POPSTACK;
1569     CATCH_SET(oldcatch);
1570
1571     if (postpr) {
1572       int ans;
1573       switch (method) {
1574       case le_amg:
1575       case sle_amg:
1576         ans=SvIV(res)<=0; break;
1577       case lt_amg:
1578       case slt_amg:
1579         ans=SvIV(res)<0; break;
1580       case ge_amg:
1581       case sge_amg:
1582         ans=SvIV(res)>=0; break;
1583       case gt_amg:
1584       case sgt_amg:
1585         ans=SvIV(res)>0; break;
1586       case eq_amg:
1587       case seq_amg:
1588         ans=SvIV(res)==0; break;
1589       case ne_amg:
1590       case sne_amg:
1591         ans=SvIV(res)!=0; break;
1592       case inc_amg:
1593       case dec_amg:
1594         SvSetSV(left,res); return left;
1595       case not_amg:
1596         ans=!SvTRUE(res); break;
1597       }
1598       return boolSV(ans);
1599     } else if (method==copy_amg) {
1600       if (!SvROK(res)) {
1601         Perl_croak(aTHX_ "Copy method did not return a reference");
1602       }
1603       return SvREFCNT_inc(SvRV(res));
1604     } else {
1605       return res;
1606     }
1607   }
1608 }
1609
1610 /*
1611 =for apidoc is_gv_magical
1612
1613 Returns C<TRUE> if given the name of a magical GV.
1614
1615 Currently only useful internally when determining if a GV should be
1616 created even in rvalue contexts.
1617
1618 C<flags> is not used at present but available for future extension to
1619 allow selecting particular classes of magical variable.
1620
1621 =cut
1622 */
1623 bool
1624 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1625 {
1626     if (!len)
1627         return FALSE;
1628
1629     switch (*name) {
1630     case 'I':
1631         if (len == 3 && strEQ(name, "ISA"))
1632             goto yes;
1633         break;
1634     case 'O':
1635         if (len == 8 && strEQ(name, "OVERLOAD"))
1636             goto yes;
1637         break;
1638     case 'S':
1639         if (len == 3 && strEQ(name, "SIG"))
1640             goto yes;
1641         break;
1642     case '\017':   /* $^O & $^OPEN */
1643         if (len == 1
1644             || (len == 4 && strEQ(name, "\027PEN")))
1645         {
1646             goto yes;
1647         }
1648         break;
1649     case '\027':   /* $^W & $^WARNING_BITS */
1650         if (len == 1
1651             || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1652             || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
1653         {
1654             goto yes;
1655         }
1656         break;
1657
1658     case '&':
1659     case '`':
1660     case '\'':
1661     case ':':
1662     case '?':
1663     case '!':
1664     case '-':
1665     case '#':
1666     case '*':
1667     case '[':
1668     case '^':
1669     case '~':
1670     case '=':
1671     case '%':
1672     case '.':
1673     case '(':
1674     case ')':
1675     case '<':
1676     case '>':
1677     case ',':
1678     case '\\':
1679     case '/':
1680     case '|':
1681     case '+':
1682     case ';':
1683     case ']':
1684     case '\001':   /* $^A */
1685     case '\003':   /* $^C */
1686     case '\004':   /* $^D */
1687     case '\005':   /* $^E */
1688     case '\006':   /* $^F */
1689     case '\010':   /* $^H */
1690     case '\011':   /* $^I, NOT \t in EBCDIC */
1691     case '\014':   /* $^L */
1692     case '\020':   /* $^P */
1693     case '\023':   /* $^S */
1694     case '\024':   /* $^T */
1695     case '\026':   /* $^V */
1696         if (len == 1)
1697             goto yes;
1698         break;
1699     case '1':
1700     case '2':
1701     case '3':
1702     case '4':
1703     case '5':
1704     case '6':
1705     case '7':
1706     case '8':
1707     case '9':
1708         if (len > 1) {
1709             char *end = name + len;
1710             while (--end > name) {
1711                 if (!isDIGIT(*end))
1712                     return FALSE;
1713             }
1714         }
1715     yes:
1716         return TRUE;
1717     default:
1718         break;
1719     }
1720     return FALSE;
1721 }