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