gv.c

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