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->gv_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", FALSE)))
 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, TRUE);
 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, FALSE);
 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", FALSE);
 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), TRUE);
 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, FALSE);
 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, FALSE))
 556               stash = gv_stashpvn(origname, nsplit - origname, TRUE);
 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, FALSE);
 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, FALSE);
 698         if (!stash)
 699             Perl_croak( aTHX_ "panic: Can't use %%%s because %"SVf" is not available",
 700                 varpv, 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, 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.  C<name> should
 712 be a valid UTF-8 string and must be null-terminated.  If C<create> is set
 713 then the package will be created if it does not already exist.  If C<create>
 714 is not set and the package does not exist then NULL is returned.
 715
 716 =cut
 717 */
 718
 719 HV*
 720 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
 721 {
 722     return gv_stashpvn(name, strlen(name), create);
 723 }
 724
 725 /*
 726 =for apidoc gv_stashpvn
 727
 728 Returns a pointer to the stash for a specified package.  C<name> should
 729 be a valid UTF-8 string.  The C<namelen> parameter indicates the length of
 730 the C<name>, in bytes.  If C<create> is set then the package will be
 731 created if it does not already exist.  If C<create> is not set and the
 732 package does not exist then NULL is returned.
 733
 734 =cut
 735 */
 736
 737 HV*
 738 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
 739 {
 740     char smallbuf[128];
 741     char *tmpbuf;
 742     HV *stash;
 743     GV *tmpgv;
 744
 745     if (namelen + 3 < sizeof smallbuf)
 746         tmpbuf = smallbuf;
 747     else
 748         Newx(tmpbuf, namelen + 3, char);
 749     Copy(name,tmpbuf,namelen,char);
 750     tmpbuf[namelen++] = ':';
 751     tmpbuf[namelen++] = ':';
 752     tmpbuf[namelen] = '\0';
 753     tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, create, SVt_PVHV);
 754     if (tmpbuf != smallbuf)
 755         Safefree(tmpbuf);
 756     if (!tmpgv)
 757         return 0;
 758     if (!GvHV(tmpgv))
 759         GvHV(tmpgv) = newHV();
 760     stash = GvHV(tmpgv);
 761     if (!HvNAME_get(stash))
 762         hv_name_set(stash, name, namelen, 0);
 763     return stash;
 764 }
 765
 766 /*
 767 =for apidoc gv_stashsv
 768
 769 Returns a pointer to the stash for a specified package, which must be a
 770 valid UTF-8 string.  See C<gv_stashpv>.
 771
 772 =cut
 773 */
 774
 775 HV*
 776 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
 777 {
 778     STRLEN len;
 779     const char * const ptr = SvPV_const(sv,len);
 780     return gv_stashpvn(ptr, len, create);
 781 }
 782
 783
 784 GV *
 785 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
 786     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
 787 }
 788
 789 GV *
 790 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
 791     STRLEN len;
 792     const char * const nambeg = SvPV_const(name, len);
 793     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
 794 }
 795
 796 GV *
 797 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 798                        I32 sv_type)
 799 {
 800     dVAR;
 801     register const char *name = nambeg;
 802     register GV *gv = NULL;
 803     GV**gvp;
 804     I32 len;
 805     register const char *name_cursor;
 806     HV *stash = NULL;
 807     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
 808     const I32 no_expand = flags & GV_NOEXPAND;
 809     const I32 add =
 810         flags & ~SVf_UTF8 & ~GV_NOADD_NOINIT & ~GV_NOEXPAND & ~GV_NOTQUAL;
 811     const char *const name_end = nambeg + full_len;
 812     const char *const name_em1 = name_end - 1;
 813
 814     if (flags & GV_NOTQUAL) {
 815         /* Caller promised that there is no stash, so we can skip the check. */
 816         len = full_len;
 817         goto no_stash;
 818     }
 819
 820     if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
 821         /* accidental stringify on a GV? */
 822         name++;
 823     }
 824
 825     for (name_cursor = name; name_cursor < name_end; name_cursor++) {
 826         if ((*name_cursor == ':' && name_cursor < name_em1
 827              && name_cursor[1] == ':')
 828             || (*name_cursor == '\'' && name_cursor[1]))
 829         {
 830             if (!stash)
 831                 stash = PL_defstash;
 832             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
 833                 return NULL;
 834
 835             len = name_cursor - name;
 836             if (len > 0) {
 837                 char smallbuf[128];
 838                 char *tmpbuf;
 839
 840                 if (len + 3 < (I32)sizeof (smallbuf))
 841                     tmpbuf = smallbuf;
 842                 else
 843                     Newx(tmpbuf, len+3, char);
 844                 Copy(name, tmpbuf, len, char);
 845                 tmpbuf[len++] = ':';
 846                 tmpbuf[len++] = ':';
 847                 tmpbuf[len] = '\0';
 848                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
 849                 gv = gvp ? *gvp : NULL;
 850                 if (gv && gv != (GV*)&PL_sv_undef) {
 851                     if (SvTYPE(gv) != SVt_PVGV)
 852                         gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
 853                     else
 854                         GvMULTI_on(gv);
 855                 }
 856                 if (tmpbuf != smallbuf)
 857                     Safefree(tmpbuf);
 858                 if (!gv || gv == (GV*)&PL_sv_undef)
 859                     return NULL;
 860
 861                 if (!(stash = GvHV(gv)))
 862                     stash = GvHV(gv) = newHV();
 863
 864                 if (!HvNAME_get(stash))
 865                     hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
 866             }
 867
 868             if (*name_cursor == ':')
 869                 name_cursor++;
 870             name_cursor++;
 871             name = name_cursor;
 872             if (name == name_end)
 873                 return gv ? gv : (GV*)*hv_fetchs(PL_defstash, "main::", TRUE);
 874         }
 875     }
 876     len = name_cursor - name;
 877
 878     /* No stash in name, so see how we can default */
 879
 880     if (!stash) {
 881     no_stash:
 882         if (len && isIDFIRST_lazy(name)) {
 883             bool global = FALSE;
 884
 885             switch (len) {
 886             case 1:
 887                 if (*name == '_')
 888                     global = TRUE;
 889                 break;
 890             case 3:
 891                 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
 892                     || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
 893                     || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
 894                     global = TRUE;
 895                 break;
 896             case 4:
 897                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
 898                     && name[3] == 'V')
 899                     global = TRUE;
 900                 break;
 901             case 5:
 902                 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
 903                     && name[3] == 'I' && name[4] == 'N')
 904                     global = TRUE;
 905                 break;
 906             case 6:
 907                 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
 908                     &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
 909                        ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
 910                     global = TRUE;
 911                 break;
 912             case 7:
 913                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
 914                     && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
 915                     && name[6] == 'T')
 916                     global = TRUE;
 917                 break;
 918             }
 919
 920             if (global)
 921                 stash = PL_defstash;
 922             else if (IN_PERL_COMPILETIME) {
 923                 stash = PL_curstash;
 924                 if (add && (PL_hints & HINT_STRICT_VARS) &&
 925                     sv_type != SVt_PVCV &&
 926                     sv_type != SVt_PVGV &&
 927                     sv_type != SVt_PVFM &&
 928                     sv_type != SVt_PVIO &&
 929                     !(len == 1 && sv_type == SVt_PV &&
 930                       (*name == 'a' || *name == 'b')) )
 931                 {
 932                     gvp = (GV**)hv_fetch(stash,name,len,0);
 933                     if (!gvp ||
 934                         *gvp == (GV*)&PL_sv_undef ||
 935                         SvTYPE(*gvp) != SVt_PVGV)
 936                     {
 937                         stash = NULL;
 938                     }
 939                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
 940                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
 941                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
 942                     {
 943                         Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
 944                             sv_type == SVt_PVAV ? '@' :
 945                             sv_type == SVt_PVHV ? '%' : '$',
 946                             name);
 947                         if (GvCVu(*gvp))
 948                             Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
 949                         stash = NULL;
 950                     }
 951                 }
 952             }
 953             else
 954                 stash = CopSTASH(PL_curcop);
 955         }
 956         else
 957             stash = PL_defstash;
 958     }
 959
 960     /* By this point we should have a stash and a name */
 961
 962     if (!stash) {
 963         if (add) {
 964             SV * const err = Perl_mess(aTHX_
 965                  "Global symbol \"%s%s\" requires explicit package name",
 966                  (sv_type == SVt_PV ? "$"
 967                   : sv_type == SVt_PVAV ? "@"
 968                   : sv_type == SVt_PVHV ? "%"
 969                   : ""), name);
 970             GV *gv;
 971             if (USE_UTF8_IN_NAMES)
 972                 SvUTF8_on(err);
 973             qerror(err);
 974             gv = gv_fetchpvn_flags("<none>::", 8, GV_ADDMULTI, SVt_PVHV);
 975             if(!gv) {
 976                 /* symbol table under destruction */
 977                 return NULL;
 978             }
 979             stash = GvHV(gv);
 980         }
 981         else
 982             return NULL;
 983     }
 984
 985     if (!SvREFCNT(stash))       /* symbol table under destruction */
 986         return NULL;
 987
 988     gvp = (GV**)hv_fetch(stash,name,len,add);
 989     if (!gvp || *gvp == (GV*)&PL_sv_undef)
 990         return NULL;
 991     gv = *gvp;
 992     if (SvTYPE(gv) == SVt_PVGV) {
 993         if (add) {
 994             GvMULTI_on(gv);
 995             gv_init_sv(gv, sv_type);
 996             if (sv_type == SVt_PVHV && len == 1 ) {
 997                 if (*name == '!')
 998                     require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
 999                 else
1000                 if (*name == '-' || *name == '+')
1001                      require_tie_mod(gv, name, newSVpvs("re::Tie::Hash::NamedCapture"), "FETCH", 0);
1002
1003             }
1004         }
1005         return gv;
1006     } else if (no_init) {
1007         return gv;
1008     } else if (no_expand && SvROK(gv)) {
1009         return gv;
1010     }
1011
1012     /* Adding a new symbol */
1013
1014     if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
1015         Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
1016     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
1017     gv_init_sv(gv, sv_type);
1018
1019     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
1020                                             : (PL_dowarn & G_WARN_ON ) ) )
1021         GvMULTI_on(gv) ;
1022
1023     /* set up magic where warranted */
1024     if (len > 1) {
1025 #ifndef EBCDIC
1026         if (*name > 'V' ) {
1027             NOOP;
1028             /* Nothing else to do.
1029                The compiler will probably turn the switch statement into a
1030                branch table. Make sure we avoid even that small overhead for
1031                the common case of lower case variable names.  */
1032         } else
1033 #endif
1034         {
1035             const char * const name2 = name + 1;
1036             switch (*name) {
1037             case 'A':
1038                 if (strEQ(name2, "RGV")) {
1039                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1040                 }
1041                 else if (strEQ(name2, "RGVOUT")) {
1042                     GvMULTI_on(gv);
1043                 }
1044                 break;
1045             case 'E':
1046                 if (strnEQ(name2, "XPORT", 5))
1047                     GvMULTI_on(gv);
1048                 break;
1049             case 'I':
1050                 if (strEQ(name2, "SA")) {
1051                     AV* const av = GvAVn(gv);
1052                     GvMULTI_on(gv);
1053                     sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, NULL, 0);
1054                     /* NOTE: No support for tied ISA */
1055                     if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
1056                         && AvFILLp(av) == -1)
1057                         {
1058                             const char *pname;
1059                             av_push(av, newSVpvn(pname = "NDBM_File",9));
1060                             gv_stashpvn(pname, 9, TRUE);
1061                             av_push(av, newSVpvn(pname = "DB_File",7));
1062                             gv_stashpvn(pname, 7, TRUE);
1063                             av_push(av, newSVpvn(pname = "GDBM_File",9));
1064                             gv_stashpvn(pname, 9, TRUE);
1065                             av_push(av, newSVpvn(pname = "SDBM_File",9));
1066                             gv_stashpvn(pname, 9, TRUE);
1067                             av_push(av, newSVpvn(pname = "ODBM_File",9));
1068                             gv_stashpvn(pname, 9, TRUE);
1069                         }
1070                 }
1071                 break;
1072             case 'O':
1073                 if (strEQ(name2, "VERLOAD")) {
1074                     HV* const hv = GvHVn(gv);
1075                     GvMULTI_on(gv);
1076                     hv_magic(hv, NULL, PERL_MAGIC_overload);
1077                 }
1078                 break;
1079             case 'S':
1080                 if (strEQ(name2, "IG")) {
1081                     HV *hv;
1082                     I32 i;
1083                     if (!PL_psig_ptr) {
1084                         Newxz(PL_psig_ptr,  SIG_SIZE, SV*);
1085                         Newxz(PL_psig_name, SIG_SIZE, SV*);
1086                         Newxz(PL_psig_pend, SIG_SIZE, int);
1087                     }
1088                     GvMULTI_on(gv);
1089                     hv = GvHVn(gv);
1090                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1091                     for (i = 1; i < SIG_SIZE; i++) {
1092                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1093                         if (init)
1094                             sv_setsv(*init, &PL_sv_undef);
1095                         PL_psig_ptr[i] = 0;
1096                         PL_psig_name[i] = 0;
1097                         PL_psig_pend[i] = 0;
1098                     }
1099                 }
1100                 break;
1101             case 'V':
1102                 if (strEQ(name2, "ERSION"))
1103                     GvMULTI_on(gv);
1104                 break;
1105             case '\003':        /* $^CHILD_ERROR_NATIVE */
1106                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1107                     goto magicalize;
1108                 break;
1109             case '\005':        /* $^ENCODING */
1110                 if (strEQ(name2, "NCODING"))
1111                     goto magicalize;
1112                 break;
1113             case '\017':        /* $^OPEN */
1114                 if (strEQ(name2, "PEN"))
1115                     goto magicalize;
1116                 break;
1117             case '\024':        /* ${^TAINT} */
1118                 if (strEQ(name2, "AINT"))
1119                     goto ro_magicalize;
1120                 break;
1121             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1122                 if (strEQ(name2, "NICODE"))
1123                     goto ro_magicalize;
1124                 if (strEQ(name2, "TF8LOCALE"))
1125                     goto ro_magicalize;
1126                 if (strEQ(name2, "TF8CACHE"))
1127                     goto magicalize;
1128                 break;
1129             case '\027':        /* $^WARNING_BITS */
1130                 if (strEQ(name2, "ARNING_BITS"))
1131                     goto magicalize;
1132                 break;
1133             case '1':
1134             case '2':
1135             case '3':
1136             case '4':
1137             case '5':
1138             case '6':
1139             case '7':
1140             case '8':
1141             case '9':
1142             {
1143                 /* ensures variable is only digits */
1144                 /* ${"1foo"} fails this test (and is thus writeable) */
1145                 /* added by japhy, but borrowed from is_gv_magical */
1146                 const char *end = name + len;
1147                 while (--end > name) {
1148                     if (!isDIGIT(*end)) return gv;
1149                 }
1150                 goto ro_magicalize;
1151             }
1152             }
1153         }
1154     } else {
1155         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1156            be case '\0' in this switch statement (ie a default case)  */
1157         switch (*name) {
1158         case '&':
1159         case '`':
1160         case '\'':
1161             if (
1162                 sv_type == SVt_PVAV ||
1163                 sv_type == SVt_PVHV ||
1164                 sv_type == SVt_PVCV ||
1165                 sv_type == SVt_PVFM ||
1166                 sv_type == SVt_PVIO
1167                 ) { break; }
1168             PL_sawampersand = TRUE;
1169             goto ro_magicalize;
1170
1171         case ':':
1172             sv_setpv(GvSVn(gv),PL_chopset);
1173             goto magicalize;
1174
1175         case '?':
1176 #ifdef COMPLEX_STATUS
1177             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1178 #endif
1179             goto magicalize;
1180
1181         case '!':
1182         GvMULTI_on(gv);
1183             /* If %! has been used, automatically load Errno.pm. */
1184
1185             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1186
1187             /* magicalization must be done before require_tie_mod is called */
1188             if (sv_type == SVt_PVHV)
1189                 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1190
1191             break;
1192         case '-':
1193         case '+':
1194         GvMULTI_on(gv); /* no used once warnings here */
1195         {
1196             bool plus = (*name == '+');
1197             SV *stashname = newSVpvs("re::Tie::Hash::NamedCapture");
1198             AV* const av = GvAVn(gv);
1199             HV *const hv = GvHVn(gv);
1200             HV *const hv_tie = newHV();
1201             SV *tie = newRV_noinc((SV*)hv_tie);
1202
1203             sv_bless(tie, gv_stashsv(stashname,1));
1204             hv_magic(hv, (GV*)tie, PERL_MAGIC_tied);
1205             sv_magic((SV*)av, (plus ? (SV*)av : NULL), PERL_MAGIC_regdata, NULL, 0);
1206             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1207
1208             if (plus)
1209                 SvREADONLY_on(GvSVn(gv));
1210             else
1211                 Perl_hv_store(aTHX_ hv_tie, STR_WITH_LEN("all"), newSViv(1), 0);
1212
1213             SvREADONLY_on(hv);
1214             SvREADONLY_on(tie);
1215             SvREADONLY_on(av);
1216
1217             if (sv_type == SVt_PVHV)
1218                 require_tie_mod(gv, name, stashname, "FETCH", 0);
1219
1220             break;
1221         }
1222         case '*':
1223         case '#':
1224             if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1225                 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1226                             "$%c is no longer supported", *name);
1227             break;
1228         case '|':
1229             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1230             goto magicalize;
1231
1232         case '\010':    /* $^H */
1233             {
1234                 HV *const hv = GvHVn(gv);
1235                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1236             }
1237             goto magicalize;
1238         case '\023':    /* $^S */
1239         case '1':
1240         case '2':
1241         case '3':
1242         case '4':
1243         case '5':
1244         case '6':
1245         case '7':
1246         case '8':
1247         case '9':
1248         ro_magicalize:
1249             SvREADONLY_on(GvSVn(gv));
1250             /* FALL THROUGH */
1251         case '[':
1252         case '^':
1253         case '~':
1254         case '=':
1255         case '%':
1256         case '.':
1257         case '(':
1258         case ')':
1259         case '<':
1260         case '>':
1261         case ',':
1262         case '\\':
1263         case '/':
1264         case '\001':    /* $^A */
1265         case '\003':    /* $^C */
1266         case '\004':    /* $^D */
1267         case '\005':    /* $^E */
1268         case '\006':    /* $^F */
1269         case '\011':    /* $^I, NOT \t in EBCDIC */
1270         case '\016':    /* $^N */
1271         case '\017':    /* $^O */
1272         case '\020':    /* $^P */
1273         case '\024':    /* $^T */
1274         case '\027':    /* $^W */
1275         magicalize:
1276             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1277             break;
1278
1279         case '\014':    /* $^L */
1280             sv_setpvn(GvSVn(gv),"\f",1);
1281             PL_formfeed = GvSVn(gv);
1282             break;
1283         case ';':
1284             sv_setpvn(GvSVn(gv),"\034",1);
1285             break;
1286         case ']':
1287         {
1288             SV * const sv = GvSVn(gv);
1289             if (!sv_derived_from(PL_patchlevel, "version"))
1290                 upg_version(PL_patchlevel);
1291             GvSV(gv) = vnumify(PL_patchlevel);
1292             SvREADONLY_on(GvSV(gv));
1293             SvREFCNT_dec(sv);
1294         }
1295         break;
1296         case '\026':    /* $^V */
1297         {
1298             SV * const sv = GvSVn(gv);
1299             GvSV(gv) = new_version(PL_patchlevel);
1300             SvREADONLY_on(GvSV(gv));
1301             SvREFCNT_dec(sv);
1302         }
1303         break;
1304         }
1305     }
1306     return gv;
1307 }
1308
1309 void
1310 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1311 {
1312     const char *name;
1313     STRLEN namelen;
1314     const HV * const hv = GvSTASH(gv);
1315     if (!hv) {
1316         SvOK_off(sv);
1317         return;
1318     }
1319     sv_setpv(sv, prefix ? prefix : "");
1320
1321     name = HvNAME_get(hv);
1322     if (name) {
1323         namelen = HvNAMELEN_get(hv);
1324     } else {
1325         name = "__ANON__";
1326         namelen = 8;
1327     }
1328
1329     if (keepmain || strNE(name, "main")) {
1330         sv_catpvn(sv,name,namelen);
1331         sv_catpvs(sv,"::");
1332     }
1333     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1334 }
1335
1336 void
1337 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1338 {
1339     const GV * const egv = GvEGV(gv);
1340     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1341 }
1342
1343 IO *
1344 Perl_newIO(pTHX)
1345 {
1346     dVAR;
1347     GV *iogv;
1348     IO * const io = (IO*)newSV(0);
1349
1350     sv_upgrade((SV *)io,SVt_PVIO);
1351     /* This used to read SvREFCNT(io) = 1;
1352        It's not clear why the reference count needed an explicit reset. NWC
1353     */
1354     assert (SvREFCNT(io) == 1);
1355     SvOBJECT_on(io);
1356     /* Clear the stashcache because a new IO could overrule a package name */
1357     hv_clear(PL_stashcache);
1358     iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
1359     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1360     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1361       iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
1362     SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1363     return io;
1364 }
1365
1366 void
1367 Perl_gv_check(pTHX_ const HV *stash)
1368 {
1369     dVAR;
1370     register I32 i;
1371
1372     if (!HvARRAY(stash))
1373         return;
1374     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1375         const HE *entry;
1376         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1377             register GV *gv;
1378             HV *hv;
1379             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1380                 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1381             {
1382                 if (hv != PL_defstash && hv != stash)
1383                      gv_check(hv);              /* nested package */
1384             }
1385             else if (isALPHA(*HeKEY(entry))) {
1386                 const char *file;
1387                 gv = (GV*)HeVAL(entry);
1388                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1389                     continue;
1390                 file = GvFILE(gv);
1391                 /* performance hack: if filename is absolute and it's a standard
1392                  * module, don't bother warning */
1393 #ifdef MACOS_TRADITIONAL
1394 #   define LIB_COMPONENT ":lib:"
1395 #else
1396 #   define LIB_COMPONENT "/lib/"
1397 #endif
1398                 if (file
1399                     && PERL_FILE_IS_ABSOLUTE(file)
1400                     && (instr(file, LIB_COMPONENT) || instr(file, ".pm")))
1401                 {
1402                     continue;
1403                 }
1404                 CopLINE_set(PL_curcop, GvLINE(gv));
1405 #ifdef USE_ITHREADS
1406                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1407 #else
1408                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1409 #endif
1410                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1411                         "Name \"%s::%s\" used only once: possible typo",
1412                         HvNAME_get(stash), GvNAME(gv));
1413             }
1414         }
1415     }
1416 }
1417
1418 GV *
1419 Perl_newGVgen(pTHX_ const char *pack)
1420 {
1421     dVAR;
1422     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1423                       GV_ADD, SVt_PVGV);
1424 }
1425
1426 /* hopefully this is only called on local symbol table entries */
1427
1428 GP*
1429 Perl_gp_ref(pTHX_ GP *gp)
1430 {
1431     dVAR;
1432     if (!gp)
1433         return NULL;
1434     gp->gp_refcnt++;
1435     if (gp->gp_cv) {
1436         if (gp->gp_cvgen) {
1437             /* multi-named GPs cannot be used for method cache */
1438             SvREFCNT_dec(gp->gp_cv);
1439             gp->gp_cv = NULL;
1440             gp->gp_cvgen = 0;
1441         }
1442         else {
1443             /* Adding a new name to a subroutine invalidates method cache */
1444             PL_sub_generation++;
1445         }
1446     }
1447     return gp;
1448 }
1449
1450 void
1451 Perl_gp_free(pTHX_ GV *gv)
1452 {
1453     dVAR;
1454     GP* gp;
1455
1456     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1457         return;
1458     if (gp->gp_refcnt == 0) {
1459         if (ckWARN_d(WARN_INTERNAL))
1460             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1461                         "Attempt to free unreferenced glob pointers"
1462                         pTHX__FORMAT pTHX__VALUE);
1463         return;
1464     }
1465     if (gp->gp_cv) {
1466         /* Deleting the name of a subroutine invalidates method cache */
1467         PL_sub_generation++;
1468     }
1469     if (--gp->gp_refcnt > 0) {
1470         if (gp->gp_egv == gv)
1471             gp->gp_egv = 0;
1472         GvGP(gv) = 0;
1473         return;
1474     }
1475
1476     if (gp->gp_file_hek)
1477         unshare_hek(gp->gp_file_hek);
1478     SvREFCNT_dec(gp->gp_sv);
1479     SvREFCNT_dec(gp->gp_av);
1480     /* FIXME - another reference loop GV -> symtab -> GV ?
1481        Somehow gp->gp_hv can end up pointing at freed garbage.  */
1482     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1483         const char *hvname = HvNAME_get(gp->gp_hv);
1484         if (PL_stashcache && hvname)
1485             hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1486                       G_DISCARD);
1487         SvREFCNT_dec(gp->gp_hv);
1488     }
1489     SvREFCNT_dec(gp->gp_io);
1490     SvREFCNT_dec(gp->gp_cv);
1491     SvREFCNT_dec(gp->gp_form);
1492
1493     Safefree(gp);
1494     GvGP(gv) = 0;
1495 }
1496
1497 int
1498 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1499 {
1500     AMT * const amtp = (AMT*)mg->mg_ptr;
1501     PERL_UNUSED_ARG(sv);
1502
1503     if (amtp && AMT_AMAGIC(amtp)) {
1504         int i;
1505         for (i = 1; i < NofAMmeth; i++) {
1506             CV * const cv = amtp->table[i];
1507             if (cv) {
1508                 SvREFCNT_dec((SV *) cv);
1509                 amtp->table[i] = NULL;
1510             }
1511         }
1512     }
1513  return 0;
1514 }
1515
1516 /* Updates and caches the CV's */
1517
1518 bool
1519 Perl_Gv_AMupdate(pTHX_ HV *stash)
1520 {
1521   dVAR;
1522   MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1523   AMT amt;
1524
1525   if (mg) {
1526       const AMT * const amtp = (AMT*)mg->mg_ptr;
1527       if (amtp->was_ok_am == PL_amagic_generation
1528           && amtp->was_ok_sub == PL_sub_generation) {
1529           return (bool)AMT_OVERLOADED(amtp);
1530       }
1531       sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1532   }
1533
1534   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1535
1536   Zero(&amt,1,AMT);
1537   amt.was_ok_am = PL_amagic_generation;
1538   amt.was_ok_sub = PL_sub_generation;
1539   amt.fallback = AMGfallNO;
1540   amt.flags = 0;
1541
1542   {
1543     int filled = 0, have_ovl = 0;
1544     int i, lim = 1;
1545
1546     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1547
1548     /* Try to find via inheritance. */
1549     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1550     SV * const sv = gv ? GvSV(gv) : NULL;
1551     CV* cv;
1552
1553     if (!gv)
1554         lim = DESTROY_amg;              /* Skip overloading entries. */
1555 #ifdef PERL_DONT_CREATE_GVSV
1556     else if (!sv) {
1557         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
1558     }
1559 #endif
1560     else if (SvTRUE(sv))
1561         amt.fallback=AMGfallYES;
1562     else if (SvOK(sv))
1563         amt.fallback=AMGfallNEVER;
1564
1565     for (i = 1; i < lim; i++)
1566         amt.table[i] = NULL;
1567     for (; i < NofAMmeth; i++) {
1568         const char * const cooky = PL_AMG_names[i];
1569         /* Human-readable form, for debugging: */
1570         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1571         const STRLEN l = strlen(cooky);
1572
1573         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1574                      cp, HvNAME_get(stash)) );
1575         /* don't fill the cache while looking up!
1576            Creation of inheritance stubs in intermediate packages may
1577            conflict with the logic of runtime method substitution.
1578            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1579            then we could have created stubs for "(+0" in A and C too.
1580            But if B overloads "bool", we may want to use it for
1581            numifying instead of C's "+0". */
1582         if (i >= DESTROY_amg)
1583             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1584         else                            /* Autoload taken care of below */
1585             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1586         cv = 0;
1587         if (gv && (cv = GvCV(gv))) {
1588             const char *hvname;
1589             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1590                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1591                 /* This is a hack to support autoloading..., while
1592                    knowing *which* methods were declared as overloaded. */
1593                 /* GvSV contains the name of the method. */
1594                 GV *ngv = NULL;
1595                 SV *gvsv = GvSV(gv);
1596
1597                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1598                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1599                              (void*)GvSV(gv), cp, hvname) );
1600                 if (!gvsv || !SvPOK(gvsv)
1601                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1602                                                        FALSE)))
1603                 {
1604                     /* Can be an import stub (created by "can"). */
1605                     const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
1606                     Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1607                                 "in package \"%.256s\"",
1608                                (GvCVGEN(gv) ? "Stub found while resolving"
1609                                 : "Can't resolve"),
1610                                name, cp, hvname);
1611                 }
1612                 cv = GvCV(gv = ngv);
1613             }
1614             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1615                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1616                          GvNAME(CvGV(cv))) );
1617             filled = 1;
1618             if (i < DESTROY_amg)
1619                 have_ovl = 1;
1620         } else if (gv) {                /* Autoloaded... */
1621             cv = (CV*)gv;
1622             filled = 1;
1623         }
1624         amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
1625     }
1626     if (filled) {
1627       AMT_AMAGIC_on(&amt);
1628       if (have_ovl)
1629           AMT_OVERLOADED_on(&amt);
1630       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1631                                                 (char*)&amt, sizeof(AMT));
1632       return have_ovl;
1633     }
1634   }
1635   /* Here we have no table: */
1636   /* no_table: */
1637   AMT_AMAGIC_off(&amt);
1638   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1639                                                 (char*)&amt, sizeof(AMTS));
1640   return FALSE;
1641 }
1642
1643
1644 CV*
1645 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1646 {
1647     dVAR;
1648     MAGIC *mg;
1649     AMT *amtp;
1650
1651     if (!stash || !HvNAME_get(stash))
1652         return NULL;
1653     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1654     if (!mg) {
1655       do_update:
1656         Gv_AMupdate(stash);
1657         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1658     }
1659     assert(mg);
1660     amtp = (AMT*)mg->mg_ptr;
1661     if ( amtp->was_ok_am != PL_amagic_generation
1662          || amtp->was_ok_sub != PL_sub_generation )
1663         goto do_update;
1664     if (AMT_AMAGIC(amtp)) {
1665         CV * const ret = amtp->table[id];
1666         if (ret && isGV(ret)) {         /* Autoloading stab */
1667             /* Passing it through may have resulted in a warning
1668                "Inherited AUTOLOAD for a non-method deprecated", since
1669                our caller is going through a function call, not a method call.
1670                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1671             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1672
1673             if (gv && GvCV(gv))
1674                 return GvCV(gv);
1675         }
1676         return ret;
1677     }
1678
1679     return NULL;
1680 }
1681
1682
1683 SV*
1684 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1685 {
1686   dVAR;
1687   MAGIC *mg;
1688   CV *cv=NULL;
1689   CV **cvp=NULL, **ocvp=NULL;
1690   AMT *amtp=NULL, *oamtp=NULL;
1691   int off = 0, off1, lr = 0, notfound = 0;
1692   int postpr = 0, force_cpy = 0;
1693   int assign = AMGf_assign & flags;
1694   const int assignshift = assign ? 1 : 0;
1695 #ifdef DEBUGGING
1696   int fl=0;
1697 #endif
1698   HV* stash=NULL;
1699   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1700       && (stash = SvSTASH(SvRV(left)))
1701       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1702       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1703                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1704                         : NULL))
1705       && ((cv = cvp[off=method+assignshift])
1706           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1707                                                           * usual method */
1708                   (
1709 #ifdef DEBUGGING
1710                    fl = 1,
1711 #endif
1712                    cv = cvp[off=method])))) {
1713     lr = -1;                    /* Call method for left argument */
1714   } else {
1715     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1716       int logic;
1717
1718       /* look for substituted methods */
1719       /* In all the covered cases we should be called with assign==0. */
1720          switch (method) {
1721          case inc_amg:
1722            force_cpy = 1;
1723            if ((cv = cvp[off=add_ass_amg])
1724                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1725              right = &PL_sv_yes; lr = -1; assign = 1;
1726            }
1727            break;
1728          case dec_amg:
1729            force_cpy = 1;
1730            if ((cv = cvp[off = subtr_ass_amg])
1731                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1732              right = &PL_sv_yes; lr = -1; assign = 1;
1733            }
1734            break;
1735          case bool__amg:
1736            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1737            break;
1738          case numer_amg:
1739            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1740            break;
1741          case string_amg:
1742            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1743            break;
1744          case not_amg:
1745            (void)((cv = cvp[off=bool__amg])
1746                   || (cv = cvp[off=numer_amg])
1747                   || (cv = cvp[off=string_amg]));
1748            postpr = 1;
1749            break;
1750          case copy_amg:
1751            {
1752              /*
1753                   * SV* ref causes confusion with the interpreter variable of
1754                   * the same name
1755                   */
1756              SV* const tmpRef=SvRV(left);
1757              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1758                 /*
1759                  * Just to be extra cautious.  Maybe in some
1760                  * additional cases sv_setsv is safe, too.
1761                  */
1762                 SV* const newref = newSVsv(tmpRef);
1763                 SvOBJECT_on(newref);
1764                 /* As a bit of a source compatibility hack, SvAMAGIC() and
1765                    friends dereference an RV, to behave the same was as when
1766                    overloading was stored on the reference, not the referant.
1767                    Hence we can't use SvAMAGIC_on()
1768                 */
1769                 SvFLAGS(newref) |= SVf_AMAGIC;
1770                 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1771                 return newref;
1772              }
1773            }
1774            break;
1775          case abs_amg:
1776            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1777                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1778              SV* const nullsv=sv_2mortal(newSViv(0));
1779              if (off1==lt_amg) {
1780                SV* const lessp = amagic_call(left,nullsv,
1781                                        lt_amg,AMGf_noright);
1782                logic = SvTRUE(lessp);
1783              } else {
1784                SV* const lessp = amagic_call(left,nullsv,
1785                                        ncmp_amg,AMGf_noright);
1786                logic = (SvNV(lessp) < 0);
1787              }
1788              if (logic) {
1789                if (off==subtr_amg) {
1790                  right = left;
1791                  left = nullsv;
1792                  lr = 1;
1793                }
1794              } else {
1795                return left;
1796              }
1797            }
1798            break;
1799          case neg_amg:
1800            if ((cv = cvp[off=subtr_amg])) {
1801              right = left;
1802              left = sv_2mortal(newSViv(0));
1803              lr = 1;
1804            }
1805            break;
1806          case int_amg:
1807          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1808              /* FAIL safe */
1809              return NULL;       /* Delegate operation to standard mechanisms. */
1810              break;
1811          case to_sv_amg:
1812          case to_av_amg:
1813          case to_hv_amg:
1814          case to_gv_amg:
1815          case to_cv_amg:
1816              /* FAIL safe */
1817              return left;       /* Delegate operation to standard mechanisms. */
1818              break;
1819          default:
1820            goto not_found;
1821          }
1822          if (!cv) goto not_found;
1823     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1824                && (stash = SvSTASH(SvRV(right)))
1825                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1826                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1827                           ? (amtp = (AMT*)mg->mg_ptr)->table
1828                           : NULL))
1829                && (cv = cvp[off=method])) { /* Method for right
1830                                              * argument found */
1831       lr=1;
1832     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1833                  && (cvp=ocvp) && (lr = -1))
1834                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1835                && !(flags & AMGf_unary)) {
1836                                 /* We look for substitution for
1837                                  * comparison operations and
1838                                  * concatenation */
1839       if (method==concat_amg || method==concat_ass_amg
1840           || method==repeat_amg || method==repeat_ass_amg) {
1841         return NULL;            /* Delegate operation to string conversion */
1842       }
1843       off = -1;
1844       switch (method) {
1845          case lt_amg:
1846          case le_amg:
1847          case gt_amg:
1848          case ge_amg:
1849          case eq_amg:
1850          case ne_amg:
1851            postpr = 1; off=ncmp_amg; break;
1852          case slt_amg:
1853          case sle_amg:
1854          case sgt_amg:
1855          case sge_amg:
1856          case seq_amg:
1857          case sne_amg:
1858            postpr = 1; off=scmp_amg; break;
1859          }
1860       if (off != -1) cv = cvp[off];
1861       if (!cv) {
1862         goto not_found;
1863       }
1864     } else {
1865     not_found:                  /* No method found, either report or croak */
1866       switch (method) {
1867          case to_sv_amg:
1868          case to_av_amg:
1869          case to_hv_amg:
1870          case to_gv_amg:
1871          case to_cv_amg:
1872              /* FAIL safe */
1873              return left;       /* Delegate operation to standard mechanisms. */
1874              break;
1875       }
1876       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1877         notfound = 1; lr = -1;
1878       } else if (cvp && (cv=cvp[nomethod_amg])) {
1879         notfound = 1; lr = 1;
1880       } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
1881         /* Skip generating the "no method found" message.  */
1882         return NULL;
1883       } else {
1884         SV *msg;
1885         if (off==-1) off=method;
1886         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1887                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
1888                       AMG_id2name(method + assignshift),
1889                       (flags & AMGf_unary ? " " : "\n\tleft "),
1890                       SvAMAGIC(left)?
1891                         "in overloaded package ":
1892                         "has no overloaded magic",
1893                       SvAMAGIC(left)?
1894                         HvNAME_get(SvSTASH(SvRV(left))):
1895                         "",
1896                       SvAMAGIC(right)?
1897                         ",\n\tright argument in overloaded package ":
1898                         (flags & AMGf_unary
1899                          ? ""
1900                          : ",\n\tright argument has no overloaded magic"),
1901                       SvAMAGIC(right)?
1902                         HvNAME_get(SvSTASH(SvRV(right))):
1903                         ""));
1904         if (amtp && amtp->fallback >= AMGfallYES) {
1905           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1906         } else {
1907           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
1908         }
1909         return NULL;
1910       }
1911       force_cpy = force_cpy || assign;
1912     }
1913   }
1914 #ifdef DEBUGGING
1915   if (!notfound) {
1916     DEBUG_o(Perl_deb(aTHX_
1917                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1918                      AMG_id2name(off),
1919                      method+assignshift==off? "" :
1920                      " (initially \"",
1921                      method+assignshift==off? "" :
1922                      AMG_id2name(method+assignshift),
1923                      method+assignshift==off? "" : "\")",
1924                      flags & AMGf_unary? "" :
1925                      lr==1 ? " for right argument": " for left argument",
1926                      flags & AMGf_unary? " for argument" : "",
1927                      stash ? HvNAME_get(stash) : "null",
1928                      fl? ",\n\tassignment variant used": "") );
1929   }
1930 #endif
1931     /* Since we use shallow copy during assignment, we need
1932      * to dublicate the contents, probably calling user-supplied
1933      * version of copy operator
1934      */
1935     /* We need to copy in following cases:
1936      * a) Assignment form was called.
1937      *          assignshift==1,  assign==T, method + 1 == off
1938      * b) Increment or decrement, called directly.
1939      *          assignshift==0,  assign==0, method + 0 == off
1940      * c) Increment or decrement, translated to assignment add/subtr.
1941      *          assignshift==0,  assign==T,
1942      *          force_cpy == T
1943      * d) Increment or decrement, translated to nomethod.
1944      *          assignshift==0,  assign==0,
1945      *          force_cpy == T
1946      * e) Assignment form translated to nomethod.
1947      *          assignshift==1,  assign==T, method + 1 != off
1948      *          force_cpy == T
1949      */
1950     /*  off is method, method+assignshift, or a result of opcode substitution.
1951      *  In the latter case assignshift==0, so only notfound case is important.
1952      */
1953   if (( (method + assignshift == off)
1954         && (assign || (method == inc_amg) || (method == dec_amg)))
1955       || force_cpy)
1956     RvDEEPCP(left);
1957   {
1958     dSP;
1959     BINOP myop;
1960     SV* res;
1961     const bool oldcatch = CATCH_GET;
1962
1963     CATCH_SET(TRUE);
1964     Zero(&myop, 1, BINOP);
1965     myop.op_last = (OP *) &myop;
1966     myop.op_next = NULL;
1967     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1968
1969     PUSHSTACKi(PERLSI_OVERLOAD);
1970     ENTER;
1971     SAVEOP();
1972     PL_op = (OP *) &myop;
1973     if (PERLDB_SUB && PL_curstash != PL_debstash)
1974         PL_op->op_private |= OPpENTERSUB_DB;
1975     PUTBACK;
1976     pp_pushmark();
1977
1978     EXTEND(SP, notfound + 5);
1979     PUSHs(lr>0? right: left);
1980     PUSHs(lr>0? left: right);
1981     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1982     if (notfound) {
1983       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1984     }
1985     PUSHs((SV*)cv);
1986     PUTBACK;
1987
1988     if ((PL_op = Perl_pp_entersub(aTHX)))
1989       CALLRUNOPS(aTHX);
1990     LEAVE;
1991     SPAGAIN;
1992
1993     res=POPs;
1994     PUTBACK;
1995     POPSTACK;
1996     CATCH_SET(oldcatch);
1997
1998     if (postpr) {
1999       int ans;
2000       switch (method) {
2001       case le_amg:
2002       case sle_amg:
2003         ans=SvIV(res)<=0; break;
2004       case lt_amg:
2005       case slt_amg:
2006         ans=SvIV(res)<0; break;
2007       case ge_amg:
2008       case sge_amg:
2009         ans=SvIV(res)>=0; break;
2010       case gt_amg:
2011       case sgt_amg:
2012         ans=SvIV(res)>0; break;
2013       case eq_amg:
2014       case seq_amg:
2015         ans=SvIV(res)==0; break;
2016       case ne_amg:
2017       case sne_amg:
2018         ans=SvIV(res)!=0; break;
2019       case inc_amg:
2020       case dec_amg:
2021         SvSetSV(left,res); return left;
2022       case not_amg:
2023         ans=!SvTRUE(res); break;
2024       default:
2025         ans=0; break;
2026       }
2027       return boolSV(ans);
2028     } else if (method==copy_amg) {
2029       if (!SvROK(res)) {
2030         Perl_croak(aTHX_ "Copy method did not return a reference");
2031       }
2032       return SvREFCNT_inc(SvRV(res));
2033     } else {
2034       return res;
2035     }
2036   }
2037 }
2038
2039 /*
2040 =for apidoc is_gv_magical_sv
2041
2042 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
2043
2044 =cut
2045 */
2046
2047 bool
2048 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
2049 {
2050     STRLEN len;
2051     const char * const temp = SvPV_const(name, len);
2052     return is_gv_magical(temp, len, flags);
2053 }
2054
2055 /*
2056 =for apidoc is_gv_magical
2057
2058 Returns C<TRUE> if given the name of a magical GV.
2059
2060 Currently only useful internally when determining if a GV should be
2061 created even in rvalue contexts.
2062
2063 C<flags> is not used at present but available for future extension to
2064 allow selecting particular classes of magical variable.
2065
2066 Currently assumes that C<name> is NUL terminated (as well as len being valid).
2067 This assumption is met by all callers within the perl core, which all pass
2068 pointers returned by SvPV.
2069
2070 =cut
2071 */
2072 bool
2073 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
2074 {
2075     PERL_UNUSED_CONTEXT;
2076     PERL_UNUSED_ARG(flags);
2077
2078     if (len > 1) {
2079         const char * const name1 = name + 1;
2080         switch (*name) {
2081         case 'I':
2082             if (len == 3 && name1[1] == 'S' && name[2] == 'A')
2083                 goto yes;
2084             break;
2085         case 'O':
2086             if (len == 8 && strEQ(name1, "VERLOAD"))
2087                 goto yes;
2088             break;
2089         case 'S':
2090             if (len == 3 && name[1] == 'I' && name[2] == 'G')
2091                 goto yes;
2092             break;
2093             /* Using ${^...} variables is likely to be sufficiently rare that
2094                it seems sensible to avoid the space hit of also checking the
2095                length.  */
2096         case '\017':   /* ${^OPEN} */
2097             if (strEQ(name1, "PEN"))
2098                 goto yes;
2099             break;
2100         case '\024':   /* ${^TAINT} */
2101             if (strEQ(name1, "AINT"))
2102                 goto yes;
2103             break;
2104         case '\025':    /* ${^UNICODE} */
2105             if (strEQ(name1, "NICODE"))
2106                 goto yes;
2107             if (strEQ(name1, "TF8LOCALE"))
2108                 goto yes;
2109             break;
2110         case '\027':   /* ${^WARNING_BITS} */
2111             if (strEQ(name1, "ARNING_BITS"))
2112                 goto yes;
2113             break;
2114         case '1':
2115         case '2':
2116         case '3':
2117         case '4':
2118         case '5':
2119         case '6':
2120         case '7':
2121         case '8':
2122         case '9':
2123         {
2124             const char *end = name + len;
2125             while (--end > name) {
2126                 if (!isDIGIT(*end))
2127                     return FALSE;
2128             }
2129             goto yes;
2130         }
2131         }
2132     } else {
2133         /* Because we're already assuming that name is NUL terminated
2134            below, we can treat an empty name as "\0"  */
2135         switch (*name) {
2136         case '&':
2137         case '`':
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 '\001':   /* $^A */
2162         case '\003':   /* $^C */
2163         case '\004':   /* $^D */
2164         case '\005':   /* $^E */
2165         case '\006':   /* $^F */
2166         case '\010':   /* $^H */
2167         case '\011':   /* $^I, NOT \t in EBCDIC */
2168         case '\014':   /* $^L */
2169         case '\016':   /* $^N */
2170         case '\017':   /* $^O */
2171         case '\020':   /* $^P */
2172         case '\023':   /* $^S */
2173         case '\024':   /* $^T */
2174         case '\026':   /* $^V */
2175         case '\027':   /* $^W */
2176         case '1':
2177         case '2':
2178         case '3':
2179         case '4':
2180         case '5':
2181         case '6':
2182         case '7':
2183         case '8':
2184         case '9':
2185         yes:
2186             return TRUE;
2187         default:
2188             break;
2189         }
2190     }
2191     return FALSE;
2192 }
2193
2194 void
2195 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2196 {
2197     dVAR;
2198     U32 hash;
2199
2200     assert(name);
2201     PERL_UNUSED_ARG(flags);
2202
2203     if (len > I32_MAX)
2204         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2205
2206     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2207         unshare_hek(GvNAME_HEK(gv));
2208     }
2209
2210     PERL_HASH(hash, name, len);
2211     GvNAME_HEK(gv) = share_hek(name, len, hash);
2212 }
2213
2214 /*
2215  * Local variables:
2216  * c-indentation-style: bsd
2217  * c-basic-offset: 4
2218  * indent-tabs-mode: t
2219  * End:
2220  *
2221  * ex: set ts=8 sts=4 sw=4 noet:
2222  */