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