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     unshare_hek(gp->gp_file_hek);
1446     SvREFCNT_dec(gp->gp_sv);
1447     SvREFCNT_dec(gp->gp_av);
1448     /* FIXME - another reference loop GV -> symtab -> GV ?
1449        Somehow gp->gp_hv can end up pointing at freed garbage.  */
1450     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1451         const char *hvname = HvNAME_get(gp->gp_hv);
1452         if (PL_stashcache && hvname)
1453             hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1454                       G_DISCARD);
1455         SvREFCNT_dec(gp->gp_hv);
1456     }
1457     SvREFCNT_dec(gp->gp_io);
1458     SvREFCNT_dec(gp->gp_cv);
1459     SvREFCNT_dec(gp->gp_form);
1460
1461     Safefree(gp);
1462     GvGP(gv) = 0;
1463 }
1464
1465 int
1466 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1467 {
1468     AMT * const amtp = (AMT*)mg->mg_ptr;
1469     PERL_UNUSED_ARG(sv);
1470
1471     if (amtp && AMT_AMAGIC(amtp)) {
1472         int i;
1473         for (i = 1; i < NofAMmeth; i++) {
1474             CV * const cv = amtp->table[i];
1475             if (cv) {
1476                 SvREFCNT_dec((SV *) cv);
1477                 amtp->table[i] = NULL;
1478             }
1479         }
1480     }
1481  return 0;
1482 }
1483
1484 /* Updates and caches the CV's */
1485
1486 bool
1487 Perl_Gv_AMupdate(pTHX_ HV *stash)
1488 {
1489   dVAR;
1490   MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1491   AMT amt;
1492
1493   if (mg) {
1494       const AMT * const amtp = (AMT*)mg->mg_ptr;
1495       if (amtp->was_ok_am == PL_amagic_generation
1496           && amtp->was_ok_sub == PL_sub_generation) {
1497           return (bool)AMT_OVERLOADED(amtp);
1498       }
1499       sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1500   }
1501
1502   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1503
1504   Zero(&amt,1,AMT);
1505   amt.was_ok_am = PL_amagic_generation;
1506   amt.was_ok_sub = PL_sub_generation;
1507   amt.fallback = AMGfallNO;
1508   amt.flags = 0;
1509
1510   {
1511     int filled = 0, have_ovl = 0;
1512     int i, lim = 1;
1513
1514     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1515
1516     /* Try to find via inheritance. */
1517     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1518     SV * const sv = gv ? GvSV(gv) : NULL;
1519     CV* cv;
1520
1521     if (!gv)
1522         lim = DESTROY_amg;              /* Skip overloading entries. */
1523 #ifdef PERL_DONT_CREATE_GVSV
1524     else if (!sv) {
1525         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
1526     }
1527 #endif
1528     else if (SvTRUE(sv))
1529         amt.fallback=AMGfallYES;
1530     else if (SvOK(sv))
1531         amt.fallback=AMGfallNEVER;
1532
1533     for (i = 1; i < lim; i++)
1534         amt.table[i] = NULL;
1535     for (; i < NofAMmeth; i++) {
1536         const char * const cooky = PL_AMG_names[i];
1537         /* Human-readable form, for debugging: */
1538         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1539         const STRLEN l = strlen(cooky);
1540
1541         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1542                      cp, HvNAME_get(stash)) );
1543         /* don't fill the cache while looking up!
1544            Creation of inheritance stubs in intermediate packages may
1545            conflict with the logic of runtime method substitution.
1546            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1547            then we could have created stubs for "(+0" in A and C too.
1548            But if B overloads "bool", we may want to use it for
1549            numifying instead of C's "+0". */
1550         if (i >= DESTROY_amg)
1551             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1552         else                            /* Autoload taken care of below */
1553             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1554         cv = 0;
1555         if (gv && (cv = GvCV(gv))) {
1556             const char *hvname;
1557             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1558                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1559                 /* This is a hack to support autoloading..., while
1560                    knowing *which* methods were declared as overloaded. */
1561                 /* GvSV contains the name of the method. */
1562                 GV *ngv = NULL;
1563                 SV *gvsv = GvSV(gv);
1564
1565                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1566                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1567                              (void*)GvSV(gv), cp, hvname) );
1568                 if (!gvsv || !SvPOK(gvsv)
1569                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1570                                                        FALSE)))
1571                 {
1572                     /* Can be an import stub (created by "can"). */
1573                     const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
1574                     Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1575                                 "in package \"%.256s\"",
1576                                (GvCVGEN(gv) ? "Stub found while resolving"
1577                                 : "Can't resolve"),
1578                                name, cp, hvname);
1579                 }
1580                 cv = GvCV(gv = ngv);
1581             }
1582             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1583                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1584                          GvNAME(CvGV(cv))) );
1585             filled = 1;
1586             if (i < DESTROY_amg)
1587                 have_ovl = 1;
1588         } else if (gv) {                /* Autoloaded... */
1589             cv = (CV*)gv;
1590             filled = 1;
1591         }
1592         amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
1593     }
1594     if (filled) {
1595       AMT_AMAGIC_on(&amt);
1596       if (have_ovl)
1597           AMT_OVERLOADED_on(&amt);
1598       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1599                                                 (char*)&amt, sizeof(AMT));
1600       return have_ovl;
1601     }
1602   }
1603   /* Here we have no table: */
1604   /* no_table: */
1605   AMT_AMAGIC_off(&amt);
1606   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1607                                                 (char*)&amt, sizeof(AMTS));
1608   return FALSE;
1609 }
1610
1611
1612 CV*
1613 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1614 {
1615     dVAR;
1616     MAGIC *mg;
1617     AMT *amtp;
1618
1619     if (!stash || !HvNAME_get(stash))
1620         return NULL;
1621     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1622     if (!mg) {
1623       do_update:
1624         Gv_AMupdate(stash);
1625         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1626     }
1627     assert(mg);
1628     amtp = (AMT*)mg->mg_ptr;
1629     if ( amtp->was_ok_am != PL_amagic_generation
1630          || amtp->was_ok_sub != PL_sub_generation )
1631         goto do_update;
1632     if (AMT_AMAGIC(amtp)) {
1633         CV * const ret = amtp->table[id];
1634         if (ret && isGV(ret)) {         /* Autoloading stab */
1635             /* Passing it through may have resulted in a warning
1636                "Inherited AUTOLOAD for a non-method deprecated", since
1637                our caller is going through a function call, not a method call.
1638                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1639             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1640
1641             if (gv && GvCV(gv))
1642                 return GvCV(gv);
1643         }
1644         return ret;
1645     }
1646
1647     return NULL;
1648 }
1649
1650
1651 SV*
1652 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1653 {
1654   dVAR;
1655   MAGIC *mg;
1656   CV *cv=NULL;
1657   CV **cvp=NULL, **ocvp=NULL;
1658   AMT *amtp=NULL, *oamtp=NULL;
1659   int off = 0, off1, lr = 0, notfound = 0;
1660   int postpr = 0, force_cpy = 0;
1661   int assign = AMGf_assign & flags;
1662   const int assignshift = assign ? 1 : 0;
1663 #ifdef DEBUGGING
1664   int fl=0;
1665 #endif
1666   HV* stash=NULL;
1667   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1668       && (stash = SvSTASH(SvRV(left)))
1669       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1670       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1671                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1672                         : NULL))
1673       && ((cv = cvp[off=method+assignshift])
1674           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1675                                                           * usual method */
1676                   (
1677 #ifdef DEBUGGING
1678                    fl = 1,
1679 #endif
1680                    cv = cvp[off=method])))) {
1681     lr = -1;                    /* Call method for left argument */
1682   } else {
1683     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1684       int logic;
1685
1686       /* look for substituted methods */
1687       /* In all the covered cases we should be called with assign==0. */
1688          switch (method) {
1689          case inc_amg:
1690            force_cpy = 1;
1691            if ((cv = cvp[off=add_ass_amg])
1692                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1693              right = &PL_sv_yes; lr = -1; assign = 1;
1694            }
1695            break;
1696          case dec_amg:
1697            force_cpy = 1;
1698            if ((cv = cvp[off = subtr_ass_amg])
1699                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1700              right = &PL_sv_yes; lr = -1; assign = 1;
1701            }
1702            break;
1703          case bool__amg:
1704            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1705            break;
1706          case numer_amg:
1707            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1708            break;
1709          case string_amg:
1710            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1711            break;
1712          case not_amg:
1713            (void)((cv = cvp[off=bool__amg])
1714                   || (cv = cvp[off=numer_amg])
1715                   || (cv = cvp[off=string_amg]));
1716            postpr = 1;
1717            break;
1718          case copy_amg:
1719            {
1720              /*
1721                   * SV* ref causes confusion with the interpreter variable of
1722                   * the same name
1723                   */
1724              SV* const tmpRef=SvRV(left);
1725              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1726                 /*
1727                  * Just to be extra cautious.  Maybe in some
1728                  * additional cases sv_setsv is safe, too.
1729                  */
1730                 SV* const newref = newSVsv(tmpRef);
1731                 SvOBJECT_on(newref);
1732                 /* As a bit of a source compatibility hack, SvAMAGIC() and
1733                    friends dereference an RV, to behave the same was as when
1734                    overloading was stored on the reference, not the referant.
1735                    Hence we can't use SvAMAGIC_on()
1736                 */
1737                 SvFLAGS(newref) |= SVf_AMAGIC;
1738                 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1739                 return newref;
1740              }
1741            }
1742            break;
1743          case abs_amg:
1744            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1745                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1746              SV* const nullsv=sv_2mortal(newSViv(0));
1747              if (off1==lt_amg) {
1748                SV* const lessp = amagic_call(left,nullsv,
1749                                        lt_amg,AMGf_noright);
1750                logic = SvTRUE(lessp);
1751              } else {
1752                SV* const lessp = amagic_call(left,nullsv,
1753                                        ncmp_amg,AMGf_noright);
1754                logic = (SvNV(lessp) < 0);
1755              }
1756              if (logic) {
1757                if (off==subtr_amg) {
1758                  right = left;
1759                  left = nullsv;
1760                  lr = 1;
1761                }
1762              } else {
1763                return left;
1764              }
1765            }
1766            break;
1767          case neg_amg:
1768            if ((cv = cvp[off=subtr_amg])) {
1769              right = left;
1770              left = sv_2mortal(newSViv(0));
1771              lr = 1;
1772            }
1773            break;
1774          case int_amg:
1775          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1776              /* FAIL safe */
1777              return NULL;       /* Delegate operation to standard mechanisms. */
1778              break;
1779          case to_sv_amg:
1780          case to_av_amg:
1781          case to_hv_amg:
1782          case to_gv_amg:
1783          case to_cv_amg:
1784              /* FAIL safe */
1785              return left;       /* Delegate operation to standard mechanisms. */
1786              break;
1787          default:
1788            goto not_found;
1789          }
1790          if (!cv) goto not_found;
1791     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1792                && (stash = SvSTASH(SvRV(right)))
1793                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1794                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1795                           ? (amtp = (AMT*)mg->mg_ptr)->table
1796                           : NULL))
1797                && (cv = cvp[off=method])) { /* Method for right
1798                                              * argument found */
1799       lr=1;
1800     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1801                  && (cvp=ocvp) && (lr = -1))
1802                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1803                && !(flags & AMGf_unary)) {
1804                                 /* We look for substitution for
1805                                  * comparison operations and
1806                                  * concatenation */
1807       if (method==concat_amg || method==concat_ass_amg
1808           || method==repeat_amg || method==repeat_ass_amg) {
1809         return NULL;            /* Delegate operation to string conversion */
1810       }
1811       off = -1;
1812       switch (method) {
1813          case lt_amg:
1814          case le_amg:
1815          case gt_amg:
1816          case ge_amg:
1817          case eq_amg:
1818          case ne_amg:
1819            postpr = 1; off=ncmp_amg; break;
1820          case slt_amg:
1821          case sle_amg:
1822          case sgt_amg:
1823          case sge_amg:
1824          case seq_amg:
1825          case sne_amg:
1826            postpr = 1; off=scmp_amg; break;
1827          }
1828       if (off != -1) cv = cvp[off];
1829       if (!cv) {
1830         goto not_found;
1831       }
1832     } else {
1833     not_found:                  /* No method found, either report or croak */
1834       switch (method) {
1835          case to_sv_amg:
1836          case to_av_amg:
1837          case to_hv_amg:
1838          case to_gv_amg:
1839          case to_cv_amg:
1840              /* FAIL safe */
1841              return left;       /* Delegate operation to standard mechanisms. */
1842              break;
1843       }
1844       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1845         notfound = 1; lr = -1;
1846       } else if (cvp && (cv=cvp[nomethod_amg])) {
1847         notfound = 1; lr = 1;
1848       } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
1849         /* Skip generating the "no method found" message.  */
1850         return NULL;
1851       } else {
1852         SV *msg;
1853         if (off==-1) off=method;
1854         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1855                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
1856                       AMG_id2name(method + assignshift),
1857                       (flags & AMGf_unary ? " " : "\n\tleft "),
1858                       SvAMAGIC(left)?
1859                         "in overloaded package ":
1860                         "has no overloaded magic",
1861                       SvAMAGIC(left)?
1862                         HvNAME_get(SvSTASH(SvRV(left))):
1863                         "",
1864                       SvAMAGIC(right)?
1865                         ",\n\tright argument in overloaded package ":
1866                         (flags & AMGf_unary
1867                          ? ""
1868                          : ",\n\tright argument has no overloaded magic"),
1869                       SvAMAGIC(right)?
1870                         HvNAME_get(SvSTASH(SvRV(right))):
1871                         ""));
1872         if (amtp && amtp->fallback >= AMGfallYES) {
1873           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1874         } else {
1875           Perl_croak(aTHX_ "%"SVf, (void*)msg);
1876         }
1877         return NULL;
1878       }
1879       force_cpy = force_cpy || assign;
1880     }
1881   }
1882 #ifdef DEBUGGING
1883   if (!notfound) {
1884     DEBUG_o(Perl_deb(aTHX_
1885                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1886                      AMG_id2name(off),
1887                      method+assignshift==off? "" :
1888                      " (initially \"",
1889                      method+assignshift==off? "" :
1890                      AMG_id2name(method+assignshift),
1891                      method+assignshift==off? "" : "\")",
1892                      flags & AMGf_unary? "" :
1893                      lr==1 ? " for right argument": " for left argument",
1894                      flags & AMGf_unary? " for argument" : "",
1895                      stash ? HvNAME_get(stash) : "null",
1896                      fl? ",\n\tassignment variant used": "") );
1897   }
1898 #endif
1899     /* Since we use shallow copy during assignment, we need
1900      * to dublicate the contents, probably calling user-supplied
1901      * version of copy operator
1902      */
1903     /* We need to copy in following cases:
1904      * a) Assignment form was called.
1905      *          assignshift==1,  assign==T, method + 1 == off
1906      * b) Increment or decrement, called directly.
1907      *          assignshift==0,  assign==0, method + 0 == off
1908      * c) Increment or decrement, translated to assignment add/subtr.
1909      *          assignshift==0,  assign==T,
1910      *          force_cpy == T
1911      * d) Increment or decrement, translated to nomethod.
1912      *          assignshift==0,  assign==0,
1913      *          force_cpy == T
1914      * e) Assignment form translated to nomethod.
1915      *          assignshift==1,  assign==T, method + 1 != off
1916      *          force_cpy == T
1917      */
1918     /*  off is method, method+assignshift, or a result of opcode substitution.
1919      *  In the latter case assignshift==0, so only notfound case is important.
1920      */
1921   if (( (method + assignshift == off)
1922         && (assign || (method == inc_amg) || (method == dec_amg)))
1923       || force_cpy)
1924     RvDEEPCP(left);
1925   {
1926     dSP;
1927     BINOP myop;
1928     SV* res;
1929     const bool oldcatch = CATCH_GET;
1930
1931     CATCH_SET(TRUE);
1932     Zero(&myop, 1, BINOP);
1933     myop.op_last = (OP *) &myop;
1934     myop.op_next = NULL;
1935     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1936
1937     PUSHSTACKi(PERLSI_OVERLOAD);
1938     ENTER;
1939     SAVEOP();
1940     PL_op = (OP *) &myop;
1941     if (PERLDB_SUB && PL_curstash != PL_debstash)
1942         PL_op->op_private |= OPpENTERSUB_DB;
1943     PUTBACK;
1944     pp_pushmark();
1945
1946     EXTEND(SP, notfound + 5);
1947     PUSHs(lr>0? right: left);
1948     PUSHs(lr>0? left: right);
1949     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1950     if (notfound) {
1951       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1952     }
1953     PUSHs((SV*)cv);
1954     PUTBACK;
1955
1956     if ((PL_op = Perl_pp_entersub(aTHX)))
1957       CALLRUNOPS(aTHX);
1958     LEAVE;
1959     SPAGAIN;
1960
1961     res=POPs;
1962     PUTBACK;
1963     POPSTACK;
1964     CATCH_SET(oldcatch);
1965
1966     if (postpr) {
1967       int ans;
1968       switch (method) {
1969       case le_amg:
1970       case sle_amg:
1971         ans=SvIV(res)<=0; break;
1972       case lt_amg:
1973       case slt_amg:
1974         ans=SvIV(res)<0; break;
1975       case ge_amg:
1976       case sge_amg:
1977         ans=SvIV(res)>=0; break;
1978       case gt_amg:
1979       case sgt_amg:
1980         ans=SvIV(res)>0; break;
1981       case eq_amg:
1982       case seq_amg:
1983         ans=SvIV(res)==0; break;
1984       case ne_amg:
1985       case sne_amg:
1986         ans=SvIV(res)!=0; break;
1987       case inc_amg:
1988       case dec_amg:
1989         SvSetSV(left,res); return left;
1990       case not_amg:
1991         ans=!SvTRUE(res); break;
1992       default:
1993         ans=0; break;
1994       }
1995       return boolSV(ans);
1996     } else if (method==copy_amg) {
1997       if (!SvROK(res)) {
1998         Perl_croak(aTHX_ "Copy method did not return a reference");
1999       }
2000       return SvREFCNT_inc(SvRV(res));
2001     } else {
2002       return res;
2003     }
2004   }
2005 }
2006
2007 /*
2008 =for apidoc is_gv_magical_sv
2009
2010 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
2011
2012 =cut
2013 */
2014
2015 bool
2016 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
2017 {
2018     STRLEN len;
2019     const char * const temp = SvPV_const(name, len);
2020     return is_gv_magical(temp, len, flags);
2021 }
2022
2023 /*
2024 =for apidoc is_gv_magical
2025
2026 Returns C<TRUE> if given the name of a magical GV.
2027
2028 Currently only useful internally when determining if a GV should be
2029 created even in rvalue contexts.
2030
2031 C<flags> is not used at present but available for future extension to
2032 allow selecting particular classes of magical variable.
2033
2034 Currently assumes that C<name> is NUL terminated (as well as len being valid).
2035 This assumption is met by all callers within the perl core, which all pass
2036 pointers returned by SvPV.
2037
2038 =cut
2039 */
2040 bool
2041 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
2042 {
2043     PERL_UNUSED_CONTEXT;
2044     PERL_UNUSED_ARG(flags);
2045
2046     if (len > 1) {
2047         const char * const name1 = name + 1;
2048         switch (*name) {
2049         case 'I':
2050             if (len == 3 && name1[1] == 'S' && name[2] == 'A')
2051                 goto yes;
2052             break;
2053         case 'O':
2054             if (len == 8 && strEQ(name1, "VERLOAD"))
2055                 goto yes;
2056             break;
2057         case 'S':
2058             if (len == 3 && name[1] == 'I' && name[2] == 'G')
2059                 goto yes;
2060             break;
2061             /* Using ${^...} variables is likely to be sufficiently rare that
2062                it seems sensible to avoid the space hit of also checking the
2063                length.  */
2064         case '\017':   /* ${^OPEN} */
2065             if (strEQ(name1, "PEN"))
2066                 goto yes;
2067             break;
2068         case '\024':   /* ${^TAINT} */
2069             if (strEQ(name1, "AINT"))
2070                 goto yes;
2071             break;
2072         case '\025':    /* ${^UNICODE} */
2073             if (strEQ(name1, "NICODE"))
2074                 goto yes;
2075             if (strEQ(name1, "TF8LOCALE"))
2076                 goto yes;
2077             break;
2078         case '\027':   /* ${^WARNING_BITS} */
2079             if (strEQ(name1, "ARNING_BITS"))
2080                 goto yes;
2081             break;
2082         case '1':
2083         case '2':
2084         case '3':
2085         case '4':
2086         case '5':
2087         case '6':
2088         case '7':
2089         case '8':
2090         case '9':
2091         {
2092             const char *end = name + len;
2093             while (--end > name) {
2094                 if (!isDIGIT(*end))
2095                     return FALSE;
2096             }
2097             goto yes;
2098         }
2099         }
2100     } else {
2101         /* Because we're already assuming that name is NUL terminated
2102            below, we can treat an empty name as "\0"  */
2103         switch (*name) {
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 '\\':
2124         case '/':
2125         case '|':
2126         case '+':
2127         case ';':
2128         case ']':
2129         case '\001':   /* $^A */
2130         case '\003':   /* $^C */
2131         case '\004':   /* $^D */
2132         case '\005':   /* $^E */
2133         case '\006':   /* $^F */
2134         case '\010':   /* $^H */
2135         case '\011':   /* $^I, NOT \t in EBCDIC */
2136         case '\014':   /* $^L */
2137         case '\016':   /* $^N */
2138         case '\017':   /* $^O */
2139         case '\020':   /* $^P */
2140         case '\023':   /* $^S */
2141         case '\024':   /* $^T */
2142         case '\026':   /* $^V */
2143         case '\027':   /* $^W */
2144         case '1':
2145         case '2':
2146         case '3':
2147         case '4':
2148         case '5':
2149         case '6':
2150         case '7':
2151         case '8':
2152         case '9':
2153         yes:
2154             return TRUE;
2155         default:
2156             break;
2157         }
2158     }
2159     return FALSE;
2160 }
2161
2162 void
2163 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2164 {
2165     dVAR;
2166     U32 hash;
2167
2168     assert(name);
2169     PERL_UNUSED_ARG(flags);
2170
2171     if (len > I32_MAX)
2172         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2173
2174     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2175         unshare_hek(GvNAME_HEK(gv));
2176     }
2177
2178     PERL_HASH(hash, name, len);
2179     GvNAME_HEK(gv) = share_hek(name, len, hash);
2180 }
2181
2182 /*
2183  * Local variables:
2184  * c-indentation-style: bsd
2185  * c-basic-offset: 4
2186  * indent-tabs-mode: t
2187  * End:
2188  *
2189  * ex: set ts=8 sts=4 sw=4 noet:
2190  */