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