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