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