gv.c

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