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         (void) start_subparse(0,0);     /* Create empty 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 (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash)
 551         && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)
 552     )
 553         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 554           "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
 555              packname, (int)len, name);
 556
 557     if (CvXSUB(cv)) {
 558         /* rather than lookup/init $AUTOLOAD here
 559          * only to have the XSUB do another lookup for $AUTOLOAD
 560          * and split that value on the last '::',
 561          * pass along the same data via some unused fields in the CV
 562          */
 563         CvSTASH(cv) = stash;
 564         SvPV_set(cv, (char *)name); /* cast to lose constness warning */
 565         SvCUR_set(cv, len);
 566         return gv;
 567     }
 568
 569     /*
 570      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
 571      * The subroutine's original name may not be "AUTOLOAD", so we don't
 572      * use that, but for lack of anything better we will use the sub's
 573      * original package to look up $AUTOLOAD.
 574      */
 575     varstash = GvSTASH(CvGV(cv));
 576     vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE);
 577     ENTER;
 578
 579     if (!isGV(vargv)) {
 580         gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
 581 #ifdef PERL_DONT_CREATE_GVSV
 582         GvSV(vargv) = NEWSV(72,0);
 583 #endif
 584     }
 585     LEAVE;
 586     varsv = GvSVn(vargv);
 587     sv_setpvn(varsv, packname, packname_len);
 588     sv_catpvn(varsv, "::", 2);
 589     sv_catpvn(varsv, name, len);
 590     SvTAINTED_off(varsv);
 591     return gv;
 592 }
 593
 594 /* The "gv" parameter should be the glob known to Perl code as *!
 595  * The scalar must already have been magicalized.
 596  */
 597 STATIC void
 598 S_require_errno(pTHX_ GV *gv)
 599 {
 600     dVAR;
 601     HV* stash = gv_stashpvn("Errno",5,FALSE);
 602
 603     if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
 604         dSP;
 605         PUTBACK;
 606         ENTER;
 607         save_scalar(gv); /* keep the value of $! */
 608         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
 609                          newSVpvn("Errno",5), Nullsv);
 610         LEAVE;
 611         SPAGAIN;
 612         stash = gv_stashpvn("Errno",5,FALSE);
 613         if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
 614             Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available");
 615     }
 616 }
 617
 618 /*
 619 =for apidoc gv_stashpv
 620
 621 Returns a pointer to the stash for a specified package.  C<name> should
 622 be a valid UTF-8 string and must be null-terminated.  If C<create> is set
 623 then the package will be created if it does not already exist.  If C<create>
 624 is not set and the package does not exist then NULL is returned.
 625
 626 =cut
 627 */
 628
 629 HV*
 630 Perl_gv_stashpv(pTHX_ const char *name, I32 create)
 631 {
 632     return gv_stashpvn(name, strlen(name), create);
 633 }
 634
 635 /*
 636 =for apidoc gv_stashpvn
 637
 638 Returns a pointer to the stash for a specified package.  C<name> should
 639 be a valid UTF-8 string.  The C<namelen> parameter indicates the length of
 640 the C<name>, in bytes.  If C<create> is set then the package will be
 641 created if it does not already exist.  If C<create> is not set and the
 642 package does not exist then NULL is returned.
 643
 644 =cut
 645 */
 646
 647 HV*
 648 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
 649 {
 650     char smallbuf[256];
 651     char *tmpbuf;
 652     HV *stash;
 653     GV *tmpgv;
 654
 655     if (namelen + 3 < sizeof smallbuf)
 656         tmpbuf = smallbuf;
 657     else
 658         Newx(tmpbuf, namelen + 3, char);
 659     Copy(name,tmpbuf,namelen,char);
 660     tmpbuf[namelen++] = ':';
 661     tmpbuf[namelen++] = ':';
 662     tmpbuf[namelen] = '\0';
 663     tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
 664     if (tmpbuf != smallbuf)
 665         Safefree(tmpbuf);
 666     if (!tmpgv)
 667         return 0;
 668     if (!GvHV(tmpgv))
 669         GvHV(tmpgv) = newHV();
 670     stash = GvHV(tmpgv);
 671     if (!HvNAME_get(stash))
 672         hv_name_set(stash, name, namelen, 0);
 673     return stash;
 674 }
 675
 676 /*
 677 =for apidoc gv_stashsv
 678
 679 Returns a pointer to the stash for a specified package, which must be a
 680 valid UTF-8 string.  See C<gv_stashpv>.
 681
 682 =cut
 683 */
 684
 685 HV*
 686 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
 687 {
 688     STRLEN len;
 689     const char * const ptr = SvPV_const(sv,len);
 690     return gv_stashpvn(ptr, len, create);
 691 }
 692
 693
 694 GV *
 695 Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
 696     return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
 697 }
 698
 699 GV *
 700 Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
 701     STRLEN len;
 702     const char * const nambeg = SvPV_const(name, len);
 703     return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
 704 }
 705
 706 GV *
 707 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 708                        I32 sv_type)
 709 {
 710     register const char *name = nambeg;
 711     register GV *gv = 0;
 712     GV**gvp;
 713     I32 len;
 714     register const char *namend;
 715     HV *stash = 0;
 716     const I32 add = flags & ~SVf_UTF8;
 717
 718     PERL_UNUSED_ARG(full_len);
 719
 720     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
 721         name++;
 722
 723     for (namend = name; *namend; namend++) {
 724         if ((*namend == ':' && namend[1] == ':')
 725             || (*namend == '\'' && namend[1]))
 726         {
 727             if (!stash)
 728                 stash = PL_defstash;
 729             if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
 730                 return Nullgv;
 731
 732             len = namend - name;
 733             if (len > 0) {
 734                 char smallbuf[256];
 735                 char *tmpbuf;
 736
 737                 if (len + 3 < sizeof (smallbuf))
 738                     tmpbuf = smallbuf;
 739                 else
 740                     Newx(tmpbuf, len+3, char);
 741                 Copy(name, tmpbuf, len, char);
 742                 tmpbuf[len++] = ':';
 743                 tmpbuf[len++] = ':';
 744                 tmpbuf[len] = '\0';
 745                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
 746                 gv = gvp ? *gvp : Nullgv;
 747                 if (gv && gv != (GV*)&PL_sv_undef) {
 748                     if (SvTYPE(gv) != SVt_PVGV)
 749                         gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI));
 750                     else
 751                         GvMULTI_on(gv);
 752                 }
 753                 if (tmpbuf != smallbuf)
 754                     Safefree(tmpbuf);
 755                 if (!gv || gv == (GV*)&PL_sv_undef)
 756                     return Nullgv;
 757
 758                 if (!(stash = GvHV(gv)))
 759                     stash = GvHV(gv) = newHV();
 760
 761                 if (!HvNAME_get(stash))
 762                     hv_name_set(stash, nambeg, namend - nambeg, 0);
 763             }
 764
 765             if (*namend == ':')
 766                 namend++;
 767             namend++;
 768             name = namend;
 769             if (!*name)
 770                 return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE);
 771         }
 772     }
 773     len = namend - name;
 774
 775     /* No stash in name, so see how we can default */
 776
 777     if (!stash) {
 778         if (isIDFIRST_lazy(name)) {
 779             bool global = FALSE;
 780
 781             /* name is always \0 terminated, and initial \0 wouldn't return
 782                true from isIDFIRST_lazy, so we know that name[1] is defined  */
 783             switch (name[1]) {
 784             case '\0':
 785                 if (*name == '_')
 786                     global = TRUE;
 787                 break;
 788             case 'N':
 789                 if (strEQ(name, "INC") || strEQ(name, "ENV"))
 790                     global = TRUE;
 791                 break;
 792             case 'I':
 793                 if (strEQ(name, "SIG"))
 794                     global = TRUE;
 795                 break;
 796             case 'T':
 797                 if (strEQ(name, "STDIN") || strEQ(name, "STDOUT") ||
 798                     strEQ(name, "STDERR"))
 799                     global = TRUE;
 800                 break;
 801             case 'R':
 802                 if (strEQ(name, "ARGV") || strEQ(name, "ARGVOUT"))
 803                     global = TRUE;
 804                 break;
 805             }
 806
 807             if (global)
 808                 stash = PL_defstash;
 809             else if (IN_PERL_COMPILETIME) {
 810                 stash = PL_curstash;
 811                 if (add && (PL_hints & HINT_STRICT_VARS) &&
 812                     sv_type != SVt_PVCV &&
 813                     sv_type != SVt_PVGV &&
 814                     sv_type != SVt_PVFM &&
 815                     sv_type != SVt_PVIO &&
 816                     !(len == 1 && sv_type == SVt_PV &&
 817                       (*name == 'a' || *name == 'b')) )
 818                 {
 819                     gvp = (GV**)hv_fetch(stash,name,len,0);
 820                     if (!gvp ||
 821                         *gvp == (GV*)&PL_sv_undef ||
 822                         SvTYPE(*gvp) != SVt_PVGV)
 823                     {
 824                         stash = 0;
 825                     }
 826                     else if ((sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp)) ||
 827                              (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
 828                              (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
 829                     {
 830                         Perl_warn(aTHX_ "Variable \"%c%s\" is not imported",
 831                             sv_type == SVt_PVAV ? '@' :
 832                             sv_type == SVt_PVHV ? '%' : '$',
 833                             name);
 834                         if (GvCVu(*gvp))
 835                             Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name);
 836                         stash = 0;
 837                     }
 838                 }
 839             }
 840             else
 841                 stash = CopSTASH(PL_curcop);
 842         }
 843         else
 844             stash = PL_defstash;
 845     }
 846
 847     /* By this point we should have a stash and a name */
 848
 849     if (!stash) {
 850         if (add) {
 851             SV * const err = Perl_mess(aTHX_
 852                  "Global symbol \"%s%s\" requires explicit package name",
 853                  (sv_type == SVt_PV ? "$"
 854                   : sv_type == SVt_PVAV ? "@"
 855                   : sv_type == SVt_PVHV ? "%"
 856                   : ""), name);
 857             if (USE_UTF8_IN_NAMES)
 858                 SvUTF8_on(err);
 859             qerror(err);
 860             stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
 861         }
 862         else
 863             return Nullgv;
 864     }
 865
 866     if (!SvREFCNT(stash))       /* symbol table under destruction */
 867         return Nullgv;
 868
 869     gvp = (GV**)hv_fetch(stash,name,len,add);
 870     if (!gvp || *gvp == (GV*)&PL_sv_undef)
 871         return Nullgv;
 872     gv = *gvp;
 873     if (SvTYPE(gv) == SVt_PVGV) {
 874         if (add) {
 875             GvMULTI_on(gv);
 876             gv_init_sv(gv, sv_type);
 877             if (*name=='!' && sv_type == SVt_PVHV && len==1)
 878                 require_errno(gv);
 879         }
 880         return gv;
 881     } else if (add & GV_NOINIT) {
 882         return gv;
 883     }
 884
 885     /* Adding a new symbol */
 886
 887     if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
 888         Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
 889     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
 890     gv_init_sv(gv, sv_type);
 891
 892     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
 893                                             : (PL_dowarn & G_WARN_ON ) ) )
 894         GvMULTI_on(gv) ;
 895
 896     /* set up magic where warranted */
 897     if (len > 1) {
 898 #ifndef EBCDIC
 899         if (*name > 'V' ) {
 900             /* Nothing else to do.
 901                The compiler will probably turn the switch statement into a
 902                branch table. Make sure we avoid even that small overhead for
 903                the common case of lower case variable names.  */
 904         } else
 905 #endif
 906         {
 907             const char * const name2 = name + 1;
 908             switch (*name) {
 909             case 'A':
 910                 if (strEQ(name2, "RGV")) {
 911                     IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
 912                 }
 913                 break;
 914             case 'E':
 915                 if (strnEQ(name2, "XPORT", 5))
 916                     GvMULTI_on(gv);
 917                 break;
 918             case 'I':
 919                 if (strEQ(name2, "SA")) {
 920                     AV* const av = GvAVn(gv);
 921                     GvMULTI_on(gv);
 922                     sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
 923                     /* NOTE: No support for tied ISA */
 924                     if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
 925                         && AvFILLp(av) == -1)
 926                         {
 927                             const char *pname;
 928                             av_push(av, newSVpvn(pname = "NDBM_File",9));
 929                             gv_stashpvn(pname, 9, TRUE);
 930                             av_push(av, newSVpvn(pname = "DB_File",7));
 931                             gv_stashpvn(pname, 7, TRUE);
 932                             av_push(av, newSVpvn(pname = "GDBM_File",9));
 933                             gv_stashpvn(pname, 9, TRUE);
 934                             av_push(av, newSVpvn(pname = "SDBM_File",9));
 935                             gv_stashpvn(pname, 9, TRUE);
 936                             av_push(av, newSVpvn(pname = "ODBM_File",9));
 937                             gv_stashpvn(pname, 9, TRUE);
 938                         }
 939                 }
 940                 break;
 941             case 'O':
 942                 if (strEQ(name2, "VERLOAD")) {
 943                     HV* const hv = GvHVn(gv);
 944                     GvMULTI_on(gv);
 945                     hv_magic(hv, Nullgv, PERL_MAGIC_overload);
 946                 }
 947                 break;
 948             case 'S':
 949                 if (strEQ(name2, "IG")) {
 950                     HV *hv;
 951                     I32 i;
 952                     if (!PL_psig_ptr) {
 953                         Newxz(PL_psig_ptr,  SIG_SIZE, SV*);
 954                         Newxz(PL_psig_name, SIG_SIZE, SV*);
 955                         Newxz(PL_psig_pend, SIG_SIZE, int);
 956                     }
 957                     GvMULTI_on(gv);
 958                     hv = GvHVn(gv);
 959                     hv_magic(hv, Nullgv, PERL_MAGIC_sig);
 960                     for (i = 1; i < SIG_SIZE; i++) {
 961                         SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
 962                         if (init)
 963                             sv_setsv(*init, &PL_sv_undef);
 964                         PL_psig_ptr[i] = 0;
 965                         PL_psig_name[i] = 0;
 966                         PL_psig_pend[i] = 0;
 967                     }
 968                 }
 969                 break;
 970             case 'V':
 971                 if (strEQ(name2, "ERSION"))
 972                     GvMULTI_on(gv);
 973                 break;
 974             case '\003':        /* $^CHILD_ERROR_NATIVE */
 975                 if (strEQ(name2, "HILD_ERROR_NATIVE"))
 976                     goto magicalize;
 977                 break;
 978             case '\005':        /* $^ENCODING */
 979                 if (strEQ(name2, "NCODING"))
 980                     goto magicalize;
 981                 break;
 982             case '\017':        /* $^OPEN */
 983                 if (strEQ(name2, "PEN"))
 984                     goto magicalize;
 985                 break;
 986             case '\024':        /* ${^TAINT} */
 987                 if (strEQ(name2, "AINT"))
 988                     goto ro_magicalize;
 989                 break;
 990             case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
 991                 if (strEQ(name2, "NICODE"))
 992                     goto ro_magicalize;
 993                 if (strEQ(name2, "TF8LOCALE"))
 994                     goto ro_magicalize;
 995                 break;
 996             case '\027':        /* $^WARNING_BITS */
 997                 if (strEQ(name2, "ARNING_BITS"))
 998                     goto magicalize;
 999                 break;
1000             case '1':
1001             case '2':
1002             case '3':
1003             case '4':
1004             case '5':
1005             case '6':
1006             case '7':
1007             case '8':
1008             case '9':
1009             {
1010                 /* ensures variable is only digits */
1011                 /* ${"1foo"} fails this test (and is thus writeable) */
1012                 /* added by japhy, but borrowed from is_gv_magical */
1013                 const char *end = name + len;
1014                 while (--end > name) {
1015                     if (!isDIGIT(*end)) return gv;
1016                 }
1017                 goto ro_magicalize;
1018             }
1019             }
1020         }
1021     } else {
1022         /* Names of length 1.  (Or 0. But name is NUL terminated, so that will
1023            be case '\0' in this switch statement (ie a default case)  */
1024         switch (*name) {
1025         case '&':
1026         case '`':
1027         case '\'':
1028             if (
1029                 sv_type == SVt_PVAV ||
1030                 sv_type == SVt_PVHV ||
1031                 sv_type == SVt_PVCV ||
1032                 sv_type == SVt_PVFM ||
1033                 sv_type == SVt_PVIO
1034                 ) { break; }
1035             PL_sawampersand = TRUE;
1036             goto ro_magicalize;
1037
1038         case ':':
1039             sv_setpv(GvSVn(gv),PL_chopset);
1040             goto magicalize;
1041
1042         case '?':
1043 #ifdef COMPLEX_STATUS
1044             SvUPGRADE(GvSVn(gv), SVt_PVLV);
1045 #endif
1046             goto magicalize;
1047
1048         case '!':
1049
1050             /* If %! has been used, automatically load Errno.pm.
1051                The require will itself set errno, so in order to
1052                preserve its value we have to set up the magic
1053                now (rather than going to magicalize)
1054             */
1055
1056             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1057
1058             if (sv_type == SVt_PVHV)
1059                 require_errno(gv);
1060
1061             break;
1062         case '-':
1063         {
1064             AV* const av = GvAVn(gv);
1065             sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
1066             SvREADONLY_on(av);
1067             goto magicalize;
1068         }
1069         case '*':
1070         case '#':
1071             if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
1072                 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
1073                             "$%c is no longer supported", *name);
1074             break;
1075         case '|':
1076             sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
1077             goto magicalize;
1078
1079         case '+':
1080         {
1081             AV* const av = GvAVn(gv);
1082             sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
1083             SvREADONLY_on(av);
1084             /* FALL THROUGH */
1085         }
1086         case '\023':    /* $^S */
1087         case '1':
1088         case '2':
1089         case '3':
1090         case '4':
1091         case '5':
1092         case '6':
1093         case '7':
1094         case '8':
1095         case '9':
1096         ro_magicalize:
1097             SvREADONLY_on(GvSVn(gv));
1098             /* FALL THROUGH */
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 '/':
1112         case '\001':    /* $^A */
1113         case '\003':    /* $^C */
1114         case '\004':    /* $^D */
1115         case '\005':    /* $^E */
1116         case '\006':    /* $^F */
1117         case '\010':    /* $^H */
1118         case '\011':    /* $^I, NOT \t in EBCDIC */
1119         case '\016':    /* $^N */
1120         case '\017':    /* $^O */
1121         case '\020':    /* $^P */
1122         case '\024':    /* $^T */
1123         case '\027':    /* $^W */
1124         magicalize:
1125             sv_magic(GvSVn(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1126             break;
1127
1128         case '\014':    /* $^L */
1129             sv_setpvn(GvSVn(gv),"\f",1);
1130             PL_formfeed = GvSVn(gv);
1131             break;
1132         case ';':
1133             sv_setpvn(GvSVn(gv),"\034",1);
1134             break;
1135         case ']':
1136         {
1137             SV * const sv = GvSVn(gv);
1138             if (!sv_derived_from(PL_patchlevel, "version"))
1139                 (void *)upg_version(PL_patchlevel);
1140             GvSV(gv) = vnumify(PL_patchlevel);
1141             SvREADONLY_on(GvSV(gv));
1142             SvREFCNT_dec(sv);
1143         }
1144         break;
1145         case '\026':    /* $^V */
1146         {
1147             SV * const sv = GvSVn(gv);
1148             GvSV(gv) = new_version(PL_patchlevel);
1149             SvREADONLY_on(GvSV(gv));
1150             SvREFCNT_dec(sv);
1151         }
1152         break;
1153         }
1154     }
1155     return gv;
1156 }
1157
1158 void
1159 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1160 {
1161     const char *name;
1162     STRLEN namelen;
1163     const HV * const hv = GvSTASH(gv);
1164     if (!hv) {
1165         SvOK_off(sv);
1166         return;
1167     }
1168     sv_setpv(sv, prefix ? prefix : "");
1169
1170     name = HvNAME_get(hv);
1171     if (name) {
1172         namelen = HvNAMELEN_get(hv);
1173     } else {
1174         name = "__ANON__";
1175         namelen = 8;
1176     }
1177
1178     if (keepmain || strNE(name, "main")) {
1179         sv_catpvn(sv,name,namelen);
1180         sv_catpvn(sv,"::", 2);
1181     }
1182     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1183 }
1184
1185 void
1186 Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
1187 {
1188     gv_fullname4(sv, gv, prefix, TRUE);
1189 }
1190
1191 void
1192 Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
1193 {
1194     const GV * const egv = GvEGV(gv);
1195     gv_fullname4(sv, egv ? egv : gv, prefix, keepmain);
1196 }
1197
1198 void
1199 Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
1200 {
1201     gv_efullname4(sv, gv, prefix, TRUE);
1202 }
1203
1204 /* compatibility with versions <= 5.003. */
1205 void
1206 Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
1207 {
1208     gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
1209 }
1210
1211 /* compatibility with versions <= 5.003. */
1212 void
1213 Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
1214 {
1215     gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
1216 }
1217
1218 IO *
1219 Perl_newIO(pTHX)
1220 {
1221     GV *iogv;
1222     IO * const io = (IO*)NEWSV(0,0);
1223
1224     sv_upgrade((SV *)io,SVt_PVIO);
1225     /* This used to read SvREFCNT(io) = 1;
1226        It's not clear why the reference count needed an explicit reset. NWC
1227     */
1228     assert (SvREFCNT(io) == 1);
1229     SvOBJECT_on(io);
1230     /* Clear the stashcache because a new IO could overrule a package name */
1231     hv_clear(PL_stashcache);
1232     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1233     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1234     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1235       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1236     SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
1237     return io;
1238 }
1239
1240 void
1241 Perl_gv_check(pTHX_ HV *stash)
1242 {
1243     register I32 i;
1244
1245     if (!HvARRAY(stash))
1246         return;
1247     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1248         const HE *entry;
1249         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1250             register GV *gv;
1251             HV *hv;
1252             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1253                 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1254             {
1255                 if (hv != PL_defstash && hv != stash)
1256                      gv_check(hv);              /* nested package */
1257             }
1258             else if (isALPHA(*HeKEY(entry))) {
1259                 const char *file;
1260                 gv = (GV*)HeVAL(entry);
1261                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1262                     continue;
1263                 file = GvFILE(gv);
1264                 /* performance hack: if filename is absolute and it's a standard
1265                  * module, don't bother warning */
1266 #ifdef MACOS_TRADITIONAL
1267 #   define LIB_COMPONENT ":lib:"
1268 #else
1269 #   define LIB_COMPONENT "/lib/"
1270 #endif
1271                 if (file
1272                     && PERL_FILE_IS_ABSOLUTE(file)
1273                     && (instr(file, LIB_COMPONENT) || instr(file, ".pm")))
1274                 {
1275                     continue;
1276                 }
1277                 CopLINE_set(PL_curcop, GvLINE(gv));
1278 #ifdef USE_ITHREADS
1279                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1280 #else
1281                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1282 #endif
1283                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1284                         "Name \"%s::%s\" used only once: possible typo",
1285                         HvNAME_get(stash), GvNAME(gv));
1286             }
1287         }
1288     }
1289 }
1290
1291 GV *
1292 Perl_newGVgen(pTHX_ const char *pack)
1293 {
1294     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1295                       TRUE, SVt_PVGV);
1296 }
1297
1298 /* hopefully this is only called on local symbol table entries */
1299
1300 GP*
1301 Perl_gp_ref(pTHX_ GP *gp)
1302 {
1303     if (!gp)
1304         return (GP*)NULL;
1305     gp->gp_refcnt++;
1306     if (gp->gp_cv) {
1307         if (gp->gp_cvgen) {
1308             /* multi-named GPs cannot be used for method cache */
1309             SvREFCNT_dec(gp->gp_cv);
1310             gp->gp_cv = Nullcv;
1311             gp->gp_cvgen = 0;
1312         }
1313         else {
1314             /* Adding a new name to a subroutine invalidates method cache */
1315             PL_sub_generation++;
1316         }
1317     }
1318     return gp;
1319 }
1320
1321 void
1322 Perl_gp_free(pTHX_ GV *gv)
1323 {
1324     GP* gp;
1325
1326     if (!gv || !(gp = GvGP(gv)))
1327         return;
1328     if (gp->gp_refcnt == 0) {
1329         if (ckWARN_d(WARN_INTERNAL))
1330             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1331                         "Attempt to free unreferenced glob pointers"
1332                         pTHX__FORMAT pTHX__VALUE);
1333         return;
1334     }
1335     if (gp->gp_cv) {
1336         /* Deleting the name of a subroutine invalidates method cache */
1337         PL_sub_generation++;
1338     }
1339     if (--gp->gp_refcnt > 0) {
1340         if (gp->gp_egv == gv)
1341             gp->gp_egv = 0;
1342         return;
1343     }
1344
1345     if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1346     if (gp->gp_av) SvREFCNT_dec(gp->gp_av);
1347     /* FIXME - another reference loop GV -> symtab -> GV ?
1348        Somehow gp->gp_hv can end up pointing at freed garbage.  */
1349     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1350         const char *hvname = HvNAME_get(gp->gp_hv);
1351         if (PL_stashcache && hvname)
1352             hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1353                       G_DISCARD);
1354         SvREFCNT_dec(gp->gp_hv);
1355     }
1356     if (gp->gp_io)   SvREFCNT_dec(gp->gp_io);
1357     if (gp->gp_cv)   SvREFCNT_dec(gp->gp_cv);
1358     if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1359
1360     Safefree(gp);
1361     GvGP(gv) = 0;
1362 }
1363
1364 int
1365 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1366 {
1367     AMT * const amtp = (AMT*)mg->mg_ptr;
1368     PERL_UNUSED_ARG(sv);
1369
1370     if (amtp && AMT_AMAGIC(amtp)) {
1371         int i;
1372         for (i = 1; i < NofAMmeth; i++) {
1373             CV * const cv = amtp->table[i];
1374             if (cv != Nullcv) {
1375                 SvREFCNT_dec((SV *) cv);
1376                 amtp->table[i] = Nullcv;
1377             }
1378         }
1379     }
1380  return 0;
1381 }
1382
1383 /* Updates and caches the CV's */
1384
1385 bool
1386 Perl_Gv_AMupdate(pTHX_ HV *stash)
1387 {
1388   MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1389   AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1390   AMT amt;
1391
1392   if (mg && amtp->was_ok_am == PL_amagic_generation
1393       && amtp->was_ok_sub == PL_sub_generation)
1394       return (bool)AMT_OVERLOADED(amtp);
1395   sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1396
1397   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1398
1399   Zero(&amt,1,AMT);
1400   amt.was_ok_am = PL_amagic_generation;
1401   amt.was_ok_sub = PL_sub_generation;
1402   amt.fallback = AMGfallNO;
1403   amt.flags = 0;
1404
1405   {
1406     int filled = 0, have_ovl = 0;
1407     int i, lim = 1;
1408
1409     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1410
1411     /* Try to find via inheritance. */
1412     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1413     SV * const sv = gv ? GvSV(gv) : NULL;
1414     CV* cv;
1415
1416     if (!gv)
1417         lim = DESTROY_amg;              /* Skip overloading entries. */
1418 #ifdef PERL_DONT_CREATE_GVSV
1419     else if (!sv) {
1420         /* Equivalent to !SvTRUE and !SvOK  */
1421     }
1422 #endif
1423     else if (SvTRUE(sv))
1424         amt.fallback=AMGfallYES;
1425     else if (SvOK(sv))
1426         amt.fallback=AMGfallNEVER;
1427
1428     for (i = 1; i < lim; i++)
1429         amt.table[i] = Nullcv;
1430     for (; i < NofAMmeth; i++) {
1431         const char *cooky = PL_AMG_names[i];
1432         /* Human-readable form, for debugging: */
1433         const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1434         const STRLEN l = strlen(cooky);
1435
1436         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1437                      cp, HvNAME_get(stash)) );
1438         /* don't fill the cache while looking up!
1439            Creation of inheritance stubs in intermediate packages may
1440            conflict with the logic of runtime method substitution.
1441            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1442            then we could have created stubs for "(+0" in A and C too.
1443            But if B overloads "bool", we may want to use it for
1444            numifying instead of C's "+0". */
1445         if (i >= DESTROY_amg)
1446             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1447         else                            /* Autoload taken care of below */
1448             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1449         cv = 0;
1450         if (gv && (cv = GvCV(gv))) {
1451             const char *hvname;
1452             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1453                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1454                 /* This is a hack to support autoloading..., while
1455                    knowing *which* methods were declared as overloaded. */
1456                 /* GvSV contains the name of the method. */
1457                 GV *ngv = Nullgv;
1458                 SV *gvsv = GvSV(gv);
1459
1460                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1461                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1462                              GvSV(gv), cp, hvname) );
1463                 if (!gvsv || !SvPOK(gvsv)
1464                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1465                                                        FALSE)))
1466                 {
1467                     /* Can be an import stub (created by "can"). */
1468                     const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
1469                     Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1470                                 "in package \"%.256s\"",
1471                                (GvCVGEN(gv) ? "Stub found while resolving"
1472                                 : "Can't resolve"),
1473                                name, cp, hvname);
1474                 }
1475                 cv = GvCV(gv = ngv);
1476             }
1477             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1478                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1479                          GvNAME(CvGV(cv))) );
1480             filled = 1;
1481             if (i < DESTROY_amg)
1482                 have_ovl = 1;
1483         } else if (gv) {                /* Autoloaded... */
1484             cv = (CV*)gv;
1485             filled = 1;
1486         }
1487         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1488     }
1489     if (filled) {
1490       AMT_AMAGIC_on(&amt);
1491       if (have_ovl)
1492           AMT_OVERLOADED_on(&amt);
1493       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1494                                                 (char*)&amt, sizeof(AMT));
1495       return have_ovl;
1496     }
1497   }
1498   /* Here we have no table: */
1499   /* no_table: */
1500   AMT_AMAGIC_off(&amt);
1501   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1502                                                 (char*)&amt, sizeof(AMTS));
1503   return FALSE;
1504 }
1505
1506
1507 CV*
1508 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1509 {
1510     MAGIC *mg;
1511     AMT *amtp;
1512
1513     if (!stash || !HvNAME_get(stash))
1514         return Nullcv;
1515     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1516     if (!mg) {
1517       do_update:
1518         Gv_AMupdate(stash);
1519         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1520     }
1521     amtp = (AMT*)mg->mg_ptr;
1522     if ( amtp->was_ok_am != PL_amagic_generation
1523          || amtp->was_ok_sub != PL_sub_generation )
1524         goto do_update;
1525     if (AMT_AMAGIC(amtp)) {
1526         CV * const ret = amtp->table[id];
1527         if (ret && isGV(ret)) {         /* Autoloading stab */
1528             /* Passing it through may have resulted in a warning
1529                "Inherited AUTOLOAD for a non-method deprecated", since
1530                our caller is going through a function call, not a method call.
1531                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1532             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1533
1534             if (gv && GvCV(gv))
1535                 return GvCV(gv);
1536         }
1537         return ret;
1538     }
1539
1540     return Nullcv;
1541 }
1542
1543
1544 SV*
1545 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1546 {
1547   dVAR;
1548   MAGIC *mg;
1549   CV *cv=NULL;
1550   CV **cvp=NULL, **ocvp=NULL;
1551   AMT *amtp=NULL, *oamtp=NULL;
1552   int off = 0, off1, lr = 0, notfound = 0;
1553   int postpr = 0, force_cpy = 0;
1554   int assign = AMGf_assign & flags;
1555   const int assignshift = assign ? 1 : 0;
1556 #ifdef DEBUGGING
1557   int fl=0;
1558 #endif
1559   HV* stash=NULL;
1560   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1561       && (stash = SvSTASH(SvRV(left)))
1562       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1563       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1564                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1565                         : (CV **) NULL))
1566       && ((cv = cvp[off=method+assignshift])
1567           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1568                                                           * usual method */
1569                   (
1570 #ifdef DEBUGGING
1571                    fl = 1,
1572 #endif
1573                    cv = cvp[off=method])))) {
1574     lr = -1;                    /* Call method for left argument */
1575   } else {
1576     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1577       int logic;
1578
1579       /* look for substituted methods */
1580       /* In all the covered cases we should be called with assign==0. */
1581          switch (method) {
1582          case inc_amg:
1583            force_cpy = 1;
1584            if ((cv = cvp[off=add_ass_amg])
1585                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1586              right = &PL_sv_yes; lr = -1; assign = 1;
1587            }
1588            break;
1589          case dec_amg:
1590            force_cpy = 1;
1591            if ((cv = cvp[off = subtr_ass_amg])
1592                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1593              right = &PL_sv_yes; lr = -1; assign = 1;
1594            }
1595            break;
1596          case bool__amg:
1597            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1598            break;
1599          case numer_amg:
1600            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1601            break;
1602          case string_amg:
1603            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1604            break;
1605          case not_amg:
1606            (void)((cv = cvp[off=bool__amg])
1607                   || (cv = cvp[off=numer_amg])
1608                   || (cv = cvp[off=string_amg]));
1609            postpr = 1;
1610            break;
1611          case copy_amg:
1612            {
1613              /*
1614                   * SV* ref causes confusion with the interpreter variable of
1615                   * the same name
1616                   */
1617              SV* const tmpRef=SvRV(left);
1618              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1619                 /*
1620                  * Just to be extra cautious.  Maybe in some
1621                  * additional cases sv_setsv is safe, too.
1622                  */
1623                 SV* const newref = newSVsv(tmpRef);
1624                 SvOBJECT_on(newref);
1625                 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1626                 return newref;
1627              }
1628            }
1629            break;
1630          case abs_amg:
1631            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1632                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1633              SV* const nullsv=sv_2mortal(newSViv(0));
1634              if (off1==lt_amg) {
1635                SV* const lessp = amagic_call(left,nullsv,
1636                                        lt_amg,AMGf_noright);
1637                logic = SvTRUE(lessp);
1638              } else {
1639                SV* const lessp = amagic_call(left,nullsv,
1640                                        ncmp_amg,AMGf_noright);
1641                logic = (SvNV(lessp) < 0);
1642              }
1643              if (logic) {
1644                if (off==subtr_amg) {
1645                  right = left;
1646                  left = nullsv;
1647                  lr = 1;
1648                }
1649              } else {
1650                return left;
1651              }
1652            }
1653            break;
1654          case neg_amg:
1655            if ((cv = cvp[off=subtr_amg])) {
1656              right = left;
1657              left = sv_2mortal(newSViv(0));
1658              lr = 1;
1659            }
1660            break;
1661          case int_amg:
1662          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1663              /* FAIL safe */
1664              return NULL;       /* Delegate operation to standard mechanisms. */
1665              break;
1666          case to_sv_amg:
1667          case to_av_amg:
1668          case to_hv_amg:
1669          case to_gv_amg:
1670          case to_cv_amg:
1671              /* FAIL safe */
1672              return left;       /* Delegate operation to standard mechanisms. */
1673              break;
1674          default:
1675            goto not_found;
1676          }
1677          if (!cv) goto not_found;
1678     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1679                && (stash = SvSTASH(SvRV(right)))
1680                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1681                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1682                           ? (amtp = (AMT*)mg->mg_ptr)->table
1683                           : (CV **) NULL))
1684                && (cv = cvp[off=method])) { /* Method for right
1685                                              * argument found */
1686       lr=1;
1687     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1688                  && (cvp=ocvp) && (lr = -1))
1689                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1690                && !(flags & AMGf_unary)) {
1691                                 /* We look for substitution for
1692                                  * comparison operations and
1693                                  * concatenation */
1694       if (method==concat_amg || method==concat_ass_amg
1695           || method==repeat_amg || method==repeat_ass_amg) {
1696         return NULL;            /* Delegate operation to string conversion */
1697       }
1698       off = -1;
1699       switch (method) {
1700          case lt_amg:
1701          case le_amg:
1702          case gt_amg:
1703          case ge_amg:
1704          case eq_amg:
1705          case ne_amg:
1706            postpr = 1; off=ncmp_amg; break;
1707          case slt_amg:
1708          case sle_amg:
1709          case sgt_amg:
1710          case sge_amg:
1711          case seq_amg:
1712          case sne_amg:
1713            postpr = 1; off=scmp_amg; break;
1714          }
1715       if (off != -1) cv = cvp[off];
1716       if (!cv) {
1717         goto not_found;
1718       }
1719     } else {
1720     not_found:                  /* No method found, either report or croak */
1721       switch (method) {
1722          case to_sv_amg:
1723          case to_av_amg:
1724          case to_hv_amg:
1725          case to_gv_amg:
1726          case to_cv_amg:
1727              /* FAIL safe */
1728              return left;       /* Delegate operation to standard mechanisms. */
1729              break;
1730       }
1731       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1732         notfound = 1; lr = -1;
1733       } else if (cvp && (cv=cvp[nomethod_amg])) {
1734         notfound = 1; lr = 1;
1735       } else {
1736         SV *msg;
1737         if (off==-1) off=method;
1738         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1739                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
1740                       AMG_id2name(method + assignshift),
1741                       (flags & AMGf_unary ? " " : "\n\tleft "),
1742                       SvAMAGIC(left)?
1743                         "in overloaded package ":
1744                         "has no overloaded magic",
1745                       SvAMAGIC(left)?
1746                         HvNAME_get(SvSTASH(SvRV(left))):
1747                         "",
1748                       SvAMAGIC(right)?
1749                         ",\n\tright argument in overloaded package ":
1750                         (flags & AMGf_unary
1751                          ? ""
1752                          : ",\n\tright argument has no overloaded magic"),
1753                       SvAMAGIC(right)?
1754                         HvNAME_get(SvSTASH(SvRV(right))):
1755                         ""));
1756         if (amtp && amtp->fallback >= AMGfallYES) {
1757           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1758         } else {
1759           Perl_croak(aTHX_ "%"SVf, msg);
1760         }
1761         return NULL;
1762       }
1763       force_cpy = force_cpy || assign;
1764     }
1765   }
1766 #ifdef DEBUGGING
1767   if (!notfound) {
1768     DEBUG_o(Perl_deb(aTHX_
1769                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1770                      AMG_id2name(off),
1771                      method+assignshift==off? "" :
1772                      " (initially \"",
1773                      method+assignshift==off? "" :
1774                      AMG_id2name(method+assignshift),
1775                      method+assignshift==off? "" : "\")",
1776                      flags & AMGf_unary? "" :
1777                      lr==1 ? " for right argument": " for left argument",
1778                      flags & AMGf_unary? " for argument" : "",
1779                      stash ? HvNAME_get(stash) : "null",
1780                      fl? ",\n\tassignment variant used": "") );
1781   }
1782 #endif
1783     /* Since we use shallow copy during assignment, we need
1784      * to dublicate the contents, probably calling user-supplied
1785      * version of copy operator
1786      */
1787     /* We need to copy in following cases:
1788      * a) Assignment form was called.
1789      *          assignshift==1,  assign==T, method + 1 == off
1790      * b) Increment or decrement, called directly.
1791      *          assignshift==0,  assign==0, method + 0 == off
1792      * c) Increment or decrement, translated to assignment add/subtr.
1793      *          assignshift==0,  assign==T,
1794      *          force_cpy == T
1795      * d) Increment or decrement, translated to nomethod.
1796      *          assignshift==0,  assign==0,
1797      *          force_cpy == T
1798      * e) Assignment form translated to nomethod.
1799      *          assignshift==1,  assign==T, method + 1 != off
1800      *          force_cpy == T
1801      */
1802     /*  off is method, method+assignshift, or a result of opcode substitution.
1803      *  In the latter case assignshift==0, so only notfound case is important.
1804      */
1805   if (( (method + assignshift == off)
1806         && (assign || (method == inc_amg) || (method == dec_amg)))
1807       || force_cpy)
1808     RvDEEPCP(left);
1809   {
1810     dSP;
1811     BINOP myop;
1812     SV* res;
1813     const bool oldcatch = CATCH_GET;
1814
1815     CATCH_SET(TRUE);
1816     Zero(&myop, 1, BINOP);
1817     myop.op_last = (OP *) &myop;
1818     myop.op_next = Nullop;
1819     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1820
1821     PUSHSTACKi(PERLSI_OVERLOAD);
1822     ENTER;
1823     SAVEOP();
1824     PL_op = (OP *) &myop;
1825     if (PERLDB_SUB && PL_curstash != PL_debstash)
1826         PL_op->op_private |= OPpENTERSUB_DB;
1827     PUTBACK;
1828     pp_pushmark();
1829
1830     EXTEND(SP, notfound + 5);
1831     PUSHs(lr>0? right: left);
1832     PUSHs(lr>0? left: right);
1833     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1834     if (notfound) {
1835       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1836     }
1837     PUSHs((SV*)cv);
1838     PUTBACK;
1839
1840     if ((PL_op = Perl_pp_entersub(aTHX)))
1841       CALLRUNOPS(aTHX);
1842     LEAVE;
1843     SPAGAIN;
1844
1845     res=POPs;
1846     PUTBACK;
1847     POPSTACK;
1848     CATCH_SET(oldcatch);
1849
1850     if (postpr) {
1851       int ans;
1852       switch (method) {
1853       case le_amg:
1854       case sle_amg:
1855         ans=SvIV(res)<=0; break;
1856       case lt_amg:
1857       case slt_amg:
1858         ans=SvIV(res)<0; break;
1859       case ge_amg:
1860       case sge_amg:
1861         ans=SvIV(res)>=0; break;
1862       case gt_amg:
1863       case sgt_amg:
1864         ans=SvIV(res)>0; break;
1865       case eq_amg:
1866       case seq_amg:
1867         ans=SvIV(res)==0; break;
1868       case ne_amg:
1869       case sne_amg:
1870         ans=SvIV(res)!=0; break;
1871       case inc_amg:
1872       case dec_amg:
1873         SvSetSV(left,res); return left;
1874       case not_amg:
1875         ans=!SvTRUE(res); break;
1876       default:
1877         ans=0; break;
1878       }
1879       return boolSV(ans);
1880     } else if (method==copy_amg) {
1881       if (!SvROK(res)) {
1882         Perl_croak(aTHX_ "Copy method did not return a reference");
1883       }
1884       return SvREFCNT_inc(SvRV(res));
1885     } else {
1886       return res;
1887     }
1888   }
1889 }
1890
1891 /*
1892 =for apidoc is_gv_magical_sv
1893
1894 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
1895
1896 =cut
1897 */
1898
1899 bool
1900 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
1901 {
1902     STRLEN len;
1903     const char * const temp = SvPV_const(name, len);
1904     return is_gv_magical(temp, len, flags);
1905 }
1906
1907 /*
1908 =for apidoc is_gv_magical
1909
1910 Returns C<TRUE> if given the name of a magical GV.
1911
1912 Currently only useful internally when determining if a GV should be
1913 created even in rvalue contexts.
1914
1915 C<flags> is not used at present but available for future extension to
1916 allow selecting particular classes of magical variable.
1917
1918 Currently assumes that C<name> is NUL terminated (as well as len being valid).
1919 This assumption is met by all callers within the perl core, which all pass
1920 pointers returned by SvPV.
1921
1922 =cut
1923 */
1924 bool
1925 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
1926 {
1927     PERL_UNUSED_ARG(flags);
1928
1929     if (len > 1) {
1930         const char * const name1 = name + 1;
1931         switch (*name) {
1932         case 'I':
1933             if (len == 3 && name1[1] == 'S' && name[2] == 'A')
1934                 goto yes;
1935             break;
1936         case 'O':
1937             if (len == 8 && strEQ(name1, "VERLOAD"))
1938                 goto yes;
1939             break;
1940         case 'S':
1941             if (len == 3 && name[1] == 'I' && name[2] == 'G')
1942                 goto yes;
1943             break;
1944             /* Using ${^...} variables is likely to be sufficiently rare that
1945                it seems sensible to avoid the space hit of also checking the
1946                length.  */
1947         case '\017':   /* ${^OPEN} */
1948             if (strEQ(name1, "PEN"))
1949                 goto yes;
1950             break;
1951         case '\024':   /* ${^TAINT} */
1952             if (strEQ(name1, "AINT"))
1953                 goto yes;
1954             break;
1955         case '\025':    /* ${^UNICODE} */
1956             if (strEQ(name1, "NICODE"))
1957                 goto yes;
1958             if (strEQ(name1, "TF8LOCALE"))
1959                 goto yes;
1960             break;
1961         case '\027':   /* ${^WARNING_BITS} */
1962             if (strEQ(name1, "ARNING_BITS"))
1963                 goto yes;
1964             break;
1965         case '1':
1966         case '2':
1967         case '3':
1968         case '4':
1969         case '5':
1970         case '6':
1971         case '7':
1972         case '8':
1973         case '9':
1974         {
1975             const char *end = name + len;
1976             while (--end > name) {
1977                 if (!isDIGIT(*end))
1978                     return FALSE;
1979             }
1980             goto yes;
1981         }
1982         }
1983     } else {
1984         /* Because we're already assuming that name is NUL terminated
1985            below, we can treat an empty name as "\0"  */
1986         switch (*name) {
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 ';':
2011         case ']':
2012         case '\001':   /* $^A */
2013         case '\003':   /* $^C */
2014         case '\004':   /* $^D */
2015         case '\005':   /* $^E */
2016         case '\006':   /* $^F */
2017         case '\010':   /* $^H */
2018         case '\011':   /* $^I, NOT \t in EBCDIC */
2019         case '\014':   /* $^L */
2020         case '\016':   /* $^N */
2021         case '\017':   /* $^O */
2022         case '\020':   /* $^P */
2023         case '\023':   /* $^S */
2024         case '\024':   /* $^T */
2025         case '\026':   /* $^V */
2026         case '\027':   /* $^W */
2027         case '1':
2028         case '2':
2029         case '3':
2030         case '4':
2031         case '5':
2032         case '6':
2033         case '7':
2034         case '8':
2035         case '9':
2036         yes:
2037             return TRUE;
2038         default:
2039             break;
2040         }
2041     }
2042     return FALSE;
2043 }
2044
2045 /*
2046  * Local variables:
2047  * c-indentation-style: bsd
2048  * c-basic-offset: 4
2049  * indent-tabs-mode: t
2050  * End:
2051  *
2052  * ex: set ts=8 sts=4 sw=4 noet:
2053  */