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("re::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
1202             break;
1203         case '-':
1204         case '+':
1205         GvMULTI_on(gv); /* no used once warnings here */
1206         {
1207             bool plus = (*name == '+');
1208             SV *stashname = newSVpvs("re::Tie::Hash::NamedCapture");
1209             AV* const av = GvAVn(gv);
1210             HV *const hv = GvHVn(gv);
1211             HV *const hv_tie = newHV();
1212             SV *tie = newRV_noinc((SV*)hv_tie);
1213
1214             sv_bless(tie, gv_stashsv(stashname, GV_ADD));
1215             hv_magic(hv, (GV*)tie, PERL_MAGIC_tied);
1216             sv_magic((SV*)av, (plus ? (SV*)av : NULL), PERL_MAGIC_regdata, NULL, 0);
1217             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1218
1219             if (plus)
1220                 SvREADONLY_on(GvSVn(gv));
1221             else
1222                 Perl_hv_store(aTHX_ hv_tie, STR_WITH_LEN("all"), newSViv(1), 0);
1223
1224             SvREADONLY_on(hv);
1225             SvREADONLY_on(tie);
1226             SvREADONLY_on(av);
1227
1228             require_tie_mod(gv, name, stashname, "FETCH", 0);
1229
1230             break;
1231         }
1232         case '*':
1233         case '#':
1234             if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1235                 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1236                             "$%c is no longer supported", *name);
1237             break;
1238         case '|':
1239             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1240             goto magicalize;
1241
1242         case '\010':    /* $^H */
1243             {
1244                 HV *const hv = GvHVn(gv);
1245                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1246             }
1247             goto magicalize;
1248         case '\023':    /* $^S */
1249         case '1':
1250         case '2':
1251         case '3':
1252         case '4':
1253         case '5':
1254         case '6':
1255         case '7':
1256         case '8':
1257         case '9':
1258         ro_magicalize:
1259             SvREADONLY_on(GvSVn(gv));
1260             /* FALL THROUGH */
1261         case '[':
1262         case '^':
1263         case '~':
1264         case '=':
1265         case '%':
1266         case '.':
1267         case '(':
1268         case ')':
1269         case '<':
1270         case '>':
1271         case ',':
1272         case '\\':
1273         case '/':
1274         case '\001':    /* $^A */
1275         case '\003':    /* $^C */
1276         case '\004':    /* $^D */
1277         case '\005':    /* $^E */
1278         case '\006':    /* $^F */
1279         case '\011':    /* $^I, NOT \t in EBCDIC */
1280         case '\016':    /* $^N */
1281         case '\017':    /* $^O */
1282         case '\020':    /* $^P */
1283         case '\024':    /* $^T */
1284         case '\027':    /* $^W */
1285         magicalize:
1286             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1287             break;
1288
1289         case '\014':    /* $^L */
1290             sv_setpvn(GvSVn(gv),"\f",1);
1291             PL_formfeed = GvSVn(gv);
1292             break;
1293         case ';':
1294             sv_setpvn(GvSVn(gv),"\034",1);
1295             break;
1296         case ']':
1297         {
1298             SV * const sv = GvSVn(gv);
1299             if (!sv_derived_from(PL_patchlevel, "version"))
1300                 upg_version(PL_patchlevel);
1301             GvSV(gv) = vnumify(PL_patchlevel);
1302             SvREADONLY_on(GvSV(gv));
1303             SvREFCNT_dec(sv);
1304         }
1305         break;
1306         case '\026':    /* $^V */
1307         {
1308             SV * const sv = GvSVn(gv);
1309             GvSV(gv) = new_version(PL_patchlevel);
1310             SvREADONLY_on(GvSV(gv));
1311             SvREFCNT_dec(sv);
1312         }
1313         break;
1314         }
1315     }
1316     return gv;
1317 }
1318
1319 void
1320 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1321 {
1322     const char *name;
1323     STRLEN namelen;
1324     const HV * const hv = GvSTASH(gv);
1325     if (!hv) {
1326         SvOK_off(sv);
1327         return;
1328     }
1329     sv_setpv(sv, prefix ? prefix : "");
1330
1331     name = HvNAME_get(hv);
1332     if (name) {
1333         namelen = HvNAMELEN_get(hv);
1334     } else {
1335         name = "__ANON__";
1336         namelen = 8;
1337     }
1338
1339     if (keepmain || strNE(name, "main")) {
1340         sv_catpvn(sv,name,namelen);
1341         sv_catpvs(sv,"::");
1342     }
1343     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1344 }
1345
1346 void
1347 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1348 {
1349     const GV * const egv = GvEGV(gv);
1350     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1351 }
1352
1353 IO *
1354 Perl_newIO(pTHX)
1355 {
1356     dVAR;
1357     GV *iogv;
1358     IO * const io = (IO*)newSV_type(SVt_PVIO);
1359     /* This used to read SvREFCNT(io) = 1;
1360        It's not clear why the reference count needed an explicit reset. NWC
1361     */
1362     assert (SvREFCNT(io) == 1);
1363     SvOBJECT_on(io);
1364     /* Clear the stashcache because a new IO could overrule a package name */
1365     hv_clear(PL_stashcache);
1366     iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
1367     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1368     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1369       iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
1370     SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1371     return io;
1372 }
1373
1374 void
1375 Perl_gv_check(pTHX_ const HV *stash)
1376 {
1377     dVAR;
1378     register I32 i;
1379
1380     if (!HvARRAY(stash))
1381         return;
1382     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1383         const HE *entry;
1384         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1385             register GV *gv;
1386             HV *hv;
1387             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1388                 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1389             {
1390                 if (hv != PL_defstash && hv != stash)
1391                      gv_check(hv);              /* nested package */
1392             }
1393             else if (isALPHA(*HeKEY(entry))) {
1394                 const char *file;
1395                 gv = (GV*)HeVAL(entry);
1396                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1397                     continue;
1398                 file = GvFILE(gv);
1399                 /* performance hack: if filename is absolute and it's a standard
1400                  * module, don't bother warning */
1401 #ifdef MACOS_TRADITIONAL
1402 #   define LIB_COMPONENT ":lib:"
1403 #else
1404 #   define LIB_COMPONENT "/lib/"
1405 #endif
1406                 if (file
1407                     && PERL_FILE_IS_ABSOLUTE(file)
1408                     && (instr(file, LIB_COMPONENT) || instr(file, ".pm")))
1409                 {
1410                     continue;
1411                 }
1412                 CopLINE_set(PL_curcop, GvLINE(gv));
1413 #ifdef USE_ITHREADS
1414                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1415 #else
1416                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1417 #endif
1418                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1419                         "Name \"%s::%s\" used only once: possible typo",
1420                         HvNAME_get(stash), GvNAME(gv));
1421             }
1422         }
1423     }
1424 }
1425
1426 GV *
1427 Perl_newGVgen(pTHX_ const char *pack)
1428 {
1429     dVAR;
1430     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1431                       GV_ADD, SVt_PVGV);
1432 }
1433
1434 /* hopefully this is only called on local symbol table entries */
1435
1436 GP*
1437 Perl_gp_ref(pTHX_ GP *gp)
1438 {
1439     dVAR;
1440     if (!gp)
1441         return NULL;
1442     gp->gp_refcnt++;
1443     if (gp->gp_cv) {
1444         if (gp->gp_cvgen) {
1445             /* multi-named GPs cannot be used for method cache */
1446             SvREFCNT_dec(gp->gp_cv);
1447             gp->gp_cv = NULL;
1448             gp->gp_cvgen = 0;
1449         }
1450         else {
1451             /* Adding a new name to a subroutine invalidates method cache */
1452             PL_sub_generation++;
1453         }
1454     }
1455     return gp;
1456 }
1457
1458 void
1459 Perl_gp_free(pTHX_ GV *gv)
1460 {
1461     dVAR;
1462     GP* gp;
1463
1464     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1465         return;
1466     if (gp->gp_refcnt == 0) {
1467         if (ckWARN_d(WARN_INTERNAL))
1468             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1469                         "Attempt to free unreferenced glob pointers"
1470                         pTHX__FORMAT pTHX__VALUE);
1471         return;
1472     }
1473     if (gp->gp_cv) {
1474         /* Deleting the name of a subroutine invalidates method cache */
1475         PL_sub_generation++;
1476     }
1477     if (--gp->gp_refcnt > 0) {
1478         if (gp->gp_egv == gv)
1479             gp->gp_egv = 0;
1480         GvGP(gv) = 0;
1481         return;
1482     }
1483
1484     if (gp->gp_file_hek)
1485         unshare_hek(gp->gp_file_hek);
1486     SvREFCNT_dec(gp->gp_sv);
1487     SvREFCNT_dec(gp->gp_av);
1488     /* FIXME - another reference loop GV -> symtab -> GV ?
1489        Somehow gp->gp_hv can end up pointing at freed garbage.  */
1490     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1491         const char *hvname = HvNAME_get(gp->gp_hv);
1492         if (PL_stashcache && hvname)
1493             hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1494                       G_DISCARD);
1495         SvREFCNT_dec(gp->gp_hv);
1496     }
1497     SvREFCNT_dec(gp->gp_io);
1498     SvREFCNT_dec(gp->gp_cv);
1499     SvREFCNT_dec(gp->gp_form);
1500
1501     Safefree(gp);
1502     GvGP(gv) = 0;
1503 }
1504
1505 int
1506 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1507 {
1508     AMT * const amtp = (AMT*)mg->mg_ptr;
1509     PERL_UNUSED_ARG(sv);
1510
1511     if (amtp && AMT_AMAGIC(amtp)) {
1512         int i;
1513         for (i = 1; i < NofAMmeth; i++) {
1514             CV * const cv = amtp->table[i];
1515             if (cv) {
1516                 SvREFCNT_dec((SV *) cv);
1517                 amtp->table[i] = NULL;
1518             }
1519         }
1520     }
1521  return 0;
1522 }
1523
1524 /* Updates and caches the CV's */
1525
1526 bool
1527 Perl_Gv_AMupdate(pTHX_ HV *stash)
1528 {
1529   dVAR;
1530   MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1531   AMT amt;
1532
1533   if (mg) {
1534       const AMT * const amtp = (AMT*)mg->mg_ptr;
1535       if (amtp->was_ok_am == PL_amagic_generation
1536           && amtp->was_ok_sub == PL_sub_generation) {
1537           return (bool)AMT_OVERLOADED(amtp);
1538       }
1539       sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1540   }
1541
1542   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1543
1544   Zero(&amt,1,AMT);
1545   amt.was_ok_am = PL_amagic_generation;
1546   amt.was_ok_sub = PL_sub_generation;
1547   amt.fallback = AMGfallNO;
1548   amt.flags = 0;
1549
1550   {
1551     int filled = 0, have_ovl = 0;
1552     int i, lim = 1;
1553
1554     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1555
1556     /* Try to find via inheritance. */
1557     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1558     SV * const sv = gv ? GvSV(gv) : NULL;
1559     CV* cv;
1560
1561     if (!gv)
1562         lim = DESTROY_amg;              /* Skip overloading entries. */
1563 #ifdef PERL_DONT_CREATE_GVSV
1564     else if (!sv) {
1565         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
1566     }
1567 #endif
1568     else if (SvTRUE(sv))
1569         amt.fallback=AMGfallYES;
1570     else if (SvOK(sv))
1571         amt.fallback=AMGfallNEVER;
1572
1573     for (i = 1; i < lim; i++)
1574         amt.table[i] = NULL;
1575     for (; i < NofAMmeth; i++) {
1576         const char * const cooky = PL_AMG_names[i];
1577         /* Human-readable form, for debugging: */
1578         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1579         const STRLEN l = strlen(cooky);
1580
1581         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1582                      cp, HvNAME_get(stash)) );
1583         /* don't fill the cache while looking up!
1584            Creation of inheritance stubs in intermediate packages may
1585            conflict with the logic of runtime method substitution.
1586            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1587            then we could have created stubs for "(+0" in A and C too.
1588            But if B overloads "bool", we may want to use it for
1589            numifying instead of C's "+0". */
1590         if (i >= DESTROY_amg)
1591             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1592         else                            /* Autoload taken care of below */
1593             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1594         cv = 0;
1595         if (gv && (cv = GvCV(gv))) {
1596             const char *hvname;
1597             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1598                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1599                 /* This is a hack to support autoloading..., while
1600                    knowing *which* methods were declared as overloaded. */
1601                 /* GvSV contains the name of the method. */
1602                 GV *ngv = NULL;
1603                 SV *gvsv = GvSV(gv);
1604
1605                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1606                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1607                              (void*)GvSV(gv), cp, hvname) );
1608                 if (!gvsv || !SvPOK(gvsv)
1609                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1610                                                        FALSE)))
1611                 {
1612                     /* Can be an import stub (created by "can"). */
1613                     const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
1614                     Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1615                                 "in package \"%.256s\"",
1616                                (GvCVGEN(gv) ? "Stub found while resolving"
1617                                 : "Can't resolve"),
1618                                name, cp, hvname);
1619                 }
1620                 cv = GvCV(gv = ngv);
1621             }
1622             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1623                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1624                          GvNAME(CvGV(cv))) );
1625             filled = 1;
1626             if (i < DESTROY_amg)
1627                 have_ovl = 1;
1628         } else if (gv) {                /* Autoloaded... */
1629             cv = (CV*)gv;
1630             filled = 1;
1631         }
1632         amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
1633     }
1634     if (filled) {
1635       AMT_AMAGIC_on(&amt);
1636       if (have_ovl)
1637           AMT_OVERLOADED_on(&amt);
1638       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1639                                                 (char*)&amt, sizeof(AMT));
1640       return have_ovl;
1641     }
1642   }
1643   /* Here we have no table: */
1644   /* no_table: */
1645   AMT_AMAGIC_off(&amt);
1646   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1647                                                 (char*)&amt, sizeof(AMTS));
1648   return FALSE;
1649 }
1650
1651
1652 CV*
1653 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1654 {
1655     dVAR;
1656     MAGIC *mg;
1657     AMT *amtp;
1658
1659     if (!stash || !HvNAME_get(stash))
1660         return NULL;
1661     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1662     if (!mg) {
1663       do_update:
1664         Gv_AMupdate(stash);
1665         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1666     }
1667     assert(mg);
1668     amtp = (AMT*)mg->mg_ptr;
1669     if ( amtp->was_ok_am != PL_amagic_generation
1670          || amtp->was_ok_sub != PL_sub_generation )
1671         goto do_update;
1672     if (AMT_AMAGIC(amtp)) {
1673         CV * const ret = amtp->table[id];
1674         if (ret && isGV(ret)) {         /* Autoloading stab */
1675             /* Passing it through may have resulted in a warning
1676                "Inherited AUTOLOAD for a non-method deprecated", since
1677                our caller is going through a function call, not a method call.
1678                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1679             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1680
1681             if (gv && GvCV(gv))
1682                 return GvCV(gv);
1683         }
1684         return ret;
1685     }
1686
1687     return NULL;
1688 }
1689
1690
1691 SV*
1692 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1693 {
1694   dVAR;
1695   MAGIC *mg;
1696   CV *cv=NULL;
1697   CV **cvp=NULL, **ocvp=NULL;
1698   AMT *amtp=NULL, *oamtp=NULL;
1699   int off = 0, off1, lr = 0, notfound = 0;
1700   int postpr = 0, force_cpy = 0;
1701   int assign = AMGf_assign & flags;
1702   const int assignshift = assign ? 1 : 0;
1703 #ifdef DEBUGGING
1704   int fl=0;
1705 #endif
1706   HV* stash=NULL;
1707   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1708       && (stash = SvSTASH(SvRV(left)))
1709       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1710       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1711                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1712                         : NULL))
1713       && ((cv = cvp[off=method+assignshift])
1714           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1715                                                           * usual method */
1716                   (
1717 #ifdef DEBUGGING
1718                    fl = 1,
1719 #endif
1720                    cv = cvp[off=method])))) {
1721     lr = -1;                    /* Call method for left argument */
1722   } else {
1723     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1724       int logic;
1725
1726       /* look for substituted methods */
1727       /* In all the covered cases we should be called with assign==0. */
1728          switch (method) {
1729          case inc_amg:
1730            force_cpy = 1;
1731            if ((cv = cvp[off=add_ass_amg])
1732                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1733              right = &PL_sv_yes; lr = -1; assign = 1;
1734            }
1735            break;
1736          case dec_amg:
1737            force_cpy = 1;
1738            if ((cv = cvp[off = subtr_ass_amg])
1739                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1740              right = &PL_sv_yes; lr = -1; assign = 1;
1741            }
1742            break;
1743          case bool__amg:
1744            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1745            break;
1746          case numer_amg:
1747            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1748            break;
1749          case string_amg:
1750            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1751            break;
1752          case not_amg:
1753            (void)((cv = cvp[off=bool__amg])
1754                   || (cv = cvp[off=numer_amg])
1755                   || (cv = cvp[off=string_amg]));
1756            postpr = 1;
1757            break;
1758          case copy_amg:
1759            {
1760              /*
1761                   * SV* ref causes confusion with the interpreter variable of
1762                   * the same name
1763                   */
1764              SV* const tmpRef=SvRV(left);
1765              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1766                 /*
1767                  * Just to be extra cautious.  Maybe in some
1768                  * additional cases sv_setsv is safe, too.
1769                  */
1770                 SV* const newref = newSVsv(tmpRef);
1771                 SvOBJECT_on(newref);
1772                 /* As a bit of a source compatibility hack, SvAMAGIC() and
1773                    friends dereference an RV, to behave the same was as when
1774                    overloading was stored on the reference, not the referant.
1775                    Hence we can't use SvAMAGIC_on()
1776                 */
1777                 SvFLAGS(newref) |= SVf_AMAGIC;
1778                 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1779                 return newref;
1780              }
1781            }
1782            break;
1783          case abs_amg:
1784            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1785                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1786              SV* const nullsv=sv_2mortal(newSViv(0));
1787              if (off1==lt_amg) {
1788                SV* const lessp = amagic_call(left,nullsv,
1789                                        lt_amg,AMGf_noright);
1790                logic = SvTRUE(lessp);
1791              } else {
1792                SV* const lessp = amagic_call(left,nullsv,
1793                                        ncmp_amg,AMGf_noright);
1794                logic = (SvNV(lessp) < 0);
1795              }
1796              if (logic) {
1797                if (off==subtr_amg) {
1798                  right = left;
1799                  left = nullsv;
1800                  lr = 1;
1801                }
1802              } else {
1803                return left;
1804              }
1805            }
1806            break;
1807          case neg_amg:
1808            if ((cv = cvp[off=subtr_amg])) {
1809              right = left;
1810              left = sv_2mortal(newSViv(0));
1811              lr = 1;
1812            }
1813            break;
1814          case int_amg:
1815          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1816              /* FAIL safe */
1817              return NULL;       /* Delegate operation to standard mechanisms. */
1818              break;
1819          case to_sv_amg:
1820          case to_av_amg:
1821          case to_hv_amg:
1822          case to_gv_amg:
1823          case to_cv_amg:
1824              /* FAIL safe */
1825              return left;       /* Delegate operation to standard mechanisms. */
1826              break;
1827          default:
1828            goto not_found;
1829          }
1830          if (!cv) goto not_found;
1831     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1832                && (stash = SvSTASH(SvRV(right)))
1833                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1834                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1835                           ? (amtp = (AMT*)mg->mg_ptr)->table
1836                           : NULL))
1837                && (cv = cvp[off=method])) { /* Method for right
1838                                              * argument found */
1839       lr=1;
1840     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1841                  && (cvp=ocvp) && (lr = -1))
1842                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1843                && !(flags & AMGf_unary)) {
1844                                 /* We look for substitution for
1845                                  * comparison operations and
1846                                  * concatenation */
1847       if (method==concat_amg || method==concat_ass_amg
1848           || method==repeat_amg || method==repeat_ass_amg) {
1849         return NULL;            /* Delegate operation to string conversion */
1850       }
1851       off = -1;
1852       switch (method) {
1853          case lt_amg:
1854          case le_amg:
1855          case gt_amg:
1856          case ge_amg:
1857          case eq_amg:
1858          case ne_amg:
1859            postpr = 1; off=ncmp_amg; break;
1860          case slt_amg:
1861          case sle_amg:
1862          case sgt_amg:
1863          case sge_amg:
1864          case seq_amg:
1865          case sne_amg:
1866            postpr = 1; off=scmp_amg; break;
1867          }
1868       if (off != -1) cv = cvp[off];
1869       if (!cv) {
1870         goto not_found;
1871       }
1872     } else {
1873     not_found:                  /* No method found, either report or croak */
1874       switch (method) {
1875          case lt_amg:
1876          case le_amg:
1877          case gt_amg:
1878          case ge_amg:
1879          case eq_amg:
1880          case ne_amg:
1881          case slt_amg:
1882          case sle_amg:
1883          case sgt_amg:
1884          case sge_amg:
1885          case seq_amg:
1886          case sne_amg:
1887            postpr = 0; break;
1888          case to_sv_amg:
1889          case to_av_amg:
1890          case to_hv_amg:
1891          case to_gv_amg:
1892          case to_cv_amg:
1893              /* FAIL safe */
1894              return left;       /* Delegate operation to standard mechanisms. */
1895              break;
1896       }
1897       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1898         notfound = 1; lr = -1;
1899       } else if (cvp && (cv=cvp[nomethod_amg])) {
1900         notfound = 1; lr = 1;
1901       } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
1902         /* Skip generating the "no method found" message.  */
1903         return NULL;
1904       } else {
1905         SV *msg;
1906         if (off==-1) off=method;
1907         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1908                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
1909                       AMG_id2name(method + assignshift),
1910                       (flags & AMGf_unary ? " " : "\n\tleft "),
1911                       SvAMAGIC(left)?
1912                         "in overloaded package ":
1913                         "has no overloaded magic",
1914                       SvAMAGIC(left)?
1915                         HvNAME_get(SvSTASH(SvRV(left))):
1916                         "",
1917                       SvAMAGIC(right)?
1918                         ",\n\tright argument in overloaded package ":
1919                         (flags & AMGf_unary
1920                          ? ""
1921                          : ",\n\tright argument has no overloaded magic"),
1922                       SvAMAGIC(right)?
1923                         HvNAME_get(SvSTASH(SvRV(right))):
1924                         ""));
1925         if (amtp && amtp->fallback >= AMGfallYES) {
1926           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1927         } else {
1928           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
1929         }
1930         return NULL;
1931       }
1932       force_cpy = force_cpy || assign;
1933     }
1934   }
1935 #ifdef DEBUGGING
1936   if (!notfound) {
1937     DEBUG_o(Perl_deb(aTHX_
1938                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1939                      AMG_id2name(off),
1940                      method+assignshift==off? "" :
1941                      " (initially \"",
1942                      method+assignshift==off? "" :
1943                      AMG_id2name(method+assignshift),
1944                      method+assignshift==off? "" : "\")",
1945                      flags & AMGf_unary? "" :
1946                      lr==1 ? " for right argument": " for left argument",
1947                      flags & AMGf_unary? " for argument" : "",
1948                      stash ? HvNAME_get(stash) : "null",
1949                      fl? ",\n\tassignment variant used": "") );
1950   }
1951 #endif
1952     /* Since we use shallow copy during assignment, we need
1953      * to dublicate the contents, probably calling user-supplied
1954      * version of copy operator
1955      */
1956     /* We need to copy in following cases:
1957      * a) Assignment form was called.
1958      *          assignshift==1,  assign==T, method + 1 == off
1959      * b) Increment or decrement, called directly.
1960      *          assignshift==0,  assign==0, method + 0 == off
1961      * c) Increment or decrement, translated to assignment add/subtr.
1962      *          assignshift==0,  assign==T,
1963      *          force_cpy == T
1964      * d) Increment or decrement, translated to nomethod.
1965      *          assignshift==0,  assign==0,
1966      *          force_cpy == T
1967      * e) Assignment form translated to nomethod.
1968      *          assignshift==1,  assign==T, method + 1 != off
1969      *          force_cpy == T
1970      */
1971     /*  off is method, method+assignshift, or a result of opcode substitution.
1972      *  In the latter case assignshift==0, so only notfound case is important.
1973      */
1974   if (( (method + assignshift == off)
1975         && (assign || (method == inc_amg) || (method == dec_amg)))
1976       || force_cpy)
1977     RvDEEPCP(left);
1978   {
1979     dSP;
1980     BINOP myop;
1981     SV* res;
1982     const bool oldcatch = CATCH_GET;
1983
1984     CATCH_SET(TRUE);
1985     Zero(&myop, 1, BINOP);
1986     myop.op_last = (OP *) &myop;
1987     myop.op_next = NULL;
1988     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1989
1990     PUSHSTACKi(PERLSI_OVERLOAD);
1991     ENTER;
1992     SAVEOP();
1993     PL_op = (OP *) &myop;
1994     if (PERLDB_SUB && PL_curstash != PL_debstash)
1995         PL_op->op_private |= OPpENTERSUB_DB;
1996     PUTBACK;
1997     pp_pushmark();
1998
1999     EXTEND(SP, notfound + 5);
2000     PUSHs(lr>0? right: left);
2001     PUSHs(lr>0? left: right);
2002     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2003     if (notfound) {
2004       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
2005     }
2006     PUSHs((SV*)cv);
2007     PUTBACK;
2008
2009     if ((PL_op = Perl_pp_entersub(aTHX)))
2010       CALLRUNOPS(aTHX);
2011     LEAVE;
2012     SPAGAIN;
2013
2014     res=POPs;
2015     PUTBACK;
2016     POPSTACK;
2017     CATCH_SET(oldcatch);
2018
2019     if (postpr) {
2020       int ans;
2021       switch (method) {
2022       case le_amg:
2023       case sle_amg:
2024         ans=SvIV(res)<=0; break;
2025       case lt_amg:
2026       case slt_amg:
2027         ans=SvIV(res)<0; break;
2028       case ge_amg:
2029       case sge_amg:
2030         ans=SvIV(res)>=0; break;
2031       case gt_amg:
2032       case sgt_amg:
2033         ans=SvIV(res)>0; break;
2034       case eq_amg:
2035       case seq_amg:
2036         ans=SvIV(res)==0; break;
2037       case ne_amg:
2038       case sne_amg:
2039         ans=SvIV(res)!=0; break;
2040       case inc_amg:
2041       case dec_amg:
2042         SvSetSV(left,res); return left;
2043       case not_amg:
2044         ans=!SvTRUE(res); break;
2045       default:
2046         ans=0; break;
2047       }
2048       return boolSV(ans);
2049     } else if (method==copy_amg) {
2050       if (!SvROK(res)) {
2051         Perl_croak(aTHX_ "Copy method did not return a reference");
2052       }
2053       return SvREFCNT_inc(SvRV(res));
2054     } else {
2055       return res;
2056     }
2057   }
2058 }
2059
2060 /*
2061 =for apidoc is_gv_magical_sv
2062
2063 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
2064
2065 =cut
2066 */
2067
2068 bool
2069 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
2070 {
2071     STRLEN len;
2072     const char * const temp = SvPV_const(name, len);
2073     return is_gv_magical(temp, len, flags);
2074 }
2075
2076 /*
2077 =for apidoc is_gv_magical
2078
2079 Returns C<TRUE> if given the name of a magical GV.
2080
2081 Currently only useful internally when determining if a GV should be
2082 created even in rvalue contexts.
2083
2084 C<flags> is not used at present but available for future extension to
2085 allow selecting particular classes of magical variable.
2086
2087 Currently assumes that C<name> is NUL terminated (as well as len being valid).
2088 This assumption is met by all callers within the perl core, which all pass
2089 pointers returned by SvPV.
2090
2091 =cut
2092 */
2093 bool
2094 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
2095 {
2096     PERL_UNUSED_CONTEXT;
2097     PERL_UNUSED_ARG(flags);
2098
2099     if (len > 1) {
2100         const char * const name1 = name + 1;
2101         switch (*name) {
2102         case 'I':
2103             if (len == 3 && name1[1] == 'S' && name[2] == 'A')
2104                 goto yes;
2105             break;
2106         case 'O':
2107             if (len == 8 && strEQ(name1, "VERLOAD"))
2108                 goto yes;
2109             break;
2110         case 'S':
2111             if (len == 3 && name[1] == 'I' && name[2] == 'G')
2112                 goto yes;
2113             break;
2114             /* Using ${^...} variables is likely to be sufficiently rare that
2115                it seems sensible to avoid the space hit of also checking the
2116                length.  */
2117         case '\017':   /* ${^OPEN} */
2118             if (strEQ(name1, "PEN"))
2119                 goto yes;
2120             break;
2121         case '\024':   /* ${^TAINT} */
2122             if (strEQ(name1, "AINT"))
2123                 goto yes;
2124             break;
2125         case '\025':    /* ${^UNICODE} */
2126             if (strEQ(name1, "NICODE"))
2127                 goto yes;
2128             if (strEQ(name1, "TF8LOCALE"))
2129                 goto yes;
2130             break;
2131         case '\027':   /* ${^WARNING_BITS} */
2132             if (strEQ(name1, "ARNING_BITS"))
2133                 goto yes;
2134             break;
2135         case '1':
2136         case '2':
2137         case '3':
2138         case '4':
2139         case '5':
2140         case '6':
2141         case '7':
2142         case '8':
2143         case '9':
2144         {
2145             const char *end = name + len;
2146             while (--end > name) {
2147                 if (!isDIGIT(*end))
2148                     return FALSE;
2149             }
2150             goto yes;
2151         }
2152         }
2153     } else {
2154         /* Because we're already assuming that name is NUL terminated
2155            below, we can treat an empty name as "\0"  */
2156         switch (*name) {
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 ')':
2173         case '<':
2174         case '>':
2175         case ',':
2176         case '\\':
2177         case '/':
2178         case '|':
2179         case '+':
2180         case ';':
2181         case ']':
2182         case '\001':   /* $^A */
2183         case '\003':   /* $^C */
2184         case '\004':   /* $^D */
2185         case '\005':   /* $^E */
2186         case '\006':   /* $^F */
2187         case '\010':   /* $^H */
2188         case '\011':   /* $^I, NOT \t in EBCDIC */
2189         case '\014':   /* $^L */
2190         case '\016':   /* $^N */
2191         case '\017':   /* $^O */
2192         case '\020':   /* $^P */
2193         case '\023':   /* $^S */
2194         case '\024':   /* $^T */
2195         case '\026':   /* $^V */
2196         case '\027':   /* $^W */
2197         case '1':
2198         case '2':
2199         case '3':
2200         case '4':
2201         case '5':
2202         case '6':
2203         case '7':
2204         case '8':
2205         case '9':
2206         yes:
2207             return TRUE;
2208         default:
2209             break;
2210         }
2211     }
2212     return FALSE;
2213 }
2214
2215 void
2216 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2217 {
2218     dVAR;
2219     U32 hash;
2220
2221     assert(name);
2222     PERL_UNUSED_ARG(flags);
2223
2224     if (len > I32_MAX)
2225         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2226
2227     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2228         unshare_hek(GvNAME_HEK(gv));
2229     }
2230
2231     PERL_HASH(hash, name, len);
2232     GvNAME_HEK(gv) = share_hek(name, len, hash);
2233 }
2234
2235 /*
2236  * Local variables:
2237  * c-indentation-style: bsd
2238  * c-basic-offset: 4
2239  * indent-tabs-mode: t
2240  * End:
2241  *
2242  * ex: set ts=8 sts=4 sw=4 noet:
2243  */