gv.c

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