gv.c

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