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