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