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
 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             else
1229                 SvREFCNT_dec(stashname);
1230
1231             break;
1232         }
1233         case '*':
1234         case '#':
1235             if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1236                 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1237                             "$%c is no longer supported", *name);
1238             break;
1239         case '|':
1240             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1241             goto magicalize;
1242
1243         case '\010':    /* $^H */
1244             {
1245                 HV *const hv = GvHVn(gv);
1246                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1247             }
1248             goto magicalize;
1249         case '\023':    /* $^S */
1250         case '1':
1251         case '2':
1252         case '3':
1253         case '4':
1254         case '5':
1255         case '6':
1256         case '7':
1257         case '8':
1258         case '9':
1259         ro_magicalize:
1260             SvREADONLY_on(GvSVn(gv));
1261             /* FALL THROUGH */
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 '/':
1275         case '\001':    /* $^A */
1276         case '\003':    /* $^C */
1277         case '\004':    /* $^D */
1278         case '\005':    /* $^E */
1279         case '\006':    /* $^F */
1280         case '\011':    /* $^I, NOT \t in EBCDIC */
1281         case '\016':    /* $^N */
1282         case '\017':    /* $^O */
1283         case '\020':    /* $^P */
1284         case '\024':    /* $^T */
1285         case '\027':    /* $^W */
1286         magicalize:
1287             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1288             break;
1289
1290         case '\014':    /* $^L */
1291             sv_setpvn(GvSVn(gv),"\f",1);
1292             PL_formfeed = GvSVn(gv);
1293             break;
1294         case ';':
1295             sv_setpvn(GvSVn(gv),"\034",1);
1296             break;
1297         case ']':
1298         {
1299             SV * const sv = GvSVn(gv);
1300             if (!sv_derived_from(PL_patchlevel, "version"))
1301                 upg_version(PL_patchlevel);
1302             GvSV(gv) = vnumify(PL_patchlevel);
1303             SvREADONLY_on(GvSV(gv));
1304             SvREFCNT_dec(sv);
1305         }
1306         break;
1307         case '\026':    /* $^V */
1308         {
1309             SV * const sv = GvSVn(gv);
1310             GvSV(gv) = new_version(PL_patchlevel);
1311             SvREADONLY_on(GvSV(gv));
1312             SvREFCNT_dec(sv);
1313         }
1314         break;
1315         }
1316     }
1317     return gv;
1318 }
1319
1320 void
1321 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1322 {
1323     const char *name;
1324     STRLEN namelen;
1325     const HV * const hv = GvSTASH(gv);
1326     if (!hv) {
1327         SvOK_off(sv);
1328         return;
1329     }
1330     sv_setpv(sv, prefix ? prefix : "");
1331
1332     name = HvNAME_get(hv);
1333     if (name) {
1334         namelen = HvNAMELEN_get(hv);
1335     } else {
1336         name = "__ANON__";
1337         namelen = 8;
1338     }
1339
1340     if (keepmain || strNE(name, "main")) {
1341         sv_catpvn(sv,name,namelen);
1342         sv_catpvs(sv,"::");
1343     }
1344     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1345 }
1346
1347 void
1348 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1349 {
1350     const GV * const egv = GvEGV(gv);
1351     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1352 }
1353
1354 IO *
1355 Perl_newIO(pTHX)
1356 {
1357     dVAR;
1358     GV *iogv;
1359     IO * const io = (IO*)newSV_type(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 lt_amg:
1877          case le_amg:
1878          case gt_amg:
1879          case ge_amg:
1880          case eq_amg:
1881          case ne_amg:
1882          case slt_amg:
1883          case sle_amg:
1884          case sgt_amg:
1885          case sge_amg:
1886          case seq_amg:
1887          case sne_amg:
1888            postpr = 0; break;
1889          case to_sv_amg:
1890          case to_av_amg:
1891          case to_hv_amg:
1892          case to_gv_amg:
1893          case to_cv_amg:
1894              /* FAIL safe */
1895              return left;       /* Delegate operation to standard mechanisms. */
1896              break;
1897       }
1898       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1899         notfound = 1; lr = -1;
1900       } else if (cvp && (cv=cvp[nomethod_amg])) {
1901         notfound = 1; lr = 1;
1902       } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
1903         /* Skip generating the "no method found" message.  */
1904         return NULL;
1905       } else {
1906         SV *msg;
1907         if (off==-1) off=method;
1908         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1909                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
1910                       AMG_id2name(method + assignshift),
1911                       (flags & AMGf_unary ? " " : "\n\tleft "),
1912                       SvAMAGIC(left)?
1913                         "in overloaded package ":
1914                         "has no overloaded magic",
1915                       SvAMAGIC(left)?
1916                         HvNAME_get(SvSTASH(SvRV(left))):
1917                         "",
1918                       SvAMAGIC(right)?
1919                         ",\n\tright argument in overloaded package ":
1920                         (flags & AMGf_unary
1921                          ? ""
1922                          : ",\n\tright argument has no overloaded magic"),
1923                       SvAMAGIC(right)?
1924                         HvNAME_get(SvSTASH(SvRV(right))):
1925                         ""));
1926         if (amtp && amtp->fallback >= AMGfallYES) {
1927           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1928         } else {
1929           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
1930         }
1931         return NULL;
1932       }
1933       force_cpy = force_cpy || assign;
1934     }
1935   }
1936 #ifdef DEBUGGING
1937   if (!notfound) {
1938     DEBUG_o(Perl_deb(aTHX_
1939                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1940                      AMG_id2name(off),
1941                      method+assignshift==off? "" :
1942                      " (initially \"",
1943                      method+assignshift==off? "" :
1944                      AMG_id2name(method+assignshift),
1945                      method+assignshift==off? "" : "\")",
1946                      flags & AMGf_unary? "" :
1947                      lr==1 ? " for right argument": " for left argument",
1948                      flags & AMGf_unary? " for argument" : "",
1949                      stash ? HvNAME_get(stash) : "null",
1950                      fl? ",\n\tassignment variant used": "") );
1951   }
1952 #endif
1953     /* Since we use shallow copy during assignment, we need
1954      * to dublicate the contents, probably calling user-supplied
1955      * version of copy operator
1956      */
1957     /* We need to copy in following cases:
1958      * a) Assignment form was called.
1959      *          assignshift==1,  assign==T, method + 1 == off
1960      * b) Increment or decrement, called directly.
1961      *          assignshift==0,  assign==0, method + 0 == off
1962      * c) Increment or decrement, translated to assignment add/subtr.
1963      *          assignshift==0,  assign==T,
1964      *          force_cpy == T
1965      * d) Increment or decrement, translated to nomethod.
1966      *          assignshift==0,  assign==0,
1967      *          force_cpy == T
1968      * e) Assignment form translated to nomethod.
1969      *          assignshift==1,  assign==T, method + 1 != off
1970      *          force_cpy == T
1971      */
1972     /*  off is method, method+assignshift, or a result of opcode substitution.
1973      *  In the latter case assignshift==0, so only notfound case is important.
1974      */
1975   if (( (method + assignshift == off)
1976         && (assign || (method == inc_amg) || (method == dec_amg)))
1977       || force_cpy)
1978     RvDEEPCP(left);
1979   {
1980     dSP;
1981     BINOP myop;
1982     SV* res;
1983     const bool oldcatch = CATCH_GET;
1984
1985     CATCH_SET(TRUE);
1986     Zero(&myop, 1, BINOP);
1987     myop.op_last = (OP *) &myop;
1988     myop.op_next = NULL;
1989     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1990
1991     PUSHSTACKi(PERLSI_OVERLOAD);
1992     ENTER;
1993     SAVEOP();
1994     PL_op = (OP *) &myop;
1995     if (PERLDB_SUB && PL_curstash != PL_debstash)
1996         PL_op->op_private |= OPpENTERSUB_DB;
1997     PUTBACK;
1998     pp_pushmark();
1999
2000     EXTEND(SP, notfound + 5);
2001     PUSHs(lr>0? right: left);
2002     PUSHs(lr>0? left: right);
2003     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2004     if (notfound) {
2005       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
2006     }
2007     PUSHs((SV*)cv);
2008     PUTBACK;
2009
2010     if ((PL_op = Perl_pp_entersub(aTHX)))
2011       CALLRUNOPS(aTHX);
2012     LEAVE;
2013     SPAGAIN;
2014
2015     res=POPs;
2016     PUTBACK;
2017     POPSTACK;
2018     CATCH_SET(oldcatch);
2019
2020     if (postpr) {
2021       int ans;
2022       switch (method) {
2023       case le_amg:
2024       case sle_amg:
2025         ans=SvIV(res)<=0; break;
2026       case lt_amg:
2027       case slt_amg:
2028         ans=SvIV(res)<0; break;
2029       case ge_amg:
2030       case sge_amg:
2031         ans=SvIV(res)>=0; break;
2032       case gt_amg:
2033       case sgt_amg:
2034         ans=SvIV(res)>0; break;
2035       case eq_amg:
2036       case seq_amg:
2037         ans=SvIV(res)==0; break;
2038       case ne_amg:
2039       case sne_amg:
2040         ans=SvIV(res)!=0; break;
2041       case inc_amg:
2042       case dec_amg:
2043         SvSetSV(left,res); return left;
2044       case not_amg:
2045         ans=!SvTRUE(res); break;
2046       default:
2047         ans=0; break;
2048       }
2049       return boolSV(ans);
2050     } else if (method==copy_amg) {
2051       if (!SvROK(res)) {
2052         Perl_croak(aTHX_ "Copy method did not return a reference");
2053       }
2054       return SvREFCNT_inc(SvRV(res));
2055     } else {
2056       return res;
2057     }
2058   }
2059 }
2060
2061 /*
2062 =for apidoc is_gv_magical_sv
2063
2064 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
2065
2066 =cut
2067 */
2068
2069 bool
2070 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
2071 {
2072     STRLEN len;
2073     const char * const temp = SvPV_const(name, len);
2074     return is_gv_magical(temp, len, flags);
2075 }
2076
2077 /*
2078 =for apidoc is_gv_magical
2079
2080 Returns C<TRUE> if given the name of a magical GV.
2081
2082 Currently only useful internally when determining if a GV should be
2083 created even in rvalue contexts.
2084
2085 C<flags> is not used at present but available for future extension to
2086 allow selecting particular classes of magical variable.
2087
2088 Currently assumes that C<name> is NUL terminated (as well as len being valid).
2089 This assumption is met by all callers within the perl core, which all pass
2090 pointers returned by SvPV.
2091
2092 =cut
2093 */
2094 bool
2095 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
2096 {
2097     PERL_UNUSED_CONTEXT;
2098     PERL_UNUSED_ARG(flags);
2099
2100     if (len > 1) {
2101         const char * const name1 = name + 1;
2102         switch (*name) {
2103         case 'I':
2104             if (len == 3 && name1[1] == 'S' && name[2] == 'A')
2105                 goto yes;
2106             break;
2107         case 'O':
2108             if (len == 8 && strEQ(name1, "VERLOAD"))
2109                 goto yes;
2110             break;
2111         case 'S':
2112             if (len == 3 && name[1] == 'I' && name[2] == 'G')
2113                 goto yes;
2114             break;
2115             /* Using ${^...} variables is likely to be sufficiently rare that
2116                it seems sensible to avoid the space hit of also checking the
2117                length.  */
2118         case '\017':   /* ${^OPEN} */
2119             if (strEQ(name1, "PEN"))
2120                 goto yes;
2121             break;
2122         case '\024':   /* ${^TAINT} */
2123             if (strEQ(name1, "AINT"))
2124                 goto yes;
2125             break;
2126         case '\025':    /* ${^UNICODE} */
2127             if (strEQ(name1, "NICODE"))
2128                 goto yes;
2129             if (strEQ(name1, "TF8LOCALE"))
2130                 goto yes;
2131             break;
2132         case '\027':   /* ${^WARNING_BITS} */
2133             if (strEQ(name1, "ARNING_BITS"))
2134                 goto yes;
2135             break;
2136         case '1':
2137         case '2':
2138         case '3':
2139         case '4':
2140         case '5':
2141         case '6':
2142         case '7':
2143         case '8':
2144         case '9':
2145         {
2146             const char *end = name + len;
2147             while (--end > name) {
2148                 if (!isDIGIT(*end))
2149                     return FALSE;
2150             }
2151             goto yes;
2152         }
2153         }
2154     } else {
2155         /* Because we're already assuming that name is NUL terminated
2156            below, we can treat an empty name as "\0"  */
2157         switch (*name) {
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 ']':
2183         case '\001':   /* $^A */
2184         case '\003':   /* $^C */
2185         case '\004':   /* $^D */
2186         case '\005':   /* $^E */
2187         case '\006':   /* $^F */
2188         case '\010':   /* $^H */
2189         case '\011':   /* $^I, NOT \t in EBCDIC */
2190         case '\014':   /* $^L */
2191         case '\016':   /* $^N */
2192         case '\017':   /* $^O */
2193         case '\020':   /* $^P */
2194         case '\023':   /* $^S */
2195         case '\024':   /* $^T */
2196         case '\026':   /* $^V */
2197         case '\027':   /* $^W */
2198         case '1':
2199         case '2':
2200         case '3':
2201         case '4':
2202         case '5':
2203         case '6':
2204         case '7':
2205         case '8':
2206         case '9':
2207         yes:
2208             return TRUE;
2209         default:
2210             break;
2211         }
2212     }
2213     return FALSE;
2214 }
2215
2216 void
2217 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2218 {
2219     dVAR;
2220     U32 hash;
2221
2222     assert(name);
2223     PERL_UNUSED_ARG(flags);
2224
2225     if (len > I32_MAX)
2226         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2227
2228     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2229         unshare_hek(GvNAME_HEK(gv));
2230     }
2231
2232     PERL_HASH(hash, name, len);
2233     GvNAME_HEK(gv) = share_hek(name, len, hash);
2234 }
2235
2236 /*
2237  * Local variables:
2238  * c-indentation-style: bsd
2239  * c-basic-offset: 4
2240  * indent-tabs-mode: t
2241  * End:
2242  *
2243  * ex: set ts=8 sts=4 sw=4 noet:
2244  */