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