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                 else if (strEQ(name2, "RGVOUT")) {
1006                     GvMULTI_on(gv);
1007                 }
1008                 break;
1009             case 'E':
1010                 if (strnEQ(name2, "XPORT", 5))
1011                     GvMULTI_on(gv);
1012                 break;
1013             case 'I':
1014                 if (strEQ(name2, "SA")) {
1015                     AV* const av = GvAVn(gv);
1016                     GvMULTI_on(gv);
1017                     sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, NULL, 0);
1018                     /* NOTE: No support for tied ISA */
1019                     if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
1020                         && AvFILLp(av) == -1)
1021                         {
1022                             const char *pname;
1023                             av_push(av, newSVpvn(pname = "NDBM_File",9));
1024                             gv_stashpvn(pname, 9, TRUE);
1025                             av_push(av, newSVpvn(pname = "DB_File",7));
1026                             gv_stashpvn(pname, 7, TRUE);
1027                             av_push(av, newSVpvn(pname = "GDBM_File",9));
1028                             gv_stashpvn(pname, 9, TRUE);
1029                             av_push(av, newSVpvn(pname = "SDBM_File",9));
1030                             gv_stashpvn(pname, 9, TRUE);
1031                             av_push(av, newSVpvn(pname = "ODBM_File",9));
1032                             gv_stashpvn(pname, 9, TRUE);
1033                         }
1034                 }
1035                 break;
1036             case 'O':
1037                 if (strEQ(name2, "VERLOAD")) {
1038                     HV* const hv = GvHVn(gv);
1039                     GvMULTI_on(gv);
1040                     hv_magic(hv, NULL, PERL_MAGIC_overload);
1041                 }
1042                 break;
1043             case 'S':
1044                 if (strEQ(name2, "IG")) {
1045                     HV *hv;
1046                     I32 i;
1047                     if (!PL_psig_ptr) {
1048                         Newxz(PL_psig_ptr,  SIG_SIZE, SV*);
1049                         Newxz(PL_psig_name, SIG_SIZE, SV*);
1050                         Newxz(PL_psig_pend, SIG_SIZE, int);
1051                     }
1052                     GvMULTI_on(gv);
1053                     hv = GvHVn(gv);
1054                     hv_magic(hv, NULL, PERL_MAGIC_sig);
1055                     for (i = 1; i < SIG_SIZE; i++) {
1056                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
1057                         if (init)
1058                             sv_setsv(*init, &PL_sv_undef);
1059                         PL_psig_ptr[i] = 0;
1060                         PL_psig_name[i] = 0;
1061                         PL_psig_pend[i] = 0;
1062                     }
1063                 }
1064                 break;
1065             case 'V':
1066                 if (strEQ(name2, "ERSION"))
1067                     GvMULTI_on(gv);
1068                 break;
1069             case '\003':        /* $^CHILD_ERROR_NATIVE */
1070                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
1071                     goto magicalize;
1072                 break;
1073             case '\005':        /* $^ENCODING */
1074                 if (strEQ(name2, "NCODING"))
1075                     goto magicalize;
1076                 break;
1077             case '\017':        /* $^OPEN */
1078                 if (strEQ(name2, "PEN"))
1079                     goto magicalize;
1080                 break;
1081             case '\024':        /* ${^TAINT} */
1082                 if (strEQ(name2, "AINT"))
1083                     goto ro_magicalize;
1084                 break;
1085             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
1086                 if (strEQ(name2, "NICODE"))
1087                     goto ro_magicalize;
1088                 if (strEQ(name2, "TF8LOCALE"))
1089                     goto ro_magicalize;
1090                 if (strEQ(name2, "TF8CACHE"))
1091                     goto magicalize;
1092                 break;
1093             case '\027':        /* $^WARNING_BITS */
1094                 if (strEQ(name2, "ARNING_BITS"))
1095                     goto magicalize;
1096                 break;
1097             case '1':
1098             case '2':
1099             case '3':
1100             case '4':
1101             case '5':
1102             case '6':
1103             case '7':
1104             case '8':
1105             case '9':
1106             {
1107                 /* ensures variable is only digits */
1108                 /* ${"1foo"} fails this test (and is thus writeable) */
1109                 /* added by japhy, but borrowed from is_gv_magical */
1110                 const char *end = name + len;
1111                 while (--end > name) {
1112                     if (!isDIGIT(*end)) return gv;
1113                 }
1114                 goto ro_magicalize;
1115             }
1116             }
1117         }
1118     } else {
1119         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1120            be case '\0' in this switch statement (ie a default case)  */
1121         switch (*name) {
1122         case '&':
1123         case '`':
1124         case '\'':
1125             if (
1126                 sv_type == SVt_PVAV ||
1127                 sv_type == SVt_PVHV ||
1128                 sv_type == SVt_PVCV ||
1129                 sv_type == SVt_PVFM ||
1130                 sv_type == SVt_PVIO
1131                 ) { break; }
1132             PL_sawampersand = TRUE;
1133             goto ro_magicalize;
1134
1135         case ':':
1136             sv_setpv(GvSVn(gv),PL_chopset);
1137             goto magicalize;
1138
1139         case '?':
1140 #ifdef COMPLEX_STATUS
1141             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1142 #endif
1143             goto magicalize;
1144
1145         case '!':
1146
1147             /* If %! has been used, automatically load Errno.pm.
1148                The require will itself set errno, so in order to
1149                preserve its value we have to set up the magic
1150                now (rather than going to magicalize)
1151             */
1152
1153             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1154
1155             if (sv_type == SVt_PVHV)
1156                 require_errno(gv);
1157
1158             break;
1159         case '-':
1160         {
1161             AV* const av = GvAVn(gv);
1162             sv_magic((SV*)av, NULL, PERL_MAGIC_regdata, NULL, 0);
1163             SvREADONLY_on(av);
1164             goto magicalize;
1165         }
1166         case '*':
1167         case '#':
1168             if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1169                 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1170                             "$%c is no longer supported", *name);
1171             break;
1172         case '|':
1173             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1174             goto magicalize;
1175
1176         case '\010':    /* $^H */
1177             {
1178                 HV *const hv = GvHVn(gv);
1179                 hv_magic(hv, NULL, PERL_MAGIC_hints);
1180             }
1181             goto magicalize;
1182
1183         case '+':
1184         {
1185             AV* const av = GvAVn(gv);
1186             sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, NULL, 0);
1187             SvREADONLY_on(av);
1188             /* FALL THROUGH */
1189         }
1190         case '\023':    /* $^S */
1191         case '1':
1192         case '2':
1193         case '3':
1194         case '4':
1195         case '5':
1196         case '6':
1197         case '7':
1198         case '8':
1199         case '9':
1200         ro_magicalize:
1201             SvREADONLY_on(GvSVn(gv));
1202             /* FALL THROUGH */
1203         case '[':
1204         case '^':
1205         case '~':
1206         case '=':
1207         case '%':
1208         case '.':
1209         case '(':
1210         case ')':
1211         case '<':
1212         case '>':
1213         case ',':
1214         case '\\':
1215         case '/':
1216         case '\001':    /* $^A */
1217         case '\003':    /* $^C */
1218         case '\004':    /* $^D */
1219         case '\005':    /* $^E */
1220         case '\006':    /* $^F */
1221         case '\011':    /* $^I, NOT \t in EBCDIC */
1222         case '\016':    /* $^N */
1223         case '\017':    /* $^O */
1224         case '\020':    /* $^P */
1225         case '\024':    /* $^T */
1226         case '\027':    /* $^W */
1227         magicalize:
1228             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1229             break;
1230
1231         case '\014':    /* $^L */
1232             sv_setpvn(GvSVn(gv),"\f",1);
1233             PL_formfeed = GvSVn(gv);
1234             break;
1235         case ';':
1236             sv_setpvn(GvSVn(gv),"\034",1);
1237             break;
1238         case ']':
1239         {
1240             SV * const sv = GvSVn(gv);
1241             if (!sv_derived_from(PL_patchlevel, "version"))
1242                 upg_version(PL_patchlevel);
1243             GvSV(gv) = vnumify(PL_patchlevel);
1244             SvREADONLY_on(GvSV(gv));
1245             SvREFCNT_dec(sv);
1246         }
1247         break;
1248         case '\026':    /* $^V */
1249         {
1250             SV * const sv = GvSVn(gv);
1251             GvSV(gv) = new_version(PL_patchlevel);
1252             SvREADONLY_on(GvSV(gv));
1253             SvREFCNT_dec(sv);
1254         }
1255         break;
1256         }
1257     }
1258     return gv;
1259 }
1260
1261 void
1262 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1263 {
1264     const char *name;
1265     STRLEN namelen;
1266     const HV * const hv = GvSTASH(gv);
1267     if (!hv) {
1268         SvOK_off(sv);
1269         return;
1270     }
1271     sv_setpv(sv, prefix ? prefix : "");
1272
1273     name = HvNAME_get(hv);
1274     if (name) {
1275         namelen = HvNAMELEN_get(hv);
1276     } else {
1277         name = "__ANON__";
1278         namelen = 8;
1279     }
1280
1281     if (keepmain || strNE(name, "main")) {
1282         sv_catpvn(sv,name,namelen);
1283         sv_catpvs(sv,"::");
1284     }
1285     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1286 }
1287
1288 void
1289 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1290 {
1291     const GV * const egv = GvEGV(gv);
1292     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1293 }
1294
1295 IO *
1296 Perl_newIO(pTHX)
1297 {
1298     dVAR;
1299     GV *iogv;
1300     IO * const io = (IO*)newSV(0);
1301
1302     sv_upgrade((SV *)io,SVt_PVIO);
1303     /* This used to read SvREFCNT(io) = 1;
1304        It's not clear why the reference count needed an explicit reset. NWC
1305     */
1306     assert (SvREFCNT(io) == 1);
1307     SvOBJECT_on(io);
1308     /* Clear the stashcache because a new IO could overrule a package name */
1309     hv_clear(PL_stashcache);
1310     iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
1311     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1312     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1313       iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
1314     SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1315     return io;
1316 }
1317
1318 void
1319 Perl_gv_check(pTHX_ const HV *stash)
1320 {
1321     dVAR;
1322     register I32 i;
1323
1324     if (!HvARRAY(stash))
1325         return;
1326     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1327         const HE *entry;
1328         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1329             register GV *gv;
1330             HV *hv;
1331             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1332                 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1333             {
1334                 if (hv != PL_defstash && hv != stash)
1335                      gv_check(hv);              /* nested package */
1336             }
1337             else if (isALPHA(*HeKEY(entry))) {
1338                 const char *file;
1339                 gv = (GV*)HeVAL(entry);
1340                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1341                     continue;
1342                 file = GvFILE(gv);
1343                 /* performance hack: if filename is absolute and it's a standard
1344                  * module, don't bother warning */
1345 #ifdef MACOS_TRADITIONAL
1346 #   define LIB_COMPONENT ":lib:"
1347 #else
1348 #   define LIB_COMPONENT "/lib/"
1349 #endif
1350                 if (file
1351                     && PERL_FILE_IS_ABSOLUTE(file)
1352                     && (instr(file, LIB_COMPONENT) || instr(file, ".pm")))
1353                 {
1354                     continue;
1355                 }
1356                 CopLINE_set(PL_curcop, GvLINE(gv));
1357 #ifdef USE_ITHREADS
1358                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1359 #else
1360                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1361 #endif
1362                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1363                         "Name \"%s::%s\" used only once: possible typo",
1364                         HvNAME_get(stash), GvNAME(gv));
1365             }
1366         }
1367     }
1368 }
1369
1370 GV *
1371 Perl_newGVgen(pTHX_ const char *pack)
1372 {
1373     dVAR;
1374     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1375                       GV_ADD, SVt_PVGV);
1376 }
1377
1378 /* hopefully this is only called on local symbol table entries */
1379
1380 GP*
1381 Perl_gp_ref(pTHX_ GP *gp)
1382 {
1383     dVAR;
1384     if (!gp)
1385         return NULL;
1386     gp->gp_refcnt++;
1387     if (gp->gp_cv) {
1388         if (gp->gp_cvgen) {
1389             /* multi-named GPs cannot be used for method cache */
1390             SvREFCNT_dec(gp->gp_cv);
1391             gp->gp_cv = NULL;
1392             gp->gp_cvgen = 0;
1393         }
1394         else {
1395             /* Adding a new name to a subroutine invalidates method cache */
1396             PL_sub_generation++;
1397         }
1398     }
1399     return gp;
1400 }
1401
1402 void
1403 Perl_gp_free(pTHX_ GV *gv)
1404 {
1405     dVAR;
1406     GP* gp;
1407
1408     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1409         return;
1410     if (gp->gp_refcnt == 0) {
1411         if (ckWARN_d(WARN_INTERNAL))
1412             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1413                         "Attempt to free unreferenced glob pointers"
1414                         pTHX__FORMAT pTHX__VALUE);
1415         return;
1416     }
1417     if (gp->gp_cv) {
1418         /* Deleting the name of a subroutine invalidates method cache */
1419         PL_sub_generation++;
1420     }
1421     if (--gp->gp_refcnt > 0) {
1422         if (gp->gp_egv == gv)
1423             gp->gp_egv = 0;
1424         GvGP(gv) = 0;
1425         return;
1426     }
1427
1428     unshare_hek(gp->gp_file_hek);
1429     SvREFCNT_dec(gp->gp_sv);
1430     SvREFCNT_dec(gp->gp_av);
1431     /* FIXME - another reference loop GV -> symtab -> GV ?
1432        Somehow gp->gp_hv can end up pointing at freed garbage.  */
1433     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1434         const char *hvname = HvNAME_get(gp->gp_hv);
1435         if (PL_stashcache && hvname)
1436             hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1437                       G_DISCARD);
1438         SvREFCNT_dec(gp->gp_hv);
1439     }
1440     SvREFCNT_dec(gp->gp_io);
1441     SvREFCNT_dec(gp->gp_cv);
1442     SvREFCNT_dec(gp->gp_form);
1443
1444     Safefree(gp);
1445     GvGP(gv) = 0;
1446 }
1447
1448 int
1449 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1450 {
1451     AMT * const amtp = (AMT*)mg->mg_ptr;
1452     PERL_UNUSED_ARG(sv);
1453
1454     if (amtp && AMT_AMAGIC(amtp)) {
1455         int i;
1456         for (i = 1; i < NofAMmeth; i++) {
1457             CV * const cv = amtp->table[i];
1458             if (cv) {
1459                 SvREFCNT_dec((SV *) cv);
1460                 amtp->table[i] = NULL;
1461             }
1462         }
1463     }
1464  return 0;
1465 }
1466
1467 /* Updates and caches the CV's */
1468
1469 bool
1470 Perl_Gv_AMupdate(pTHX_ HV *stash)
1471 {
1472   dVAR;
1473   MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1474   AMT amt;
1475
1476   if (mg) {
1477       const AMT * const amtp = (AMT*)mg->mg_ptr;
1478       if (amtp->was_ok_am == PL_amagic_generation
1479           && amtp->was_ok_sub == PL_sub_generation) {
1480           return (bool)AMT_OVERLOADED(amtp);
1481       }
1482       sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1483   }
1484
1485   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1486
1487   Zero(&amt,1,AMT);
1488   amt.was_ok_am = PL_amagic_generation;
1489   amt.was_ok_sub = PL_sub_generation;
1490   amt.fallback = AMGfallNO;
1491   amt.flags = 0;
1492
1493   {
1494     int filled = 0, have_ovl = 0;
1495     int i, lim = 1;
1496
1497     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1498
1499     /* Try to find via inheritance. */
1500     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1501     SV * const sv = gv ? GvSV(gv) : NULL;
1502     CV* cv;
1503
1504     if (!gv)
1505         lim = DESTROY_amg;              /* Skip overloading entries. */
1506 #ifdef PERL_DONT_CREATE_GVSV
1507     else if (!sv) {
1508         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
1509     }
1510 #endif
1511     else if (SvTRUE(sv))
1512         amt.fallback=AMGfallYES;
1513     else if (SvOK(sv))
1514         amt.fallback=AMGfallNEVER;
1515
1516     for (i = 1; i < lim; i++)
1517         amt.table[i] = NULL;
1518     for (; i < NofAMmeth; i++) {
1519         const char * const cooky = PL_AMG_names[i];
1520         /* Human-readable form, for debugging: */
1521         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1522         const STRLEN l = strlen(cooky);
1523
1524         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1525                      cp, HvNAME_get(stash)) );
1526         /* don't fill the cache while looking up!
1527            Creation of inheritance stubs in intermediate packages may
1528            conflict with the logic of runtime method substitution.
1529            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1530            then we could have created stubs for "(+0" in A and C too.
1531            But if B overloads "bool", we may want to use it for
1532            numifying instead of C's "+0". */
1533         if (i >= DESTROY_amg)
1534             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1535         else                            /* Autoload taken care of below */
1536             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1537         cv = 0;
1538         if (gv && (cv = GvCV(gv))) {
1539             const char *hvname;
1540             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1541                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1542                 /* This is a hack to support autoloading..., while
1543                    knowing *which* methods were declared as overloaded. */
1544                 /* GvSV contains the name of the method. */
1545                 GV *ngv = NULL;
1546                 SV *gvsv = GvSV(gv);
1547
1548                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1549                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1550                              (void*)GvSV(gv), cp, hvname) );
1551                 if (!gvsv || !SvPOK(gvsv)
1552                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1553                                                        FALSE)))
1554                 {
1555                     /* Can be an import stub (created by "can"). */
1556                     const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
1557                     Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1558                                 "in package \"%.256s\"",
1559                                (GvCVGEN(gv) ? "Stub found while resolving"
1560                                 : "Can't resolve"),
1561                                name, cp, hvname);
1562                 }
1563                 cv = GvCV(gv = ngv);
1564             }
1565             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1566                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1567                          GvNAME(CvGV(cv))) );
1568             filled = 1;
1569             if (i < DESTROY_amg)
1570                 have_ovl = 1;
1571         } else if (gv) {                /* Autoloaded... */
1572             cv = (CV*)gv;
1573             filled = 1;
1574         }
1575         amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
1576     }
1577     if (filled) {
1578       AMT_AMAGIC_on(&amt);
1579       if (have_ovl)
1580           AMT_OVERLOADED_on(&amt);
1581       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1582                                                 (char*)&amt, sizeof(AMT));
1583       return have_ovl;
1584     }
1585   }
1586   /* Here we have no table: */
1587   /* no_table: */
1588   AMT_AMAGIC_off(&amt);
1589   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1590                                                 (char*)&amt, sizeof(AMTS));
1591   return FALSE;
1592 }
1593
1594
1595 CV*
1596 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1597 {
1598     dVAR;
1599     MAGIC *mg;
1600     AMT *amtp;
1601
1602     if (!stash || !HvNAME_get(stash))
1603         return NULL;
1604     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1605     if (!mg) {
1606       do_update:
1607         Gv_AMupdate(stash);
1608         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1609     }
1610     assert(mg);
1611     amtp = (AMT*)mg->mg_ptr;
1612     if ( amtp->was_ok_am != PL_amagic_generation
1613          || amtp->was_ok_sub != PL_sub_generation )
1614         goto do_update;
1615     if (AMT_AMAGIC(amtp)) {
1616         CV * const ret = amtp->table[id];
1617         if (ret && isGV(ret)) {         /* Autoloading stab */
1618             /* Passing it through may have resulted in a warning
1619                "Inherited AUTOLOAD for a non-method deprecated", since
1620                our caller is going through a function call, not a method call.
1621                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1622             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1623
1624             if (gv && GvCV(gv))
1625                 return GvCV(gv);
1626         }
1627         return ret;
1628     }
1629
1630     return NULL;
1631 }
1632
1633
1634 SV*
1635 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1636 {
1637   dVAR;
1638   MAGIC *mg;
1639   CV *cv=NULL;
1640   CV **cvp=NULL, **ocvp=NULL;
1641   AMT *amtp=NULL, *oamtp=NULL;
1642   int off = 0, off1, lr = 0, notfound = 0;
1643   int postpr = 0, force_cpy = 0;
1644   int assign = AMGf_assign & flags;
1645   const int assignshift = assign ? 1 : 0;
1646 #ifdef DEBUGGING
1647   int fl=0;
1648 #endif
1649   HV* stash=NULL;
1650   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1651       && (stash = SvSTASH(SvRV(left)))
1652       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1653       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1654                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1655                         : NULL))
1656       && ((cv = cvp[off=method+assignshift])
1657           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1658                                                           * usual method */
1659                   (
1660 #ifdef DEBUGGING
1661                    fl = 1,
1662 #endif
1663                    cv = cvp[off=method])))) {
1664     lr = -1;                    /* Call method for left argument */
1665   } else {
1666     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1667       int logic;
1668
1669       /* look for substituted methods */
1670       /* In all the covered cases we should be called with assign==0. */
1671          switch (method) {
1672          case inc_amg:
1673            force_cpy = 1;
1674            if ((cv = cvp[off=add_ass_amg])
1675                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1676              right = &PL_sv_yes; lr = -1; assign = 1;
1677            }
1678            break;
1679          case dec_amg:
1680            force_cpy = 1;
1681            if ((cv = cvp[off = subtr_ass_amg])
1682                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1683              right = &PL_sv_yes; lr = -1; assign = 1;
1684            }
1685            break;
1686          case bool__amg:
1687            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1688            break;
1689          case numer_amg:
1690            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1691            break;
1692          case string_amg:
1693            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1694            break;
1695          case not_amg:
1696            (void)((cv = cvp[off=bool__amg])
1697                   || (cv = cvp[off=numer_amg])
1698                   || (cv = cvp[off=string_amg]));
1699            postpr = 1;
1700            break;
1701          case copy_amg:
1702            {
1703              /*
1704                   * SV* ref causes confusion with the interpreter variable of
1705                   * the same name
1706                   */
1707              SV* const tmpRef=SvRV(left);
1708              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1709                 /*
1710                  * Just to be extra cautious.  Maybe in some
1711                  * additional cases sv_setsv is safe, too.
1712                  */
1713                 SV* const newref = newSVsv(tmpRef);
1714                 SvOBJECT_on(newref);
1715                 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1716                 return newref;
1717              }
1718            }
1719            break;
1720          case abs_amg:
1721            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1722                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1723              SV* const nullsv=sv_2mortal(newSViv(0));
1724              if (off1==lt_amg) {
1725                SV* const lessp = amagic_call(left,nullsv,
1726                                        lt_amg,AMGf_noright);
1727                logic = SvTRUE(lessp);
1728              } else {
1729                SV* const lessp = amagic_call(left,nullsv,
1730                                        ncmp_amg,AMGf_noright);
1731                logic = (SvNV(lessp) < 0);
1732              }
1733              if (logic) {
1734                if (off==subtr_amg) {
1735                  right = left;
1736                  left = nullsv;
1737                  lr = 1;
1738                }
1739              } else {
1740                return left;
1741              }
1742            }
1743            break;
1744          case neg_amg:
1745            if ((cv = cvp[off=subtr_amg])) {
1746              right = left;
1747              left = sv_2mortal(newSViv(0));
1748              lr = 1;
1749            }
1750            break;
1751          case int_amg:
1752          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1753              /* FAIL safe */
1754              return NULL;       /* Delegate operation to standard mechanisms. */
1755              break;
1756          case to_sv_amg:
1757          case to_av_amg:
1758          case to_hv_amg:
1759          case to_gv_amg:
1760          case to_cv_amg:
1761              /* FAIL safe */
1762              return left;       /* Delegate operation to standard mechanisms. */
1763              break;
1764          default:
1765            goto not_found;
1766          }
1767          if (!cv) goto not_found;
1768     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1769                && (stash = SvSTASH(SvRV(right)))
1770                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1771                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1772                           ? (amtp = (AMT*)mg->mg_ptr)->table
1773                           : NULL))
1774                && (cv = cvp[off=method])) { /* Method for right
1775                                              * argument found */
1776       lr=1;
1777     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1778                  && (cvp=ocvp) && (lr = -1))
1779                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1780                && !(flags & AMGf_unary)) {
1781                                 /* We look for substitution for
1782                                  * comparison operations and
1783                                  * concatenation */
1784       if (method==concat_amg || method==concat_ass_amg
1785           || method==repeat_amg || method==repeat_ass_amg) {
1786         return NULL;            /* Delegate operation to string conversion */
1787       }
1788       off = -1;
1789       switch (method) {
1790          case lt_amg:
1791          case le_amg:
1792          case gt_amg:
1793          case ge_amg:
1794          case eq_amg:
1795          case ne_amg:
1796            postpr = 1; off=ncmp_amg; break;
1797          case slt_amg:
1798          case sle_amg:
1799          case sgt_amg:
1800          case sge_amg:
1801          case seq_amg:
1802          case sne_amg:
1803            postpr = 1; off=scmp_amg; break;
1804          }
1805       if (off != -1) cv = cvp[off];
1806       if (!cv) {
1807         goto not_found;
1808       }
1809     } else {
1810     not_found:                  /* No method found, either report or croak */
1811       switch (method) {
1812          case to_sv_amg:
1813          case to_av_amg:
1814          case to_hv_amg:
1815          case to_gv_amg:
1816          case to_cv_amg:
1817              /* FAIL safe */
1818              return left;       /* Delegate operation to standard mechanisms. */
1819              break;
1820       }
1821       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1822         notfound = 1; lr = -1;
1823       } else if (cvp && (cv=cvp[nomethod_amg])) {
1824         notfound = 1; lr = 1;
1825       } else {
1826         SV *msg;
1827         if (off==-1) off=method;
1828         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1829                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
1830                       AMG_id2name(method + assignshift),
1831                       (flags & AMGf_unary ? " " : "\n\tleft "),
1832                       SvAMAGIC(left)?
1833                         "in overloaded package ":
1834                         "has no overloaded magic",
1835                       SvAMAGIC(left)?
1836                         HvNAME_get(SvSTASH(SvRV(left))):
1837                         "",
1838                       SvAMAGIC(right)?
1839                         ",\n\tright argument in overloaded package ":
1840                         (flags & AMGf_unary
1841                          ? ""
1842                          : ",\n\tright argument has no overloaded magic"),
1843                       SvAMAGIC(right)?
1844                         HvNAME_get(SvSTASH(SvRV(right))):
1845                         ""));
1846         if (amtp && amtp->fallback >= AMGfallYES) {
1847           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1848         } else {
1849           Perl_croak(aTHX_ "%"SVf, (void*)msg);
1850         }
1851         return NULL;
1852       }
1853       force_cpy = force_cpy || assign;
1854     }
1855   }
1856 #ifdef DEBUGGING
1857   if (!notfound) {
1858     DEBUG_o(Perl_deb(aTHX_
1859                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1860                      AMG_id2name(off),
1861                      method+assignshift==off? "" :
1862                      " (initially \"",
1863                      method+assignshift==off? "" :
1864                      AMG_id2name(method+assignshift),
1865                      method+assignshift==off? "" : "\")",
1866                      flags & AMGf_unary? "" :
1867                      lr==1 ? " for right argument": " for left argument",
1868                      flags & AMGf_unary? " for argument" : "",
1869                      stash ? HvNAME_get(stash) : "null",
1870                      fl? ",\n\tassignment variant used": "") );
1871   }
1872 #endif
1873     /* Since we use shallow copy during assignment, we need
1874      * to dublicate the contents, probably calling user-supplied
1875      * version of copy operator
1876      */
1877     /* We need to copy in following cases:
1878      * a) Assignment form was called.
1879      *          assignshift==1,  assign==T, method + 1 == off
1880      * b) Increment or decrement, called directly.
1881      *          assignshift==0,  assign==0, method + 0 == off
1882      * c) Increment or decrement, translated to assignment add/subtr.
1883      *          assignshift==0,  assign==T,
1884      *          force_cpy == T
1885      * d) Increment or decrement, translated to nomethod.
1886      *          assignshift==0,  assign==0,
1887      *          force_cpy == T
1888      * e) Assignment form translated to nomethod.
1889      *          assignshift==1,  assign==T, method + 1 != off
1890      *          force_cpy == T
1891      */
1892     /*  off is method, method+assignshift, or a result of opcode substitution.
1893      *  In the latter case assignshift==0, so only notfound case is important.
1894      */
1895   if (( (method + assignshift == off)
1896         && (assign || (method == inc_amg) || (method == dec_amg)))
1897       || force_cpy)
1898     RvDEEPCP(left);
1899   {
1900     dSP;
1901     BINOP myop;
1902     SV* res;
1903     const bool oldcatch = CATCH_GET;
1904
1905     CATCH_SET(TRUE);
1906     Zero(&myop, 1, BINOP);
1907     myop.op_last = (OP *) &myop;
1908     myop.op_next = NULL;
1909     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1910
1911     PUSHSTACKi(PERLSI_OVERLOAD);
1912     ENTER;
1913     SAVEOP();
1914     PL_op = (OP *) &myop;
1915     if (PERLDB_SUB && PL_curstash != PL_debstash)
1916         PL_op->op_private |= OPpENTERSUB_DB;
1917     PUTBACK;
1918     pp_pushmark();
1919
1920     EXTEND(SP, notfound + 5);
1921     PUSHs(lr>0? right: left);
1922     PUSHs(lr>0? left: right);
1923     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1924     if (notfound) {
1925       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1926     }
1927     PUSHs((SV*)cv);
1928     PUTBACK;
1929
1930     if ((PL_op = Perl_pp_entersub(aTHX)))
1931       CALLRUNOPS(aTHX);
1932     LEAVE;
1933     SPAGAIN;
1934
1935     res=POPs;
1936     PUTBACK;
1937     POPSTACK;
1938     CATCH_SET(oldcatch);
1939
1940     if (postpr) {
1941       int ans;
1942       switch (method) {
1943       case le_amg:
1944       case sle_amg:
1945         ans=SvIV(res)<=0; break;
1946       case lt_amg:
1947       case slt_amg:
1948         ans=SvIV(res)<0; break;
1949       case ge_amg:
1950       case sge_amg:
1951         ans=SvIV(res)>=0; break;
1952       case gt_amg:
1953       case sgt_amg:
1954         ans=SvIV(res)>0; break;
1955       case eq_amg:
1956       case seq_amg:
1957         ans=SvIV(res)==0; break;
1958       case ne_amg:
1959       case sne_amg:
1960         ans=SvIV(res)!=0; break;
1961       case inc_amg:
1962       case dec_amg:
1963         SvSetSV(left,res); return left;
1964       case not_amg:
1965         ans=!SvTRUE(res); break;
1966       default:
1967         ans=0; break;
1968       }
1969       return boolSV(ans);
1970     } else if (method==copy_amg) {
1971       if (!SvROK(res)) {
1972         Perl_croak(aTHX_ "Copy method did not return a reference");
1973       }
1974       return SvREFCNT_inc(SvRV(res));
1975     } else {
1976       return res;
1977     }
1978   }
1979 }
1980
1981 /*
1982 =for apidoc is_gv_magical_sv
1983
1984 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1985
1986 =cut
1987 */
1988
1989 bool
1990 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1991 {
1992     STRLEN len;
1993     const char * const temp = SvPV_const(name, len);
1994     return is_gv_magical(temp, len, flags);
1995 }
1996
1997 /*
1998 =for apidoc is_gv_magical
1999
2000 Returns C<TRUE> if given the name of a magical GV.
2001
2002 Currently only useful internally when determining if a GV should be
2003 created even in rvalue contexts.
2004
2005 C<flags> is not used at present but available for future extension to
2006 allow selecting particular classes of magical variable.
2007
2008 Currently assumes that C<name> is NUL terminated (as well as len being valid).
2009 This assumption is met by all callers within the perl core, which all pass
2010 pointers returned by SvPV.
2011
2012 =cut
2013 */
2014 bool
2015 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
2016 {
2017     PERL_UNUSED_CONTEXT;
2018     PERL_UNUSED_ARG(flags);
2019
2020     if (len > 1) {
2021         const char * const name1 = name + 1;
2022         switch (*name) {
2023         case 'I':
2024             if (len == 3 && name1[1] == 'S' && name[2] == 'A')
2025                 goto yes;
2026             break;
2027         case 'O':
2028             if (len == 8 && strEQ(name1, "VERLOAD"))
2029                 goto yes;
2030             break;
2031         case 'S':
2032             if (len == 3 && name[1] == 'I' && name[2] == 'G')
2033                 goto yes;
2034             break;
2035             /* Using ${^...} variables is likely to be sufficiently rare that
2036                it seems sensible to avoid the space hit of also checking the
2037                length.  */
2038         case '\017':   /* ${^OPEN} */
2039             if (strEQ(name1, "PEN"))
2040                 goto yes;
2041             break;
2042         case '\024':   /* ${^TAINT} */
2043             if (strEQ(name1, "AINT"))
2044                 goto yes;
2045             break;
2046         case '\025':    /* ${^UNICODE} */
2047             if (strEQ(name1, "NICODE"))
2048                 goto yes;
2049             if (strEQ(name1, "TF8LOCALE"))
2050                 goto yes;
2051             break;
2052         case '\027':   /* ${^WARNING_BITS} */
2053             if (strEQ(name1, "ARNING_BITS"))
2054                 goto yes;
2055             break;
2056         case '1':
2057         case '2':
2058         case '3':
2059         case '4':
2060         case '5':
2061         case '6':
2062         case '7':
2063         case '8':
2064         case '9':
2065         {
2066             const char *end = name + len;
2067             while (--end > name) {
2068                 if (!isDIGIT(*end))
2069                     return FALSE;
2070             }
2071             goto yes;
2072         }
2073         }
2074     } else {
2075         /* Because we're already assuming that name is NUL terminated
2076            below, we can treat an empty name as "\0"  */
2077         switch (*name) {
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 '+':
2101         case ';':
2102         case ']':
2103         case '\001':   /* $^A */
2104         case '\003':   /* $^C */
2105         case '\004':   /* $^D */
2106         case '\005':   /* $^E */
2107         case '\006':   /* $^F */
2108         case '\010':   /* $^H */
2109         case '\011':   /* $^I, NOT \t in EBCDIC */
2110         case '\014':   /* $^L */
2111         case '\016':   /* $^N */
2112         case '\017':   /* $^O */
2113         case '\020':   /* $^P */
2114         case '\023':   /* $^S */
2115         case '\024':   /* $^T */
2116         case '\026':   /* $^V */
2117         case '\027':   /* $^W */
2118         case '1':
2119         case '2':
2120         case '3':
2121         case '4':
2122         case '5':
2123         case '6':
2124         case '7':
2125         case '8':
2126         case '9':
2127         yes:
2128             return TRUE;
2129         default:
2130             break;
2131         }
2132     }
2133     return FALSE;
2134 }
2135
2136 void
2137 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2138 {
2139     dVAR;
2140     U32 hash;
2141
2142     assert(name);
2143     PERL_UNUSED_ARG(flags);
2144
2145     if (len > I32_MAX)
2146         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2147
2148     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2149         unshare_hek(GvNAME_HEK(gv));
2150     }
2151
2152     PERL_HASH(hash, name, len);
2153     GvNAME_HEK(gv) = share_hek(name, len, hash);
2154 }
2155
2156 /*
2157  * Local variables:
2158  * c-indentation-style: bsd
2159  * c-basic-offset: 4
2160  * indent-tabs-mode: t
2161  * End:
2162  *
2163  * ex: set ts=8 sts=4 sw=4 noet:
2164  */