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