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