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