gv.c

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