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