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