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