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     if (!len)
 692         len = 1;
 693
 694     /* No stash in name, so see how we can default */
 695
 696     if (!stash) {
 697         if (isIDFIRST_lazy(name)) {
 698             bool global = FALSE;
 699
 700             if (isUPPER(*name)) {
 701                 if (*name == 'S' && (
 702                     strEQ(name, "SIG") ||
 703                     strEQ(name, "STDIN") ||
 704                     strEQ(name, "STDOUT") ||
 705                     strEQ(name, "STDERR")))
 706                     global = TRUE;
 707                 else if (*name == 'I' && strEQ(name, "INC"))
 708                     global = TRUE;
 709                 else if (*name == 'E' && strEQ(name, "ENV"))
 710                     global = TRUE;
 711                 else if (*name == 'A' && (
 712                   strEQ(name, "ARGV") ||
 713                   strEQ(name, "ARGVOUT")))
 714                     global = TRUE;
 715             }
 716             else if (*name == '_' && !name[1])
 717                 global = TRUE;
 718
 719             if (global)
 720                 stash = PL_defstash;
 721             else if ((COP*)PL_curcop == &PL_compiling) {
 722                 stash = PL_curstash;
 723                 if (add && (PL_hints & HINT_STRICT_VARS) &&
 724                     sv_type != SVt_PVCV &&
 725                     sv_type != SVt_PVGV &&
 726                     sv_type != SVt_PVFM &&
 727                     sv_type != SVt_PVIO &&
 728                     !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
 729                 {
 730                     gvp = (GV**)hv_fetch(stash,name,len,0);
 731                     if (!gvp ||
 732                         *gvp == (GV*)&PL_sv_undef ||
 733                         SvTYPE(*gvp) != SVt_PVGV)
 734                     {
 735                         stash = 0;
 736                     }
 737                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
 738                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
 739                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
 740                     {
 741                         Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
 742                             sv_type == SVt_PVAV ? '@' :
 743                             sv_type == SVt_PVHV ? '%' : '$',
 744                             name);
 745                         if (GvCVu(*gvp))
 746                             Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
 747                         stash = 0;
 748                     }
 749                 }
 750             }
 751             else
 752                 stash = CopSTASH(PL_curcop);
 753         }
 754         else
 755             stash = PL_defstash;
 756     }
 757
 758     /* By this point we should have a stash and a name */
 759
 760     if (!stash) {
 761         if (add) {
 762             qerror(Perl_mess(aTHX_
 763                  "Global symbol \"%s%s\" requires explicit package name",
 764                  (sv_type == SVt_PV ? "$"
 765                   : sv_type == SVt_PVAV ? "@"
 766                   : sv_type == SVt_PVHV ? "%"
 767                   : ""), name));
 768             stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
 769         }
 770         else
 771             return Nullgv;
 772     }
 773
 774     if (!SvREFCNT(stash))       /* symbol table under destruction */
 775         return Nullgv;
 776
 777     gvp = (GV**)hv_fetch(stash,name,len,add);
 778     if (!gvp || *gvp == (GV*)&PL_sv_undef)
 779         return Nullgv;
 780     gv = *gvp;
 781     if (SvTYPE(gv) == SVt_PVGV) {
 782         if (add) {
 783             GvMULTI_on(gv);
 784             gv_init_sv(gv, sv_type);
 785             if (*name=='!' && sv_type == SVt_PVHV && len==1)
 786                 require_errno(gv);
 787         }
 788         return gv;
 789     } else if (add & GV_NOINIT) {
 790         return gv;
 791     }
 792
 793     /* Adding a new symbol */
 794
 795     if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
 796         Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
 797     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
 798     gv_init_sv(gv, sv_type);
 799
 800     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
 801                                             : (PL_dowarn & G_WARN_ON ) ) )
 802         GvMULTI_on(gv) ;
 803
 804     /* set up magic where warranted */
 805     switch (*name) {
 806     case 'A':
 807         if (strEQ(name, "ARGV")) {
 808             IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
 809         }
 810         break;
 811     case 'E':
 812         if (strnEQ(name, "EXPORT", 6))
 813             GvMULTI_on(gv);
 814         break;
 815     case 'I':
 816         if (strEQ(name, "ISA")) {
 817             AV* av = GvAVn(gv);
 818             GvMULTI_on(gv);
 819             sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
 820             /* NOTE: No support for tied ISA */
 821             if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
 822                 && AvFILLp(av) == -1)
 823             {
 824                 char *pname;
 825                 av_push(av, newSVpvn(pname = "NDBM_File",9));
 826                 gv_stashpvn(pname, 9, TRUE);
 827                 av_push(av, newSVpvn(pname = "DB_File",7));
 828                 gv_stashpvn(pname, 7, TRUE);
 829                 av_push(av, newSVpvn(pname = "GDBM_File",9));
 830                 gv_stashpvn(pname, 9, TRUE);
 831                 av_push(av, newSVpvn(pname = "SDBM_File",9));
 832                 gv_stashpvn(pname, 9, TRUE);
 833                 av_push(av, newSVpvn(pname = "ODBM_File",9));
 834                 gv_stashpvn(pname, 9, TRUE);
 835             }
 836         }
 837         break;
 838     case 'O':
 839         if (strEQ(name, "OVERLOAD")) {
 840             HV* hv = GvHVn(gv);
 841             GvMULTI_on(gv);
 842             hv_magic(hv, Nullgv, PERL_MAGIC_overload);
 843         }
 844         break;
 845     case 'S':
 846         if (strEQ(name, "SIG")) {
 847             HV *hv;
 848             I32 i;
 849             if (!PL_psig_ptr) {
 850                 Newz(73, PL_psig_ptr,  SIG_SIZE, SV*);
 851                 Newz(73, PL_psig_name, SIG_SIZE, SV*);
 852                 Newz(73, PL_psig_pend, SIG_SIZE, int);
 853             }
 854             GvMULTI_on(gv);
 855             hv = GvHVn(gv);
 856             hv_magic(hv, Nullgv, PERL_MAGIC_sig);
 857             for (i = 1; i < SIG_SIZE; i++) {
 858                 SV ** init;
 859                 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
 860                 if (init)
 861                     sv_setsv(*init, &PL_sv_undef);
 862                 PL_psig_ptr[i] = 0;
 863                 PL_psig_name[i] = 0;
 864                 PL_psig_pend[i] = 0;
 865             }
 866         }
 867         break;
 868     case 'V':
 869         if (strEQ(name, "VERSION"))
 870             GvMULTI_on(gv);
 871         break;
 872
 873     case '&':
 874     case '`':
 875     case '\'':
 876        if (
 877            len > 1 ||
 878            sv_type == SVt_PVAV ||
 879            sv_type == SVt_PVHV ||
 880            sv_type == SVt_PVCV ||
 881            sv_type == SVt_PVFM ||
 882            sv_type == SVt_PVIO
 883        ) { break; }
 884         PL_sawampersand = TRUE;
 885         goto ro_magicalize;
 886
 887     case ':':
 888         if (len > 1)
 889             break;
 890         sv_setpv(GvSV(gv),PL_chopset);
 891         goto magicalize;
 892
 893     case '?':
 894         if (len > 1)
 895             break;
 896 #ifdef COMPLEX_STATUS
 897         (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
 898 #endif
 899         goto magicalize;
 900
 901     case '!':
 902         if (len > 1)
 903             break;
 904
 905         /* If %! has been used, automatically load Errno.pm.
 906            The require will itself set errno, so in order to
 907            preserve its value we have to set up the magic
 908            now (rather than going to magicalize)
 909         */
 910
 911         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
 912
 913         if (sv_type == SVt_PVHV)
 914             require_errno(gv);
 915
 916         break;
 917     case '-':
 918         if (len > 1)
 919             break;
 920         else {
 921             AV* av = GvAVn(gv);
 922             sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
 923             SvREADONLY_on(av);
 924         }
 925         goto magicalize;
 926     case '#':
 927     case '*':
 928         if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && len == 1 && sv_type == SVt_PV)
 929             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Use of $%s is deprecated", name);
 930         /* FALL THROUGH */
 931     case '[':
 932     case '^':
 933     case '~':
 934     case '=':
 935     case '%':
 936     case '.':
 937     case '(':
 938     case ')':
 939     case '<':
 940     case '>':
 941     case ',':
 942     case '\\':
 943     case '/':
 944     case '\001':        /* $^A */
 945     case '\003':        /* $^C */
 946     case '\004':        /* $^D */
 947     case '\006':        /* $^F */
 948     case '\010':        /* $^H */
 949     case '\011':        /* $^I, NOT \t in EBCDIC */
 950     case '\016':        /* $^N */
 951     case '\020':        /* $^P */
 952         if (len > 1)
 953             break;
 954         goto magicalize;
 955     case '|':
 956         if (len > 1)
 957             break;
 958         sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
 959         goto magicalize;
 960     case '\005':        /* $^E && $^ENCODING */
 961         if (len > 1 && strNE(name, "\005NCODING"))
 962             break;
 963         goto magicalize;
 964
 965     case '\017':        /* $^O & $^OPEN */
 966         if (len > 1 && strNE(name, "\017PEN"))
 967             break;
 968         goto magicalize;
 969     case '\023':        /* $^S */
 970         if (len > 1)
 971             break;
 972         goto ro_magicalize;
 973     case '\024':        /* $^T, ${^TAINT} */
 974         if (len == 1)
 975             goto magicalize;
 976         else if (strEQ(name, "\024AINT"))
 977             goto ro_magicalize;
 978         else
 979             break;
 980     case '\025':
 981         if (len > 1 && strNE(name, "\025NICODE"))
 982             break;
 983         goto ro_magicalize;
 984
 985     case '\027':        /* $^W & $^WARNING_BITS */
 986         if (len > 1
 987             && strNE(name, "\027ARNING_BITS")
 988             )
 989             break;
 990         goto magicalize;
 991
 992     case '+':
 993         if (len > 1)
 994             break;
 995         else {
 996             AV* av = GvAVn(gv);
 997             sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
 998             SvREADONLY_on(av);
 999         }
