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             SvNVX(sv) = SvNVX(PL_patchlevel);
 817             SvNOK_on(sv);
 818             (void)SvPV_nolen(sv);
 819             SvREADONLY_on(sv);
 820         }
 821         break;
 822     }
 823     return gv;
 824 }
 825
 826 void
 827 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
 828 {
 829     HV *hv = GvSTASH(gv);
 830     if (!hv) {
 831         SvOK_off(sv);
 832         return;
 833     }
 834     sv_setpv(sv, prefix ? prefix : "");
 835     sv_catpv(sv,HvNAME(hv));
 836     sv_catpvn(sv,"::", 2);
 837     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
 838 }
 839
 840 void
 841 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
 842 {
 843     GV *egv = GvEGV(gv);
 844     if (!egv)
 845         egv = gv;
 846     gv_fullname3(sv, egv, prefix);
 847 }
 848
 849 /* XXX compatibility with versions <= 5.003. */
 850 void
 851 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
 852 {
 853     gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
 854 }
 855
 856 /* XXX compatibility with versions <= 5.003. */
 857 void
 858 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
 859 {
 860     gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
 861 }
 862
 863 IO *
 864 Perl_newIO(pTHX)
 865 {
 866     dTHR;
 867     IO *io;
 868     GV *iogv;
 869
 870     io = (IO*)NEWSV(0,0);
 871     sv_upgrade((SV *)io,SVt_PVIO);
 872     SvREFCNT(io) = 1;
 873     SvOBJECT_on(io);
 874     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
 875     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
 876     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
 877       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
 878     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
 879     return io;
 880 }
 881
 882 void
 883 Perl_gv_check(pTHX_ HV *stash)
 884 {
 885     dTHR;
 886     register HE *entry;
 887     register I32 i;
 888     register GV *gv;
 889     HV *hv;
 890
 891     if (!HvARRAY(stash))
 892         return;
 893     for (i = 0; i <= (I32) HvMAX(stash); i++) {
 894         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
 895             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
 896                 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
 897             {
 898                 if (hv != PL_defstash && hv != stash)
 899                      gv_check(hv);              /* nested package */
 900             }
 901             else if (isALPHA(*HeKEY(entry))) {
 902                 char *file;
 903                 gv = (GV*)HeVAL(entry);
 904                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
 905                     continue;
 906                 file = GvFILE(gv);
 907                 /* performance hack: if filename is absolute and it's a standard
 908                  * module, don't bother warning */
 909                 if (file
 910                     && PERL_FILE_IS_ABSOLUTE(file)
 911                     && (instr(file, "/lib/") || instr(file, ".pm")))
 912                 {
 913                     continue;
 914                 }
 915                 CopLINE_set(PL_curcop, GvLINE(gv));
 916 #ifdef USE_ITHREADS
 917                 CopFILE(PL_curcop) = file;      /* set for warning */
 918 #else
 919                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
 920 #endif
 921                 Perl_warner(aTHX_ WARN_ONCE,
 922                         "Name \"%s::%s\" used only once: possible typo",
 923                         HvNAME(stash), GvNAME(gv));
 924             }
 925         }
 926     }
 927 }
 928
 929 GV *
 930 Perl_newGVgen(pTHX_ char *pack)
 931 {
 932     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
 933                       TRUE, SVt_PVGV);
 934 }
 935
 936 /* hopefully this is only called on local symbol table entries */
 937
 938 GP*
 939 Perl_gp_ref(pTHX_ GP *gp)
 940 {
 941     if (!gp)
 942         return (GP*)NULL;
 943     gp->gp_refcnt++;
 944     if (gp->gp_cv) {
 945         if (gp->gp_cvgen) {
 946             /* multi-named GPs cannot be used for method cache */
 947             SvREFCNT_dec(gp->gp_cv);
 948             gp->gp_cv = Nullcv;
 949             gp->gp_cvgen = 0;
 950         }
 951         else {
 952             /* Adding a new name to a subroutine invalidates method cache */
 953             PL_sub_generation++;
 954         }
 955     }
 956     return gp;
 957 }
 958
 959 void
 960 Perl_gp_free(pTHX_ GV *gv)
 961 {
 962     dTHR;
 963     GP* gp;
 964     CV* cv;
 965
 966     if (!gv || !(gp = GvGP(gv)))
 967         return;
 968     if (gp->gp_refcnt == 0) {
 969         if (ckWARN_d(WARN_INTERNAL))
 970             Perl_warner(aTHX_ WARN_INTERNAL,
 971                         "Attempt to free unreferenced glob pointers");
 972         return;
 973     }
 974     if (gp->gp_cv) {
 975         /* Deleting the name of a subroutine invalidates method cache */
 976         PL_sub_generation++;
 977     }
 978     if (--gp->gp_refcnt > 0) {
 979         if (gp->gp_egv == gv)
 980             gp->gp_egv = 0;
 981         return;
 982     }
 983
 984     SvREFCNT_dec(gp->gp_sv);
 985     SvREFCNT_dec(gp->gp_av);
 986     SvREFCNT_dec(gp->gp_hv);
 987     SvREFCNT_dec(gp->gp_io);
 988     SvREFCNT_dec(gp->gp_cv);
 989     SvREFCNT_dec(gp->gp_form);
 990
 991     Safefree(gp);
 992     GvGP(gv) = 0;
 993 }
 994
 995 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
 996 #define MICROPORT
 997 #endif
 998
 999 #ifdef  MICROPORT       /* Microport 2.4 hack */
