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