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