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