gv.c

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