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