gv.c

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