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