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