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