gv.c

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