gv.c

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