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