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