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