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