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     const char * const origname = name;
 622
 623     PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
 624
 625     if (stash && SvTYPE(stash) < SVt_PVHV)
 626         stash = NULL;
 627
 628     for (nend = name; *nend; nend++) {
 629         if (*nend == '\'') {
 630             nsplit = nend;
 631             name = nend + 1;
 632         }
 633         else if (*nend == ':' && *(nend + 1) == ':') {
 634             nsplit = nend++;
 635             name = nend + 1;
 636         }
 637     }
 638     if (nsplit) {
 639         if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
 640             /* ->SUPER::method should really be looked up in original stash */
 641             SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
 642                                                   CopSTASHPV(PL_curcop)));
 643             /* __PACKAGE__::SUPER stash should be autovivified */
 644             stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr));
 645             DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
 646                          origname, HvNAME_get(stash), name) );
 647         }
 648         else {
 649             /* don't autovifify if ->NoSuchStash::method */
 650             stash = gv_stashpvn(origname, nsplit - origname, 0);
 651
 652             /* however, explicit calls to Pkg::SUPER::method may
 653                happen, and may require autovivification to work */
 654             if (!stash && (nsplit - origname) >= 7 &&
 655                 strnEQ(nsplit - 7, "::SUPER", 7) &&
 656                 gv_stashpvn(origname, nsplit - origname - 7, 0))
 657               stash = gv_get_super_pkg(origname, nsplit - origname);
 658         }
 659         ostash = stash;
 660     }
 661
 662     gv = gv_fetchmeth(stash, name, nend - name, 0);
 663     if (!gv) {
 664         if (strEQ(name,"import") || strEQ(name,"unimport"))
 665             gv = (GV*)&PL_sv_yes;
 666         else if (autoload)
 667             gv = gv_autoload4(ostash, name, nend - name, TRUE);
 668     }
 669     else if (autoload) {
 670         CV* const cv = GvCV(gv);
 671         if (!CvROOT(cv) && !CvXSUB(cv)) {
 672             GV* stubgv;
 673             GV* autogv;
 674
 675             if (CvANON(cv))
 676                 stubgv = gv;
 677             else {
 678                 stubgv = CvGV(cv);
 679                 if (GvCV(stubgv) != cv)         /* orphaned import */
 680                     stubgv = gv;
 681             }
 682             autogv = gv_autoload4(GvSTASH(stubgv),
 683                                   GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
 684             if (autogv)
 685                 gv = autogv;
 686         }
 687     }
 688
 689     return gv;
 690 }
 691
 692 GV*
 693 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 694 {
 695     dVAR;
 696     GV* gv;
 697     CV* cv;
 698     HV* varstash;
 699     GV* vargv;
 700     SV* varsv;
 701     const char *packname = "";
 702     STRLEN packname_len = 0;
 703
 704     PERL_ARGS_ASSERT_GV_AUTOLOAD4;
 705
 706     if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
 707         return NULL;
 708     if (stash) {
 709         if (SvTYPE(stash) < SVt_PVHV) {
 710             packname = SvPV_const((SV*)stash, packname_len);
 711             stash = NULL;
 712         }
 713         else {
 714             packname = HvNAME_get(stash);
 715             packname_len = HvNAMELEN_get(stash);
 716         }
 717     }
 718     if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
 719         return NULL;
 720     cv = GvCV(gv);
 721
 722     if (!(CvROOT(cv) || CvXSUB(cv)))
 723         return NULL;
 724
 725     /*
 726      * Inheriting AUTOLOAD for non-methods works ... for now.
 727      */
 728     if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
 729         && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)
 730     )
 731         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 732           "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
 733              packname, (int)len, name);
 734
 735     if (CvISXSUB(cv)) {
 736         /* rather than lookup/init $AUTOLOAD here
 737          * only to have the XSUB do another lookup for $AUTOLOAD
 738          * and split that value on the last '::',
 739          * pass along the same data via some unused fields in the CV
 740          */
 741         CvSTASH(cv) = stash;
 742         SvPV_set(cv, (char *)name); /* cast to lose constness warning */
 743         SvCUR_set(cv, len);
 744         return gv;
 745     }
 746
 747     /*
 748      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
 749      * The subroutine's original name may not be "AUTOLOAD", so we don't
 750      * use that, but for lack of anything better we will use the sub's
 751      * original package to look up $AUTOLOAD.
 752      */
 753     varstash = GvSTASH(CvGV(cv));
 754     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
 755     ENTER;
 756
 757     if (!isGV(vargv)) {
 758         gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
 759 #ifdef PERL_DONT_CREATE_GVSV
 760         GvSV(vargv) = newSV(0);
 761 #endif
 762     }
 763     LEAVE;
 764     varsv = GvSVn(vargv);
 765     sv_setpvn(varsv, packname, packname_len);
 766     sv_catpvs(varsv, "::");
 767     sv_catpvn(varsv, name, len);
 768     return gv;
 769 }
 770
 771
 772 /* require_tie_mod() internal routine for requiring a module
 773  * that implements the logic of automatical ties like %! and %-
 774  *
 775  * The "gv" parameter should be the glob.
 776  * "varpv" holds the name of the var, used for error messages.
 777  * "namesv" holds the module name. Its refcount will be decremented.
 778  * "methpv" holds the method name to test for to check that things
 779  *   are working reasonably close to as expected.
 780  * "flags": if flag & 1 then save the scalar before loading.
 781  * For the protection of $! to work (it is set by this routine)
 782  * the sv slot must already be magicalized.
 783  */
 784 STATIC HV*
 785 S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags)
 786 {
 787     dVAR;
 788     HV* stash = gv_stashsv(namesv, 0);
 789
 790     PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
 791
 792     if (!stash || !(gv_fetchmethod(stash, methpv))) {
 793         SV *module = newSVsv(namesv);
 794         char varname = *varpv; /* varpv might be clobbered by load_module,
 795                                   so save it. For the moment it's always
 796                                   a single char. */
 797         dSP;
 798         ENTER;
 799         if ( flags & 1 )
 800             save_scalar(gv);
 801         PUSHSTACKi(PERLSI_MAGIC);
 802         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL);
 803         POPSTACK;
 804         LEAVE;
 805         SPAGAIN;
 806         stash = gv_stashsv(namesv, 0);
 807         if (!stash)
 808             Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
 809                     varname, SVfARG(namesv));
 810         else if (!gv_fetchmethod(stash, methpv))
 811             Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s",
 812                     varname, SVfARG(namesv), methpv);
 813     }
 814     SvREFCNT_dec(namesv);
 815     return stash;
 816 }
 817
 818 /*
 819 =for apidoc gv_stashpv
 820
 821 Returns a pointer to the stash for a specified package.  Uses C<strlen> to
 822 determine the length of C<name>, then calls C<gv_stashpvn()>.
 823
 824 =cut
 825 */
 826
 827 HV*
 828 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
 829 {
 830     PERL_ARGS_ASSERT_GV_STASHPV;
 831     return gv_stashpvn(name, strlen(name), create);
 832 }
 833
 834 /*
 835 =for apidoc gv_stashpvn
 836
 837 Returns a pointer to the stash for a specified package.  The C<namelen>
 838 parameter indicates the length of the C<name>, in bytes.  C<flags> is passed
 839 to C<gv_fetchpvn_flags()>, so if set to C<GV_ADD> then the package will be
 840 created if it does not already exist.  If the package does not exist and
 841 C<flags> is 0 (or any other setting that does not create packages) then NULL
 842 is returned.
 843
 844
 845 =cut
 846 */
 847
 848 HV*
 849 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags)
 850 {
 851     char smallbuf[128];
 852     char *tmpbuf;
 853     HV *stash;
 854     GV *tmpgv;
 855
 856     PERL_ARGS_ASSERT_GV_STASHPVN;
 857
 858     if (namelen + 2 <= sizeof smallbuf)
 859         tmpbuf = smallbuf;
 860     else
 861         Newx(tmpbuf, namelen + 2, char);
 862     Copy(name,tmpbuf,namelen,char);
 863     tmpbuf[namelen++] = ':';
 864     tmpbuf[namelen++] = ':';
 865     tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, flags, SVt_PVHV);
 866     if (tmpbuf != smallbuf)
 867         Safefree(tmpbuf);
 868     if (!tmpgv)
 869         return NULL;
 870     if (!GvHV(tmpgv))
 871         GvHV(tmpgv) = newHV();
 872     stash = GvHV(tmpgv);
 873     if (!HvNAME_get(stash))
 874         hv_name_set(stash, name, namelen, 0);
 875     return stash;
 876 }
 877
 878 /*
 879 =for apidoc gv_stashsv
 880
 881 Returns a pointer to the stash for a specified package.  See C<gv_stashpvn>.
 882
 883 =cut
 884 */
 885
 886 HV*
 887 Perl_gv_stashsv(pTHX_ SV *sv, I32 flags)
 888 {
 889     STRLEN len;
 890     const char * const ptr = SvPV_const(sv,len);
 891
 892     PERL_ARGS_ASSERT_GV_STASHSV;
 893
 894     return gv_stashpvn(ptr, len, flags);
 895 }
 896
 897
 898 GV *
 899 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) {
 900     PERL_ARGS_ASSERT_GV_FETCHPV;
 901     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
 902 }
 903
 904 GV *
 905 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) {
 906     STRLEN len;
 907     const char * const nambeg = SvPV_const(name, len);
 908     PERL_ARGS_ASSERT_GV_FETCHSV;
 909     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
 910 }
 911
 912 GV *
 913 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 914                        const svtype sv_type)
 915 {
 916     dVAR;
 917     register const char *name = nambeg;
 918     register GV *gv = NULL;
 919     GV**gvp;
 920     I32 len;
 921     register const char *name_cursor;
 922     HV *stash = NULL;
 923     const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT);
 924     const I32 no_expand = flags & GV_NOEXPAND;
 925     const I32 add = flags & ~GV_NOADD_MASK;
 926     const char *const name_end = nambeg + full_len;
 927     const char *const name_em1 = name_end - 1;
 928     U32 faking_it;
 929
 930     PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS;
 931
 932     if (flags & GV_NOTQUAL) {
 933         /* Caller promised that there is no stash, so we can skip the check. */
 934         len = full_len;
 935         goto no_stash;
 936     }
 937
 938     if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
 939         /* accidental stringify on a GV? */
 940         name++;
 941     }
 942
 943     for (name_cursor = name; name_cursor < name_end; name_cursor++) {
 944         if ((*name_cursor == ':' && name_cursor < name_em1
 945              && name_cursor[1] == ':')
 946             || (*name_cursor == '\'' && name_cursor[1]))
 947         {
 948             if (!stash)
 949                 stash = PL_defstash;
 950             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
 951                 return NULL;
 952
 953             len = name_cursor - name;
 954             if (len > 0) {
 955                 char smallbuf[128];
 956                 char *tmpbuf;
 957
 958                 if (len + 2 <= (I32)sizeof (smallbuf))
 959                     tmpbuf = smallbuf;
 960                 else
 961                     Newx(tmpbuf, len+2, char);
 962                 Copy(name, tmpbuf, len, char);
 963                 tmpbuf[len++] = ':';
 964                 tmpbuf[len++] = ':';
 965                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
 966                 gv = gvp ? *gvp : NULL;
 967                 if (gv && gv != (GV*)&PL_sv_undef) {
 968                     if (SvTYPE(gv) != SVt_PVGV)
 969                         gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
 970                     else
 971                         GvMULTI_on(gv);
 972                 }
 973                 if (tmpbuf != smallbuf)
 974                     Safefree(tmpbuf);
 975                 if (!gv || gv == (GV*)&PL_sv_undef)
 976                     return NULL;
 977
 978                 if (!(stash = GvHV(gv)))
 979                     stash = GvHV(gv) = newHV();
 980
 981                 if (!HvNAME_get(stash))
 982                     hv_name_set(stash, nambeg, name_cursor - nambeg, 0);
 983             }
 984
 985             if (*name_cursor == ':')
 986                 name_cursor++;
 987             name_cursor++;
 988             name = name_cursor;
 989             if (name == name_end)
 990                 return gv ? gv : (GV*)*hv_fetchs(PL_defstash, "main::", TRUE);
 991         }
 992     }
 993     len = name_cursor - name;
 994
 995     /* No stash in name, so see how we can default */
 996
 997     if (!stash) {
 998     no_stash:
 999         if (len && isIDFIRST_lazy(name)) {
1000             bool global = FALSE;
1001
1002             switch (len) {
1003             case 1:
1004                 if (*name == '_')
1005                     global = TRUE;
1006                 break;
1007             case 3:
1008                 if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C')
1009                     || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V')
1010                     || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G'))
1011                     global = TRUE;
1012                 break;
1013             case 4:
1014                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1015                     && name[3] == 'V')
1016                     global = TRUE;
1017                 break;
1018             case 5:
1019                 if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D'
1020                     && name[3] == 'I' && name[4] == 'N')
1021                     global = TRUE;
1022                 break;
1023             case 6:
1024                 if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D')
1025                     &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T')
1026                        ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R')))
1027                     global = TRUE;
1028                 break;
1029             case 7:
1030                 if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G'
1031                     && name[3] == 'V' && name[4] == 'O' && name[5] == 'U'
1032                     && name[6] == 'T')
1033                     global = TRUE;
1034                 break;
1035             }
1036
1037             if (global)
1038                 stash = PL_defstash;
1039             else if (IN_PERL_COMPILETIME) {
1040                 stash = PL_curstash;
1041                 if (add && (PL_hints & HINT_STRICT_VARS) &&
1042                     sv_type != SVt_PVCV &&
1043                     sv_type != SVt_PVGV &&
1044                     sv_type != SVt_PVFM &&
1045                     sv_type != SVt_PVIO &&
1046                     !(len == 1 && sv_type == SVt_PV &&
1047                       (*name == 'a' || *name == 'b')) )
1048                 {
1049                     gvp = (GV**)hv_fetch(stash,name,len,0);
1050                     if (!gvp ||
1051                         *gvp == (GV*)&PL_sv_undef ||
1052                         SvTYPE(*gvp) != SVt_PVGV)
1053                     {
1054                         stash = NULL;
1055                     }
1056                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
1057                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
1058                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
1059                     {
1060                         Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
1061                             sv_type == SVt_PVAV ? '@' :
1062                             sv_type == SVt_PVHV ? '%' : '$',
1063                             name);
1064                         if (GvCVu(*gvp))
1065                             Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
1066                         stash = NULL;
1067                     }
1068                 }
1069             }
1070             else
1071                 stash = CopSTASH(PL_curcop);
1072         }
1073         else
1074             stash = PL_defstash;
1075     }
1076
1077     /* By this point we should have a stash and a name */
1078
1079     if (!stash) {
1080         if (add) {
1081             SV * const err = Perl_mess(aTHX_
1082                  "Global symbol \"%s%s\" requires explicit package name",
1083                  (sv_type == SVt_PV ? "$"
1084                   : sv_type == SVt_PVAV ? "@"
1085                   : sv_type == SVt_PVHV ? "%"
1086                   : ""), name);
1087             GV *gv;
1088             if (USE_UTF8_IN_NAMES)
1089                 SvUTF8_on(err);
1090             qerror(err);
1091             gv = gv_fetchpvn_flags("<none>::", 8, GV_ADDMULTI, SVt_PVHV);
1092             if(!gv) {
1093                 /* symbol table under destruction */
1094                 return NULL;
1095             }
1096             stash = GvHV(gv);
1097         }
1098         else
1099             return NULL;
1100     }
1101
1102     if (!SvREFCNT(stash))       /* symbol table under destruction */
1103         return NULL;
1104
1105     gvp = (GV**)hv_fetch(stash,name,len,add);
1106     if (!gvp || *gvp == (GV*)&PL_sv_undef)
1107         return NULL;
1108     gv = *gvp;
1109     if (SvTYPE(gv) == SVt_PVGV) {
1110         if (add) {
1111             GvMULTI_on(gv);
1112             gv_init_sv(gv, sv_type);
1113             if (len == 1 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
1114                 if (*name == '!')
1115                     require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1116                 else if (*name == '-' || *name == '+')
1117                     require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1118             }
1119         }
1120         return gv;
1121     } else if (no_init) {
1122         return gv;
1123     } else if (no_expand && SvROK(gv)) {
1124         return gv;
1125     }
1126
1127     /* Adding a new symbol.
1128        Unless of course there was already something non-GV here, in which case
1129        we want to behave as if there was always a GV here, containing some sort
1130        of subroutine.
1131        Otherwise we run the risk of creating things like GvIO, which can cause
1132        subtle bugs. eg the one that tripped up SQL::Translator  */
1133
1134     faking_it = SvOK(gv);
1135
1136     if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
1137         Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
1138     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
1139     gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
1140
1141     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
1142                                             : (PL_dowarn & G_WARN_ON ) ) )
1143         GvMULTI_on(gv) ;
1144
1145     /* set up magic where warranted */
1146     if (len > 1) {
1147 #ifndef EBCDIC
1148         if (*name > 'V' ) {
1149             NOOP;
1150             /* Nothing else to do.
1151                The compiler will probably turn the switch statement into a
1152                branch table. Make sure we avoid even that small overhead for
1153                the common case of lower case variable names.  */
1154         } else
1155 #endif
1156         {
1157             const char * const name2 = name + 1;
1158             switch (*name) {
1159             case 'A':
1160                 if (strEQ(name2, "RGV")) {
1161                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
1162                 }
1163                 else if (strEQ(name2, "RGVOUT")) {
1164                     GvMULTI_on(gv);
1165                 }
1166                 break;
1167             case 'E':
1168                 if (strnEQ(name2, "XPORT", 5))
1169                     GvMULTI_on(gv);
1170                 break;
1171             case 'I':
1172                 if (strEQ(name2, "SA")) {
1173                     AV* const av = GvAVn(gv);
1174                     GvMULTI_on(gv);
1175                     sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, NULL, 0);
1176                     /* NOTE: No support for tied ISA */
1177                     if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
1178                         && AvFILLp(av) == -1)
1179                         {
1180                             const char *pname;
1181                             av_push(av, newSVpvn(pname = "NDBM_File",9));
1182                             gv_stashpvn(pname, 9, GV_ADD);
1183                             av_push(av, newSVpvn(pname = "DB_File",7));
1184                             gv_stashpvn(pname, 7, GV_ADD);
1185                             av_push(av, newSVpvn(pname = "GDBM_File",9));
1186                             gv_stashpvn(pname, 9, GV_ADD);
1187                             av_push(av, newSVpvn(pname = "SDBM_File",9));
1188                             gv_stashpvn(pname, 9, GV_ADD);
1189                             av_push(av, newSVpvn(pname = "ODBM_File",9));
1190                             gv_stashpvn(pname, 9, GV_ADD);
1191                         }
1192                 }
1193                 break;
1194             case 'O':
1195                 if (strEQ(name2, "VERLOAD")) {
1196                     HV* const hv = GvHVn(gv);
1197                     GvMULTI_on(gv);
1198                     hv_magic(hv, NULL, PERL_MAGIC_overload);
1199                 }
1200                 break;
1201             case 'S':
1202                 if (strEQ(name2, "IG")) {
1203                     HV *hv;
1204                     I32 i;
1205                     if (!PL_psig_ptr) {
1206                         Newxz(PL_psig_ptr,  SIG_SIZE, SV*);
1207                         Newxz(PL_psig_name, SIG_SIZE, SV*);
1208                         Newxz(PL_psig_pend, SIG_SIZE, int);
1209                     }
1210                     GvMULTI_on(gv);
1211                     hv = GvHVn(gv);
1212                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1213                     for (i = 1; i < SIG_SIZE; i++) {
1214                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1215                         if (init)
1216                             sv_setsv(*init, &PL_sv_undef);
1217                         PL_psig_ptr[i] = 0;
1218                         PL_psig_name[i] = 0;
1219                         PL_psig_pend[i] = 0;
1220                     }
1221                 }
1222                 break;
1223             case 'V':
1224                 if (strEQ(name2, "ERSION"))
1225                     GvMULTI_on(gv);
1226                 break;
1227             case '\003':        /* $^CHILD_ERROR_NATIVE */
1228                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1229                     goto magicalize;
1230                 break;
1231             case '\005':        /* $^ENCODING */
1232                 if (strEQ(name2, "NCODING"))
1233                     goto magicalize;
1234                 break;
1235             case '\015':        /* $^MATCH */
1236                 if (strEQ(name2, "ATCH"))
1237                     goto magicalize;
1238             case '\017':        /* $^OPEN */
1239                 if (strEQ(name2, "PEN"))
1240                     goto magicalize;
1241                 break;
1242             case '\020':        /* $^PREMATCH  $^POSTMATCH */
1243                 if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
1244                     goto magicalize;
1245             case '\024':        /* ${^TAINT} */
1246                 if (strEQ(name2, "AINT"))
1247                     goto ro_magicalize;
1248                 break;
1249             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1250                 if (strEQ(name2, "NICODE"))
1251                     goto ro_magicalize;
1252                 if (strEQ(name2, "TF8LOCALE"))
1253                     goto ro_magicalize;
1254                 if (strEQ(name2, "TF8CACHE"))
1255                     goto magicalize;
1256                 break;
1257             case '\027':        /* $^WARNING_BITS */
1258                 if (strEQ(name2, "ARNING_BITS"))
1259                     goto magicalize;
1260                 break;
1261             case '1':
1262             case '2':
1263             case '3':
1264             case '4':
1265             case '5':
1266             case '6':
1267             case '7':
1268             case '8':
1269             case '9':
1270             {
1271                 /* Ensures that we have an all-digit variable, ${"1foo"} fails
1272                    this test  */
1273                 /* This snippet is taken from is_gv_magical */
1274                 const char *end = name + len;
1275                 while (--end > name) {
1276                     if (!isDIGIT(*end)) return gv;
1277                 }
1278                 goto magicalize;
1279             }
1280             }
1281         }
1282     } else {
1283         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1284            be case '\0' in this switch statement (ie a default case)  */
1285         switch (*name) {
1286         case '&':
1287         case '`':
1288         case '\'':
1289             if (
1290                 sv_type == SVt_PVAV ||
1291                 sv_type == SVt_PVHV ||
1292                 sv_type == SVt_PVCV ||
1293                 sv_type == SVt_PVFM ||
1294                 sv_type == SVt_PVIO
1295                 ) { break; }
1296             PL_sawampersand = TRUE;
1297             goto magicalize;
1298
1299         case ':':
1300             sv_setpv(GvSVn(gv),PL_chopset);
1301             goto magicalize;
1302
1303         case '?':
1304 #ifdef COMPLEX_STATUS
1305             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1306 #endif
1307             goto magicalize;
1308
1309         case '!':
1310             GvMULTI_on(gv);
1311             /* If %! has been used, automatically load Errno.pm. */
1312
1313             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1314
1315             /* magicalization must be done before require_tie_mod is called */
1316             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1317                 require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
1318
1319             break;
1320         case '-':
1321         case '+':
1322         GvMULTI_on(gv); /* no used once warnings here */
1323         {
1324             AV* const av = GvAVn(gv);
1325             SV* const avc = (*name == '+') ? (SV*)av : NULL;
1326
1327             sv_magic((SV*)av, avc, PERL_MAGIC_regdata, NULL, 0);
1328             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1329             if (avc)
1330                 SvREADONLY_on(GvSVn(gv));
1331             SvREADONLY_on(av);
1332
1333             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
1334                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
1335
1336             break;
1337         }
1338         case '*':
1339         case '#':
1340             if (sv_type == SVt_PV && ckWARN2_d(WARN_DEPRECATED, WARN_SYNTAX))
1341                 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1342                             "$%c is no longer supported", *name);
1343             break;
1344         case '|':
1345             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1346             goto magicalize;
1347
1348         case '\010':    /* $^H */
1349             {
1350                 HV *const hv = GvHVn(gv);
1351                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1352             }
1353             goto magicalize;
1354         case '\023':    /* $^S */
1355         ro_magicalize:
1356             SvREADONLY_on(GvSVn(gv));
1357             /* FALL THROUGH */
1358         case '1':
1359         case '2':
1360         case '3':
1361         case '4':
1362         case '5':
1363         case '6':
1364         case '7':
1365         case '8':
1366         case '9':
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 '/':
1380         case '\001':    /* $^A */
1381         case '\003':    /* $^C */
1382         case '\004':    /* $^D */
1383         case '\005':    /* $^E */
1384         case '\006':    /* $^F */
1385         case '\011':    /* $^I, NOT \t in EBCDIC */
1386         case '\016':    /* $^N */
1387         case '\017':    /* $^O */
1388         case '\020':    /* $^P */
1389         case '\024':    /* $^T */
1390         case '\027':    /* $^W */
1391         magicalize:
1392             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1393             break;
1394
1395         case '\014':    /* $^L */
1396             sv_setpvn(GvSVn(gv),"\f",1);
1397             PL_formfeed = GvSVn(gv);
1398             break;
1399         case ';':
1400             sv_setpvn(GvSVn(gv),"\034",1);
1401             break;
1402         case ']':
1403         {
1404             SV * const sv = GvSVn(gv);
1405             if (!sv_derived_from(PL_patchlevel, "version"))
1406                 upg_version(PL_patchlevel, TRUE);
1407             GvSV(gv) = vnumify(PL_patchlevel);
1408             SvREADONLY_on(GvSV(gv));
1409             SvREFCNT_dec(sv);
1410         }
1411         break;
1412         case '\026':    /* $^V */
1413         {
1414             SV * const sv = GvSVn(gv);
1415             GvSV(gv) = new_version(PL_patchlevel);
1416             SvREADONLY_on(GvSV(gv));
1417             SvREFCNT_dec(sv);
1418         }
1419         break;
1420         }
1421     }
1422     return gv;
1423 }
1424
1425 void
1426 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1427 {
1428     const char *name;
1429     STRLEN namelen;
1430     const HV * const hv = GvSTASH(gv);
1431
1432     PERL_ARGS_ASSERT_GV_FULLNAME4;
1433
1434     if (!hv) {
1435         SvOK_off(sv);
1436         return;
1437     }
1438     sv_setpv(sv, prefix ? prefix : "");
1439
1440     name = HvNAME_get(hv);
1441     if (name) {
1442         namelen = HvNAMELEN_get(hv);
1443     } else {
1444         name = "__ANON__";
1445         namelen = 8;
1446     }
1447
1448     if (keepmain || strNE(name, "main")) {
1449         sv_catpvn(sv,name,namelen);
1450         sv_catpvs(sv,"::");
1451     }
1452     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1453 }
1454
1455 void
1456 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1457 {
1458     const GV * const egv = GvEGV(gv);
1459
1460     PERL_ARGS_ASSERT_GV_EFULLNAME4;
1461
1462     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1463 }
1464
1465 IO *
1466 Perl_newIO(pTHX)
1467 {
1468     dVAR;
1469     GV *iogv;
1470     IO * const io = (IO*)newSV_type(SVt_PVIO);
1471     /* This used to read SvREFCNT(io) = 1;
1472        It's not clear why the reference count needed an explicit reset. NWC
1473     */
1474     assert (SvREFCNT(io) == 1);
1475     SvOBJECT_on(io);
1476     /* Clear the stashcache because a new IO could overrule a package name */
1477     hv_clear(PL_stashcache);
1478     iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
1479     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1480     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1481       iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
1482     SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1483     return io;
1484 }
1485
1486 void
1487 Perl_gv_check(pTHX_ const HV *stash)
1488 {
1489     dVAR;
1490     register I32 i;
1491
1492     PERL_ARGS_ASSERT_GV_CHECK;
1493
1494     if (!HvARRAY(stash))
1495         return;
1496     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1497         const HE *entry;
1498         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1499             register GV *gv;
1500             HV *hv;
1501             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1502                 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1503             {
1504                 if (hv != PL_defstash && hv != stash)
1505                      gv_check(hv);              /* nested package */
1506             }
1507             else if (isALPHA(*HeKEY(entry))) {
1508                 const char *file;
1509                 gv = (GV*)HeVAL(entry);
1510                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1511                     continue;
1512                 file = GvFILE(gv);
1513                 CopLINE_set(PL_curcop, GvLINE(gv));
1514 #ifdef USE_ITHREADS
1515                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1516 #else
1517                 CopFILEGV(PL_curcop)
1518                     = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0);
1519 #endif
1520                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1521                         "Name \"%s::%s\" used only once: possible typo",
1522                         HvNAME_get(stash), GvNAME(gv));
1523             }
1524         }
1525     }
1526 }
1527
1528 GV *
1529 Perl_newGVgen(pTHX_ const char *pack)
1530 {
1531     dVAR;
1532
1533     PERL_ARGS_ASSERT_NEWGVGEN;
1534
1535     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1536                       GV_ADD, SVt_PVGV);
1537 }
1538
1539 /* hopefully this is only called on local symbol table entries */
1540
1541 GP*
1542 Perl_gp_ref(pTHX_ GP *gp)
1543 {
1544     dVAR;
1545     if (!gp)
1546         return NULL;
1547     gp->gp_refcnt++;
1548     if (gp->gp_cv) {
1549         if (gp->gp_cvgen) {
1550             /* If the GP they asked for a reference to contains
1551                a method cache entry, clear it first, so that we
1552                don't infect them with our cached entry */
1553             SvREFCNT_dec(gp->gp_cv);
1554             gp->gp_cv = NULL;
1555             gp->gp_cvgen = 0;
1556         }
1557     }
1558     return gp;
1559 }
1560
1561 void
1562 Perl_gp_free(pTHX_ GV *gv)
1563 {
1564     dVAR;
1565     GP* gp;
1566
1567     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1568         return;
1569     if (gp->gp_refcnt == 0) {
1570         if (ckWARN_d(WARN_INTERNAL))
1571             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1572                         "Attempt to free unreferenced glob pointers"
1573                         pTHX__FORMAT pTHX__VALUE);
1574         return;
1575     }
1576     if (--gp->gp_refcnt > 0) {
1577         if (gp->gp_egv == gv)
1578             gp->gp_egv = 0;
1579         GvGP(gv) = 0;
1580         return;
1581     }
1582
1583     if (gp->gp_file_hek)
1584         unshare_hek(gp->gp_file_hek);
1585     SvREFCNT_dec(gp->gp_sv);
1586     SvREFCNT_dec(gp->gp_av);
1587     /* FIXME - another reference loop GV -> symtab -> GV ?
1588        Somehow gp->gp_hv can end up pointing at freed garbage.  */
1589     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1590         const char *hvname = HvNAME_get(gp->gp_hv);
1591         if (PL_stashcache && hvname)
1592             (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1593                       G_DISCARD);
1594         SvREFCNT_dec(gp->gp_hv);
1595     }
1596     SvREFCNT_dec(gp->gp_io);
1597     SvREFCNT_dec(gp->gp_cv);
1598     SvREFCNT_dec(gp->gp_form);
1599
1600     Safefree(gp);
1601     GvGP(gv) = 0;
1602 }
1603
1604 int
1605 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1606 {
1607     AMT * const amtp = (AMT*)mg->mg_ptr;
1608     PERL_UNUSED_ARG(sv);
1609
1610     PERL_ARGS_ASSERT_MAGIC_FREEOVRLD;
1611
1612     if (amtp && AMT_AMAGIC(amtp)) {
1613         int i;
1614         for (i = 1; i < NofAMmeth; i++) {
1615             CV * const cv = amtp->table[i];
1616             if (cv) {
1617                 SvREFCNT_dec((SV *) cv);
1618                 amtp->table[i] = NULL;
1619             }
1620         }
1621     }
1622  return 0;
1623 }
1624
1625 /* Updates and caches the CV's */
1626
1627 bool
1628 Perl_Gv_AMupdate(pTHX_ HV *stash)
1629 {
1630   dVAR;
1631   MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1632   AMT amt;
1633   const struct mro_meta* stash_meta = HvMROMETA(stash);
1634   U32 newgen;
1635
1636   PERL_ARGS_ASSERT_GV_AMUPDATE;
1637
1638   newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1639   if (mg) {
1640       const AMT * const amtp = (AMT*)mg->mg_ptr;
1641       if (amtp->was_ok_am == PL_amagic_generation
1642           && amtp->was_ok_sub == newgen) {
1643           return (bool)AMT_OVERLOADED(amtp);
1644       }
1645       sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1646   }
1647
1648   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1649
1650   Zero(&amt,1,AMT);
1651   amt.was_ok_am = PL_amagic_generation;
1652   amt.was_ok_sub = newgen;
1653   amt.fallback = AMGfallNO;
1654   amt.flags = 0;
1655
1656   {
1657     int filled = 0, have_ovl = 0;
1658     int i, lim = 1;
1659
1660     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1661
1662     /* Try to find via inheritance. */
1663     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1664     SV * const sv = gv ? GvSV(gv) : NULL;
1665     CV* cv;
1666
1667     if (!gv)
1668         lim = DESTROY_amg;              /* Skip overloading entries. */
1669 #ifdef PERL_DONT_CREATE_GVSV
1670     else if (!sv) {
1671         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
1672     }
1673 #endif
1674     else if (SvTRUE(sv))
1675         amt.fallback=AMGfallYES;
1676     else if (SvOK(sv))
1677         amt.fallback=AMGfallNEVER;
1678
1679     for (i = 1; i < lim; i++)
1680         amt.table[i] = NULL;
1681     for (; i < NofAMmeth; i++) {
1682         const char * const cooky = PL_AMG_names[i];
1683         /* Human-readable form, for debugging: */
1684         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1685         const STRLEN l = PL_AMG_namelens[i];
1686
1687         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1688                      cp, HvNAME_get(stash)) );
1689         /* don't fill the cache while looking up!
1690            Creation of inheritance stubs in intermediate packages may
1691            conflict with the logic of runtime method substitution.
1692            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1693            then we could have created stubs for "(+0" in A and C too.
1694            But if B overloads "bool", we may want to use it for
1695            numifying instead of C's "+0". */
1696         if (i >= DESTROY_amg)
1697             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1698         else                            /* Autoload taken care of below */
1699             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1700         cv = 0;
1701         if (gv && (cv = GvCV(gv))) {
1702             const char *hvname;
1703             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1704                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1705                 /* This is a hack to support autoloading..., while
1706                    knowing *which* methods were declared as overloaded. */
1707                 /* GvSV contains the name of the method. */
1708                 GV *ngv = NULL;
1709                 SV *gvsv = GvSV(gv);
1710
1711                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1712                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1713                              (void*)GvSV(gv), cp, hvname) );
1714                 if (!gvsv || !SvPOK(gvsv)
1715                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1716                                                        FALSE)))
1717                 {
1718                     /* Can be an import stub (created by "can"). */
1719                     const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
1720                     Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1721                                 "in package \"%.256s\"",
1722                                (GvCVGEN(gv) ? "Stub found while resolving"
1723                                 : "Can't resolve"),
1724                                name, cp, hvname);
1725                 }
1726                 cv = GvCV(gv = ngv);
1727             }
1728             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1729                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1730                          GvNAME(CvGV(cv))) );
1731             filled = 1;
1732             if (i < DESTROY_amg)
1733                 have_ovl = 1;
1734         } else if (gv) {                /* Autoloaded... */
1735             cv = (CV*)gv;
1736             filled = 1;
1737         }
1738         amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
1739     }
1740     if (filled) {
1741       AMT_AMAGIC_on(&amt);
1742       if (have_ovl)
1743           AMT_OVERLOADED_on(&amt);
1744       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1745                                                 (char*)&amt, sizeof(AMT));
1746       return have_ovl;
1747     }
1748   }
1749   /* Here we have no table: */
1750   /* no_table: */
1751   AMT_AMAGIC_off(&amt);
1752   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1753                                                 (char*)&amt, sizeof(AMTS));
1754   return FALSE;
1755 }
1756
1757
1758 CV*
1759 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1760 {
1761     dVAR;
1762     MAGIC *mg;
1763     AMT *amtp;
1764     U32 newgen;
1765     struct mro_meta* stash_meta;
1766
1767     if (!stash || !HvNAME_get(stash))
1768         return NULL;
1769
1770     stash_meta = HvMROMETA(stash);
1771     newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen;
1772
1773     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1774     if (!mg) {
1775       do_update:
1776         Gv_AMupdate(stash);
1777         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1778     }
1779     assert(mg);
1780     amtp = (AMT*)mg->mg_ptr;
1781     if ( amtp->was_ok_am != PL_amagic_generation
1782          || amtp->was_ok_sub != newgen )
1783         goto do_update;
1784     if (AMT_AMAGIC(amtp)) {
1785         CV * const ret = amtp->table[id];
1786         if (ret && isGV(ret)) {         /* Autoloading stab */
1787             /* Passing it through may have resulted in a warning
1788                "Inherited AUTOLOAD for a non-method deprecated", since
1789                our caller is going through a function call, not a method call.
1790                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1791             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1792
1793             if (gv && GvCV(gv))
1794                 return GvCV(gv);
1795         }
1796         return ret;
1797     }
1798
1799     return NULL;
1800 }
1801
1802
1803 SV*
1804 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1805 {
1806   dVAR;
1807   MAGIC *mg;
1808   CV *cv=NULL;
1809   CV **cvp=NULL, **ocvp=NULL;
1810   AMT *amtp=NULL, *oamtp=NULL;
1811   int off = 0, off1, lr = 0, notfound = 0;
1812   int postpr = 0, force_cpy = 0;
1813   int assign = AMGf_assign & flags;
1814   const int assignshift = assign ? 1 : 0;
1815 #ifdef DEBUGGING
1816   int fl=0;
1817 #endif
1818   HV* stash=NULL;
1819
1820   PERL_ARGS_ASSERT_AMAGIC_CALL;
1821
1822   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1823       && (stash = SvSTASH(SvRV(left)))
1824       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1825       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1826                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1827                         : NULL))
1828       && ((cv = cvp[off=method+assignshift])
1829           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1830                                                           * usual method */
1831                   (
1832 #ifdef DEBUGGING
1833                    fl = 1,
1834 #endif
1835                    cv = cvp[off=method])))) {
1836     lr = -1;                    /* Call method for left argument */
1837   } else {
1838     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1839       int logic;
1840
1841       /* look for substituted methods */
1842       /* In all the covered cases we should be called with assign==0. */
1843          switch (method) {
1844          case inc_amg:
1845            force_cpy = 1;
1846            if ((cv = cvp[off=add_ass_amg])
1847                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1848              right = &PL_sv_yes; lr = -1; assign = 1;
1849            }
1850            break;
1851          case dec_amg:
1852            force_cpy = 1;
1853            if ((cv = cvp[off = subtr_ass_amg])
1854                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1855              right = &PL_sv_yes; lr = -1; assign = 1;
1856            }
1857            break;
1858          case bool__amg:
1859            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1860            break;
1861          case numer_amg:
1862            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1863            break;
1864          case string_amg:
1865            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1866            break;
1867          case not_amg:
1868            (void)((cv = cvp[off=bool__amg])
1869                   || (cv = cvp[off=numer_amg])
1870                   || (cv = cvp[off=string_amg]));
1871            postpr = 1;
1872            break;
1873          case copy_amg:
1874            {
1875              /*
1876                   * SV* ref causes confusion with the interpreter variable of
1877                   * the same name
1878                   */
1879              SV* const tmpRef=SvRV(left);
1880              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1881                 /*
1882                  * Just to be extra cautious.  Maybe in some
1883                  * additional cases sv_setsv is safe, too.
1884                  */
1885                 SV* const newref = newSVsv(tmpRef);
1886                 SvOBJECT_on(newref);
1887                 /* As a bit of a source compatibility hack, SvAMAGIC() and
1888                    friends dereference an RV, to behave the same was as when
1889                    overloading was stored on the reference, not the referant.
1890                    Hence we can't use SvAMAGIC_on()
1891                 */
1892                 SvFLAGS(newref) |= SVf_AMAGIC;
1893                 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1894                 return newref;
1895              }
1896            }
1897            break;
1898          case abs_amg:
1899            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1900                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1901              SV* const nullsv=sv_2mortal(newSViv(0));
1902              if (off1==lt_amg) {
1903                SV* const lessp = amagic_call(left,nullsv,
1904                                        lt_amg,AMGf_noright);
1905                logic = SvTRUE(lessp);
1906              } else {
1907                SV* const lessp = amagic_call(left,nullsv,
1908                                        ncmp_amg,AMGf_noright);
1909                logic = (SvNV(lessp) < 0);
1910              }
1911              if (logic) {
1912                if (off==subtr_amg) {
1913                  right = left;
1914                  left = nullsv;
1915                  lr = 1;
1916                }
1917              } else {
1918                return left;
1919              }
1920            }
1921            break;
1922          case neg_amg:
1923            if ((cv = cvp[off=subtr_amg])) {
1924              right = left;
1925              left = sv_2mortal(newSViv(0));
1926              lr = 1;
1927            }
1928            break;
1929          case int_amg:
1930          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1931              /* FAIL safe */
1932              return NULL;       /* Delegate operation to standard mechanisms. */
1933              break;
1934          case to_sv_amg:
1935          case to_av_amg:
1936          case to_hv_amg:
1937          case to_gv_amg:
1938          case to_cv_amg:
1939              /* FAIL safe */
1940              return left;       /* Delegate operation to standard mechanisms. */
1941              break;
1942          default:
1943            goto not_found;
1944          }
1945          if (!cv) goto not_found;
1946     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1947                && (stash = SvSTASH(SvRV(right)))
1948                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1949                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1950                           ? (amtp = (AMT*)mg->mg_ptr)->table
1951                           : NULL))
1952                && (cv = cvp[off=method])) { /* Method for right
1953                                              * argument found */
1954       lr=1;
1955     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1956                  && (cvp=ocvp) && (lr = -1))
1957                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1958                && !(flags & AMGf_unary)) {
1959                                 /* We look for substitution for
1960                                  * comparison operations and
1961                                  * concatenation */
1962       if (method==concat_amg || method==concat_ass_amg
1963           || method==repeat_amg || method==repeat_ass_amg) {
1964         return NULL;            /* Delegate operation to string conversion */
1965       }
1966       off = -1;
1967       switch (method) {
1968          case lt_amg:
1969          case le_amg:
1970          case gt_amg:
1971          case ge_amg:
1972          case eq_amg:
1973          case ne_amg:
1974            postpr = 1; off=ncmp_amg; break;
1975          case slt_amg:
1976          case sle_amg:
1977          case sgt_amg:
1978          case sge_amg:
1979          case seq_amg:
1980          case sne_amg:
1981            postpr = 1; off=scmp_amg; break;
1982          }
1983       if (off != -1) cv = cvp[off];
1984       if (!cv) {
1985         goto not_found;
1986       }
1987     } else {
1988     not_found:                  /* No method found, either report or croak */
1989       switch (method) {
1990          case lt_amg:
1991          case le_amg:
1992          case gt_amg:
1993          case ge_amg:
1994          case eq_amg:
1995          case ne_amg:
1996          case slt_amg:
1997          case sle_amg:
1998          case sgt_amg:
1999          case sge_amg:
2000          case seq_amg:
2001          case sne_amg:
2002            postpr = 0; break;
2003          case to_sv_amg:
2004          case to_av_amg:
2005          case to_hv_amg:
2006          case to_gv_amg:
2007          case to_cv_amg:
2008              /* FAIL safe */
2009              return left;       /* Delegate operation to standard mechanisms. */
2010              break;
2011       }
2012       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
2013         notfound = 1; lr = -1;
2014       } else if (cvp && (cv=cvp[nomethod_amg])) {
2015         notfound = 1; lr = 1;
2016       } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
2017         /* Skip generating the "no method found" message.  */
2018         return NULL;
2019       } else {
2020         SV *msg;
2021         if (off==-1) off=method;
2022         msg = sv_2mortal(Perl_newSVpvf(aTHX_
2023                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
2024                       AMG_id2name(method + assignshift),
2025                       (flags & AMGf_unary ? " " : "\n\tleft "),
2026                       SvAMAGIC(left)?
2027                         "in overloaded package ":
2028                         "has no overloaded magic",
2029                       SvAMAGIC(left)?
2030                         HvNAME_get(SvSTASH(SvRV(left))):
2031                         "",
2032                       SvAMAGIC(right)?
2033                         ",\n\tright argument in overloaded package ":
2034                         (flags & AMGf_unary
2035                          ? ""
2036                          : ",\n\tright argument has no overloaded magic"),
2037                       SvAMAGIC(right)?
2038                         HvNAME_get(SvSTASH(SvRV(right))):
2039                         ""));
2040         if (amtp && amtp->fallback >= AMGfallYES) {
2041           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
2042         } else {
2043           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
2044         }
2045         return NULL;
2046       }
2047       force_cpy = force_cpy || assign;
2048     }
2049   }
2050 #ifdef DEBUGGING
2051   if (!notfound) {
2052     DEBUG_o(Perl_deb(aTHX_
2053                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
2054                      AMG_id2name(off),
2055                      method+assignshift==off? "" :
2056                      " (initially \"",
2057                      method+assignshift==off? "" :
2058                      AMG_id2name(method+assignshift),
2059                      method+assignshift==off? "" : "\")",
2060                      flags & AMGf_unary? "" :
2061                      lr==1 ? " for right argument": " for left argument",
2062                      flags & AMGf_unary? " for argument" : "",
2063                      stash ? HvNAME_get(stash) : "null",
2064                      fl? ",\n\tassignment variant used": "") );
2065   }
2066 #endif
2067     /* Since we use shallow copy during assignment, we need
2068      * to dublicate the contents, probably calling user-supplied
2069      * version of copy operator
2070      */
2071     /* We need to copy in following cases:
2072      * a) Assignment form was called.
2073      *          assignshift==1,  assign==T, method + 1 == off
2074      * b) Increment or decrement, called directly.
2075      *          assignshift==0,  assign==0, method + 0 == off
2076      * c) Increment or decrement, translated to assignment add/subtr.
2077      *          assignshift==0,  assign==T,
2078      *          force_cpy == T
2079      * d) Increment or decrement, translated to nomethod.
2080      *          assignshift==0,  assign==0,
2081      *          force_cpy == T
2082      * e) Assignment form translated to nomethod.
2083      *          assignshift==1,  assign==T, method + 1 != off
2084      *          force_cpy == T
2085      */
2086     /*  off is method, method+assignshift, or a result of opcode substitution.
2087      *  In the latter case assignshift==0, so only notfound case is important.
2088      */
2089   if (( (method + assignshift == off)
2090         && (assign || (method == inc_amg) || (method == dec_amg)))
2091       || force_cpy)
2092     RvDEEPCP(left);
2093   {
2094     dSP;
2095     BINOP myop;
2096     SV* res;
2097     const bool oldcatch = CATCH_GET;
2098
2099     CATCH_SET(TRUE);
2100     Zero(&myop, 1, BINOP);
2101     myop.op_last = (OP *) &myop;
2102     myop.op_next = NULL;
2103     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
2104
2105     PUSHSTACKi(PERLSI_OVERLOAD);
2106     ENTER;
2107     SAVEOP();
2108     PL_op = (OP *) &myop;
2109     if (PERLDB_SUB && PL_curstash != PL_debstash)
2110         PL_op->op_private |= OPpENTERSUB_DB;
2111     PUTBACK;
2112     pp_pushmark();
2113
2114     EXTEND(SP, notfound + 5);
2115     PUSHs(lr>0? right: left);
2116     PUSHs(lr>0? left: right);
2117     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
2118     if (notfound) {
2119       PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift),
2120                            AMG_id2namelen(method + assignshift), SVs_TEMP));
2121     }
2122     PUSHs((SV*)cv);
2123     PUTBACK;
2124
2125     if ((PL_op = Perl_pp_entersub(aTHX)))
2126       CALLRUNOPS(aTHX);
2127     LEAVE;
2128     SPAGAIN;
2129
2130     res=POPs;
2131     PUTBACK;
2132     POPSTACK;
2133     CATCH_SET(oldcatch);
2134
2135     if (postpr) {
2136       int ans;
2137       switch (method) {
2138       case le_amg:
2139       case sle_amg:
2140         ans=SvIV(res)<=0; break;
2141       case lt_amg:
2142       case slt_amg:
2143         ans=SvIV(res)<0; break;
2144       case ge_amg:
2145       case sge_amg:
2146         ans=SvIV(res)>=0; break;
2147       case gt_amg:
2148       case sgt_amg:
2149         ans=SvIV(res)>0; break;
2150       case eq_amg:
2151       case seq_amg:
2152         ans=SvIV(res)==0; break;
2153       case ne_amg:
2154       case sne_amg:
2155         ans=SvIV(res)!=0; break;
2156       case inc_amg:
2157       case dec_amg:
2158         SvSetSV(left,res); return left;
2159       case not_amg:
2160         ans=!SvTRUE(res); break;
2161       default:
2162         ans=0; break;
2163       }
2164       return boolSV(ans);
2165     } else if (method==copy_amg) {
2166       if (!SvROK(res)) {
2167         Perl_croak(aTHX_ "Copy method did not return a reference");
2168       }
2169       return SvREFCNT_inc(SvRV(res));
2170     } else {
2171       return res;
2172     }
2173   }
2174 }
2175
2176 /*
2177 =for apidoc is_gv_magical_sv
2178
2179 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
2180
2181 =cut
2182 */
2183
2184 bool
2185 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
2186 {
2187     STRLEN len;
2188     const char * const temp = SvPV_const(name, len);
2189
2190     PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV;
2191
2192     return is_gv_magical(temp, len, flags);
2193 }
2194
2195 /*
2196 =for apidoc is_gv_magical
2197
2198 Returns C<TRUE> if given the name of a magical GV.
2199
2200 Currently only useful internally when determining if a GV should be
2201 created even in rvalue contexts.
2202
2203 C<flags> is not used at present but available for future extension to
2204 allow selecting particular classes of magical variable.
2205
2206 Currently assumes that C<name> is NUL terminated (as well as len being valid).
2207 This assumption is met by all callers within the perl core, which all pass
2208 pointers returned by SvPV.
2209
2210 =cut
2211 */
2212 bool
2213 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
2214 {
2215     PERL_UNUSED_CONTEXT;
2216     PERL_UNUSED_ARG(flags);
2217
2218     PERL_ARGS_ASSERT_IS_GV_MAGICAL;
2219
2220     if (len > 1) {
2221         const char * const name1 = name + 1;
2222         switch (*name) {
2223         case 'I':
2224             if (len == 3 && name[1] == 'S' && name[2] == 'A')
2225                 goto yes;
2226             break;
2227         case 'O':
2228             if (len == 8 && strEQ(name1, "VERLOAD"))
2229                 goto yes;
2230             break;
2231         case 'S':
2232             if (len == 3 && name[1] == 'I' && name[2] == 'G')
2233                 goto yes;
2234             break;
2235             /* Using ${^...} variables is likely to be sufficiently rare that
2236                it seems sensible to avoid the space hit of also checking the
2237                length.  */
2238         case '\017':   /* ${^OPEN} */
2239             if (strEQ(name1, "PEN"))
2240                 goto yes;
2241             break;
2242         case '\024':   /* ${^TAINT} */
2243             if (strEQ(name1, "AINT"))
2244                 goto yes;
2245             break;
2246         case '\025':    /* ${^UNICODE} */
2247             if (strEQ(name1, "NICODE"))
2248                 goto yes;
2249             if (strEQ(name1, "TF8LOCALE"))
2250                 goto yes;
2251             break;
2252         case '\027':   /* ${^WARNING_BITS} */
2253             if (strEQ(name1, "ARNING_BITS"))
2254                 goto yes;
2255             break;
2256         case '1':
2257         case '2':
2258         case '3':
2259         case '4':
2260         case '5':
2261         case '6':
2262         case '7':
2263         case '8':
2264         case '9':
2265         {
2266             const char *end = name + len;
2267             while (--end > name) {
2268                 if (!isDIGIT(*end))
2269                     return FALSE;
2270             }
2271             goto yes;
2272         }
2273         }
2274     } else {
2275         /* Because we're already assuming that name is NUL terminated
2276            below, we can treat an empty name as "\0"  */
2277         switch (*name) {
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 ']':
2303         case '\001':   /* $^A */
2304         case '\003':   /* $^C */
2305         case '\004':   /* $^D */
2306         case '\005':   /* $^E */
2307         case '\006':   /* $^F */
2308         case '\010':   /* $^H */
2309         case '\011':   /* $^I, NOT \t in EBCDIC */
2310         case '\014':   /* $^L */
2311         case '\016':   /* $^N */
2312         case '\017':   /* $^O */
2313         case '\020':   /* $^P */
2314         case '\023':   /* $^S */
2315         case '\024':   /* $^T */
2316         case '\026':   /* $^V */
2317         case '\027':   /* $^W */
2318         case '1':
2319         case '2':
2320         case '3':
2321         case '4':
2322         case '5':
2323         case '6':
2324         case '7':
2325         case '8':
2326         case '9':
2327         yes:
2328             return TRUE;
2329         default:
2330             break;
2331         }
2332     }
2333     return FALSE;
2334 }
2335
2336 void
2337 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2338 {
2339     dVAR;
2340     U32 hash;
2341
2342     PERL_ARGS_ASSERT_GV_NAME_SET;
2343     PERL_UNUSED_ARG(flags);
2344
2345     if (len > I32_MAX)
2346         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2347
2348     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2349         unshare_hek(GvNAME_HEK(gv));
2350     }
2351
2352     PERL_HASH(hash, name, len);
2353     GvNAME_HEK(gv) = share_hek(name, len, hash);
2354 }
2355
2356 /*
2357  * Local variables:
2358  * c-indentation-style: bsd
2359  * c-basic-offset: 4
2360  * indent-tabs-mode: t
2361  * End:
2362  *
2363  * ex: set ts=8 sts=4 sw=4 noet:
2364  */