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