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