gv.c

   1 /*    gv.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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 in 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  *     [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"]
  20  */
  21
  22 /*
  23 =head1 GV Functions
  24
  25 A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
  26 It is a structure that holds a pointer to a scalar, an array, a hash etc,
  27 corresponding to $foo, @foo, %foo.
  28
  29 GVs are usually found as values in stashes (symbol table hashes) where
  30 Perl stores its global variables.
  31
  32 =cut
  33 */
  34
  35 #include "EXTERN.h"
  36 #define PERL_IN_GV_C
  37 #include "perl.h"
  38 #include "overload.c"
  39
  40 static const char S_autoload[] = "AUTOLOAD";
  41 static const STRLEN S_autolen = sizeof(S_autoload)-1;
  42
  43 GV *
  44 Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
  45 {
  46     SV **where;
  47
  48     if (
  49         !gv
  50      || (
  51             SvTYPE((const SV *)gv) != SVt_PVGV
  52          && SvTYPE((const SV *)gv) != SVt_PVLV
  53         )
  54     ) {
  55         const char *what;
  56         if (type == SVt_PVIO) {
  57             /*
  58              * if it walks like a dirhandle, then let's assume that
  59              * this is a dirhandle.
  60              */
  61             what = PL_op->op_type ==  OP_READDIR ||
  62                 PL_op->op_type ==  OP_TELLDIR ||
  63                 PL_op->op_type ==  OP_SEEKDIR ||
  64                 PL_op->op_type ==  OP_REWINDDIR ||
  65                 PL_op->op_type ==  OP_CLOSEDIR ?
  66                 "dirhandle" : "filehandle";
  67             /* diag_listed_as: Bad symbol for filehandle */
  68         } else if (type == SVt_PVHV) {
  69             what = "hash";
  70         } else {
  71             what = type == SVt_PVAV ? "array" : "scalar";
  72         }
  73         Perl_croak(aTHX_ "Bad symbol for %s", what);
  74     }
  75
  76     if (type == SVt_PVHV) {
  77         where = (SV **)&GvHV(gv);
  78     } else if (type == SVt_PVAV) {
  79         where = (SV **)&GvAV(gv);
  80     } else if (type == SVt_PVIO) {
  81         where = (SV **)&GvIOp(gv);
  82     } else {
  83         where = &GvSV(gv);
  84     }
  85
  86     if (!*where)
  87         *where = newSV_type(type);
  88     return gv;
  89 }
  90
  91 GV *
  92 Perl_gv_fetchfile(pTHX_ const char *name)
  93 {
  94     PERL_ARGS_ASSERT_GV_FETCHFILE;
  95     return gv_fetchfile_flags(name, strlen(name), 0);
  96 }
  97
  98 GV *
  99 Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen,
 100                         const U32 flags)
 101 {
 102     dVAR;
 103     char smallbuf[128];
 104     char *tmpbuf;
 105     const STRLEN tmplen = namelen + 2;
 106     GV *gv;
 107
 108     PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS;
 109     PERL_UNUSED_ARG(flags);
 110
 111     if (!PL_defstash)
 112         return NULL;
 113
 114     if (tmplen <= sizeof smallbuf)
 115         tmpbuf = smallbuf;
 116     else
 117         Newx(tmpbuf, tmplen, char);
 118     /* This is where the debugger's %{"::_<$filename"} hash is created */
 119     tmpbuf[0] = '_';
 120     tmpbuf[1] = '<';
 121     memcpy(tmpbuf + 2, name, namelen);
 122     gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE);
 123     if (!isGV(gv)) {
 124         gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE);
 125 #ifdef PERL_DONT_CREATE_GVSV
 126         GvSV(gv) = newSVpvn(name, namelen);
 127 #else
 128         sv_setpvn(GvSV(gv), name, namelen);
 129 #endif
 130     }
 131     if ((PERLDB_LINE || PERLDB_SAVESRC) && !GvAV(gv))
 132             hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile);
 133     if (tmpbuf != smallbuf)
 134         Safefree(tmpbuf);
 135     return gv;
 136 }
 137
 138 /*
 139 =for apidoc gv_const_sv
 140
 141 If C<gv> is a typeglob whose subroutine entry is a constant sub eligible for
 142 inlining, or C<gv> is a placeholder reference that would be promoted to such
 143 a typeglob, then returns the value returned by the sub.  Otherwise, returns
 144 NULL.
 145
 146 =cut
 147 */
 148
 149 SV *
 150 Perl_gv_const_sv(pTHX_ GV *gv)
 151 {
 152     PERL_ARGS_ASSERT_GV_CONST_SV;
 153
 154     if (SvTYPE(gv) == SVt_PVGV)
 155         return cv_const_sv(GvCVu(gv));
 156     return SvROK(gv) ? SvRV(gv) : NULL;
 157 }
 158
 159 GP *
 160 Perl_newGP(pTHX_ GV *const gv)
 161 {
 162     GP *gp;
 163     U32 hash;
 164 #ifdef USE_ITHREADS
 165     const char *const file
 166         = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : "";
 167     const STRLEN len = strlen(file);
 168 #else
 169     SV *const temp_sv = CopFILESV(PL_curcop);
 170     const char *file;
 171     STRLEN len;
 172
 173     PERL_ARGS_ASSERT_NEWGP;
 174
 175     if (temp_sv) {
 176         file = SvPVX(temp_sv);
 177         len = SvCUR(temp_sv);
 178     } else {
 179         file = "";
 180         len = 0;
 181     }
 182 #endif
 183
 184     PERL_HASH(hash, file, len);
 185
 186     Newxz(gp, 1, GP);
 187
 188 #ifndef PERL_DONT_CREATE_GVSV
 189     gp->gp_sv = newSV(0);
 190 #endif
 191
 192     gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0;
 193     /* XXX Ideally this cast would be replaced with a change to const char*
 194        in the struct.  */
 195     gp->gp_file_hek = share_hek(file, len, hash);
 196     gp->gp_egv = gv;
 197     gp->gp_refcnt = 1;
 198
 199     return gp;
 200 }
 201
 202 /* Assign CvGV(cv) = gv, handling weak references.
 203  * See also S_anonymise_cv_maybe */
 204
 205 void
 206 Perl_cvgv_set(pTHX_ CV* cv, GV* gv)
 207 {
 208     GV * const oldgv = CvGV(cv);
 209     PERL_ARGS_ASSERT_CVGV_SET;
 210
 211     if (oldgv == gv)
 212         return;
 213
 214     if (oldgv) {
 215         if (CvCVGV_RC(cv)) {
 216             SvREFCNT_dec(oldgv);
 217             CvCVGV_RC_off(cv);
 218         }
 219         else {
 220             sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv));
 221         }
 222     }
 223
 224     SvANY(cv)->xcv_gv = gv;
 225     assert(!CvCVGV_RC(cv));
 226
 227     if (!gv)
 228         return;
 229
 230     if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv))
 231         Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv));
 232     else {
 233         CvCVGV_RC_on(cv);
 234         SvREFCNT_inc_simple_void_NN(gv);
 235     }
 236 }
 237
 238
 239 void
 240 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
 241 {
 242     dVAR;
 243     const U32 old_type = SvTYPE(gv);
 244     const bool doproto = old_type > SVt_NULL;
 245     char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
 246     const STRLEN protolen = proto ? SvCUR(gv) : 0;
 247     SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
 248     const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
 249
 250     PERL_ARGS_ASSERT_GV_INIT;
 251     assert (!(proto && has_constant));
 252
 253     if (has_constant) {
 254         /* The constant has to be a simple scalar type.  */
 255         switch (SvTYPE(has_constant)) {
 256         case SVt_PVAV:
 257         case SVt_PVHV:
 258         case SVt_PVCV:
 259         case SVt_PVFM:
 260         case SVt_PVIO:
 261             Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob",
 262                        sv_reftype(has_constant, 0));
 263         default: NOOP;
 264         }
 265         SvRV_set(gv, NULL);
 266         SvROK_off(gv);
 267     }
 268
 269
 270     if (old_type < SVt_PVGV) {
 271         if (old_type >= SVt_PV)
 272             SvCUR_set(gv, 0);
 273         sv_upgrade(MUTABLE_SV(gv), SVt_PVGV);
 274     }
 275     if (SvLEN(gv)) {
 276         if (proto) {
 277             SvPV_set(gv, NULL);
 278             SvLEN_set(gv, 0);
 279             SvPOK_off(gv);
 280         } else
 281             Safefree(SvPVX_mutable(gv));
 282     }
 283     SvIOK_off(gv);
 284     isGV_with_GP_on(gv);
 285
 286     GvGP(gv) = Perl_newGP(aTHX_ gv);
 287     GvSTASH(gv) = stash;
 288     if (stash)
 289         Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv));
 290     gv_name_set(gv, name, len, GV_ADD);
 291     if (multi || doproto)              /* doproto means it _was_ mentioned */
 292         GvMULTI_on(gv);
 293     if (doproto) {                      /* Replicate part of newSUB here. */
 294         CV *cv;
 295         ENTER;
 296         if (has_constant) {
 297             char *name0 = NULL;
 298             if (name[len])
 299                 /* newCONSTSUB doesn't take a len arg, so make sure we
 300                  * give it a \0-terminated string */
 301                 name0 = savepvn(name,len);
 302
 303             /* newCONSTSUB takes ownership of the reference from us.  */
 304             cv = newCONSTSUB(stash, (name0 ? name0 : name), has_constant);
 305             assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
 306             if (name0)
 307                 Safefree(name0);
 308             /* If this reference was a copy of another, then the subroutine
 309                must have been "imported", by a Perl space assignment to a GV
 310                from a reference to CV.  */
 311             if (exported_constant)
 312                 GvIMPORTED_CV_on(gv);
 313         } else {
 314             (void) start_subparse(0,0); /* Create empty CV in compcv. */
 315             cv = PL_compcv;
 316             GvCV(gv) = cv;
 317         }
 318         LEAVE;
 319
 320         mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */
 321         CvGV_set(cv, gv);
 322         CvFILE_set_from_cop(cv, PL_curcop);
 323         CvSTASH(cv) = PL_curstash;
 324         if (PL_curstash)
 325             Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv));
 326         if (proto) {
 327             sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
 328                             SV_HAS_TRAILING_NUL);
 329         }
 330     }
 331 }
 332
 333 STATIC void
 334 S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type)
 335 {
 336     PERL_ARGS_ASSERT_GV_INIT_SV;
 337
 338     switch (sv_type) {
 339     case SVt_PVIO:
 340         (void)GvIOn(gv);
 341         break;
 342     case SVt_PVAV:
 343         (void)GvAVn(gv);
 344         break;
 345     case SVt_PVHV:
 346         (void)GvHVn(gv);
 347         break;
 348 #ifdef PERL_DONT_CREATE_GVSV
 349     case SVt_NULL:
 350     case SVt_PVCV:
 351     case SVt_PVFM:
 352     case SVt_PVGV:
 353         break;
 354     default:
 355         if(GvSVn(gv)) {
 356             /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13
 357                If we just cast GvSVn(gv) to void, it ignores evaluating it for
 358                its side effect */
 359         }
 360 #endif
 361     }
 362 }
 363
 364 /*
 365 =for apidoc gv_fetchmeth
 366
 367 Returns the glob with the given C<name> and a defined subroutine or
 368 C<NULL>.  The glob lives in the given C<stash>, or in the stashes
 369 accessible via @ISA and UNIVERSAL::.
 370
 371 The argument C<level> should be either 0 or -1.  If C<level==0>, as a
 372 side-effect creates a glob with the given C<name> in the given C<stash>
 373 which in the case of success contains an alias for the subroutine, and sets
 374 up caching info for this glob.
 375
 376 This function grants C<"SUPER"> token as a postfix of the stash name. The
 377 GV returned from C<gv_fetchmeth> may be a method cache entry, which is not
 378 visible to Perl code.  So when calling C<call_sv>, you should not use
 379 the GV directly; instead, you should use the method's CV, which can be
 380 obtained from the GV with the C<GvCV> macro.
 381
 382 =cut
 383 */
 384
 385 /* NOTE: No support for tied ISA */
 386
 387 GV *
 388 Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 389 {
 390     dVAR;
 391     GV** gvp;
 392     AV* linear_av;
 393     SV** linear_svp;
 394     SV* linear_sv;
 395     HV* cstash;
 396     GV* candidate = NULL;
 397     CV* cand_cv = NULL;
 398     CV* old_cv;
 399     GV* topgv = NULL;
 400     const char *hvname;
 401     I32 create = (level >= 0) ? 1 : 0;
 402     I32 items;
 403     STRLEN packlen;
 404     U32 topgen_cmp;
 405
 406     PERL_ARGS_ASSERT_GV_FETCHMETH;
 407
 408     /* UNIVERSAL methods should be callable without a stash */
 409     if (!stash) {
 410         create = 0;  /* probably appropriate */
 411         if(!(stash = gv_stashpvs("UNIVERSAL", 0)))
 412             return 0;
 413     }
 414
 415     assert(stash);
 416
 417     hvname = HvNAME_get(stash);
 418     if (!hvname)
 419       Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 420
 421     assert(hvname);
 422     assert(name);
 423
 424     DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
 425
 426     topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation;
 427
 428     /* check locally for a real method or a cache entry */
 429     gvp = (GV**)hv_fetch(stash, name, len, create);
 430     if(gvp) {
 431         topgv = *gvp;
 432         assert(topgv);
 433         if (SvTYPE(topgv) != SVt_PVGV)
 434             gv_init(topgv, stash, name, len, TRUE);
 435         if ((cand_cv = GvCV(topgv))) {
 436             /* If genuine method or valid cache entry, use it */
 437             if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) {
 438                 return topgv;
 439             }
 440             else {
 441                 /* stale cache entry, junk it and move on */
 442                 SvREFCNT_dec(cand_cv);
 443                 GvCV(topgv) = cand_cv = NULL;
 444                 GvCVGEN(topgv) = 0;
 445             }
 446         }
 447         else if (GvCVGEN(topgv) == topgen_cmp) {
 448             /* cache indicates no such method definitively */
 449             return 0;
 450         }
 451     }
 452
 453     packlen = HvNAMELEN_get(stash);
 454     if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
 455         HV* basestash;
 456         packlen -= 7;
 457         basestash = gv_stashpvn(hvname, packlen, GV_ADD);
 458         linear_av = mro_get_linear_isa(basestash);
 459     }
 460     else {
 461         linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */
 462     }
 463
 464     linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
 465     items = AvFILLp(linear_av); /* no +1, to skip over self */
 466     while (items--) {
 467         linear_sv = *linear_svp++;
 468         assert(linear_sv);
 469         cstash = gv_stashsv(linear_sv, 0);
 470
 471         if (!cstash) {
 472             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
 473                            SVfARG(linear_sv), hvname);
 474             continue;
 475         }
 476
 477         assert(cstash);
 478
 479         gvp = (GV**)hv_fetch(cstash, name, len, 0);
 480         if (!gvp) continue;
 481         candidate = *gvp;
 482         assert(candidate);
 483         if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE);
 484         if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 485             /*
 486              * Found real method, cache method in topgv if:
 487              *  1. topgv has no synonyms (else inheritance crosses wires)
 488              *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
 489              */
 490             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
 491                   if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
 492                   SvREFCNT_inc_simple_void_NN(cand_cv);
 493                   GvCV(topgv) = cand_cv;
 494                   GvCVGEN(topgv) = topgen_cmp;
 495             }
 496             return candidate;
 497         }
 498     }
 499
 500     /* Check UNIVERSAL without caching */
 501     if(level == 0 || level == -1) {
 502         candidate = gv_fetchmeth(NULL, name, len, 1);
 503         if(candidate) {
 504             cand_cv = GvCV(candidate);
 505             if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) {
 506                   if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv);
 507                   SvREFCNT_inc_simple_void_NN(cand_cv);
 508                   GvCV(topgv) = cand_cv;
 509                   GvCVGEN(topgv) = topgen_cmp;
 510             }
 511             return candidate;
 512         }
 513     }
 514
 515     if (topgv && GvREFCNT(topgv) == 1) {
 516         /* cache the fact that the method is not defined */
 517         GvCVGEN(topgv) = topgen_cmp;
 518     }
 519
 520     return 0;
 521 }
 522
 523 /*
 524 =for apidoc gv_fetchmeth_autoload
 525
 526 Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
 527 Returns a glob for the subroutine.
 528
 529 For an autoloaded subroutine without a GV, will create a GV even
 530 if C<level < 0>.  For an autoloaded subroutine without a stub, GvCV()
 531 of the result may be zero.
 532
 533 =cut
 534 */
 535
 536 GV *
 537 Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 538 {
 539     GV *gv = gv_fetchmeth(stash, name, len, level);
 540
 541     PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD;
 542
 543     if (!gv) {
 544         CV *cv;
 545         GV **gvp;
 546
 547         if (!stash)
 548             return NULL;        /* UNIVERSAL::AUTOLOAD could cause trouble */
 549         if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
 550             return NULL;
 551         if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
 552             return NULL;
 553         cv = GvCV(gv);
 554         if (!(CvROOT(cv) || CvXSUB(cv)))
 555             return NULL;
 556         /* Have an autoload */
 557         if (level < 0)  /* Cannot do without a stub */
 558             gv_fetchmeth(stash, name, len, 0);
 559         gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
 560         if (!gvp)
 561             return NULL;
 562         return *gvp;
 563     }
 564     return gv;
 565 }
 566
 567 /*
 568 =for apidoc gv_fetchmethod_autoload
 569
 570 Returns the glob which contains the subroutine to call to invoke the method
 571 on the C<stash>.  In fact in the presence of autoloading this may be the
 572 glob for "AUTOLOAD".  In this case the corresponding variable $AUTOLOAD is
 573 already setup.
 574
 575 The third parameter of C<gv_fetchmethod_autoload> determines whether
 576 AUTOLOAD lookup is performed if the given method is not present: non-zero
 577 means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD.
 578 Calling C<gv_fetchmethod> is equivalent to calling C<gv_fetchmethod_autoload>
 579 with a non-zero C<autoload> parameter.
 580
 581 These functions grant C<"SUPER"> token as a prefix of the method name. Note
 582 that if you want to keep the returned glob for a long time, you need to
 583 check for it being "AUTOLOAD", since at the later time the call may load a
 584 different subroutine due to $AUTOLOAD changing its value. Use the glob
 585 created via a side effect to do this.
 586
 587 These functions have the same side-effects and as C<gv_fetchmeth> with
 588 C<level==0>.  C<name> should be writable if contains C<':'> or C<'
 589 ''>. The warning against passing the GV returned by C<gv_fetchmeth> to
 590 C<call_sv> apply equally to these functions.
 591
 592 =cut
 593 */
 594
 595 STATIC HV*
 596 S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen)
 597 {
 598     AV* superisa;
 599     GV** gvp;
 600     GV* gv;
 601     HV* stash;
 602
 603     PERL_ARGS_ASSERT_GV_GET_SUPER_PKG;
 604
 605     stash = gv_stashpvn(name, namelen, 0);
 606     if(stash) return stash;
 607
 608     /* If we must create it, give it an @ISA array containing
 609        the real package this SUPER is for, so that it's tied
 610        into the cache invalidation code correctly */
 611     stash = gv_stashpvn(name, namelen, GV_ADD);
 612     gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
 613     gv = *gvp;
 614     gv_init(gv, stash, "ISA", 3, TRUE);
 615     superisa = GvAVn(gv);
 616     GvMULTI_on(gv);
 617     sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
 618 #ifdef USE_ITHREADS
 619     av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0));
 620 #else
 621     av_push(superisa, newSVhek(CopSTASH(PL_curcop)
 622                                ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
 623 #endif
 624
 625     return stash;
 626 }
 627
 628 GV *
 629 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 630 {
 631     PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
 632
 633     return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
 634 }
 635
 636 /* Don't merge this yet, as it's likely to get a len parameter, and possibly
 637    even a U32 hash */
 638 GV *
 639 Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags)
 640 {
 641     dVAR;
 642     register const char *nend;
 643     const char *nsplit = NULL;
 644     GV* gv;
 645     HV* ostash = stash;
 646     const char * const origname = name;
 647     SV *const error_report = MUTABLE_SV(stash);
 648     const U32 autoload = flags & GV_AUTOLOAD;
 649     const U32 do_croak = flags & GV_CROAK;
 650
 651     PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS;
 652
 653     if (SvTYPE(stash) < SVt_PVHV)
 654         stash = NULL;
 655     else {
 656         /* The only way stash can become NULL later on is if nsplit is set,
 657            which in turn means that there is no need for a SVt_PVHV case
 658            the error reporting code.  */
 659     }
 660
 661     for (nend = name; *nend; nend++) {
 662         if (*nend == '\'') {
 663             nsplit = nend;
 664             name = nend + 1;
 665         }
 666         else if (*nend == ':' && *(nend + 1) == ':') {
 667             nsplit = nend++;
 668             name = nend + 1;
 669         }
 670     }
 671     if (nsplit) {
 672         if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
 673             /* ->SUPER::method should really be looked up in original stash */
 674             SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
 675                                                   CopSTASHPV(PL_curcop)));
 676             /* __PACKAGE__::SUPER stash should be autovivified */
 677             stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr));
 678             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
 679                          origname, HvNAME_get(stash), name) );
 680         }
 681         else {
 682             /* don't autovifify if ->NoSuchStash::method */
 683             stash = gv_stashpvn(origname, nsplit - origname, 0);
 684
 685             /* however, explicit calls to Pkg::SUPER::method may
 686                happen, and may require autovivification to work */
 687             if (!stash && (nsplit - origname) >= 7 &&
 688                 strnEQ(nsplit - 7, "::SUPER", 7) &&
 689                 gv_stashpvn(origname, nsplit - origname - 7, 0))
 690               stash = gv_get_super_pkg(origname, nsplit - origname);
 691         }
 692         ostash = stash;
 693     }
 694
 695     gv = gv_fetchmeth(stash, name, nend - name, 0);
 696     if (!gv) {
 697         if (strEQ(name,"import") || strEQ(name,"unimport"))
 698             gv = MUTABLE_GV(&PL_sv_yes);
 699         else if (autoload)
 700             gv = gv_autoload4(ostash, name, nend - name, TRUE);
 701         if (!gv && do_croak) {
 702             /* Right now this is exclusively for the benefit of S_method_common
 703                in pp_hot.c  */
 704             if (stash) {
 705                 Perl_croak(aTHX_
 706                            "Can't locate object method \"%s\" via package \"%.*s\"",
 707                            name, (int)HvNAMELEN_get(stash), HvNAME_get(stash));
 708             }
 709             else {
 710                 STRLEN packlen;
 711                 const char *packname;
 712
 713                 if (nsplit) {
 714                     packlen = nsplit - origname;
 715                     packname = origname;
 716                 } else {
 717                     packname = SvPV_const(error_report, packlen);
 718                 }
 719
 720                 Perl_croak(aTHX_
 721                            "Can't locate object method \"%s\" via package \"%.*s\""
 722                            " (perhaps you forgot to load \"%.*s\"?)",
 723                            name, (int)packlen, packname, (int)packlen, packname);
 724             }
 725         }
 726     }
 727     else if (autoload) {
 728         CV* const cv = GvCV(gv);
 729         if (!CvROOT(cv) && !CvXSUB(cv)) {
 730             GV* stubgv;
 731             GV* autogv;
 732
 733             if (CvANON(cv))
 734                 stubgv = gv;
 735             else {
 736                 stubgv = CvGV(cv);
 737                 if (GvCV(stubgv) != cv)         /* orphaned import */
 738                     stubgv = gv;
 739             }
 740             autogv = gv_autoload4(GvSTASH(stubgv),
 741                                   GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
 742             if (autogv)
 743                 gv = autogv;
 744         }
 745     }
 746
 747     return gv;
 748 }
 749
 750 GV*
 751 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 752 {
 753     dVAR;
 754     GV* gv;
 755     CV* cv;
 756     HV* varstash;
 757     GV* vargv;
 758     SV* varsv;
 759     const char *packname = "";
 760     STRLEN packname_len = 0;
 761
 762     PERL_ARGS_ASSERT_GV_AUTOLOAD4;
 763
 764     if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
 765         return NULL;
 766     if (stash) {
 767         if (SvTYPE(stash) < SVt_PVHV) {
 768             packname = SvPV_const(MUTABLE_SV(stash), packname_len);
 769             stash = NULL;
 770         }
 771         else {
 772             packname = HvNAME_get(stash);
 773             packname_len = HvNAMELEN_get(stash);
 774         }
 775     }
 776     if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
 777         return NULL;
 778     cv = GvCV(gv);
 779
 780     if (!(CvROOT(cv) || CvXSUB(cv)))
 781         return NULL;
 782
 783     /*
 784      * Inheriting AUTOLOAD for non-methods works ... for now.
 785      */
 786     if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
 787     )
 788         Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
 789                          "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
 790                          packname, (int)len, name);
 791
 792     if (CvISXSUB(cv)) {
 793         /* rather than lookup/init $AUTOLOAD here
 794          * only to have the XSUB do another lookup for $AUTOLOAD
 795          * and split that value on the last '::',
 796          * pass along the same data via some unused fields in the CV
 797          */
 798         CvSTASH(cv) = stash;
 799         if (stash)
 800             Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(cv));
 801         SvPV_set(cv, (char *)name); /* cast to lose constness warning */
 802         SvCUR_set(cv, len);
 803         return gv;
 804     }
 805
 806     /*
 807      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
 808      * The subroutine's original name may not be "AUTOLOAD", so we don't
 809      * use that, but for lack of anything better we will use the sub's
 810      * original package to look up $AUTOLOAD.
 811      */
 812     varstash = GvSTASH(CvGV(cv));
 813     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
 814     ENTER;
 815
 816     if (!isGV(vargv)) {
 817         gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
 818 #ifdef PERL_DONT_CREATE_GVSV
 819         GvSV(vargv) = newSV(0);
 820 #endif
 821     }
 822     LEAVE;
 823     varsv = GvSVn(vargv);
 824     sv_setpvn(varsv, packname, packname_len);
 825     sv_catpvs(varsv, "::");
 826     sv_catpvn(varsv, name, len);
 827     return gv;
 828 }
 829
 830
 831 /* require_tie_mod() internal routine for requiring a module
 832  * that implements the logic of automatical ties like %! and %-
 833  *
 834  * The "gv" parameter should be the glob.
 835  * "varpv" holds the name of the var, used for error messages.
 836  * "namesv" holds the module name. Its refcount will be decremented.
 837  * "methpv" holds the method name to test for to check that things
 838  *   are working reasonably close to as expected.
 839  * "flags": if flag & 1 then save the scalar before loading.
 840  * For the protection of $! to work (it is set by this routine)
 841  * the sv slot must already be magicalized.
 842  */
 843 STATIC HV*
 844 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
 845 {
 846     dVAR;
 847     HV* stash = gv_stashsv(namesv, 0);
 848
 849     PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
 850
 851     if (!stash || !(gv_fetchmethod(stash, methpv))) {
 852         SV *module = newSVsv(namesv);
 853         char varname = *varpv; /* varpv might be clobbered by load_module,
 854                                   so save it. For the moment it's always
 855                                   a single char. */
 856         dSP;
 857         ENTER;
 858         if ( flags & 1 )
 859             save_scalar(gv);
 860         PUSHSTACKi(PERLSI_MAGIC);
 861         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
 862         POPSTACK;
 863         LEAVE;
 864         SPAGAIN;
 865         stash = gv_stashsv(namesv, 0);
 866         if (!stash)
 867             Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
 868                     varname, SVfARG(namesv));
 869         else if (!gv_fetchmethod(stash, methpv))
 870             Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
 871                     varname, SVfARG(namesv), methpv);
 872     }
 873     SvREFCNT_dec(namesv);
 874     return stash;
 875 }
 876
 877 /*
 878 =for apidoc gv_stashpv
 879
 880 Returns a pointer to the stash for a specified package.  Uses C<strlen> to
 881 determine the length of C<name>, then calls C<gv_stashpvn()>.
 882
 883 =cut
 884 */
 885
 886 HV*
 887 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
 888 {
 889     PERL_ARGS_ASSERT_GV_STASHPV;
 890     return gv_stashpvn(name, strlen(name), create);
 891 }
 892
 893 /*
 894 =for apidoc gv_stashpvn
 895
 896 Returns a pointer to the stash for a specified package.  The C<namelen>
 897 parameter indicates the length of the C<name>, in bytes.  C<flags> is passed
 898 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
 899 created if it does not already exist.  If the package does not exist and
 900 C<flags> is 0 (or any other setting that does not create packages) then NULL
 901 is returned.
 902
 903
 904 =cut
 905 */
 906
 907 HV*
 908 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
 909 {
 910     char smallbuf[128];
 911     char *tmpbuf;
 912     HV *stash;
 913     GV *tmpgv;
 914     U32 tmplen = namelen + 2;
 915
 916     PERL_ARGS_ASSERT_GV_STASHPVN;
 917
 918     if (tmplen <= sizeof smallbuf)
 919         tmpbuf = smallbuf;
 920     else
 921         Newx(tmpbuf, tmplen, char);
 922     Copy(name, tmpbuf, namelen, char);
 923     tmpbuf[namelen]   = ':';
 924     tmpbuf[namelen+1] = ':';
 925     tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV);
 926     if (tmpbuf != smallbuf)
 927         Safefree(tmpbuf);
 928     if (!tmpgv)
 929         return NULL;
 930     if (!GvHV(tmpgv))
 931         GvHV(tmpgv) = newHV();
 932     stash = GvHV(tmpgv);
 933     if (!HvNAME_get(stash))
 934         hv_name_set(stash, name, namelen, 0);
 935     return stash;
 936 }
 937
 938 /*
 939 =for apidoc gv_stashsv
 940
 941 Returns a pointer to the stash for a specified package.  See C<gv_stashpvn>.
 942
 943 =cut
 944 */
 945
 946 HV*
 947 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
 948 {
 949     STRLEN len;
 950     const char * const ptr = SvPV_const(sv,len);
 951
 952     PERL_ARGS_ASSERT_GV_STASHSV;
 953
 954     return gv_stashpvn(ptr, len, flags);
 955 }
 956
 957
 958 GV *
 959 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
 960     PERL_ARGS_ASSERT_GV_FETCHPV;
 961     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
 962 }
 963
 964 GV *
 965 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
 966     STRLEN len;
 967     const char * const nambeg = SvPV_const(name, len);
 968     PERL_ARGS_ASSERT_GV_FETCHSV;
 969     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
 970 }
 971
 972 STATIC void
 973 S_gv_magicalize_isa(pTHX_ GV *gv, const char *nambeg, I32 add)
 974 {
 975     AV* av;
 976
 977     PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA;
 978
 979     av = GvAVn(gv);
 980     GvMULTI_on(gv);
 981     sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa,
 982              NULL, 0);
 983     /* NOTE: No support for tied ISA */
 984     if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
 985         && AvFILLp(av) == -1)
 986         {
 987             av_push(av, newSVpvs("NDBM_File"));
 988             gv_stashpvs("NDBM_File", GV_ADD);
 989             av_push(av, newSVpvs("DB_File"));
 990             gv_stashpvs("DB_File", GV_ADD);
 991             av_push(av, newSVpvs("GDBM_File"));
 992             gv_stashpvs("GDBM_File", GV_ADD);
 993             av_push(av, newSVpvs("SDBM_File"));
 994             gv_stashpvs("SDBM_File", GV_ADD);
 995             av_push(av, newSVpvs("ODBM_File"));
 996             gv_stashpvs("ODBM_File", GV_ADD);
 997         }
 998 }
 999
