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(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   U32 newgen;
1513
1514   newgen = PL_sub_generation + HvMROMETA(stash)->cache_gen;
1515   if (mg) {
1516       const AMT * const amtp = (AMT*)mg->mg_ptr;
1517       if (amtp->was_ok_am == PL_amagic_generation
1518           && amtp->was_ok_sub == newgen) {
1519           return (bool)AMT_OVERLOADED(amtp);
1520       }
1521       sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1522   }
1523
1524   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1525
1526   Zero(&amt,1,AMT);
1527   amt.was_ok_am = PL_amagic_generation;
1528   amt.was_ok_sub = newgen;
1529   amt.fallback = AMGfallNO;
1530   amt.flags = 0;
1531
1532   {
1533     int filled = 0, have_ovl = 0;
1534     int i, lim = 1;
1535
1536     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1537
1538     /* Try to find via inheritance. */
1539     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1540     SV * const sv = gv ? GvSV(gv) : NULL;
1541     CV* cv;
1542
1543     if (!gv)
1544         lim = DESTROY_amg;              /* Skip overloading entries. */
1545 #ifdef PERL_DONT_CREATE_GVSV
1546     else if (!sv) {
1547         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
1548     }
1549 #endif
1550     else if (SvTRUE(sv))
1551         amt.fallback=AMGfallYES;
1552     else if (SvOK(sv))
1553         amt.fallback=AMGfallNEVER;
1554
1555     for (i = 1; i < lim; i++)
1556         amt.table[i] = NULL;
1557     for (; i < NofAMmeth; i++) {
1558         const char * const cooky = PL_AMG_names[i];
1559         /* Human-readable form, for debugging: */
1560         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1561         const STRLEN l = strlen(cooky);
1562
1563         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1564                      cp, HvNAME_get(stash)) );
1565         /* don't fill the cache while looking up!
1566            Creation of inheritance stubs in intermediate packages may
1567            conflict with the logic of runtime method substitution.
1568            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1569            then we could have created stubs for "(+0" in A and C too.
1570            But if B overloads "bool", we may want to use it for
1571            numifying instead of C's "+0". */
1572         if (i >= DESTROY_amg)
1573             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1574         else                            /* Autoload taken care of below */
1575             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1576         cv = 0;
1577         if (gv && (cv = GvCV(gv))) {
1578             const char *hvname;
1579             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1580                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1581                 /* This is a hack to support autoloading..., while
1582                    knowing *which* methods were declared as overloaded. */
1583                 /* GvSV contains the name of the method. */
1584                 GV *ngv = NULL;
1585                 SV *gvsv = GvSV(gv);
1586
1587                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1588                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1589                              (void*)GvSV(gv), cp, hvname) );
1590                 if (!gvsv || !SvPOK(gvsv)
1591                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1592                                                        FALSE)))
1593                 {
1594                     /* Can be an import stub (created by "can"). */
1595                     const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
1596                     Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1597                                 "in package \"%.256s\"",
1598                                (GvCVGEN(gv) ? "Stub found while resolving"
1599                                 : "Can't resolve"),
1600                                name, cp, hvname);
1601                 }
1602                 cv = GvCV(gv = ngv);
1603             }
1604             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1605                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1606                          GvNAME(CvGV(cv))) );
1607             filled = 1;
1608             if (i < DESTROY_amg)
1609                 have_ovl = 1;
1610         } else if (gv) {                /* Autoloaded... */
1611             cv = (CV*)gv;
1612             filled = 1;
1613         }
1614         amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
1615     }
1616     if (filled) {
1617       AMT_AMAGIC_on(&amt);
1618       if (have_ovl)
1619           AMT_OVERLOADED_on(&amt);
1620       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1621                                                 (char*)&amt, sizeof(AMT));
1622       return have_ovl;
1623     }
1624   }
1625   /* Here we have no table: */
1626   /* no_table: */
1627   AMT_AMAGIC_off(&amt);
1628   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1629                                                 (char*)&amt, sizeof(AMTS));
1630   return FALSE;
1631 }
1632
1633
1634 CV*
1635 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1636 {
1637     dVAR;
1638     MAGIC *mg;
1639     AMT *amtp;
1640     U32 newgen;
1641
1642     if (!stash || !HvNAME_get(stash))
1643         return NULL;
1644
1645     newgen = PL_sub_generation + HvMROMETA(stash)->cache_gen;
1646
1647     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1648     if (!mg) {
1649       do_update:
1650         Gv_AMupdate(stash);
1651         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1652     }
1653     assert(mg);
1654     amtp = (AMT*)mg->mg_ptr;
1655     if ( amtp->was_ok_am != PL_amagic_generation
1656          || amtp->was_ok_sub != newgen )
1657         goto do_update;
1658     if (AMT_AMAGIC(amtp)) {
1659         CV * const ret = amtp->table[id];
1660         if (ret && isGV(ret)) {         /* Autoloading stab */
1661             /* Passing it through may have resulted in a warning
1662                "Inherited AUTOLOAD for a non-method deprecated", since
1663                our caller is going through a function call, not a method call.
1664                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1665             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1666
1667             if (gv && GvCV(gv))
1668                 return GvCV(gv);
1669         }
1670         return ret;
1671     }
1672
1673     return NULL;
1674 }
1675
1676
1677 SV*
1678 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1679 {
1680   dVAR;
1681   MAGIC *mg;
1682   CV *cv=NULL;
1683   CV **cvp=NULL, **ocvp=NULL;
1684   AMT *amtp=NULL, *oamtp=NULL;
1685   int off = 0, off1, lr = 0, notfound = 0;
1686   int postpr = 0, force_cpy = 0;
1687   int assign = AMGf_assign & flags;
1688   const int assignshift = assign ? 1 : 0;
1689 #ifdef DEBUGGING
1690   int fl=0;
1691 #endif
1692   HV* stash=NULL;
1693   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1694       && (stash = SvSTASH(SvRV(left)))
1695       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1696       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1697                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1698                         : NULL))
1699       && ((cv = cvp[off=method+assignshift])
1700           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1701                                                           * usual method */
1702                   (
1703 #ifdef DEBUGGING
1704                    fl = 1,
1705 #endif
1706                    cv = cvp[off=method])))) {
1707     lr = -1;                    /* Call method for left argument */
1708   } else {
1709     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1710       int logic;
1711
1712       /* look for substituted methods */
1713       /* In all the covered cases we should be called with assign==0. */
1714          switch (method) {
1715          case inc_amg:
1716            force_cpy = 1;
1717            if ((cv = cvp[off=add_ass_amg])
1718                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1719              right = &PL_sv_yes; lr = -1; assign = 1;
1720            }
1721            break;
1722          case dec_amg:
1723            force_cpy = 1;
1724            if ((cv = cvp[off = subtr_ass_amg])
1725                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1726              right = &PL_sv_yes; lr = -1; assign = 1;
1727            }
1728            break;
1729          case bool__amg:
1730            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1731            break;
1732          case numer_amg:
1733            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1734            break;
1735          case string_amg:
1736            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1737            break;
1738          case not_amg:
1739            (void)((cv = cvp[off=bool__amg])
1740                   || (cv = cvp[off=numer_amg])
1741                   || (cv = cvp[off=string_amg]));
1742            postpr = 1;
1743            break;
1744          case copy_amg:
1745            {
1746              /*
1747                   * SV* ref causes confusion with the interpreter variable of
1748                   * the same name
1749                   */
1750              SV* const tmpRef=SvRV(left);
1751              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1752                 /*
1753                  * Just to be extra cautious.  Maybe in some
1754                  * additional cases sv_setsv is safe, too.
1755                  */
1756                 SV* const newref = newSVsv(tmpRef);
1757                 SvOBJECT_on(newref);
1758                 /* As a bit of a source compatibility hack, SvAMAGIC() and
1759                    friends dereference an RV, to behave the same was as when
1760                    overloading was stored on the reference, not the referant.
1761                    Hence we can't use SvAMAGIC_on()
1762                 */
1763                 SvFLAGS(newref) |= SVf_AMAGIC;
1764                 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1765                 return newref;
1766              }
1767            }
1768            break;
1769          case abs_amg:
1770            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1771                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1772              SV* const nullsv=sv_2mortal(newSViv(0));
1773              if (off1==lt_amg) {
1774                SV* const lessp = amagic_call(left,nullsv,
1775                                        lt_amg,AMGf_noright);
1776                logic = SvTRUE(lessp);
1777              } else {
1778                SV* const lessp = amagic_call(left,nullsv,
1779                                        ncmp_amg,AMGf_noright);
1780                logic = (SvNV(lessp) < 0);
1781              }
1782              if (logic) {
1783                if (off==subtr_amg) {
1784                  right = left;
1785                  left = nullsv;
1786                  lr = 1;
1787                }
1788              } else {
1789                return left;
1790              }
1791            }
1792            break;
1793          case neg_amg:
1794            if ((cv = cvp[off=subtr_amg])) {
1795              right = left;
1796              left = sv_2mortal(newSViv(0));
1797              lr = 1;
1798            }
1799            break;
1800          case int_amg:
1801          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1802              /* FAIL safe */
1803              return NULL;       /* Delegate operation to standard mechanisms. */
1804              break;
1805          case to_sv_amg:
1806          case to_av_amg:
1807          case to_hv_amg:
1808          case to_gv_amg:
1809          case to_cv_amg:
1810              /* FAIL safe */
1811              return left;       /* Delegate operation to standard mechanisms. */
1812              break;
1813          default:
1814            goto not_found;
1815          }
1816          if (!cv) goto not_found;
1817     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1818                && (stash = SvSTASH(SvRV(right)))
1819                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1820                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1821                           ? (amtp = (AMT*)mg->mg_ptr)->table
1822                           : NULL))
1823                && (cv = cvp[off=method])) { /* Method for right
1824                                              * argument found */
1825       lr=1;
1826     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1827                  && (cvp=ocvp) && (lr = -1))
1828                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1829                && !(flags & AMGf_unary)) {
1830                                 /* We look for substitution for
1831                                  * comparison operations and
1832                                  * concatenation */
1833       if (method==concat_amg || method==concat_ass_amg
1834           || method==repeat_amg || method==repeat_ass_amg) {
1835         return NULL;            /* Delegate operation to string conversion */
1836       }
1837       off = -1;
1838       switch (method) {
1839          case lt_amg:
1840          case le_amg:
1841          case gt_amg:
1842          case ge_amg:
1843          case eq_amg:
1844          case ne_amg:
1845            postpr = 1; off=ncmp_amg; break;
1846          case slt_amg:
1847          case sle_amg:
1848          case sgt_amg:
1849          case sge_amg:
1850          case seq_amg:
1851          case sne_amg:
1852            postpr = 1; off=scmp_amg; break;
1853          }
1854       if (off != -1) cv = cvp[off];
1855       if (!cv) {
1856         goto not_found;
1857       }
1858     } else {
1859     not_found:                  /* No method found, either report or croak */
1860       switch (method) {
1861          case lt_amg:
1862          case le_amg:
1863          case gt_amg:
1864          case ge_amg:
1865          case eq_amg:
1866          case ne_amg:
1867          case slt_amg:
1868          case sle_amg:
1869          case sgt_amg:
1870          case sge_amg:
1871          case seq_amg:
1872          case sne_amg:
1873            postpr = 0; break;
1874          case to_sv_amg:
1875          case to_av_amg:
1876          case to_hv_amg:
1877          case to_gv_amg:
1878          case to_cv_amg:
1879              /* FAIL safe */
1880              return left;       /* Delegate operation to standard mechanisms. */
1881              break;
1882       }
1883       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1884         notfound = 1; lr = -1;
1885       } else if (cvp && (cv=cvp[nomethod_amg])) {
1886         notfound = 1; lr = 1;
1887       } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
1888         /* Skip generating the "no method found" message.  */
1889         return NULL;
1890       } else {
1891         SV *msg;
1892         if (off==-1) off=method;
1893         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1894                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
1895                       AMG_id2name(method + assignshift),
1896                       (flags & AMGf_unary ? " " : "\n\tleft "),
1897                       SvAMAGIC(left)?
1898                         "in overloaded package ":
1899                         "has no overloaded magic",
1900                       SvAMAGIC(left)?
1901                         HvNAME_get(SvSTASH(SvRV(left))):
1902                         "",
1903                       SvAMAGIC(right)?
1904                         ",\n\tright argument in overloaded package ":
1905                         (flags & AMGf_unary
1906                          ? ""
1907                          : ",\n\tright argument has no overloaded magic"),
1908                       SvAMAGIC(right)?
1909                         HvNAME_get(SvSTASH(SvRV(right))):
1910                         ""));
1911         if (amtp && amtp->fallback >= AMGfallYES) {
1912           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1913         } else {
1914           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
1915         }
1916         return NULL;
1917       }
1918       force_cpy = force_cpy || assign;
1919     }
1920   }
1921 #ifdef DEBUGGING
1922   if (!notfound) {
1923     DEBUG_o(Perl_deb(aTHX_
1924                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1925                      AMG_id2name(off),
1926                      method+assignshift==off? "" :
1927                      " (initially \"",
1928                      method+assignshift==off? "" :
1929                      AMG_id2name(method+assignshift),
1930                      method+assignshift==off? "" : "\")",
1931                      flags & AMGf_unary? "" :
1932                      lr==1 ? " for right argument": " for left argument",
1933                      flags & AMGf_unary? " for argument" : "",
1934                      stash ? HvNAME_get(stash) : "null",
1935                      fl? ",\n\tassignment variant used": "") );
1936   }
1937 #endif
1938     /* Since we use shallow copy during assignment, we need
1939      * to dublicate the contents, probably calling user-supplied
1940      * version of copy operator
1941      */
1942     /* We need to copy in following cases:
1943      * a) Assignment form was called.
1944      *          assignshift==1,  assign==T, method + 1 == off
1945      * b) Increment or decrement, called directly.
1946      *          assignshift==0,  assign==0, method + 0 == off
1947      * c) Increment or decrement, translated to assignment add/subtr.
1948      *          assignshift==0,  assign==T,
1949      *          force_cpy == T
1950      * d) Increment or decrement, translated to nomethod.
1951      *          assignshift==0,  assign==0,
1952      *          force_cpy == T
1953      * e) Assignment form translated to nomethod.
1954      *          assignshift==1,  assign==T, method + 1 != off
1955      *          force_cpy == T
1956      */
1957     /*  off is method, method+assignshift, or a result of opcode substitution.
1958      *  In the latter case assignshift==0, so only notfound case is important.
1959      */
1960   if (( (method + assignshift == off)
1961         && (assign || (method == inc_amg) || (method == dec_amg)))
1962       || force_cpy)
1963     RvDEEPCP(left);
1964   {
1965     dSP;
1966     BINOP myop;
1967     SV* res;
1968     const bool oldcatch = CATCH_GET;
1969
1970     CATCH_SET(TRUE);
1971     Zero(&myop, 1, BINOP);
1972     myop.op_last = (OP *) &myop;
1973     myop.op_next = NULL;
1974     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1975
1976     PUSHSTACKi(PERLSI_OVERLOAD);
1977     ENTER;
1978     SAVEOP();
1979     PL_op = (OP *) &myop;
1980     if (PERLDB_SUB && PL_curstash != PL_debstash)
1981         PL_op->op_private |= OPpENTERSUB_DB;
1982     PUTBACK;
1983     pp_pushmark();
1984
1985     EXTEND(SP, notfound + 5);
1986     PUSHs(lr>0? right: left);
1987     PUSHs(lr>0? left: right);
1988     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1989     if (notfound) {
1990       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1991     }
1992     PUSHs((SV*)cv);
1993     PUTBACK;
1994
1995     if ((PL_op = Perl_pp_entersub(aTHX)))
1996       CALLRUNOPS(aTHX);
1997     LEAVE;
1998     SPAGAIN;
1999
2000     res=POPs;
2001     PUTBACK;
2002     POPSTACK;
2003     CATCH_SET(oldcatch);
2004
2005     if (postpr) {
2006       int ans;
2007       switch (method) {
2008       case le_amg:
2009       case sle_amg:
2010         ans=SvIV(res)<=0; break;
2011       case lt_amg:
2012       case slt_amg:
2013         ans=SvIV(res)<0; break;
2014       case ge_amg:
2015       case sge_amg:
2016         ans=SvIV(res)>=0; break;
2017       case gt_amg:
2018       case sgt_amg:
2019         ans=SvIV(res)>0; break;
2020       case eq_amg:
2021       case seq_amg:
2022         ans=SvIV(res)==0; break;
2023       case ne_amg:
2024       case sne_amg:
2025         ans=SvIV(res)!=0; break;
2026       case inc_amg:
2027       case dec_amg:
2028         SvSetSV(left,res); return left;
2029       case not_amg:
2030         ans=!SvTRUE(res); break;
2031       default:
2032         ans=0; break;
2033       }
2034       return boolSV(ans);
2035     } else if (method==copy_amg) {
2036       if (!SvROK(res)) {
2037         Perl_croak(aTHX_ "Copy method did not return a reference");
2038       }
2039       return SvREFCNT_inc(SvRV(res));
2040     } else {
2041       return res;
2042     }
2043   }
2044 }
2045
2046 /*
2047 =for apidoc is_gv_magical_sv
2048
2049 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
2050
2051 =cut
2052 */
2053
2054 bool
2055 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
2056 {
2057     STRLEN len;
2058     const char * const temp = SvPV_const(name, len);
2059     return is_gv_magical(temp, len, flags);
2060 }
2061
2062 /*
2063 =for apidoc is_gv_magical
2064
2065 Returns C<TRUE> if given the name of a magical GV.
2066
2067 Currently only useful internally when determining if a GV should be
2068 created even in rvalue contexts.
2069
2070 C<flags> is not used at present but available for future extension to
2071 allow selecting particular classes of magical variable.
2072
2073 Currently assumes that C<name> is NUL terminated (as well as len being valid).
2074 This assumption is met by all callers within the perl core, which all pass
2075 pointers returned by SvPV.
2076
2077 =cut
2078 */
2079 bool
2080 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
2081 {
2082     PERL_UNUSED_CONTEXT;
2083     PERL_UNUSED_ARG(flags);
2084
2085     if (len > 1) {
2086         const char * const name1 = name + 1;
2087         switch (*name) {
2088         case 'I':
2089             if (len == 3 && name1[1] == 'S' && name[2] == 'A')
2090                 goto yes;
2091             break;
2092         case 'O':
2093             if (len == 8 && strEQ(name1, "VERLOAD"))
2094                 goto yes;
2095             break;
2096         case 'S':
2097             if (len == 3 && name[1] == 'I' && name[2] == 'G')
2098                 goto yes;
2099             break;
2100             /* Using ${^...} variables is likely to be sufficiently rare that
2101                it seems sensible to avoid the space hit of also checking the
2102                length.  */
2103         case '\017':   /* ${^OPEN} */
2104             if (strEQ(name1, "PEN"))
2105                 goto yes;
2106             break;
2107         case '\024':   /* ${^TAINT} */
2108             if (strEQ(name1, "AINT"))
2109                 goto yes;
2110             break;
2111         case '\025':    /* ${^UNICODE} */
2112             if (strEQ(name1, "NICODE"))
2113                 goto yes;
2114             if (strEQ(name1, "TF8LOCALE"))
2115                 goto yes;
2116             break;
2117         case '\027':   /* ${^WARNING_BITS} */
2118             if (strEQ(name1, "ARNING_BITS"))
2119                 goto yes;
2120             break;
2121         case '1':
2122         case '2':
2123         case '3':
2124         case '4':
2125         case '5':
2126         case '6':
2127         case '7':
2128         case '8':
2129         case '9':
2130         {
2131             const char *end = name + len;
2132             while (--end > name) {
2133                 if (!isDIGIT(*end))
2134                     return FALSE;
2135             }
2136             goto yes;
2137         }
2138         }
2139     } else {
2140         /* Because we're already assuming that name is NUL terminated
2141            below, we can treat an empty name as "\0"  */
2142         switch (*name) {
2143         case '&':
2144         case '`':
2145         case '\'':
2146         case ':':
2147         case '?':
2148         case '!':
2149         case '-':
2150         case '#':
2151         case '[':
2152         case '^':
2153         case '~':
2154         case '=':
2155         case '%':
2156         case '.':
2157         case '(':
2158         case ')':
2159         case '<':
2160         case '>':
2161         case ',':
2162         case '\\':
2163         case '/':
2164         case '|':
2165         case '+':
2166         case ';':
2167         case ']':
2168         case '\001':   /* $^A */
2169         case '\003':   /* $^C */
2170         case '\004':   /* $^D */
2171         case '\005':   /* $^E */
2172         case '\006':   /* $^F */
2173         case '\010':   /* $^H */
2174         case '\011':   /* $^I, NOT \t in EBCDIC */
2175         case '\014':   /* $^L */
2176         case '\016':   /* $^N */
2177         case '\017':   /* $^O */
2178         case '\020':   /* $^P */
2179         case '\023':   /* $^S */
2180         case '\024':   /* $^T */
2181         case '\026':   /* $^V */
2182         case '\027':   /* $^W */
2183         case '1':
2184         case '2':
2185         case '3':
2186         case '4':
2187         case '5':
2188         case '6':
2189         case '7':
2190         case '8':
2191         case '9':
2192         yes:
2193             return TRUE;
2194         default:
2195             break;
2196         }
2197     }
2198     return FALSE;
2199 }
2200
2201 void
2202 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2203 {
2204     dVAR;
2205     U32 hash;
2206
2207     assert(name);
2208     PERL_UNUSED_ARG(flags);
2209
2210     if (len > I32_MAX)
2211         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2212
2213     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2214         unshare_hek(GvNAME_HEK(gv));
2215     }
2216
2217     PERL_HASH(hash, name, len);
2218     GvNAME_HEK(gv) = share_hek(name, len, hash);
2219 }
2220
2221 /*
2222  * Local variables:
2223  * c-indentation-style: bsd
2224  * c-basic-offset: 4
2225  * indent-tabs-mode: t
2226  * End:
2227  *
2228  * ex: set ts=8 sts=4 sw=4 noet:
2229  */