1000 AV *GvAVn(gv)
1001 register GV *gv;
1002 {
1003     if (GvGP(gv)->gp_av)
1004         return GvGP(gv)->gp_av;
1005     else
1006         return GvGP(gv_AVadd(gv))->gp_av;
1007 }
1008
1009 HV *GvHVn(gv)
1010 register GV *gv;
1011 {
1012     if (GvGP(gv)->gp_hv)
1013         return GvGP(gv)->gp_hv;
1014     else
1015         return GvGP(gv_HVadd(gv))->gp_hv;
1016 }
1017 #endif                  /* Microport 2.4 hack */
1018
1019 /* Updates and caches the CV's */
1020
1021 bool
1022 Perl_Gv_AMupdate(pTHX_ HV *stash)
1023 {
1024   dTHR;
1025   GV** gvp;
1026   HV* hv;
1027   GV* gv;
1028   CV* cv;
1029   MAGIC* mg=mg_find((SV*)stash,'c');
1030   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1031   AMT amt;
1032   STRLEN n_a;
1033
1034   if (mg && amtp->was_ok_am == PL_amagic_generation
1035       && amtp->was_ok_sub == PL_sub_generation)
1036       return AMT_AMAGIC(amtp);
1037   if (amtp && AMT_AMAGIC(amtp)) {       /* Have table. */
1038     int i;
1039     for (i=1; i<NofAMmeth; i++) {
1040       if (amtp->table[i]) {
1041         SvREFCNT_dec(amtp->table[i]);
1042       }
1043     }
1044   }
1045   sv_unmagic((SV*)stash, 'c');
1046
1047   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1048
1049   amt.was_ok_am = PL_amagic_generation;
1050   amt.was_ok_sub = PL_sub_generation;
1051   amt.fallback = AMGfallNO;
1052   amt.flags = 0;
1053
1054 #ifdef OVERLOAD_VIA_HASH
1055   gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */
1056   if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) {
1057     int filled=0;
1058     int i;
1059     char *cp;
1060     SV* sv;
1061     SV** svp;
1062
1063     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1064
1065     if (( cp = (char *)PL_AMG_names[0] ) &&
1066         (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
1067       if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1068       else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1069     }
1070     for (i = 1; i < NofAMmeth; i++) {
1071       cv = 0;
1072       cp = (char *)PL_AMG_names[i];
1073
1074         svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
1075         if (svp && ((sv = *svp) != &PL_sv_undef)) {
1076           switch (SvTYPE(sv)) {
1077             default:
1078               if (!SvROK(sv)) {
1079                 if (!SvOK(sv)) break;
1080                 gv = gv_fetchmethod(stash, SvPV(sv, n_a));
1081                 if (gv) cv = GvCV(gv);
1082                 break;
1083               }
1084               cv = (CV*)SvRV(sv);
1085               if (SvTYPE(cv) == SVt_PVCV)
1086                   break;
1087                 /* FALL THROUGH */
1088             case SVt_PVHV:
1089             case SVt_PVAV:
1090               Perl_croak(aTHX_ "Not a subroutine reference in overload table");
1091               return FALSE;
1092             case SVt_PVCV:
1093               cv = (CV*)sv;
1094               break;
1095             case SVt_PVGV:
1096               if (!(cv = GvCVu((GV*)sv)))
1097                 cv = sv_2cv(sv, &stash, &gv, FALSE);
1098               break;
1099           }
1100           if (cv) filled=1;
1101           else {
1102             Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n",
1103                 cp,HvNAME(stash));
1104             return FALSE;
1105           }
1106         }
1107 #else
1108   {
1109     int filled = 0;
1110     int i;
1111     const char *cp;
1112     SV* sv = NULL;
1113     SV** svp;
1114
1115     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1116
1117     if ( cp = PL_AMG_names[0] ) {
1118         /* Try to find via inheritance. */
1119         gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
1120         if (gv) sv = GvSV(gv);
1121
1122         if (!gv) goto no_table;
1123         else if (SvTRUE(sv)) amt.fallback=AMGfallYES;
1124         else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
1125     }
1126
1127     for (i = 1; i < NofAMmeth; i++) {
1128         SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i]));
1129         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1130                      cp, HvNAME(stash)) );
1131         /* don't fill the cache while looking up! */
1132         gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
1133         cv = 0;
1134         if(gv && (cv = GvCV(gv))) {
1135             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1136                 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1137                 /* GvSV contains the name of the method. */
1138                 GV *ngv;
1139
1140                 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
1141                              SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) );
1142                 if (!SvPOK(GvSV(gv))
1143                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1144                                                        FALSE)))
1145                 {
1146                     /* Can be an import stub (created by `can'). */
1147                     if (GvCVGEN(gv)) {
1148                         Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
1149                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1150                               cp, HvNAME(stash));
1151                     } else
1152                         Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
1153                               (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
1154                               cp, HvNAME(stash));
1155                 }
1156                 cv = GvCV(gv = ngv);
1157             }
1158             DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1159                          cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1160                          GvNAME(CvGV(cv))) );
1161             filled = 1;
1162         }
1163 #endif
1164         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1165     }
1166     if (filled) {
1167       AMT_AMAGIC_on(&amt);
1168       sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
1169       return TRUE;
1170     }
1171   }
1172   /* Here we have no table: */
1173  no_table:
1174   AMT_AMAGIC_off(&amt);
1175   sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
1176   return FALSE;
1177 }
1178
1179 SV*
1180 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1181 {
1182   dTHR;
1183   MAGIC *mg;
1184   CV *cv;
1185   CV **cvp=NULL, **ocvp=NULL;
1186   AMT *amtp, *oamtp;
1187   int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1188   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1189   HV* stash;
1190   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1191       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
1192       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1193                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1194                         : (CV **) NULL))
1195       && ((cv = cvp[off=method+assignshift])
1196           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1197                                                           * usual method */
1198                   (fl = 1, cv = cvp[off=method])))) {
1199     lr = -1;                    /* Call method for left argument */
1200   } else {
1201     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1202       int logic;
1203
1204       /* look for substituted methods */
1205       /* In all the covered cases we should be called with assign==0. */
1206          switch (method) {
1207          case inc_amg:
1208            force_cpy = 1;
1209            if ((cv = cvp[off=add_ass_amg])
1210                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1211              right = &PL_sv_yes; lr = -1; assign = 1;
1212            }
1213            break;
1214          case dec_amg:
1215            force_cpy = 1;
1216            if ((cv = cvp[off = subtr_ass_amg])
1217                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1218              right = &PL_sv_yes; lr = -1; assign = 1;
1219            }
1220            break;
1221          case bool__amg:
1222            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1223            break;
1224          case numer_amg:
1225            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1226            break;
1227          case string_amg:
1228            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1229            break;
1230  case not_amg:
1231    (void)((cv = cvp[off=bool__amg])
1232           || (cv = cvp[off=numer_amg])
1233           || (cv = cvp[off=string_amg]));
1234    postpr = 1;
1235    break;
1236          case copy_amg:
1237            {
1238              /*
1239                   * SV* ref causes confusion with the interpreter variable of
1240                   * the same name
1241                   */
1242              SV* tmpRef=SvRV(left);
1243              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1244                 /*
1245                  * Just to be extra cautious.  Maybe in some
1246                  * additional cases sv_setsv is safe, too.
1247                  */
1248                 SV* newref = newSVsv(tmpRef);
1249                 SvOBJECT_on(newref);
1250                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1251                 return newref;
1252              }
1253            }
1254            break;
1255          case abs_amg:
1256            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1257                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1258              SV* nullsv=sv_2mortal(newSViv(0));
1259              if (off1==lt_amg) {
1260                SV* lessp = amagic_call(left,nullsv,
1261                                        lt_amg,AMGf_noright);
1262                logic = SvTRUE(lessp);
1263              } else {
1264                SV* lessp = amagic_call(left,nullsv,
1265                                        ncmp_amg,AMGf_noright);
1266                logic = (SvNV(lessp) < 0);
1267              }
1268              if (logic) {
1269                if (off==subtr_amg) {
1270                  right = left;
1271                  left = nullsv;
1272                  lr = 1;
1273                }
1274              } else {
1275                return left;
1276              }
1277            }
1278            break;
1279          case neg_amg:
1280            if (cv = cvp[off=subtr_amg]) {
1281              right = left;
1282              left = sv_2mortal(newSViv(0));
1283              lr = 1;
1284            }
1285            break;
1286          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1287          case to_sv_amg:
1288          case to_av_amg:
1289          case to_hv_amg:
1290          case to_gv_amg:
1291          case to_cv_amg:
1292              /* FAIL safe */
1293              return NULL;       /* Delegate operation to standard mechanisms. */
1294              break;
1295          default:
1296            goto not_found;
1297          }
1298          if (!cv) goto not_found;
1299     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1300                && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
1301                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1302                           ? (amtp = (AMT*)mg->mg_ptr)->table
1303                           : (CV **) NULL))
1304                && (cv = cvp[off=method])) { /* Method for right
1305                                              * argument found */
1306       lr=1;
1307     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1308                  && (cvp=ocvp) && (lr = -1))
1309                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1310                && !(flags & AMGf_unary)) {
1311                                 /* We look for substitution for
1312                                  * comparison operations and
1313                                  * concatenation */
1314       if (method==concat_amg || method==concat_ass_amg
1315           || method==repeat_amg || method==repeat_ass_amg) {
1316         return NULL;            /* Delegate operation to string conversion */
1317       }
1318       off = -1;
1319       switch (method) {
1320          case lt_amg:
1321          case le_amg:
1322          case gt_amg:
1323          case ge_amg:
1324          case eq_amg:
1325          case ne_amg:
1326            postpr = 1; off=ncmp_amg; break;
1327          case slt_amg:
1328          case sle_amg:
1329          case sgt_amg:
1330          case sge_amg:
1331          case seq_amg:
1332          case sne_amg:
1333            postpr = 1; off=scmp_amg; break;
1334          }
1335       if (off != -1) cv = cvp[off];
1336       if (!cv) {
1337         goto not_found;
1338       }
1339     } else {
1340     not_found:                  /* No method found, either report or croak */
1341       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1342         notfound = 1; lr = -1;
1343       } else if (cvp && (cv=cvp[nomethod_amg])) {
1344         notfound = 1; lr = 1;
1345       } else {
1346         SV *msg;
1347         if (off==-1) off=method;
1348         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1349                       "Operation `%s': no method found,%sargument %s%s%s%s",
1350                       PL_AMG_names[method + assignshift],
1351                       (flags & AMGf_unary ? " " : "\n\tleft "),
1352                       SvAMAGIC(left)?
1353                         "in overloaded package ":
1354                         "has no overloaded magic",
1355                       SvAMAGIC(left)?
1356                         HvNAME(SvSTASH(SvRV(left))):
1357                         "",
1358                       SvAMAGIC(right)?
1359                         ",\n\tright argument in overloaded package ":
1360                         (flags & AMGf_unary
1361                          ? ""
1362                          : ",\n\tright argument has no overloaded magic"),
1363                       SvAMAGIC(right)?
1364                         HvNAME(SvSTASH(SvRV(right))):
1365                         ""));
1366         if (amtp && amtp->fallback >= AMGfallYES) {
1367           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1368         } else {
1369           Perl_croak(aTHX_ "%_", msg);
1370         }
1371         return NULL;
1372       }
1373       force_cpy = force_cpy || assign;
1374     }
1375   }
1376   if (!notfound) {
1377     DEBUG_o( Perl_deb(aTHX_
1378   "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1379                  PL_AMG_names[off],
1380                  method+assignshift==off? "" :
1381                              " (initially `",
1382                  method+assignshift==off? "" :
1383                              PL_AMG_names[method+assignshift],
1384                  method+assignshift==off? "" : "')",
1385                  flags & AMGf_unary? "" :
1386                    lr==1 ? " for right argument": " for left argument",
1387                  flags & AMGf_unary? " for argument" : "",
1388                  HvNAME(stash),
1389                  fl? ",\n\tassignment variant used": "") );
1390   }
1391     /* Since we use shallow copy during assignment, we need
1392      * to dublicate the contents, probably calling user-supplied
1393      * version of copy operator
1394      */
1395     /* We need to copy in following cases:
1396      * a) Assignment form was called.
1397      *          assignshift==1,  assign==T, method + 1 == off
1398      * b) Increment or decrement, called directly.
1399      *          assignshift==0,  assign==0, method + 0 == off
1400      * c) Increment or decrement, translated to assignment add/subtr.
1401      *          assignshift==0,  assign==T,
1402      *          force_cpy == T
1403      * d) Increment or decrement, translated to nomethod.
1404      *          assignshift==0,  assign==0,
1405      *          force_cpy == T
1406      * e) Assignment form translated to nomethod.
1407      *          assignshift==1,  assign==T, method + 1 != off
1408      *          force_cpy == T
1409      */
1410     /*  off is method, method+assignshift, or a result of opcode substitution.
1411      *  In the latter case assignshift==0, so only notfound case is important.
1412      */
1413   if (( (method + assignshift == off)
1414         && (assign || (method == inc_amg) || (method == dec_amg)))
1415       || force_cpy)
1416     RvDEEPCP(left);
1417   {
1418     dSP;
1419     BINOP myop;
1420     SV* res;
1421     bool oldcatch = CATCH_GET;
1422
1423     CATCH_SET(TRUE);
1424     Zero(&myop, 1, BINOP);
1425     myop.op_last = (OP *) &myop;
1426     myop.op_next = Nullop;
1427     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1428
1429     PUSHSTACKi(PERLSI_OVERLOAD);
1430     ENTER;
1431     SAVEOP();
1432     PL_op = (OP *) &myop;
1433     if (PERLDB_SUB && PL_curstash != PL_debstash)
1434         PL_op->op_private |= OPpENTERSUB_DB;
1435     PUTBACK;
1436     pp_pushmark();
1437
1438     EXTEND(SP, notfound + 5);
1439     PUSHs(lr>0? right: left);
1440     PUSHs(lr>0? left: right);
1441     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1442     if (notfound) {
1443       PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0)));
1444     }
1445     PUSHs((SV*)cv);
1446     PUTBACK;
1447
1448     if (PL_op = Perl_pp_entersub(aTHX))
1449       CALLRUNOPS(aTHX);
1450     LEAVE;
1451     SPAGAIN;
1452
1453     res=POPs;
1454     PUTBACK;
1455     POPSTACK;
1456     CATCH_SET(oldcatch);
1457
1458     if (postpr) {
1459       int ans;
1460       switch (method) {
1461       case le_amg:
1462       case sle_amg:
1463         ans=SvIV(res)<=0; break;
1464       case lt_amg:
1465       case slt_amg:
1466         ans=SvIV(res)<0; break;
1467       case ge_amg:
1468       case sge_amg:
1469         ans=SvIV(res)>=0; break;
1470       case gt_amg:
1471       case sgt_amg:
1472         ans=SvIV(res)>0; break;
1473       case eq_amg:
1474       case seq_amg:
1475         ans=SvIV(res)==0; break;
1476       case ne_amg:
1477       case sne_amg:
1478         ans=SvIV(res)!=0; break;
1479       case inc_amg:
1480       case dec_amg:
1481         SvSetSV(left,res); return left;
1482       case not_amg:
1483         ans=!SvTRUE(res); break;
1484       }
1485       return boolSV(ans);
1486     } else if (method==copy_amg) {
1487       if (!SvROK(res)) {
1488         Perl_croak(aTHX_ "Copy method did not return a reference");
1489       }
1490       return SvREFCNT_inc(SvRV(res));
1491     } else {
1492       return res;
1493     }
1494   }
1495 }