gv.c

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