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