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                 CopLINE_set(PL_curcop, GvLINE(gv));
1394 #ifdef USE_ITHREADS
1395                 CopFILE(PL_curcop) = (char *)file;      /* set for warning */
1396 #else
1397                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1398 #endif
1399                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1400                         "Name \"%s::%s\" used only once: possible typo",
1401                         HvNAME_get(stash), GvNAME(gv));
1402             }
1403         }
1404     }
1405 }
1406
1407 GV *
1408 Perl_newGVgen(pTHX_ const char *pack)
1409 {
1410     dVAR;
1411     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1412                       GV_ADD, SVt_PVGV);
1413 }
1414
1415 /* hopefully this is only called on local symbol table entries */
1416
1417 GP*
1418 Perl_gp_ref(pTHX_ GP *gp)
1419 {
1420     dVAR;
1421     if (!gp)
1422         return NULL;
1423     gp->gp_refcnt++;
1424     if (gp->gp_cv) {
1425         if (gp->gp_cvgen) {
1426             /* multi-named GPs cannot be used for method cache */
1427             SvREFCNT_dec(gp->gp_cv);
1428             gp->gp_cv = NULL;
1429             gp->gp_cvgen = 0;
1430         }
1431         else {
1432             /* Adding a new name to a subroutine invalidates method cache */
1433             PL_sub_generation++;
1434         }
1435     }
1436     return gp;
1437 }
1438
1439 void
1440 Perl_gp_free(pTHX_ GV *gv)
1441 {
1442     dVAR;
1443     GP* gp;
1444
1445     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
1446         return;
1447     if (gp->gp_refcnt == 0) {
1448         if (ckWARN_d(WARN_INTERNAL))
1449             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1450                         "Attempt to free unreferenced glob pointers"
1451                         pTHX__FORMAT pTHX__VALUE);
1452         return;
1453     }
1454     if (gp->gp_cv) {
1455         /* Deleting the name of a subroutine invalidates method cache */
1456         PL_sub_generation++;
1457     }
1458     if (--gp->gp_refcnt > 0) {
1459         if (gp->gp_egv == gv)
1460             gp->gp_egv = 0;
1461         GvGP(gv) = 0;
1462         return;
1463     }
1464
1465     if (gp->gp_file_hek)
1466         unshare_hek(gp->gp_file_hek);
1467     SvREFCNT_dec(gp->gp_sv);
1468     SvREFCNT_dec(gp->gp_av);
1469     /* FIXME - another reference loop GV -> symtab -> GV ?
1470        Somehow gp->gp_hv can end up pointing at freed garbage.  */
1471     if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) {
1472         const char *hvname = HvNAME_get(gp->gp_hv);
1473         if (PL_stashcache && hvname)
1474             hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv),
1475                       G_DISCARD);
1476         SvREFCNT_dec(gp->gp_hv);
1477     }
1478     SvREFCNT_dec(gp->gp_io);
1479     SvREFCNT_dec(gp->gp_cv);
1480     SvREFCNT_dec(gp->gp_form);
1481
1482     Safefree(gp);
1483     GvGP(gv) = 0;
1484 }
1485
1486 int
1487 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1488 {
1489     AMT * const amtp = (AMT*)mg->mg_ptr;
1490     PERL_UNUSED_ARG(sv);
1491
1492     if (amtp && AMT_AMAGIC(amtp)) {
1493         int i;
1494         for (i = 1; i < NofAMmeth; i++) {
1495             CV * const cv = amtp->table[i];
1496             if (cv) {
1497                 SvREFCNT_dec((SV *) cv);
1498                 amtp->table[i] = NULL;
1499             }
1500         }
1501     }
1502  return 0;
1503 }
1504
1505 /* Updates and caches the CV's */
1506
1507 bool
1508 Perl_Gv_AMupdate(pTHX_ HV *stash)
1509 {
1510   dVAR;
1511   MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1512   AMT amt;
1513
1514   if (mg) {
1515       const AMT * const amtp = (AMT*)mg->mg_ptr;
1516       if (amtp->was_ok_am == PL_amagic_generation
1517           && amtp->was_ok_sub == PL_sub_generation) {
1518           return (bool)AMT_OVERLOADED(amtp);
1519       }
1520       sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1521   }
1522
1523   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) );
1524
1525   Zero(&amt,1,AMT);
1526   amt.was_ok_am = PL_amagic_generation;
1527   amt.was_ok_sub = PL_sub_generation;
1528   amt.fallback = AMGfallNO;
1529   amt.flags = 0;
1530
1531   {
1532     int filled = 0, have_ovl = 0;
1533     int i, lim = 1;
1534
1535     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1536
1537     /* Try to find via inheritance. */
1538     GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1539     SV * const sv = gv ? GvSV(gv) : NULL;
1540     CV* cv;
1541
1542     if (!gv)
1543         lim = DESTROY_amg;              /* Skip overloading entries. */
1544 #ifdef PERL_DONT_CREATE_GVSV
1545     else if (!sv) {
1546         NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
1547     }
1548 #endif
1549     else if (SvTRUE(sv))
1550         amt.fallback=AMGfallYES;
1551     else if (SvOK(sv))
1552         amt.fallback=AMGfallNEVER;
1553
1554     for (i = 1; i < lim; i++)
1555         amt.table[i] = NULL;
1556     for (; i < NofAMmeth; i++) {
1557         const char * const cooky = PL_AMG_names[i];
1558         /* Human-readable form, for debugging: */
1559         const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1560         const STRLEN l = strlen(cooky);
1561
1562         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n",
1563                      cp, HvNAME_get(stash)) );
1564         /* don't fill the cache while looking up!
1565            Creation of inheritance stubs in intermediate packages may
1566            conflict with the logic of runtime method substitution.
1567            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1568            then we could have created stubs for "(+0" in A and C too.
1569            But if B overloads "bool", we may want to use it for
1570            numifying instead of C's "+0". */
1571         if (i >= DESTROY_amg)
1572             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1573         else                            /* Autoload taken care of below */
1574             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1575         cv = 0;
1576         if (gv && (cv = GvCV(gv))) {
1577             const char *hvname;
1578             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1579                 && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) {
1580                 /* This is a hack to support autoloading..., while
1581                    knowing *which* methods were declared as overloaded. */
1582                 /* GvSV contains the name of the method. */
1583                 GV *ngv = NULL;
1584                 SV *gvsv = GvSV(gv);
1585
1586                 DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
1587                         "\" for overloaded \"%s\" in package \"%.256s\"\n",
1588                              (void*)GvSV(gv), cp, hvname) );
1589                 if (!gvsv || !SvPOK(gvsv)
1590                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv),
1591                                                        FALSE)))
1592                 {
1593                     /* Can be an import stub (created by "can"). */
1594                     const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
1595                     Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
1596                                 "in package \"%.256s\"",
1597                                (GvCVGEN(gv) ? "Stub found while resolving"
1598                                 : "Can't resolve"),
1599                                name, cp, hvname);
1600                 }
1601                 cv = GvCV(gv = ngv);
1602             }
1603             DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n",
1604                          cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))),
1605                          GvNAME(CvGV(cv))) );
1606             filled = 1;
1607             if (i < DESTROY_amg)
1608                 have_ovl = 1;
1609         } else if (gv) {                /* Autoloaded... */
1610             cv = (CV*)gv;
1611             filled = 1;
1612         }
1613         amt.table[i]=(CV*)SvREFCNT_inc_simple(cv);
1614     }
1615     if (filled) {
1616       AMT_AMAGIC_on(&amt);
1617       if (have_ovl)
1618           AMT_OVERLOADED_on(&amt);
1619       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1620                                                 (char*)&amt, sizeof(AMT));
1621       return have_ovl;
1622     }
1623   }
1624   /* Here we have no table: */
1625   /* no_table: */
1626   AMT_AMAGIC_off(&amt);
1627   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1628                                                 (char*)&amt, sizeof(AMTS));
1629   return FALSE;
1630 }
1631
1632
1633 CV*
1634 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1635 {
1636     dVAR;
1637     MAGIC *mg;
1638     AMT *amtp;
1639
1640     if (!stash || !HvNAME_get(stash))
1641         return NULL;
1642     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1643     if (!mg) {
1644       do_update:
1645         Gv_AMupdate(stash);
1646         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1647     }
1648     assert(mg);
1649     amtp = (AMT*)mg->mg_ptr;
1650     if ( amtp->was_ok_am != PL_amagic_generation
1651          || amtp->was_ok_sub != PL_sub_generation )
1652         goto do_update;
1653     if (AMT_AMAGIC(amtp)) {
1654         CV * const ret = amtp->table[id];
1655         if (ret && isGV(ret)) {         /* Autoloading stab */
1656             /* Passing it through may have resulted in a warning
1657                "Inherited AUTOLOAD for a non-method deprecated", since
1658                our caller is going through a function call, not a method call.
1659                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1660             GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]);
1661
1662             if (gv && GvCV(gv))
1663                 return GvCV(gv);
1664         }
1665         return ret;
1666     }
1667
1668     return NULL;
1669 }
1670
1671
1672 SV*
1673 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1674 {
1675   dVAR;
1676   MAGIC *mg;
1677   CV *cv=NULL;
1678   CV **cvp=NULL, **ocvp=NULL;
1679   AMT *amtp=NULL, *oamtp=NULL;
1680   int off = 0, off1, lr = 0, notfound = 0;
1681   int postpr = 0, force_cpy = 0;
1682   int assign = AMGf_assign & flags;
1683   const int assignshift = assign ? 1 : 0;
1684 #ifdef DEBUGGING
1685   int fl=0;
1686 #endif
1687   HV* stash=NULL;
1688   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1689       && (stash = SvSTASH(SvRV(left)))
1690       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1691       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1692                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1693                         : NULL))
1694       && ((cv = cvp[off=method+assignshift])
1695           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1696                                                           * usual method */
1697                   (
1698 #ifdef DEBUGGING
1699                    fl = 1,
1700 #endif
1701                    cv = cvp[off=method])))) {
1702     lr = -1;                    /* Call method for left argument */
1703   } else {
1704     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1705       int logic;
1706
1707       /* look for substituted methods */
1708       /* In all the covered cases we should be called with assign==0. */
1709          switch (method) {
1710          case inc_amg:
1711            force_cpy = 1;
1712            if ((cv = cvp[off=add_ass_amg])
1713                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1714              right = &PL_sv_yes; lr = -1; assign = 1;
1715            }
1716            break;
1717          case dec_amg:
1718            force_cpy = 1;
1719            if ((cv = cvp[off = subtr_ass_amg])
1720                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1721              right = &PL_sv_yes; lr = -1; assign = 1;
1722            }
1723            break;
1724          case bool__amg:
1725            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1726            break;
1727          case numer_amg:
1728            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1729            break;
1730          case string_amg:
1731            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1732            break;
1733          case not_amg:
1734            (void)((cv = cvp[off=bool__amg])
1735                   || (cv = cvp[off=numer_amg])
1736                   || (cv = cvp[off=string_amg]));
1737            postpr = 1;
1738            break;
1739          case copy_amg:
1740            {
1741              /*
1742                   * SV* ref causes confusion with the interpreter variable of
1743                   * the same name
1744                   */
1745              SV* const tmpRef=SvRV(left);
1746              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1747                 /*
1748                  * Just to be extra cautious.  Maybe in some
1749                  * additional cases sv_setsv is safe, too.
1750                  */
1751                 SV* const newref = newSVsv(tmpRef);
1752                 SvOBJECT_on(newref);
1753                 /* As a bit of a source compatibility hack, SvAMAGIC() and
1754                    friends dereference an RV, to behave the same was as when
1755                    overloading was stored on the reference, not the referant.
1756                    Hence we can't use SvAMAGIC_on()
1757                 */
1758                 SvFLAGS(newref) |= SVf_AMAGIC;
1759                 SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
1760                 return newref;
1761              }
1762            }
1763            break;
1764          case abs_amg:
1765            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1766                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1767              SV* const nullsv=sv_2mortal(newSViv(0));
1768              if (off1==lt_amg) {
1769                SV* const lessp = amagic_call(left,nullsv,
1770                                        lt_amg,AMGf_noright);
1771                logic = SvTRUE(lessp);
1772              } else {
1773                SV* const lessp = amagic_call(left,nullsv,
1774                                        ncmp_amg,AMGf_noright);
1775                logic = (SvNV(lessp) < 0);
1776              }
1777              if (logic) {
1778                if (off==subtr_amg) {
1779                  right = left;
1780                  left = nullsv;
1781                  lr = 1;
1782                }
1783              } else {
1784                return left;
1785              }
1786            }
1787            break;
1788          case neg_amg:
1789            if ((cv = cvp[off=subtr_amg])) {
1790              right = left;
1791              left = sv_2mortal(newSViv(0));
1792              lr = 1;
1793            }
1794            break;
1795          case int_amg:
1796          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1797              /* FAIL safe */
1798              return NULL;       /* Delegate operation to standard mechanisms. */
1799              break;
1800          case to_sv_amg:
1801          case to_av_amg:
1802          case to_hv_amg:
1803          case to_gv_amg:
1804          case to_cv_amg:
1805              /* FAIL safe */
1806              return left;       /* Delegate operation to standard mechanisms. */
1807              break;
1808          default:
1809            goto not_found;
1810          }
1811          if (!cv) goto not_found;
1812     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1813                && (stash = SvSTASH(SvRV(right)))
1814                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1815                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1816                           ? (amtp = (AMT*)mg->mg_ptr)->table
1817                           : NULL))
1818                && (cv = cvp[off=method])) { /* Method for right
1819                                              * argument found */
1820       lr=1;
1821     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1822                  && (cvp=ocvp) && (lr = -1))
1823                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1824                && !(flags & AMGf_unary)) {
1825                                 /* We look for substitution for
1826                                  * comparison operations and
1827                                  * concatenation */
1828       if (method==concat_amg || method==concat_ass_amg
1829           || method==repeat_amg || method==repeat_ass_amg) {
1830         return NULL;            /* Delegate operation to string conversion */
1831       }
1832       off = -1;
1833       switch (method) {
1834          case lt_amg:
1835          case le_amg:
1836          case gt_amg:
1837          case ge_amg:
1838          case eq_amg:
1839          case ne_amg:
1840            postpr = 1; off=ncmp_amg; break;
1841          case slt_amg:
1842          case sle_amg:
1843          case sgt_amg:
1844          case sge_amg:
1845          case seq_amg:
1846          case sne_amg:
1847            postpr = 1; off=scmp_amg; break;
1848          }
1849       if (off != -1) cv = cvp[off];
1850       if (!cv) {
1851         goto not_found;
1852       }
1853     } else {
1854     not_found:                  /* No method found, either report or croak */
1855       switch (method) {
1856          case lt_amg:
1857          case le_amg:
1858          case gt_amg:
1859          case ge_amg:
1860          case eq_amg:
1861          case ne_amg:
1862          case slt_amg:
1863          case sle_amg:
1864          case sgt_amg:
1865          case sge_amg:
1866          case seq_amg:
1867          case sne_amg:
1868            postpr = 0; break;
1869          case to_sv_amg:
1870          case to_av_amg:
1871          case to_hv_amg:
1872          case to_gv_amg:
1873          case to_cv_amg:
1874              /* FAIL safe */
1875              return left;       /* Delegate operation to standard mechanisms. */
1876              break;
1877       }
1878       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1879         notfound = 1; lr = -1;
1880       } else if (cvp && (cv=cvp[nomethod_amg])) {
1881         notfound = 1; lr = 1;
1882       } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) {
1883         /* Skip generating the "no method found" message.  */
1884         return NULL;
1885       } else {
1886         SV *msg;
1887         if (off==-1) off=method;
1888         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1889                       "Operation \"%s\": no method found,%sargument %s%s%s%s",
1890                       AMG_id2name(method + assignshift),
1891                       (flags & AMGf_unary ? " " : "\n\tleft "),
1892                       SvAMAGIC(left)?
1893                         "in overloaded package ":
1894                         "has no overloaded magic",
1895                       SvAMAGIC(left)?
1896                         HvNAME_get(SvSTASH(SvRV(left))):
1897                         "",
1898                       SvAMAGIC(right)?
1899                         ",\n\tright argument in overloaded package ":
1900                         (flags & AMGf_unary
1901                          ? ""
1902                          : ",\n\tright argument has no overloaded magic"),
1903                       SvAMAGIC(right)?
1904                         HvNAME_get(SvSTASH(SvRV(right))):
1905                         ""));
1906         if (amtp && amtp->fallback >= AMGfallYES) {
1907           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
1908         } else {
1909           Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
1910         }
1911         return NULL;
1912       }
1913       force_cpy = force_cpy || assign;
1914     }
1915   }
1916 #ifdef DEBUGGING
1917   if (!notfound) {
1918     DEBUG_o(Perl_deb(aTHX_
1919                      "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1920                      AMG_id2name(off),
1921                      method+assignshift==off? "" :
1922                      " (initially \"",
1923                      method+assignshift==off? "" :
1924                      AMG_id2name(method+assignshift),
1925                      method+assignshift==off? "" : "\")",
1926                      flags & AMGf_unary? "" :
1927                      lr==1 ? " for right argument": " for left argument",
1928                      flags & AMGf_unary? " for argument" : "",
1929                      stash ? HvNAME_get(stash) : "null",
1930                      fl? ",\n\tassignment variant used": "") );
1931   }
1932 #endif
1933     /* Since we use shallow copy during assignment, we need
1934      * to dublicate the contents, probably calling user-supplied
1935      * version of copy operator
1936      */
1937     /* We need to copy in following cases:
1938      * a) Assignment form was called.
1939      *          assignshift==1,  assign==T, method + 1 == off
1940      * b) Increment or decrement, called directly.
1941      *          assignshift==0,  assign==0, method + 0 == off
1942      * c) Increment or decrement, translated to assignment add/subtr.
1943      *          assignshift==0,  assign==T,
1944      *          force_cpy == T
1945      * d) Increment or decrement, translated to nomethod.
1946      *          assignshift==0,  assign==0,
1947      *          force_cpy == T
1948      * e) Assignment form translated to nomethod.
1949      *          assignshift==1,  assign==T, method + 1 != off
1950      *          force_cpy == T
1951      */
1952     /*  off is method, method+assignshift, or a result of opcode substitution.
1953      *  In the latter case assignshift==0, so only notfound case is important.
1954      */
1955   if (( (method + assignshift == off)
1956         && (assign || (method == inc_amg) || (method == dec_amg)))
1957       || force_cpy)
1958     RvDEEPCP(left);
1959   {
1960     dSP;
1961     BINOP myop;
1962     SV* res;
1963     const bool oldcatch = CATCH_GET;
1964
1965     CATCH_SET(TRUE);
1966     Zero(&myop, 1, BINOP);
1967     myop.op_last = (OP *) &myop;
1968     myop.op_next = NULL;
1969     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1970
1971     PUSHSTACKi(PERLSI_OVERLOAD);
1972     ENTER;
1973     SAVEOP();
1974     PL_op = (OP *) &myop;
1975     if (PERLDB_SUB && PL_curstash != PL_debstash)
1976         PL_op->op_private |= OPpENTERSUB_DB;
1977     PUTBACK;
1978     pp_pushmark();
1979
1980     EXTEND(SP, notfound + 5);
1981     PUSHs(lr>0? right: left);
1982     PUSHs(lr>0? left: right);
1983     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1984     if (notfound) {
1985       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1986     }
1987     PUSHs((SV*)cv);
1988     PUTBACK;
1989
1990     if ((PL_op = Perl_pp_entersub(aTHX)))
1991       CALLRUNOPS(aTHX);
1992     LEAVE;
1993     SPAGAIN;
1994
1995     res=POPs;
1996     PUTBACK;
1997     POPSTACK;
1998     CATCH_SET(oldcatch);
1999
2000     if (postpr) {
2001       int ans;
2002       switch (method) {
2003       case le_amg:
2004       case sle_amg:
2005         ans=SvIV(res)<=0; break;
2006       case lt_amg:
2007       case slt_amg:
2008         ans=SvIV(res)<0; break;
2009       case ge_amg:
2010       case sge_amg:
2011         ans=SvIV(res)>=0; break;
2012       case gt_amg:
2013       case sgt_amg:
2014         ans=SvIV(res)>0; break;
2015       case eq_amg:
2016       case seq_amg:
2017         ans=SvIV(res)==0; break;
2018       case ne_amg:
2019       case sne_amg:
2020         ans=SvIV(res)!=0; break;
2021       case inc_amg:
2022       case dec_amg:
2023         SvSetSV(left,res); return left;
2024       case not_amg:
2025         ans=!SvTRUE(res); break;
2026       default:
2027         ans=0; break;
2028       }
2029       return boolSV(ans);
2030     } else if (method==copy_amg) {
2031       if (!SvROK(res)) {
2032         Perl_croak(aTHX_ "Copy method did not return a reference");
2033       }
2034       return SvREFCNT_inc(SvRV(res));
2035     } else {
2036       return res;
2037     }
2038   }
2039 }
2040
2041 /*
2042 =for apidoc is_gv_magical_sv
2043
2044 Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
2045
2046 =cut
2047 */
2048
2049 bool
2050 Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
2051 {
2052     STRLEN len;
2053     const char * const temp = SvPV_const(name, len);
2054     return is_gv_magical(temp, len, flags);
2055 }
2056
2057 /*
2058 =for apidoc is_gv_magical
2059
2060 Returns C<TRUE> if given the name of a magical GV.
2061
2062 Currently only useful internally when determining if a GV should be
2063 created even in rvalue contexts.
2064
2065 C<flags> is not used at present but available for future extension to
2066 allow selecting particular classes of magical variable.
2067
2068 Currently assumes that C<name> is NUL terminated (as well as len being valid).
2069 This assumption is met by all callers within the perl core, which all pass
2070 pointers returned by SvPV.
2071
2072 =cut
2073 */
2074 bool
2075 Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
2076 {
2077     PERL_UNUSED_CONTEXT;
2078     PERL_UNUSED_ARG(flags);
2079
2080     if (len > 1) {
2081         const char * const name1 = name + 1;
2082         switch (*name) {
2083         case 'I':
2084             if (len == 3 && name1[1] == 'S' && name[2] == 'A')
2085                 goto yes;
2086             break;
2087         case 'O':
2088             if (len == 8 && strEQ(name1, "VERLOAD"))
2089                 goto yes;
2090             break;
2091         case 'S':
2092             if (len == 3 && name[1] == 'I' && name[2] == 'G')
2093                 goto yes;
2094             break;
2095             /* Using ${^...} variables is likely to be sufficiently rare that
2096                it seems sensible to avoid the space hit of also checking the
2097                length.  */
2098         case '\017':   /* ${^OPEN} */
2099             if (strEQ(name1, "PEN"))
2100                 goto yes;
2101             break;
2102         case '\024':   /* ${^TAINT} */
2103             if (strEQ(name1, "AINT"))
2104                 goto yes;
2105             break;
2106         case '\025':    /* ${^UNICODE} */
2107             if (strEQ(name1, "NICODE"))
2108                 goto yes;
2109             if (strEQ(name1, "TF8LOCALE"))
2110                 goto yes;
2111             break;
2112         case '\027':   /* ${^WARNING_BITS} */
2113             if (strEQ(name1, "ARNING_BITS"))
2114                 goto yes;
2115             break;
2116         case '1':
2117         case '2':
2118         case '3':
2119         case '4':
2120         case '5':
2121         case '6':
2122         case '7':
2123         case '8':
2124         case '9':
2125         {
2126             const char *end = name + len;
2127             while (--end > name) {
2128                 if (!isDIGIT(*end))
2129                     return FALSE;
2130             }
2131             goto yes;
2132         }
2133         }
2134     } else {
2135         /* Because we're already assuming that name is NUL terminated
2136            below, we can treat an empty name as "\0"  */
2137         switch (*name) {
2138         case '&':
2139         case '`':
2140         case '\'':
2141         case ':':
2142         case '?':
2143         case '!':
2144         case '-':
2145         case '#':
2146         case '[':
2147         case '^':
2148         case '~':
2149         case '=':
2150         case '%':
2151         case '.':
2152         case '(':
2153         case ')':
2154         case '<':
2155         case '>':
2156         case ',':
2157         case '\\':
2158         case '/':
2159         case '|':
2160         case '+':
2161         case ';':
2162         case ']':
2163         case '\001':   /* $^A */
2164         case '\003':   /* $^C */
2165         case '\004':   /* $^D */
2166         case '\005':   /* $^E */
2167         case '\006':   /* $^F */
2168         case '\010':   /* $^H */
2169         case '\011':   /* $^I, NOT \t in EBCDIC */
2170         case '\014':   /* $^L */
2171         case '\016':   /* $^N */
2172         case '\017':   /* $^O */
2173         case '\020':   /* $^P */
2174         case '\023':   /* $^S */
2175         case '\024':   /* $^T */
2176         case '\026':   /* $^V */
2177         case '\027':   /* $^W */
2178         case '1':
2179         case '2':
2180         case '3':
2181         case '4':
2182         case '5':
2183         case '6':
2184         case '7':
2185         case '8':
2186         case '9':
2187         yes:
2188             return TRUE;
2189         default:
2190             break;
2191         }
2192     }
2193     return FALSE;
2194 }
2195
2196 void
2197 Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
2198 {
2199     dVAR;
2200     U32 hash;
2201
2202     assert(name);
2203     PERL_UNUSED_ARG(flags);
2204
2205     if (len > I32_MAX)
2206         Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len);
2207
2208     if (!(flags & GV_ADD) && GvNAME_HEK(gv)) {
2209         unshare_hek(GvNAME_HEK(gv));
2210     }
2211
2212     PERL_HASH(hash, name, len);
2213     GvNAME_HEK(gv) = share_hek(name, len, hash);
2214 }
2215
2216 /*
2217  * Local variables:
2218  * c-indentation-style: bsd
2219  * c-basic-offset: 4
2220  * indent-tabs-mode: t
2221  * End:
2222  *
2223  * ex: set ts=8 sts=4 sw=4 noet:
2224  */