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