gv.c

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