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