1000 STATIC void
1001 S_gv_magicalize_overload(pTHX_ GV *gv)
1002 {
1003     HV* hv;
1004
1005     PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD;
1006
1007     hv = GvHVn(gv);
1008     GvMULTI_on(gv);
1009     hv_magic(hv, NULL, PERL_MAGIC_overload);
1010 }
1011
1012 GV *
1013 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
1014                        const svtype sv_type)
1015 {
1016     dVAR;
1017     register const char *name = nambeg;
1018     register GV *gv = NULL;
1019     GV**gvp;
1020     I32 len;
1021     register const char *name_cursor;
1022     HV *stash = NULL;
1023     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
1024     const I32 no_expand = flags & GV_NOEXPAND;
1025     const I32 add = flags & ~GV_NOADD_MASK;
1026     const char *const name_end = nambeg + full_len;
1027     const char *const name_em1 = name_end - 1;
1028     U32 faking_it;
1029
1030     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
1031
1032     if (flags & GV_NOTQUAL) {
1033         /* Caller promised that there is no stash, so we can skip the check. */
1034         len = full_len;
1035         goto no_stash;
1036     }
1037
1038     if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
1039         /* accidental stringify on a GV? */
1040         name++;
1041     }
1042
1043     for (name_cursor = name; name_cursor < name_end; name_cursor++) {
1044         if ((*name_cursor == ':' && name_cursor < name_em1
1045              && name_cursor[1] == ':')
1046             || (*name_cursor == '\'' && name_cursor[1]))
1047         {
1048             if (!stash)
1049                 stash = PL_defstash;
1050             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
1051                 return NULL;
1052
1053             len = name_cursor - name;
1054             if (len > 0) {
1055                 char smallbuf[128];
1056                 char *tmpbuf;
1057
1058                 if (len + 2 <= (I32)sizeof (smallbuf))
1059                     tmpbuf = smallbuf;
1060                 else
1061                     Newx(tmpbuf, len+2, char);
1062                 Copy(name, tmpbuf, len, char);
1063                 tmpbuf[len++] = ':';
1064                 tmpbuf[len++] = ':';
1065                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
1066                 gv = gvp ? *gvp : NULL;
1067                 if (gv && gv != (const GV *)&PL_sv_undef) {
1068                     if (SvTYPE(gv) != SVt_PVGV)
1069                         gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
1070                     else
1071                         GvMULTI_on(gv);
1072                 }
1073                 if (tmpbuf != smallbuf)
1074                     Safefree(tmpbuf);
1075                 if (!gv || gv == (const GV *)&PL_sv_undef)
1076                     return NULL;
1077
1078                 if (!(stash = GvHV(gv)))
1079                     stash = GvHV(gv) = newHV();
1080
1081                 if (!HvNAME_get(stash))
1082                     hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
1083             }
1084
1085             if (*name_cursor == ':')
1086                 name_cursor++;
1087             name_cursor++;
1088             name = name_cursor;
1089             if (name == name_end)
1090                 return gv
1091                     ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));
1092         }
1093     }
1094     len = name_cursor - name;
1095
1096     /* No stash in name, so see how we can default */
1097
1098     if (!stash) {
1099     no_stash:
1100         if (len && isIDFIRST_lazy(name)) {
1101             bool global = FALSE;
1102
1103             switch (len) {
1104             case 1:
1105                 if (*name == '_')
1106                     global = TRUE;
1107                 break;
1108             case 3:
1109                 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1110                     || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1111                     || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1112                     global = TRUE;
1113                 break;
1114             case 4:
1115                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1116                     && name[3] == 'V')
1117                     global = TRUE;
1118                 break;
1119             case 5:
1120                 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1121                     && name[3] == 'I' && name[4] == 'N')
1122                     global = TRUE;
1123                 break;
1124             case 6:
1125                 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1126                     &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1127                        ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1128                     global = TRUE;
1129                 break;
1130             case 7:
1131                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1132                     && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1133                     && name[6] == 'T')
1134                     global = TRUE;
1135                 break;
1136             }
1137
1138             if (global)
1139                 stash = PL_defstash;
1140             else if (IN_PERL_COMPILETIME) {
1141                 stash = PL_curstash;
1142                 if (add && (PL_hints & HINT_STRICT_VARS) &&
1143                     sv_type != SVt_PVCV &&
1144                     sv_type != SVt_PVGV &&
1145                     sv_type != SVt_PVFM &&
1146                     sv_type != SVt_PVIO &&
1147                     !(len == 1 && sv_type == SVt_PV &&
1148                       (*name == 'a' || *name == 'b')) )
1149                 {
1150                     gvp = (GV**)hv_fetch(stash,name,len,0);
1151                     if (!gvp ||
1152                         *gvp == (const GV *)&PL_sv_undef ||
1153                         SvTYPE(*gvp) != SVt_PVGV)
1154                     {
1155                         stash = NULL;
1156                     }
1157                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1158                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1159                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1160                     {
1161                         /* diag_listed_as: Variable "%s" is not imported%s */
1162                         Perl_ck_warner_d(
1163                             aTHX_ packWARN(WARN_MISC),
1164                             "Variable \"%c%s\" is not imported",
1165                             sv_type == SVt_PVAV ? '@' :
1166                             sv_type == SVt_PVHV ? '%' : '$',
1167                             name);
1168                         if (GvCVu(*gvp))
1169                             Perl_ck_warner_d(
1170                                 aTHX_ packWARN(WARN_MISC),
1171                                 "\t(Did you mean &%s instead?)\n", name
1172                             );
1173                         stash = NULL;
1174                     }
1175                 }
1176             }
1177             else
1178                 stash = CopSTASH(PL_curcop);
1179         }
1180         else
1181             stash = PL_defstash;
1182     }
1183
1184     /* By this point we should have a stash and a name */
1185
1186     if (!stash) {
1187         if (add) {
1188             SV * const err = Perl_mess(aTHX_
1189                  "Global symbol \"%s%s\" requires explicit package name",
1190                  (sv_type == SVt_PV ? "$"
1191                   : sv_type == SVt_PVAV ? "@"
1192                   : sv_type == SVt_PVHV ? "%"
1193                   : ""), name);
1194             GV *gv;
1195             if (USE_UTF8_IN_NAMES)
1196                 SvUTF8_on(err);
1197             qerror(err);
1198             gv = gv_fetchpvs("<none>::", GV_ADDMULTI, SVt_PVHV);
1199             if(!gv) {
1200                 /* symbol table under destruction */
1201                 return NULL;
1202             }
1203             stash = GvHV(gv);
1204         }
1205         else
1206             return NULL;
1207     }
1208
1209     if (!SvREFCNT(stash))       /* symbol table under destruction */
1210         return NULL;
1211
1212     gvp = (GV**)hv_fetch(stash,name,len,add);
1213     if (!gvp || *gvp == (const GV *)&PL_sv_undef)
1214         return NULL;
1215     gv = *gvp;
1216     if (SvTYPE(gv) == SVt_PVGV) {
1217         if (add) {
1218             GvMULTI_on(gv);
1219             gv_init_sv(gv, sv_type);
1220             if (len == 1 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
1221                 if (*name == '!')
1222                     require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1223                 else if (*name == '-' || *name == '+')
1224                     require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1225             }
1226         }
1227         return gv;
1228     } else if (no_init) {
1229         return gv;
1230     } else if (no_expand && SvROK(gv)) {
1231         return gv;
1232     }
1233
1234     /* Adding a new symbol.
1235        Unless of course there was already something non-GV here, in which case
1236        we want to behave as if there was always a GV here, containing some sort
1237        of subroutine.
1238        Otherwise we run the risk of creating things like GvIO, which can cause
1239        subtle bugs. eg the one that tripped up SQL::Translator  */
1240
1241     faking_it = SvOK(gv);
1242
1243     if (add & GV_ADDWARN)
1244         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
1245     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
1246     gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
1247
1248     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
1249                                             : (PL_dowarn & G_WARN_ON ) ) )
1250         GvMULTI_on(gv) ;
1251
1252     /* set up magic where warranted */
1253     if (stash != PL_defstash) { /* not the main stash */
1254         /* We only have to check for four names here: EXPORT, ISA, OVERLOAD
1255            and VERSION. All the others apply only to the main stash. */
1256         if (len > 1) {
1257             const char * const name2 = name + 1;
1258             switch (*name) {
1259             case 'E':
1260                 if (strnEQ(name2, "XPORT", 5))
1261                     GvMULTI_on(gv);
1262                 break;
1263             case 'I':
1264                 if (strEQ(name2, "SA"))
1265                     gv_magicalize_isa(gv, nambeg, add);
1266                 break;
1267             case 'O':
1268                 if (strEQ(name2, "VERLOAD"))
1269                     gv_magicalize_overload(gv);
1270                 break;
1271             case 'V':
1272                 if (strEQ(name2, "ERSION"))
1273                     GvMULTI_on(gv);
1274                 break;
1275             }
1276         }
1277     }
1278     else if (len > 1) {
1279 #ifndef EBCDIC
1280         if (*name > 'V' ) {
1281             NOOP;
1282             /* Nothing else to do.
1283                The compiler will probably turn the switch statement into a
1284                branch table. Make sure we avoid even that small overhead for
1285                the common case of lower case variable names.  */
1286         } else
1287 #endif
1288         {
1289             const char * const name2 = name + 1;
1290             switch (*name) {
1291             case 'A':
1292                 if (strEQ(name2, "RGV")) {
1293                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1294                 }
1295                 else if (strEQ(name2, "RGVOUT")) {
1296                     GvMULTI_on(gv);
1297                 }
1298                 break;
1299             case 'E':
1300                 if (strnEQ(name2, "XPORT", 5))
1301                     GvMULTI_on(gv);
1302                 break;
1303             case 'I':
1304                 if (strEQ(name2, "SA")) {
1305                     gv_magicalize_isa(gv, nambeg, add);
1306                 }
1307                 break;
1308             case 'O':
1309                 if (strEQ(name2, "VERLOAD")) {
1310                     gv_magicalize_overload(gv);
1311                 }
1312                 break;
1313             case 'S':
1314                 if (strEQ(name2, "IG")) {
1315                     HV *hv;
1316                     I32 i;
1317                     if (!PL_psig_name) {
1318                         Newxz(PL_psig_name, 2 * SIG_SIZE, SV*);
1319                         Newxz(PL_psig_pend, SIG_SIZE, int);
1320                         PL_psig_ptr = PL_psig_name + SIG_SIZE;
1321                     } else {
1322                         /* I think that the only way to get here is to re-use an
1323                            embedded perl interpreter, where the previous
1324                            use didn't clean up fully because
1325                            PL_perl_destruct_level was 0. I'm not sure that we
1326                            "support" that, in that I suspect in that scenario
1327                            there are sufficient other garbage values left in the
1328                            interpreter structure that something else will crash
1329                            before we get here. I suspect that this is one of
1330                            those "doctor, it hurts when I do this" bugs.  */
1331                         Zero(PL_psig_name, 2 * SIG_SIZE, SV*);
1332                         Zero(PL_psig_pend, SIG_SIZE, int);
1333                     }
1334                     GvMULTI_on(gv);
1335                     hv = GvHVn(gv);
1336                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1337                     for (i = 1; i < SIG_SIZE; i++) {
1338                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1339                         if (init)
1340                             sv_setsv(*init, &PL_sv_undef);
1341                     }
1342                 }
1343                 break;
1344             case 'V':
1345                 if (strEQ(name2, "ERSION"))
1346                     GvMULTI_on(gv);
1347                 break;
1348             case '\003':        /* $^CHILD_ERROR_NATIVE */
1349                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1350                     goto magicalize;
1351                 break;
1352             case '\005':        /* $^ENCODING */
1353                 if (strEQ(name2, "NCODING"))
1354                     goto magicalize;
1355                 break;
1356             case '\015':        /* $^MATCH */
1357                 if (strEQ(name2, "ATCH"))
1358                     goto magicalize;
1359             case '\017':        /* $^OPEN */
1360                 if (strEQ(name2, "PEN"))
1361                     goto magicalize;
1362                 break;
1363             case '\020':        /* $^PREMATCH  $^POSTMATCH */
1364                 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1365                     goto magicalize;
1366             case '\024':        /* ${^TAINT} */
1367                 if (strEQ(name2, "AINT"))
1368                     goto ro_magicalize;
1369                 break;
1370             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1371                 if (strEQ(name2, "NICODE"))
1372                     goto ro_magicalize;
1373                 if (strEQ(name2, "TF8LOCALE"))
1374                     goto ro_magicalize;
1375                 if (strEQ(name2, "TF8CACHE"))
1376                     goto magicalize;
1377                 break;
1378             case '\027':        /* $^WARNING_BITS */
1379                 if (strEQ(name2, "ARNING_BITS"))
1380                     goto magicalize;
1381                 break;
1382             case '1':
1383             case '2':
1384             case '3':
1385             case '4':
1386             case '5':
1387             case '6':
1388             case '7':
1389             case '8':
1390             case '9':
1391             {
1392                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1393                    this test  */
1394                 /* This snippet is taken from is_gv_magical */
1395                 const char *end = name + len;
1396                 while (--end > name) {
1397                     if (!isDIGIT(*end)) return gv;
1398                 }
1399                 goto magicalize;
1400             }
1401             }
1402         }
1403     } else {
1404         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1405            be case '\0' in this switch statement (ie a default case)  */
1406         switch (*name) {
1407         case '&':               /* $& */
1408         case '`':               /* $` */
1409         case '\'':              /* $' */
1410             if (
1411                 sv_type == SVt_PVAV ||
1412                 sv_type == SVt_PVHV ||
1413                 sv_type == SVt_PVCV ||
1414                 sv_type == SVt_PVFM ||
1415                 sv_type == SVt_PVIO
1416                 ) { break; }
1417             PL_sawampersand = TRUE;
1418             goto magicalize;
1419
1420         case ':':               /* $: */
1421             sv_setpv(GvSVn(gv),PL_chopset);
1422             goto magicalize;
1423
1424         case '?':               /* $? */
1425 #ifdef COMPLEX_STATUS
1426             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1427 #endif
1428             goto magicalize;
1429
1430         case '!':               /* $! */
1431             GvMULTI_on(gv);
1432             /* If %! has been used, automatically load Errno.pm. */
1433
1434             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1435
1436             /* magicalization must be done before require_tie_mod is called */
1437             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1438                 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1439
1440             break;
1441         case '-':               /* $- */
1442         case '+':               /* $+ */
1443         GvMULTI_on(gv); /* no used once warnings here */
1444         {
1445             AV* const av = GvAVn(gv);
1446             SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL;
1447
1448             sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0);
1449             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1450             if (avc)
1451                 SvREADONLY_on(GvSVn(gv));
1452             SvREADONLY_on(av);
1453
1454             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1455                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1456
1457             break;
1458         }
1459         case '*':               /* $* */
1460         case '#':               /* $# */
1461             if (sv_type == SVt_PV)
1462                 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1463                                  "$%c is no longer supported", *name);
1464             break;
1465         case '|':               /* $| */
1466             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1467             goto magicalize;
1468
1469         case '\010':    /* $^H */
1470             {
1471                 HV *const hv = GvHVn(gv);
1472                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1473             }
1474             goto magicalize;
1475         case '\023':    /* $^S */
1476         ro_magicalize:
1477             SvREADONLY_on(GvSVn(gv));
1478             /* FALL THROUGH */
1479         case '0':               /* $0 */
1480         case '1':               /* $1 */
1481         case '2':               /* $2 */
1482         case '3':               /* $3 */
1483         case '4':               /* $4 */
1484         case '5':               /* $5 */
1485         case '6':               /* $6 */
1486         case '7':               /* $7 */
1487         case '8':               /* $8 */
1488         case '9':               /* $9 */
1489         case '[':               /* $[ */
1490         case '^':               /* $^ */
1491         case '~':               /* $~ */
1492         case '=':               /* $= */
1493         case '%':               /* $% */
1494         case '.':               /* $. */
1495         case '(':               /* $( */
1496         case ')':               /* $) */
1497         case '<':               /* $< */
1498         case '>':               /* $> */
1499         case '\\':              /* $\ */
1500         case '/':               /* $/ */
1501         case '\001':    /* $^A */
1502         case '\003':    /* $^C */
1503         case '\004':    /* $^D */
1504         case '\005':    /* $^E */
1505         case '\006':    /* $^F */
1506         case '\011':    /* $^I, NOT \t in EBCDIC */
1507         case '\016':    /* $^N */
1508         case '\017':    /* $^O */
1509         case '\020':    /* $^P */
1510         case '\024':    /* $^T */
1511         case '\027':    /* $^W */
1512         magicalize:
1513             sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len);
1514             break;
1515
1516         case '\014':    /* $^L */
1517             sv_setpvs(GvSVn(gv),"\f");
1518             PL_formfeed = GvSVn(gv);
1519             break;
1520         case ';':               /* $; */
1521             sv_setpvs(GvSVn(gv),"\034");
1522             break;
1523         case ']':               /* $] */
1524         {
1525             SV * const sv = GvSVn(gv);
1526             if (!sv_derived_from(PL_patchlevel, "version"))
1527                 upg_version(PL_patchlevel, TRUE);
1528             GvSV(gv) = vnumify(PL_patchlevel);
1529             SvREADONLY_on(GvSV(gv));
1530             SvREFCNT_dec(sv);
1531         }
1532         break;
1533         case '\026':    /* $^V */
1534         {
1535             SV * const sv = GvSVn(gv);
1536             GvSV(gv) = new_version(PL_patchlevel);
1537             SvREADONLY_on(GvSV(gv));
1538             SvREFCNT_dec(sv);
1539         }
1540         break;
1541         }
1542     }
1543     return gv;
1544 }
1545
1546 void
1547 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1548 {
1549     const char *name;
1550     STRLEN namelen;
1551     const HV * const hv = GvSTASH(gv);
1552
1553     PERL_ARGS_ASSERT_GV_FULLNAME4;
1554
1555     if (!hv) {
1556         SvOK_off(sv);
1557         return;
1558     }
1559     sv_setpv(sv, prefix ? prefix : "");
1560
1561     name = HvNAME_get(hv);
1562     if (name) {
1563         namelen = HvNAMELEN_get(hv);
1564     } else {
1565         name = "__ANON__";
1566         namelen = 8;
1567     }
1568
1569     if (keepmain || strNE(name, "main")) {
1570         sv_catpvn(sv,name,namelen);
1571         sv_catpvs(sv,"::");
1572     }
1573     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1574 }
1575
1576 void
1577 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1578 {
1579     const GV * const egv = GvEGVx(gv);
1580
1581     PERL_ARGS_ASSERT_GV_EFULLNAME4;
1582
1583     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1584 }
1585
1586 void
1587 Perl_gv_check(pTHX_ const HV *stash)
1588 {
1589     dVAR;
1590     register I32 i;
1591
1592     PERL_ARGS_ASSERT_GV_CHECK;
1593
1594     if (!HvARRAY(stash))
1595         return;
1596     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1597         const HE *entry;
1598         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1599             register GV *gv;
1600             HV *hv;
1601             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1602                 (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv)))
1603             {
1604                 if (hv != PL_defstash && hv != stash)
1605                      gv_check(hv);              /* nested package */
1606             }
1607             else if (isALPHA(*HeKEY(entry))) {
1608                 const char *file;
1609                 gv = MUTABLE_GV(HeVAL(entry));
1610                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1611                     continue;
1612                 file = GvFILE(gv);
1613                 CopLINE_set(PL_curcop, GvLINE(gv));
1614 #ifdef USE_ITHREADS
1615                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1616 #else
1617                 CopFILEGV(PL_curcop)
1618                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1619 #endif
1620                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1621                         "Name \"%s::%s\" used only once: possible typo",
1622                         HvNAME_get(stash), GvNAME(gv));
1623             }
1624         }
1625     }
1626 }
1627
1628 GV *
1629 Perl_newGVgen(pTHX_ const char *pack)
1630 {
1631     dVAR;
1632
1633     PERL_ARGS_ASSERT_NEWGVGEN;
1634
1635     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1636                       GV_ADD, SVt_PVGV);
1637 }
1638
1639 /* hopefully this is only called on local symbol table entries */
1640
1641 GP*
1642 Perl_gp_ref(pTHX_ GP *gp)
1643 {
1644     dVAR;
1645     if (!gp)
1646         return NULL;
1647     gp->gp_refcnt++;
1648     if (gp->gp_cv) {
1649         if (gp->gp_cvgen) {
1650             /* If the GP they asked for a reference to contains
1651                a method cache entry, clear it first, so that we
1652                don't infect them with our cached entry */
1653             SvREFCNT_dec(gp->gp_cv);
1654             gp->gp_cv = NULL;
1655             gp->gp_cvgen = 0;
1656         }
1657     }
1658     return gp;
1659 }
1660
1661 void
1662 Perl_gp_free(pTHX_ GV *gv)
1663 {
1664     dVAR;
1665     GP* gp;
1666
1667     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1668         return;
1669     if (gp->gp_refcnt == 0) {
1670         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
1671                          "Attempt to free unreferenced glob pointers"
1672                          pTHX__FORMAT pTHX__VALUE);
1673         return;
1674     }
1675     if (--gp->gp_refcnt > 0) {
1676         if (gp->gp_egv == gv)
1677             gp->gp_egv = 0;
1678         GvGP(gv) = 0;
1679         return;
1680     }
1681
1682     if (gp->gp_file_hek)
1683         unshare_hek(gp->gp_file_hek);
1684     SvREFCNT_dec(gp->gp_sv);
1685     SvREFCNT_dec(gp->gp_av);
1686     /* FIXME - another reference loop GV -> symtab -> GV ?
1687        Somehow gp->gp_hv can end up pointing at freed garbage.  */
1688     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1689         const char *hvname = HvNAME_get(gp->gp_hv);
1690         if (PL_stashcache && hvname)
1691             (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1692                       G_DISCARD);
1693         SvREFCNT_dec(gp->gp_hv);
1694     }
1695     SvREFCNT_dec(gp->gp_io);
1696     SvREFCNT_dec(gp->gp_cv);
1697     SvREFCNT_dec(gp->gp_form);
1698
1699     Safefree(gp);
1700     GvGP(gv) = 0;
1701 }
1702
1703 int
1704 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1705 {
1706     AMT * const amtp = (AMT*)mg->mg_ptr;
1707     PERL_UNUSED_ARG(sv);
1708
1709     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
1710
1711     if (amtp && AMT_AMAGIC(amtp)) {
1712         int i;
1713         for (i = 1; i < NofAMmeth; i++) {
1714             CV * const cv = amtp->table[i];
1715             if (cv) {
1716                 SvREFCNT_dec(MUTABLE_SV(cv));
1717                 amtp->table[i] = NULL;
1718             }
1719         }
1720     }
1721  return 0;
1722 }
1723
1724 /* Updates and caches the CV's */
1725 /* Returns:
1726  * 1 on success and there is some overload
1727  * 0 if there is no overload
1728  * -1 if some error occurred and it couldn't croak
1729  */
1730
1731 int
1732 Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
1733 {
1734   dVAR;
1735   MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1736   AMT amt;
1737   const struct mro_meta* stash_meta = HvMROMETA(stash);
1738   U32 newgen;
1739
1740   PERL_ARGS_ASSERT_GV_AMUPDATE;
1741
1742   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1743   if (mg) {
1744       const AMT * const amtp = (AMT*)mg->mg_ptr;
1745       if (amtp->was_ok_am == PL_amagic_generation
1746           && amtp->was_ok_sub == newgen) {
1747           return AMT_OVERLOADED(amtp) ? 1 : 0;
1748       }
1749       sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table);
1750   }
1751
1752   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1753
1754   Zero(&amt,1,AMT);
1755   amt.was_ok_am = PL_amagic_generation;
1756   amt.was_ok_sub = newgen;
1757   amt.fallback = AMGfallNO;
1758   amt.flags = 0;
1759
1760   {
1761     int filled = 0, have_ovl = 0;
1762     int i, lim = 1;
1763
1764     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1765
1766     /* Try to find via inheritance. */
1767     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1768     SV * const sv = gv ? GvSV(gv) : NULL;
1769     CV* cv;
1770
1771     if (!gv)
1772         lim = DESTROY_amg;              /* Skip overloading entries. */
1773 #ifdef PERL_DONT_CREATE_GVSV
1774     else if (!sv) {
1775         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
1776     }
1777 #endif
1778     else if (SvTRUE(sv))
1779         amt.fallback=AMGfallYES;
1780     else if (SvOK(sv))
1781         amt.fallback=AMGfallNEVER;
1782
1783     for (i = 1; i < lim; i++)
1784         amt.table[i] = NULL;
1785     for (; i < NofAMmeth; i++) {
1786         const char * const cooky = PL_AMG_names[i];
1787         /* Human-readable form, for debugging: */
1788         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1789         const STRLEN l = PL_AMG_namelens[i];
1790
1791         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1792                      cp, HvNAME_get(stash)) );
1793         /* don't fill the cache while looking up!
1794            Creation of inheritance stubs in intermediate packages may
1795            conflict with the logic of runtime method substitution.
1796            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1797            then we could have created stubs for "(+0" in A and C too.
1798            But if B overloads "bool", we may want to use it for
1799            numifying instead of C's "+0". */
1800         if (i >= DESTROY_amg)
1801             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1802         else                            /* Autoload taken care of below */
1803             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1804         cv = 0;
1805         if (gv && (cv = GvCV(gv))) {
1806             const char *hvname;
1807             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1808                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1809                 /* This is a hack to support autoloading..., while
1810                    knowing *which* methods were declared as overloaded. */
1811                 /* GvSV contains the name of the method. */
1812                 GV *ngv = NULL;
1813                 SV *gvsv = GvSV(gv);
1814
1815                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1816                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1817                              (void*)GvSV(gv), cp, hvname) );
1818                 if (!gvsv || !SvPOK(gvsv)
1819                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1820                                                        FALSE)))
1821                 {
1822                     /* Can be an import stub (created by "can"). */
1823                     if (destructing) {
1824                         return -1;
1825                     }
1826                     else {
1827                         const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
1828                         Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1829                                     "in package \"%.256s\"",
1830                                    (GvCVGEN(gv) ? "Stub found while resolving"
1831                                     : "Can't resolve"),
1832                                    name, cp, hvname);
1833                     }
1834                 }
1835                 cv = GvCV(gv = ngv);
1836             }
1837             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1838                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1839                          GvNAME(CvGV(cv))) );
1840             filled = 1;
1841             if (i < DESTROY_amg)
1842                 have_ovl = 1;
1843         } else if (gv) {                /* Autoloaded... */
1844             cv = MUTABLE_CV(gv);
1845             filled = 1;
1846         }
1847         amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv));
1848     }
1849     if (filled) {
1850       AMT_AMAGIC_on(&amt);
1851       if (have_ovl)
1852           AMT_OVERLOADED_on(&amt);
1853       sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
1854                                                 (char*)&amt, sizeof(AMT));
1855       return have_ovl;
1856     }
1857   }
1858   /* Here we have no table: */
1859   /* no_table: */
1860   AMT_AMAGIC_off(&amt);
1861   sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table,
1862                                                 (char*)&amt, sizeof(AMTS));
1863   return 0;
1864 }
1865
1866
1867 CV*
1868 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1869 {
1870     dVAR;
1871     MAGIC *mg;
1872     AMT *amtp;
1873     U32 newgen;
1874     struct mro_meta* stash_meta;
1875
1876     if (!stash || !HvNAME_get(stash))
1877         return NULL;
1878
1879     stash_meta = HvMROMETA(stash);
1880     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1881
1882     mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1883     if (!mg) {
1884       do_update:
1885         /* If we're looking up a destructor to invoke, we must avoid
1886          * that Gv_AMupdate croaks, because we might be dying already */
1887         if (Gv_AMupdate(stash, id == DESTROY_amg) == -1) {
1888             /* and if it didn't found a destructor, we fall back
1889              * to a simpler method that will only look for the
1890              * destructor instead of the whole magic */
1891             if (id == DESTROY_amg) {
1892                 GV * const gv = gv_fetchmethod(stash, "DESTROY");
1893                 if (gv)
1894                     return GvCV(gv);
1895             }
1896             return NULL;
1897         }
1898         mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
1899     }
1900     assert(mg);
1901     amtp = (AMT*)mg->mg_ptr;
1902     if ( amtp->was_ok_am != PL_amagic_generation
1903          || amtp->was_ok_sub != newgen )
1904         goto do_update;
1905     if (AMT_AMAGIC(amtp)) {
1906         CV * const ret = amtp->table[id];
1907         if (ret && isGV(ret)) {         /* Autoloading stab */
1908             /* Passing it through may have resulted in a warning
1909                "Inherited AUTOLOAD for a non-method deprecated", since
1910                our caller is going through a function call, not a method call.
1911                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1912             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1913
1914             if (gv && GvCV(gv))
1915                 return GvCV(gv);
1916         }
1917         return ret;
1918     }
1919
1920     return NULL;
1921 }
1922
1923
1924 /* Implement tryAMAGICun_MG macro.
1925    Do get magic, then see if the stack arg is overloaded and if so call it.
1926    Flags:
1927         AMGf_set     return the arg using SETs rather than assigning to
1928                      the targ
1929         AMGf_numeric apply sv_2num to the stack arg.
1930 */
1931
1932 bool
1933 Perl_try_amagic_un(pTHX_ int method, int flags) {
1934     dVAR;
1935     dSP;
1936     SV* tmpsv;
1937     SV* const arg = TOPs;
1938
1939     SvGETMAGIC(arg);
1940
1941     if (SvAMAGIC(arg) && (tmpsv = AMG_CALLun_var(arg,method))) {
1942         if (flags & AMGf_set) {
1943             SETs(tmpsv);
1944         }
1945         else {
1946             dTARGET;
1947             if (SvPADMY(TARG)) {
1948                 sv_setsv(TARG, tmpsv);
1949                 SETTARG;
1950             }
1951             else
1952                 SETs(tmpsv);
1953         }
1954         PUTBACK;
1955         return TRUE;
1956     }
1957
1958     if ((flags & AMGf_numeric) && SvROK(arg))
1959         *sp = sv_2num(arg);
1960     return FALSE;
1961 }
1962
1963
1964 /* Implement tryAMAGICbin_MG macro.
1965    Do get magic, then see if the two stack args are overloaded and if so
1966    call it.
1967    Flags:
1968         AMGf_set     return the arg using SETs rather than assigning to
1969                      the targ
1970         AMGf_assign  op may be called as mutator (eg +=)
1971         AMGf_numeric apply sv_2num to the stack arg.
1972 */
1973
1974 bool
1975 Perl_try_amagic_bin(pTHX_ int method, int flags) {
1976     dVAR;
1977     dSP;
1978     SV* const left = TOPm1s;
1979     SV* const right = TOPs;
1980
1981     SvGETMAGIC(left);
1982     if (left != right)
1983         SvGETMAGIC(right);
1984
1985     if (SvAMAGIC(left) || SvAMAGIC(right)) {
1986         SV * const tmpsv = amagic_call(left, right, method,
1987                     ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0));
1988         if (tmpsv) {
1989             if (flags & AMGf_set) {
1990                 (void)POPs;
1991                 SETs(tmpsv);
1992             }
1993             else {
1994                 dATARGET;
1995                 (void)POPs;
1996                 if (opASSIGN || SvPADMY(TARG)) {
1997                     sv_setsv(TARG, tmpsv);
1998                     SETTARG;
1999                 }
2000                 else
2001                     SETs(tmpsv);
2002             }
2003             PUTBACK;
2004             return TRUE;
2005         }
2006     }
2007     if (flags & AMGf_numeric) {
2008         if (SvROK(left))
2009             *(sp-1) = sv_2num(left);
2010         if (SvROK(right))
2011             *sp     = sv_2num(right);
2012     }
2013     return FALSE;
2014 }
2015
2016
2017 SV*
2018 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
2019 {
2020   dVAR;
2021   MAGIC *mg;
2022   CV *cv=NULL;
2023   CV **cvp=NULL, **ocvp=NULL;
2024   AMT *amtp=NULL, *oamtp=NULL;
2025   int off = 0, off1, lr = 0, notfound = 0;
2026   int postpr = 0, force_cpy = 0;
2027   int assign = AMGf_assign & flags;
2028   const int assignshift = assign ? 1 : 0;
2029 #ifdef DEBUGGING
2030   int fl=0;
2031 #endif
2032   HV* stash=NULL;
2033
2034   PERL_ARGS_ASSERT_AMAGIC_CALL;
2035
2036   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
2037       SV *lex_mask = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
2038                                               0, "overloading", 11, 0, 0);
2039
2040       if ( !lex_mask || !SvOK(lex_mask) )
2041           /* overloading lexically disabled */
2042           return NULL;
2043       else if ( lex_mask && SvPOK(lex_mask) ) {
2044           /* we have an entry in the hints hash, check if method has been
2045            * masked by overloading.pm */
2046           STRLEN len;
2047           const int offset = method / 8;
2048           const int bit    = method % 8;
2049           char *pv = SvPV(lex_mask, len);
2050
2051           /* Bit set, so this overloading operator is disabled */
2052           if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
2053               return NULL;
2054       }
2055   }
2056
2057   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
2058       && (stash = SvSTASH(SvRV(left)))
2059       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2060       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2061                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
2062                         : NULL))
2063       && ((cv = cvp[off=method+assignshift])
2064           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
2065                                                           * usual method */
2066                   (
2067 #ifdef DEBUGGING
2068                    fl = 1,
2069 #endif
2070                    cv = cvp[off=method])))) {
2071     lr = -1;                    /* Call method for left argument */
2072   } else {
2073     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
2074       int logic;
2075
2076       /* look for substituted methods */
2077       /* In all the covered cases we should be called with assign==0. */
2078          switch (method) {
2079          case inc_amg:
2080            force_cpy = 1;
2081            if ((cv = cvp[off=add_ass_amg])
2082                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
2083              right = &PL_sv_yes; lr = -1; assign = 1;
2084            }
2085            break;
2086          case dec_amg:
2087            force_cpy = 1;
2088            if ((cv = cvp[off = subtr_ass_amg])
2089                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
2090              right = &PL_sv_yes; lr = -1; assign = 1;
2091            }
2092            break;
2093          case bool__amg:
2094            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
2095            break;
2096          case numer_amg:
2097            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
2098            break;
2099          case string_amg:
2100            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
2101            break;
2102          case not_amg:
2103            (void)((cv = cvp[off=bool__amg])
2104                   || (cv = cvp[off=numer_amg])
2105                   || (cv = cvp[off=string_amg]));
2106            if (cv)
2107                postpr = 1;
2108            break;
2109          case copy_amg:
2110            {
2111              /*
2112                   * SV* ref causes confusion with the interpreter variable of
2113                   * the same name
2114                   */
2115              SV* const tmpRef=SvRV(left);
2116              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
2117                 /*
2118                  * Just to be extra cautious.  Maybe in some
2119                  * additional cases sv_setsv is safe, too.
2120                  */
2121                 SV* const newref = newSVsv(tmpRef);
2122                 SvOBJECT_on(newref);
2123                 /* As a bit of a source compatibility hack, SvAMAGIC() and
2124                    friends dereference an RV, to behave the same was as when
2125                    overloading was stored on the reference, not the referant.
2126                    Hence we can't use SvAMAGIC_on()
2127                 */
2128                 SvFLAGS(newref) |= SVf_AMAGIC;
2129                 SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
2130                 return newref;
2131              }
2132            }
2133            break;
2134          case abs_amg:
2135            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
2136                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
2137              SV* const nullsv=sv_2mortal(newSViv(0));
2138              if (off1==lt_amg) {
2139                SV* const lessp = amagic_call(left,nullsv,
2140                                        lt_amg,AMGf_noright);
2141                logic = SvTRUE(lessp);
2142              } else {
2143                SV* const lessp = amagic_call(left,nullsv,
2144                                        ncmp_amg,AMGf_noright);
2145                logic = (SvNV(lessp) < 0);
2146              }
2147              if (logic) {
2148                if (off==subtr_amg) {
2149                  right = left;
2150                  left = nullsv;
2151                  lr = 1;
2152                }
2153              } else {
2154                return left;
2155              }
2156            }
2157            break;
2158          case neg_amg:
2159            if ((cv = cvp[off=subtr_amg])) {
2160              right = left;
2161              left = sv_2mortal(newSViv(0));
2162              lr = 1;
2163            }
2164            break;
2165          case int_amg:
2166          case iter_amg:                 /* XXXX Eventually should do to_gv. */
2167          case ftest_amg:                /* XXXX Eventually should do to_gv. */
2168          case regexp_amg:
2169              /* FAIL safe */
2170              return NULL;       /* Delegate operation to standard mechanisms. */
2171              break;
2172          case to_sv_amg:
2173          case to_av_amg:
2174          case to_hv_amg:
2175          case to_gv_amg:
2176          case to_cv_amg:
2177              /* FAIL safe */
2178              return left;       /* Delegate operation to standard mechanisms. */
2179              break;
2180          default:
2181            goto not_found;
2182          }
2183          if (!cv) goto not_found;
2184     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
2185                && (stash = SvSTASH(SvRV(right)))
2186                && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
2187                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
2188                           ? (amtp = (AMT*)mg->mg_ptr)->table
2189                           : NULL))
2190                && (cv = cvp[off=method])) { /* Method for right
2191                                              * argument found */
2192       lr=1;
2193     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
2194                  && (cvp=ocvp) && (lr = -1))
2195                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
2196                && !(flags & AMGf_unary)) {
2197                                 /* We look for substitution for
2198                                  * comparison operations and
2199                                  * concatenation */
2200       if (method==concat_amg || method==concat_ass_amg
2201           || method==repeat_amg || method==repeat_ass_amg) {
2202         return NULL;            /* Delegate operation to string conversion */
2203       }
2204       off = -1;
2205       switch (method) {
2206          case lt_amg:
2207          case le_amg:
2208          case gt_amg:
2209          case ge_amg:
2210          case eq_amg:
2211          case ne_amg:
2212              off = ncmp_amg;
2213              break;
2214          case slt_amg:
2215          case sle_amg:
2216          case sgt_amg:
2217          case sge_amg:
2218          case seq_amg:
2219          case sne_amg:
2220              off = scmp_amg;
2221              break;
2222          }
2223       if ((off != -1) && (cv = cvp[off]))
2224           postpr = 1;
2225       else
2226           goto not_found;
2227     } else {
2228     not_found:                  /* No method found, either report or croak */
2229       switch (method) {
2230          case to_sv_amg:
2231          case to_av_amg:
2232          case to_hv_amg:
2233          case to_gv_amg:
2234          case to_cv_amg:
2235              /* FAIL safe */
2236              return left;       /* Delegate operation to standard mechanisms. */
2237              break;
2238       }
2239       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2240         notfound = 1; lr = -1;
2241       } else if (cvp && (cv=cvp[nomethod_amg])) {
2242         notfound = 1; lr = 1;
2243       } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
2244         /* Skip generating the "no method found" message.  */
2245         return NULL;
2246       } else {
2247         SV *msg;
2248         if (off==-1) off=method;
2249         msg = sv_2mortal(Perl_newSVpvf(aTHX_
2250                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
2251                       AMG_id2name(method + assignshift),
2252                       (flags & AMGf_unary ? " " : "\n\tleft "),
2253                       SvAMAGIC(left)?
2254                         "in overloaded package ":
2255                         "has no overloaded magic",
2256                       SvAMAGIC(left)?
2257                         HvNAME_get(SvSTASH(SvRV(left))):
2258                         "",
2259                       SvAMAGIC(right)?
2260                         ",\n\tright argument in overloaded package ":
2261                         (flags & AMGf_unary
2262                          ? ""
2263                          : ",\n\tright argument has no overloaded magic"),
2264                       SvAMAGIC(right)?
2265                         HvNAME_get(SvSTASH(SvRV(right))):
2266                         ""));
2267         if (amtp && amtp->fallback >= AMGfallYES) {
2268           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
2269         } else {
2270           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2271         }
2272         return NULL;
2273       }
2274       force_cpy = force_cpy || assign;
2275     }
2276   }
2277 #ifdef DEBUGGING
2278   if (!notfound) {
2279     DEBUG_o(Perl_deb(aTHX_
2280                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
2281                      AMG_id2name(off),
2282                      method+assignshift==off? "" :
2283                      " (initially \"",
2284                      method+assignshift==off? "" :
2285                      AMG_id2name(method+assignshift),
2286                      method+assignshift==off? "" : "\")",
2287                      flags & AMGf_unary? "" :
2288                      lr==1 ? " for right argument": " for left argument",
2289                      flags & AMGf_unary? " for argument" : "",
2290                      stash ? HvNAME_get(stash) : "null",
2291                      fl? ",\n\tassignment variant used": "") );
2292   }
2293 #endif
2294     /* Since we use shallow copy during assignment, we need
2295      * to dublicate the contents, probably calling user-supplied
2296      * version of copy operator
2297      */
2298     /* We need to copy in following cases:
2299      * a) Assignment form was called.
2300      *          assignshift==1,  assign==T, method + 1 == off
2301      * b) Increment or decrement, called directly.
2302      *          assignshift==0,  assign==0, method + 0 == off
2303      * c) Increment or decrement, translated to assignment add/subtr.
2304      *          assignshift==0,  assign==T,
2305      *          force_cpy == T
2306      * d) Increment or decrement, translated to nomethod.
2307      *          assignshift==0,  assign==0,
2308      *          force_cpy == T
2309      * e) Assignment form translated to nomethod.
2310      *          assignshift==1,  assign==T, method + 1 != off
2311      *          force_cpy == T
2312      */
2313     /*  off is method, method+assignshift, or a result of opcode substitution.
2314      *  In the latter case assignshift==0, so only notfound case is important.
2315      */
2316   if (( (method + assignshift == off)
2317         && (assign || (method == inc_amg) || (method == dec_amg)))
2318       || force_cpy)
2319   {
2320     RvDEEPCP(left);
2321   }
2322
2323   {
2324     dSP;
2325     BINOP myop;
2326     SV* res;
2327     const bool oldcatch = CATCH_GET;
2328
2329     CATCH_SET(TRUE);
2330     Zero(&myop, 1, BINOP);
2331     myop.op_last = (OP *) &myop;
2332     myop.op_next = NULL;
2333     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2334
2335     PUSHSTACKi(PERLSI_OVERLOAD);
2336     ENTER;
2337     SAVEOP();
2338     PL_op = (OP *) &myop;
2339     if (PERLDB_SUB && PL_curstash != PL_debstash)
2340         PL_op->op_private |= OPpENTERSUB_DB;
2341     PUTBACK;
2342     pp_pushmark();
2343
2344     EXTEND(SP, notfound + 5);
2345     PUSHs(lr>0? right: left);
2346     PUSHs(lr>0? left: right);
2347     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2348     if (notfound) {
2349       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2350                            AMG_id2namelen(method + assignshift), SVs_TEMP));
2351     }
2352     PUSHs(MUTABLE_SV(cv));
2353     PUTBACK;
2354
2355     if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX)))
2356       CALLRUNOPS(aTHX);
2357     LEAVE;
2358     SPAGAIN;
2359
2360     res=POPs;
2361     PUTBACK;
2362     POPSTACK;
2363     CATCH_SET(oldcatch);
2364
2365     if (postpr) {
2366       int ans;
2367       switch (method) {
2368       case le_amg:
2369       case sle_amg:
2370         ans=SvIV(res)<=0; break;
2371       case lt_amg:
2372       case slt_amg:
2373         ans=SvIV(res)<0; break;
2374       case ge_amg:
2375       case sge_amg:
2376         ans=SvIV(res)>=0; break;
2377       case gt_amg:
2378       case sgt_amg:
2379         ans=SvIV(res)>0; break;
2380       case eq_amg:
2381       case seq_amg:
2382         ans=SvIV(res)==0; break;
2383       case ne_amg:
2384       case sne_amg:
2385         ans=SvIV(res)!=0; break;
2386       case inc_amg:
2387       case dec_amg:
2388         SvSetSV(left,res); return left;
2389       case not_amg:
2390         ans=!SvTRUE(res); break;
2391       default:
2392         ans=0; break;
2393       }
2394       return boolSV(ans);
2395     } else if (method==copy_amg) {
2396       if (!SvROK(res)) {
2397         Perl_croak(aTHX_ "Copy method did not return a reference");
2398       }
2399       return SvREFCNT_inc(SvRV(res));
2400     } else {
2401       return res;
2402     }
2403   }
2404 }
2405
2406 /*
2407 =for apidoc is_gv_magical_sv
2408
2409 Returns C<TRUE> if given the name of a magical GV.
2410
2411 Currently only useful internally when determining if a GV should be
2412 created even in rvalue contexts.
2413
2414 C<flags> is not used at present but available for future extension to
2415 allow selecting particular classes of magical variable.
2416
2417 Currently assumes that C<name> is NUL terminated (as well as len being valid).
2418 This assumption is met by all callers within the perl core, which all pass
2419 pointers returned by SvPV.
2420
2421 =cut
2422 */
2423
2424 bool
2425 Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags)
2426 {
2427     STRLEN len;
2428     const char *const name = SvPV_const(name_sv, len);
2429
2430     PERL_UNUSED_ARG(flags);
2431     PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV;
2432
2433     if (len > 1) {
2434         const char * const name1 = name + 1;
2435         switch (*name) {
2436         case 'I':
2437             if (len == 3 && name[1] == 'S' && name[2] == 'A')
2438                 goto yes;
2439             break;
2440         case 'O':
2441             if (len == 8 && strEQ(name1, "VERLOAD"))
2442                 goto yes;
2443             break;
2444         case 'S':
2445             if (len == 3 && name[1] == 'I' && name[2] == 'G')
2446                 goto yes;
2447             break;
2448             /* Using ${^...} variables is likely to be sufficiently rare that
2449                it seems sensible to avoid the space hit of also checking the
2450                length.  */
2451         case '\017':   /* ${^OPEN} */
2452             if (strEQ(name1, "PEN"))
2453                 goto yes;
2454             break;
2455         case '\024':   /* ${^TAINT} */
2456             if (strEQ(name1, "AINT"))
2457                 goto yes;
2458             break;
2459         case '\025':    /* ${^UNICODE} */
2460             if (strEQ(name1, "NICODE"))
2461                 goto yes;
2462             if (strEQ(name1, "TF8LOCALE"))
2463                 goto yes;
2464             break;
2465         case '\027':   /* ${^WARNING_BITS} */
2466             if (strEQ(name1, "ARNING_BITS"))
2467                 goto yes;
2468             break;
2469         case '1':
2470         case '2':
2471         case '3':
2472         case '4':
2473         case '5':
2474         case '6':
2475         case '7':
2476         case '8':
2477         case '9':
2478         {
2479             const char *end = name + len;
2480             while (--end > name) {
2481                 if (!isDIGIT(*end))
2482                     return FALSE;
2483             }
2484             goto yes;
2485         }
2486         }
2487     } else {
2488         /* Because we're already assuming that name is NUL terminated
2489            below, we can treat an empty name as "\0"  */
2490         switch (*name) {
2491         case '&':
2492         case '`':
2493         case '\'':
2494         case ':':
2495         case '?':
2496         case '!':
2497         case '-':
2498         case '#':
2499         case '[':
2500         case '^':
2501         case '~':
2502         case '=':
2503         case '%':
2504         case '.':
2505         case '(':
2506         case ')':
2507         case '<':
2508         case '>':
2509         case '\\':
2510         case '/':
2511         case '|':
2512         case '+':
2513         case ';':
2514         case ']':
2515         case '\001':   /* $^A */
2516         case '\003':   /* $^C */
2517         case '\004':   /* $^D */
2518         case '\005':   /* $^E */
2519         case '\006':   /* $^F */
2520         case '\010':   /* $^H */
2521         case '\011':   /* $^I, NOT \t in EBCDIC */
2522         case '\014':   /* $^L */
2523         case '\016':   /* $^N */
2524         case '\017':   /* $^O */
2525         case '\020':   /* $^P */
2526         case '\023':   /* $^S */
2527         case '\024':   /* $^T */
2528         case '\026':   /* $^V */
2529         case '\027':   /* $^W */
2530         case '1':
2531         case '2':
2532         case '3':
2533         case '4':
2534         case '5':
2535         case '6':
2536         case '7':
2537         case '8':
2538         case '9':
2539         yes:
2540             return TRUE;
2541         default:
2542             break;
2543         }
2544     }
2545     return FALSE;
2546 }
2547
2548 void
2549 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2550 {
2551     dVAR;
2552     U32 hash;
2553
2554     PERL_ARGS_ASSERT_GV_NAME_SET;
2555     PERL_UNUSED_ARG(flags);
2556
2557     if (len > I32_MAX)
2558         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2559
2560     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2561         unshare_hek(GvNAME_HEK(gv));
2562     }
2563
2564     PERL_HASH(hash, name, len);
2565     GvNAME_HEK(gv) = share_hek(name, len, hash);
2566 }
2567
2568 /*
2569 =for apidoc gv_try_downgrade
2570
2571 If the typeglob C<gv> can be expressed more succinctly, by having
2572 something other than a real GV in its place in the stash, replace it
2573 with the optimised form.  Basic requirements for this are that C<gv>
2574 is a real typeglob, is sufficiently ordinary, and is only referenced
2575 from its package.  This function is meant to be used when a GV has been
2576 looked up in part to see what was there, causing upgrading, but based
2577 on what was found it turns out that the real GV isn't required after all.
2578
2579 If C<gv> is a completely empty typeglob, it is deleted from the stash.
2580
2581 If C<gv> is a typeglob containing only a sufficiently-ordinary constant
2582 sub, the typeglob is replaced with a scalar-reference placeholder that
2583 more compactly represents the same thing.
2584
2585 =cut
2586 */
2587
2588 void
2589 Perl_gv_try_downgrade(pTHX_ GV *gv)
2590 {
2591     HV *stash;
2592     CV *cv;
2593     HEK *namehek;
2594     SV **gvp;
2595     PERL_ARGS_ASSERT_GV_TRY_DOWNGRADE;
2596     if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) &&
2597             !SvOBJECT(gv) && !SvREADONLY(gv) &&
2598             isGV_with_GP(gv) && GvGP(gv) &&
2599             !GvINTRO(gv) && GvREFCNT(gv) == 1 &&
2600             !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) &&
2601             GvEGVx(gv) == gv && (stash = GvSTASH(gv))))
2602         return;
2603     if (SvMAGICAL(gv)) {
2604         MAGIC *mg;
2605         /* only backref magic is allowed */
2606         if (SvGMAGICAL(gv) || SvSMAGICAL(gv))
2607             return;
2608         for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) {
2609             if (mg->mg_type != PERL_MAGIC_backref)
2610                 return;
2611         }
2612     }
2613     cv = GvCV(gv);
2614     if (!cv) {
2615         HEK *gvnhek = GvNAME_HEK(gv);
2616         (void)hv_delete(stash, HEK_KEY(gvnhek),
2617             HEK_UTF8(gvnhek) ? -HEK_LEN(gvnhek) : HEK_LEN(gvnhek), G_DISCARD);
2618     } else if (GvMULTI(gv) && cv &&
2619             !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) &&
2620             CvSTASH(cv) == stash && CvGV(cv) == gv &&
2621             CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) &&
2622             !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) &&
2623             (namehek = GvNAME_HEK(gv)) &&
2624             (gvp = hv_fetch(stash, HEK_KEY(namehek),
2625                         HEK_LEN(namehek)*(HEK_UTF8(namehek) ? -1 : 1), 0)) &&
2626             *gvp == (SV*)gv) {
2627         SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr);
2628         SvREFCNT(gv) = 0;
2629         sv_clear((SV*)gv);
2630         SvREFCNT(gv) = 1;
2631         SvFLAGS(gv) = SVt_IV|SVf_ROK;
2632         SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) -
2633                                 STRUCT_OFFSET(XPVIV, xiv_iv));
2634         SvRV_set(gv, value);
2635     }
2636 }
2637
2638 /*
2639  * Local variables:
2640  * c-indentation-style: bsd
2641  * c-basic-offset: 4
2642  * indent-tabs-mode: t
2643  * End:
2644  *
2645  * ex: set ts=8 sts=4 sw=4 noet:
2646  */