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