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