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