1000         /* FALL THROUGH */
1001     case '1':
1002     case '2':
1003     case '3':
1004     case '4':
1005     case '5':
1006     case '6':
1007     case '7':
1008     case '8':
1009     case '9':
1010         /* ensures variable is only digits */
1011         /* ${"1foo"} fails this test (and is thus writeable) */
1012         /* added by japhy, but borrowed from is_gv_magical */
1013
1014         if (len > 1) {
1015             const char *end = name + len;
1016             while (--end > name) {
1017                 if (!isDIGIT(*end)) return gv;
1018             }
1019         }
1020
1021       ro_magicalize:
1022         SvREADONLY_on(GvSV(gv));
1023       magicalize:
1024         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1025         break;
1026
1027     case '\014':        /* $^L */
1028         if (len > 1)
1029             break;
1030         sv_setpv(GvSV(gv),"\f");
1031         PL_formfeed = GvSV(gv);
1032         break;
1033     case ';':
1034         if (len > 1)
1035             break;
1036         sv_setpv(GvSV(gv),"\034");
1037         break;
1038     case ']':
1039         if (len == 1) {
1040             SV *sv = GvSV(gv);
1041             (void)SvUPGRADE(sv, SVt_PVNV);
1042             Perl_sv_setpvf(aTHX_ sv,
1043 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
1044                             "%8.6"
1045 #else
1046                             "%5.3"
1047 #endif
1048                             NVff,
1049                             SvNVX(PL_patchlevel));
1050             SvNVX(sv) = SvNVX(PL_patchlevel);
1051             SvNOK_on(sv);
1052             SvREADONLY_on(sv);
1053         }
1054         break;
1055     case '\026':        /* $^V */
1056         if (len == 1) {
1057             SV *sv = GvSV(gv);
1058             GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
1059             SvREFCNT_dec(sv);
1060         }
1061         break;
1062     }
1063     return gv;
1064 }
1065
1066 void
1067 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1068 {
1069     HV *hv = GvSTASH(gv);
1070     if (!hv) {
1071         (void)SvOK_off(sv);
1072         return;
1073     }
1074     sv_setpv(sv, prefix ? prefix : "");
1075     if (keepmain || strNE(HvNAME(hv), "main")) {
1076         sv_catpv(sv,HvNAME(hv));
1077         sv_catpvn(sv,"::", 2);
1078     }
1079     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1080 }
1081
1082 void
1083 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1084 {
1085     gv_fullname4(sv, gv, prefix, TRUE);
1086 }
1087
1088 void
1089 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1090 {
1091     GV *egv = GvEGV(gv);
1092     if (!egv)
1093         egv = gv;
1094     gv_fullname4(sv, egv, prefix, keepmain);
1095 }
1096
1097 void
1098 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1099 {
1100     gv_efullname4(sv, gv, prefix, TRUE);
1101 }
1102
1103 /* XXX compatibility with versions <= 5.003. */
1104 void
1105 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
1106 {
1107     gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1108 }
1109
1110 /* XXX compatibility with versions <= 5.003. */
1111 void
1112 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
1113 {
1114     gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1115 }
1116
1117 IO *
1118 Perl_newIO(pTHX)
1119 {
1120     IO *io;
1121     GV *iogv;
1122
1123     io = (IO*)NEWSV(0,0);
1124     sv_upgrade((SV *)io,SVt_PVIO);
1125     SvREFCNT(io) = 1;
1126     SvOBJECT_on(io);
1127     /* Clear the stashcache because a new IO could overrule a
1128        package name */
1129     hv_clear(PL_stashcache);
1130     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1131     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1132     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1133       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1134     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1135     return io;
1136 }
1137
1138 void
1139 Perl_gv_check(pTHX_ HV *stash)
1140 {
1141     register HE *entry;
1142     register I32 i;
1143     register GV *gv;
1144     HV *hv;
1145
1146     if (!HvARRAY(stash))
1147         return;
1148     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1149         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1150             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1151                 (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)))
1152             {
1153                 if (hv != PL_defstash && hv != stash)
1154                      gv_check(hv);              /* nested package */
1155             }
1156             else if (isALPHA(*HeKEY(entry))) {
1157                 char *file;
1158                 gv = (GV*)HeVAL(entry);
1159                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1160                     continue;
1161                 file = GvFILE(gv);
1162                 /* performance hack: if filename is absolute and it's a standard
1163                  * module, don't bother warning */
1164                 if (file
1165                     && PERL_FILE_IS_ABSOLUTE(file)
1166 #ifdef MACOS_TRADITIONAL
1167                     && (instr(file, ":lib:")
1168 #else
1169                     && (instr(file, "/lib/")
1170 #endif
1171                     || instr(file, ".pm")))
1172                 {
1173                     continue;
1174                 }
1175                 CopLINE_set(PL_curcop, GvLINE(gv));
1176 #ifdef USE_ITHREADS
1177                 CopFILE(PL_curcop) = file;      /* set for warning */
1178 #else
1179                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1180 #endif
1181                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1182                         "Name \"%s::%s\" used only once: possible typo",
1183                         HvNAME(stash), GvNAME(gv));
1184             }
1185         }
1186     }
1187 }
1188
1189 GV *
1190 Perl_newGVgen(pTHX_ char *pack)
1191 {
1192     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1193                       TRUE, SVt_PVGV);
1194 }
1195
1196 /* hopefully this is only called on local symbol table entries */
1197
1198 GP*
1199 Perl_gp_ref(pTHX_ GP *gp)
1200 {
1201     if (!gp)
1202         return (GP*)NULL;
1203     gp->gp_refcnt++;
1204     if (gp->gp_cv) {
1205         if (gp->gp_cvgen) {
1206             /* multi-named GPs cannot be used for method cache */
1207             SvREFCNT_dec(gp->gp_cv);
1208             gp->gp_cv = Nullcv;
1209             gp->gp_cvgen = 0;
1210         }
1211         else {
1212             /* Adding a new name to a subroutine invalidates method cache */
1213             PL_sub_generation++;
1214         }
1215     }
1216     return gp;
1217 }
1218
1219 void
1220 Perl_gp_free(pTHX_ GV *gv)
1221 {
1222     GP* gp;
1223
1224     if (!gv || !(gp = GvGP(gv)))
1225         return;
1226     if (gp->gp_refcnt == 0) {
1227         if (ckWARN_d(WARN_INTERNAL))
1228             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1229                         "Attempt to free unreferenced glob pointers");
1230         return;
1231     }
1232     if (gp->gp_cv) {
1233         /* Deleting the name of a subroutine invalidates method cache */
1234         PL_sub_generation++;
1235     }
1236     if (--gp->gp_refcnt > 0) {
1237         if (gp->gp_egv == gv)
1238             gp->gp_egv = 0;
1239         return;
1240     }
1241
1242     SvREFCNT_dec(gp->gp_sv);
1243     SvREFCNT_dec(gp->gp_av);
1244     if(gp->gp_hv && HvNAME(gp->gp_hv) && PL_stashcache)
1245         hv_delete(PL_stashcache, HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)), G_DISCARD);
1246     SvREFCNT_dec(gp->gp_hv);
1247     SvREFCNT_dec(gp->gp_io);
1248     SvREFCNT_dec(gp->gp_cv);
1249     SvREFCNT_dec(gp->gp_form);
1250
1251     Safefree(gp);
1252     GvGP(gv) = 0;
1253 }
1254
1255 int
1256 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1257 {
1258     AMT *amtp = (AMT*)mg->mg_ptr;
1259     if (amtp && AMT_AMAGIC(amtp)) {
1260         int i;
1261         for (i = 1; i < NofAMmeth; i++) {
1262             CV *cv = amtp->table[i];
1263             if (cv != Nullcv) {
1264                 SvREFCNT_dec((SV *) cv);
1265                 amtp->table[i] = Nullcv;
1266             }
1267         }
1268     }
1269  return 0;
1270 }
1271
1272 /* Updates and caches the CV's */
1273
1274 bool
1275 Perl_Gv_AMupdate(pTHX_ HV *stash)
1276 {
1277   GV* gv;
1278   CV* cv;
1279   MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
1280   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1281   AMT amt;
1282
1283   if (mg && amtp->was_ok_am == PL_amagic_generation
1284       && amtp->was_ok_sub == PL_sub_generation)
1285       return (bool)AMT_OVERLOADED(amtp);
1286   sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1287
1288   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1289
1290   Zero(&amt,1,AMT);
1291   amt.was_ok_am = PL_amagic_generation;
1292   amt.was_ok_sub = PL_sub_generation;
1293   amt.fallback = AMGfallNO;
1294   amt.flags = 0;
1295
1296   {
1297     int filled = 0, have_ovl = 0;
1298     int i, lim = 1;
1299     SV* sv = NULL;
1300
1301     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1302
1303     /* Try to find via inheritance. */
1304     gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1305     if (gv)
1306         sv = GvSV(gv);
1307
1308     if (!gv)
1309         lim = DESTROY_amg;              /* Skip overloading entries. */
1310     else if (SvTRUE(sv))
1311         amt.fallback=AMGfallYES;
1312     else if (SvOK(sv))
1313         amt.fallback=AMGfallNEVER;
1314
1315     for (i = 1; i < lim; i++)
1316         amt.table[i] = Nullcv;
1317     for (; i < NofAMmeth; i++) {
1318         char *cooky = (char*)PL_AMG_names[i];
1319         /* Human-readable form, for debugging: */
1320         char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1321         STRLEN l = strlen(cooky);
1322
1323         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1324                      cp, HvNAME(stash)) );
1325         /* don't fill the cache while looking up!
1326            Creation of inheritance stubs in intermediate packages may
1327            conflict with the logic of runtime method substitution.
1328            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1329            then we could have created stubs for "(+0" in A and C too.
1330            But if B overloads "bool", we may want to use it for
1331            numifying instead of C's "+0". */
1332         if (i >= DESTROY_amg)
1333             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1334         else                            /* Autoload taken care of below */
1335             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1336         cv = 0;
1337         if (gv && (cv = GvCV(gv))) {
1338             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1339                 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1340                 /* This is a hack to support autoloading..., while
1341                    knowing *which* methods were declared as overloaded. */
1342                 /* GvSV contains the name of the method. */
1343                 GV *ngv = Nullgv;
1344
1345                 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256"SVf"' for overloaded `%s' in package `%.256s'\n",
1346                              GvSV(gv), cp, HvNAME(stash)) );
1347                 if (!SvPOK(GvSV(gv))
1348                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1349                                                        FALSE)))
1350                 {
1351                     /* Can be an import stub (created by `can'). */
1352                     SV *gvsv = GvSV(gv);
1353                     const char *name = SvPOK(gvsv) ?  SvPVX(gvsv) : "???";
1354                     Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' in package `%.256s'",
1355                                (GvCVGEN(gv) ? "Stub found while resolving"
1356                                 : "Can't resolve"),
1357                                name, cp, HvNAME(stash));
1358                 }
1359                 cv = GvCV(gv = ngv);
1360             }
1361             DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1362                          cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1363                          GvNAME(CvGV(cv))) );
1364             filled = 1;
1365             if (i < DESTROY_amg)
1366                 have_ovl = 1;
1367         } else if (gv) {                /* Autoloaded... */
1368             cv = (CV*)gv;
1369             filled = 1;
1370         }
1371         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1372     }
1373     if (filled) {
1374       AMT_AMAGIC_on(&amt);
1375       if (have_ovl)
1376           AMT_OVERLOADED_on(&amt);
1377       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1378                                                 (char*)&amt, sizeof(AMT));
1379       return have_ovl;
1380     }
1381   }
1382   /* Here we have no table: */
1383   /* no_table: */
1384   AMT_AMAGIC_off(&amt);
1385   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1386                                                 (char*)&amt, sizeof(AMTS));
1387   return FALSE;
1388 }
1389
1390
1391 CV*
1392 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1393 {
1394     MAGIC *mg;
1395     AMT *amtp;
1396     CV *ret;
1397
1398     if (!stash)
1399         return Nullcv;
1400     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1401     if (!mg) {
1402       do_update:
1403         Gv_AMupdate(stash);
1404         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1405     }
1406     amtp = (AMT*)mg->mg_ptr;
1407     if ( amtp->was_ok_am != PL_amagic_generation
1408          || amtp->was_ok_sub != PL_sub_generation )
1409         goto do_update;
1410     if (AMT_AMAGIC(amtp)) {
1411         ret = amtp->table[id];
1412         if (ret && isGV(ret)) {         /* Autoloading stab */
1413             /* Passing it through may have resulted in a warning
1414                "Inherited AUTOLOAD for a non-method deprecated", since
1415                our caller is going through a function call, not a method call.
1416                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1417             GV *gv = gv_fetchmethod(stash, (char*)PL_AMG_names[id]);
1418
1419             if (gv && GvCV(gv))
1420                 return GvCV(gv);
1421         }
1422         return ret;
1423     }
1424
1425     return Nullcv;
1426 }
1427
1428
1429 SV*
1430 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1431 {
1432   MAGIC *mg;
1433   CV *cv=NULL;
1434   CV **cvp=NULL, **ocvp=NULL;
1435   AMT *amtp=NULL, *oamtp=NULL;
1436   int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1437   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1438 #ifdef DEBUGGING
1439   int fl=0;
1440 #endif
1441   HV* stash=NULL;
1442   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1443       && (stash = SvSTASH(SvRV(left)))
1444       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1445       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1446                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1447                         : (CV **) NULL))
1448       && ((cv = cvp[off=method+assignshift])
1449           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1450                                                           * usual method */
1451                   (
1452 #ifdef DEBUGGING
1453                    fl = 1,
1454 #endif
1455                    cv = cvp[off=method])))) {
1456     lr = -1;                    /* Call method for left argument */
1457   } else {
1458     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1459       int logic;
1460
1461       /* look for substituted methods */
1462       /* In all the covered cases we should be called with assign==0. */
1463          switch (method) {
1464          case inc_amg:
1465            force_cpy = 1;
1466            if ((cv = cvp[off=add_ass_amg])
1467                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1468              right = &PL_sv_yes; lr = -1; assign = 1;
1469            }
1470            break;
1471          case dec_amg:
1472            force_cpy = 1;
1473            if ((cv = cvp[off = subtr_ass_amg])
1474                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1475              right = &PL_sv_yes; lr = -1; assign = 1;
1476            }
1477            break;
1478          case bool__amg:
1479            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1480            break;
1481          case numer_amg:
1482            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1483            break;
1484          case string_amg:
1485            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1486            break;
1487  case not_amg:
1488    (void)((cv = cvp[off=bool__amg])
1489           || (cv = cvp[off=numer_amg])
1490           || (cv = cvp[off=string_amg]));
1491    postpr = 1;
1492    break;
1493          case copy_amg:
1494            {
1495              /*
1496                   * SV* ref causes confusion with the interpreter variable of
1497                   * the same name
1498                   */
1499              SV* tmpRef=SvRV(left);
1500              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1501                 /*
1502                  * Just to be extra cautious.  Maybe in some
1503                  * additional cases sv_setsv is safe, too.
1504                  */
1505                 SV* newref = newSVsv(tmpRef);
1506                 SvOBJECT_on(newref);
1507                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1508                 return newref;
1509              }
1510            }
1511            break;
1512          case abs_amg:
1513            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1514                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1515              SV* nullsv=sv_2mortal(newSViv(0));
1516              if (off1==lt_amg) {
1517                SV* lessp = amagic_call(left,nullsv,
1518                                        lt_amg,AMGf_noright);
1519                logic = SvTRUE(lessp);
1520              } else {
1521                SV* lessp = amagic_call(left,nullsv,
1522                                        ncmp_amg,AMGf_noright);
1523                logic = (SvNV(lessp) < 0);
1524              }
1525              if (logic) {
1526                if (off==subtr_amg) {
1527                  right = left;
1528                  left = nullsv;
1529                  lr = 1;
1530                }
1531              } else {
1532                return left;
1533              }
1534            }
1535            break;
1536          case neg_amg:
1537            if ((cv = cvp[off=subtr_amg])) {
1538              right = left;
1539              left = sv_2mortal(newSViv(0));
1540              lr = 1;
1541            }
1542            break;
1543          case int_amg:
1544          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1545              /* FAIL safe */
1546              return NULL;       /* Delegate operation to standard mechanisms. */
1547              break;
1548          case to_sv_amg:
1549          case to_av_amg:
1550          case to_hv_amg:
1551          case to_gv_amg:
1552          case to_cv_amg:
1553              /* FAIL safe */
1554              return left;       /* Delegate operation to standard mechanisms. */
1555              break;
1556          default:
1557            goto not_found;
1558          }
1559          if (!cv) goto not_found;
1560     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1561                && (stash = SvSTASH(SvRV(right)))
1562                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1563                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1564                           ? (amtp = (AMT*)mg->mg_ptr)->table
1565                           : (CV **) NULL))
1566                && (cv = cvp[off=method])) { /* Method for right
1567                                              * argument found */
1568       lr=1;
1569     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1570                  && (cvp=ocvp) && (lr = -1))
1571                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1572                && !(flags & AMGf_unary)) {
1573                                 /* We look for substitution for
1574                                  * comparison operations and
1575                                  * concatenation */
1576       if (method==concat_amg || method==concat_ass_amg
1577           || method==repeat_amg || method==repeat_ass_amg) {
1578         return NULL;            /* Delegate operation to string conversion */
1579       }
1580       off = -1;
1581       switch (method) {
1582          case lt_amg:
1583          case le_amg:
1584          case gt_amg:
1585          case ge_amg:
1586          case eq_amg:
1587          case ne_amg:
1588            postpr = 1; off=ncmp_amg; break;
1589          case slt_amg:
1590          case sle_amg:
1591          case sgt_amg:
1592          case sge_amg:
1593          case seq_amg:
1594          case sne_amg:
1595            postpr = 1; off=scmp_amg; break;
1596          }
1597       if (off != -1) cv = cvp[off];
1598       if (!cv) {
1599         goto not_found;
1600       }
1601     } else {
1602     not_found:                  /* No method found, either report or croak */
1603       switch (method) {
1604          case to_sv_amg:
1605          case to_av_amg:
1606          case to_hv_amg:
1607          case to_gv_amg:
1608          case to_cv_amg:
1609              /* FAIL safe */
1610              return left;       /* Delegate operation to standard mechanisms. */
1611              break;
1612       }
1613       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1614         notfound = 1; lr = -1;
1615       } else if (cvp && (cv=cvp[nomethod_amg])) {
1616         notfound = 1; lr = 1;
1617       } else {
1618         SV *msg;
1619         if (off==-1) off=method;
1620         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1621                       "Operation `%s': no method found,%sargument %s%s%s%s",
1622                       AMG_id2name(method + assignshift),
1623                       (flags & AMGf_unary ? " " : "\n\tleft "),
1624                       SvAMAGIC(left)?
1625                         "in overloaded package ":
1626                         "has no overloaded magic",
1627                       SvAMAGIC(left)?
1628                         HvNAME(SvSTASH(SvRV(left))):
1629                         "",
1630                       SvAMAGIC(right)?
1631                         ",\n\tright argument in overloaded package ":
1632                         (flags & AMGf_unary
1633                          ? ""
1634                          : ",\n\tright argument has no overloaded magic"),
1635                       SvAMAGIC(right)?
1636                         HvNAME(SvSTASH(SvRV(right))):
1637                         ""));
1638         if (amtp && amtp->fallback >= AMGfallYES) {
1639           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1640         } else {
1641           Perl_croak(aTHX_ "%"SVf, msg);
1642         }
1643         return NULL;
1644       }
1645       force_cpy = force_cpy || assign;
1646     }
1647   }
1648 #ifdef DEBUGGING
1649   if (!notfound) {
1650     DEBUG_o(Perl_deb(aTHX_
1651                      "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1652                      AMG_id2name(off),
1653                      method+assignshift==off? "" :
1654                      " (initially `",
1655                      method+assignshift==off? "" :
1656                      AMG_id2name(method+assignshift),
1657                      method+assignshift==off? "" : "')",
1658                      flags & AMGf_unary? "" :
1659                      lr==1 ? " for right argument": " for left argument",
1660                      flags & AMGf_unary? " for argument" : "",
1661                      stash ? HvNAME(stash) : "null",
1662                      fl? ",\n\tassignment variant used": "") );
1663   }
1664 #endif
1665     /* Since we use shallow copy during assignment, we need
1666      * to dublicate the contents, probably calling user-supplied
1667      * version of copy operator
1668      */
1669     /* We need to copy in following cases:
1670      * a) Assignment form was called.
1671      *          assignshift==1,  assign==T, method + 1 == off
1672      * b) Increment or decrement, called directly.
1673      *          assignshift==0,  assign==0, method + 0 == off
1674      * c) Increment or decrement, translated to assignment add/subtr.
1675      *          assignshift==0,  assign==T,
1676      *          force_cpy == T
1677      * d) Increment or decrement, translated to nomethod.
1678      *          assignshift==0,  assign==0,
1679      *          force_cpy == T
1680      * e) Assignment form translated to nomethod.
1681      *          assignshift==1,  assign==T, method + 1 != off
1682      *          force_cpy == T
1683      */
1684     /*  off is method, method+assignshift, or a result of opcode substitution.
1685      *  In the latter case assignshift==0, so only notfound case is important.
1686      */
1687   if (( (method + assignshift == off)
1688         && (assign || (method == inc_amg) || (method == dec_amg)))
1689       || force_cpy)
1690     RvDEEPCP(left);
1691   {
1692     dSP;
1693     BINOP myop;
1694     SV* res;
1695     bool oldcatch = CATCH_GET;
1696
1697     CATCH_SET(TRUE);
1698     Zero(&myop, 1, BINOP);
1699     myop.op_last = (OP *) &myop;
1700     myop.op_next = Nullop;
1701     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1702
1703     PUSHSTACKi(PERLSI_OVERLOAD);
1704     ENTER;
1705     SAVEOP();
1706     PL_op = (OP *) &myop;
1707     if (PERLDB_SUB && PL_curstash != PL_debstash)
1708         PL_op->op_private |= OPpENTERSUB_DB;
1709     PUTBACK;
1710     pp_pushmark();
1711
1712     EXTEND(SP, notfound + 5);
1713     PUSHs(lr>0? right: left);
1714     PUSHs(lr>0? left: right);
1715     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1716     if (notfound) {
1717       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1718     }
1719     PUSHs((SV*)cv);
1720     PUTBACK;
1721
1722     if ((PL_op = Perl_pp_entersub(aTHX)))
1723       CALLRUNOPS(aTHX);
1724     LEAVE;
1725     SPAGAIN;
1726
1727     res=POPs;
1728     PUTBACK;
1729     POPSTACK;
1730     CATCH_SET(oldcatch);
1731
1732     if (postpr) {
1733       int ans=0;
1734       switch (method) {
1735       case le_amg:
1736       case sle_amg:
1737         ans=SvIV(res)<=0; break;
1738       case lt_amg:
1739       case slt_amg:
1740         ans=SvIV(res)<0; break;
1741       case ge_amg:
1742       case sge_amg:
1743         ans=SvIV(res)>=0; break;
1744       case gt_amg:
1745       case sgt_amg:
1746         ans=SvIV(res)>0; break;
1747       case eq_amg:
1748       case seq_amg:
1749         ans=SvIV(res)==0; break;
1750       case ne_amg:
1751       case sne_amg:
1752         ans=SvIV(res)!=0; break;
1753       case inc_amg:
1754       case dec_amg:
1755         SvSetSV(left,res); return left;
1756       case not_amg:
1757         ans=!SvTRUE(res); break;
1758       }
1759       return boolSV(ans);
1760     } else if (method==copy_amg) {
1761       if (!SvROK(res)) {
1762         Perl_croak(aTHX_ "Copy method did not return a reference");
1763       }
1764       return SvREFCNT_inc(SvRV(res));
1765     } else {
1766       return res;
1767     }
1768   }
1769 }
1770
1771 /*
1772 =for apidoc is_gv_magical
1773
1774 Returns C<TRUE> if given the name of a magical GV.
1775
1776 Currently only useful internally when determining if a GV should be
1777 created even in rvalue contexts.
1778
1779 C<flags> is not used at present but available for future extension to
1780 allow selecting particular classes of magical variable.
1781
1782 =cut
1783 */
1784 bool
1785 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1786 {
1787     if (!len)
1788         return FALSE;
1789
1790     switch (*name) {
1791     case 'I':
1792         if (len == 3 && strEQ(name, "ISA"))
1793             goto yes;
1794         break;
1795     case 'O':
1796         if (len == 8 && strEQ(name, "OVERLOAD"))
1797             goto yes;
1798         break;
1799     case 'S':
1800         if (len == 3 && strEQ(name, "SIG"))
1801             goto yes;
1802         break;
1803     case '\017':   /* $^O & $^OPEN */
1804         if (len == 1
1805             || (len == 4 && strEQ(name, "\017PEN")))
1806         {
1807             goto yes;
1808         }
1809         break;
1810     case '\025':
1811         if (len > 1 && strEQ(name, "\025NICODE"))
1812             goto yes;
1813     case '\027':   /* $^W & $^WARNING_BITS */
1814         if (len == 1
1815             || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1816             )
1817         {
1818             goto yes;
1819         }
1820         break;
1821
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 ';':
1847     case ']':
1848     case '\001':   /* $^A */
1849     case '\003':   /* $^C */
1850     case '\004':   /* $^D */
1851     case '\005':   /* $^E */
1852     case '\006':   /* $^F */
1853     case '\010':   /* $^H */
1854     case '\011':   /* $^I, NOT \t in EBCDIC */
1855     case '\014':   /* $^L */
1856     case '\016':   /* $^N */
1857     case '\020':   /* $^P */
1858     case '\023':   /* $^S */
1859     case '\026':   /* $^V */
1860         if (len == 1)
1861             goto yes;
1862         break;
1863     case '\024':   /* $^T, ${^TAINT} */
1864         if (len == 1 || strEQ(name, "\024AINT"))
1865             goto yes;
1866         break;
1867     case '1':
1868     case '2':
1869     case '3':
1870     case '4':
1871     case '5':
1872     case '6':
1873     case '7':
1874     case '8':
1875     case '9':
1876         if (len > 1) {
1877             char *end = name + len;
1878             while (--end > name) {
1879                 if (!isDIGIT(*end))
1880                     return FALSE;
1881             }
1882         }
1883     yes:
1884         return TRUE;
1885     default:
1886         break;
1887     }
1888     return FALSE;
1889 }