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             register SV *err = 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             if (USE_UTF8_IN_NAMES)
 771                 SvUTF8_on(err);
 772             qerror(err);
 773             stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
 774         }
 775         else
 776             return Nullgv;
 777     }
 778
 779     if (!SvREFCNT(stash))       /* symbol table under destruction */
 780         return Nullgv;
 781
 782     gvp = (GV**)hv_fetch(stash,name,len,add);
 783     if (!gvp || *gvp == (GV*)&PL_sv_undef)
 784         return Nullgv;
 785     gv = *gvp;
 786     if (SvTYPE(gv) == SVt_PVGV) {
 787         if (add) {
 788             GvMULTI_on(gv);
 789             gv_init_sv(gv, sv_type);
 790             if (*name=='!' && sv_type == SVt_PVHV && len==1)
 791                 require_errno(gv);
 792         }
 793         return gv;
 794     } else if (add & GV_NOINIT) {
 795         return gv;
 796     }
 797
 798     /* Adding a new symbol */
 799
 800     if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
 801         Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
 802     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
 803     gv_init_sv(gv, sv_type);
 804
 805     if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
 806                                             : (PL_dowarn & G_WARN_ON ) ) )
 807         GvMULTI_on(gv) ;
 808
 809     /* set up magic where warranted */
 810     switch (*name) {
 811     case 'A':
 812         if (strEQ(name, "ARGV")) {
 813             IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
 814         }
 815         break;
 816     case 'E':
 817         if (strnEQ(name, "EXPORT", 6))
 818             GvMULTI_on(gv);
 819         break;
 820     case 'I':
 821         if (strEQ(name, "ISA")) {
 822             AV* av = GvAVn(gv);
 823             GvMULTI_on(gv);
 824             sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
 825             /* NOTE: No support for tied ISA */
 826             if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
 827                 && AvFILLp(av) == -1)
 828             {
 829                 char *pname;
 830                 av_push(av, newSVpvn(pname = "NDBM_File",9));
 831                 gv_stashpvn(pname, 9, TRUE);
 832                 av_push(av, newSVpvn(pname = "DB_File",7));
 833                 gv_stashpvn(pname, 7, TRUE);
 834                 av_push(av, newSVpvn(pname = "GDBM_File",9));
 835                 gv_stashpvn(pname, 9, TRUE);
 836                 av_push(av, newSVpvn(pname = "SDBM_File",9));
 837                 gv_stashpvn(pname, 9, TRUE);
 838                 av_push(av, newSVpvn(pname = "ODBM_File",9));
 839                 gv_stashpvn(pname, 9, TRUE);
 840             }
 841         }
 842         break;
 843     case 'O':
 844         if (strEQ(name, "OVERLOAD")) {
 845             HV* hv = GvHVn(gv);
 846             GvMULTI_on(gv);
 847             hv_magic(hv, Nullgv, PERL_MAGIC_overload);
 848         }
 849         break;
 850     case 'S':
 851         if (strEQ(name, "SIG")) {
 852             HV *hv;
 853             I32 i;
 854             if (!PL_psig_ptr) {
 855                 Newz(73, PL_psig_ptr,  SIG_SIZE, SV*);
 856                 Newz(73, PL_psig_name, SIG_SIZE, SV*);
 857                 Newz(73, PL_psig_pend, SIG_SIZE, int);
 858             }
 859             GvMULTI_on(gv);
 860             hv = GvHVn(gv);
 861             hv_magic(hv, Nullgv, PERL_MAGIC_sig);
 862             for (i = 1; i < SIG_SIZE; i++) {
 863                 SV ** init;
 864                 init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
 865                 if (init)
 866                     sv_setsv(*init, &PL_sv_undef);
 867                 PL_psig_ptr[i] = 0;
 868                 PL_psig_name[i] = 0;
 869                 PL_psig_pend[i] = 0;
 870             }
 871         }
 872         break;
 873     case 'V':
 874         if (strEQ(name, "VERSION"))
 875             GvMULTI_on(gv);
 876         break;
 877
 878     case '&':
 879     case '`':
 880     case '\'':
 881        if (
 882            len > 1 ||
 883            sv_type == SVt_PVAV ||
 884            sv_type == SVt_PVHV ||
 885            sv_type == SVt_PVCV ||
 886            sv_type == SVt_PVFM ||
 887            sv_type == SVt_PVIO
 888        ) { break; }
 889         PL_sawampersand = TRUE;
 890         goto ro_magicalize;
 891
 892     case ':':
 893         if (len > 1)
 894             break;
 895         sv_setpv(GvSV(gv),PL_chopset);
 896         goto magicalize;
 897
 898     case '?':
 899         if (len > 1)
 900             break;
 901 #ifdef COMPLEX_STATUS
 902         (void)SvUPGRADE(GvSV(gv), SVt_PVLV);
 903 #endif
 904         goto magicalize;
 905
 906     case '!':
 907         if (len > 1)
 908             break;
 909
 910         /* If %! has been used, automatically load Errno.pm.
 911            The require will itself set errno, so in order to
 912            preserve its value we have to set up the magic
 913            now (rather than going to magicalize)
 914         */
 915
 916         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
 917
 918         if (sv_type == SVt_PVHV)
 919             require_errno(gv);
 920
 921         break;
 922     case '-':
 923         if (len > 1)
 924             break;
 925         else {
 926             AV* av = GvAVn(gv);
 927             sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
 928             SvREADONLY_on(av);
 929         }
 930         goto magicalize;
 931     case '*':
 932         if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
 933             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 934                     "$* is no longer supported");
 935         break;
 936     case '#':
 937         if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
 938             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 939                     "Use of $# is deprecated");
 940         /* FALL THROUGH */
 941     case '[':
 942     case '^':
 943     case '~':
 944     case '=':
 945     case '%':
 946     case '.':
 947     case '(':
 948     case ')':
 949     case '<':
 950     case '>':
 951     case ',':
 952     case '\\':
 953     case '/':
 954     case '\001':        /* $^A */
 955     case '\003':        /* $^C */
 956     case '\004':        /* $^D */
 957     case '\006':        /* $^F */
 958     case '\010':        /* $^H */
 959     case '\011':        /* $^I, NOT \t in EBCDIC */
 960     case '\016':        /* $^N */
 961     case '\020':        /* $^P */
 962         if (len > 1)
 963             break;
 964         goto magicalize;
 965     case '|':
 966         if (len > 1)
 967             break;
 968         sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
 969         goto magicalize;
 970     case '\005':        /* $^E && $^ENCODING */
 971         if (len > 1 && strNE(name, "\005NCODING"))
 972             break;
 973         goto magicalize;
 974
 975     case '\017':        /* $^O & $^OPEN */
 976         if (len > 1 && strNE(name, "\017PEN"))
 977             break;
 978         goto magicalize;
 979     case '\023':        /* $^S */
 980         if (len > 1)
 981             break;
 982         goto ro_magicalize;
 983     case '\024':        /* $^T, ${^TAINT} */
 984         if (len == 1)
 985             goto magicalize;
 986         else if (strEQ(name, "\024AINT"))
 987             goto ro_magicalize;
 988         else
 989             break;
 990     case '\025':
 991         if (len > 1 && strNE(name, "\025NICODE"))
 992             break;
 993         goto ro_magicalize;
 994
 995     case '\027':        /* $^W & $^WARNING_BITS */
 996         if (len > 1
 997             && strNE(name, "\027ARNING_BITS")
 998             )
 999             break;
1000         goto magicalize;
1001
1002     case '+':
1003         if (len > 1)
1004             break;
1005         else {
1006             AV* av = GvAVn(gv);
1007             sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
1008             SvREADONLY_on(av);
1009         }
1010         /* FALL THROUGH */
1011     case '1':
1012     case '2':
1013     case '3':
1014     case '4':
1015     case '5':
1016     case '6':
1017     case '7':
1018     case '8':
1019     case '9':
1020         /* ensures variable is only digits */
1021         /* ${"1foo"} fails this test (and is thus writeable) */
1022         /* added by japhy, but borrowed from is_gv_magical */
1023
1024         if (len > 1) {
1025             const char *end = name + len;
1026             while (--end > name) {
1027                 if (!isDIGIT(*end)) return gv;
1028             }
1029         }
1030
1031       ro_magicalize:
1032         SvREADONLY_on(GvSV(gv));
1033       magicalize:
1034         sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
1035         break;
1036
1037     case '\014':        /* $^L */
1038         if (len > 1)
1039             break;
1040         sv_setpv(GvSV(gv),"\f");
1041         PL_formfeed = GvSV(gv);
1042         break;
1043     case ';':
1044         if (len > 1)
1045             break;
1046         sv_setpv(GvSV(gv),"\034");
1047         break;
1048     case ']':
1049         if (len == 1) {
1050             SV *sv = GvSV(gv);
1051             (void)SvUPGRADE(sv, SVt_PVNV);
1052             Perl_sv_setpvf(aTHX_ sv,
1053 #if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
1054                             "%8.6"
1055 #else
1056                             "%5.3"
1057 #endif
1058                             NVff,
1059                             SvNVX(PL_patchlevel));
1060             SvNVX(sv) = SvNVX(PL_patchlevel);
1061             SvNOK_on(sv);
1062             SvREADONLY_on(sv);
1063         }
1064         break;
1065     case '\026':        /* $^V */
1066         if (len == 1) {
1067             SV *sv = GvSV(gv);
1068             GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
1069             SvREFCNT_dec(sv);
1070         }
1071         break;
1072     }
1073     return gv;
1074 }
1075
1076 void
1077 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1078 {
1079     char *name;
1080     HV *hv = GvSTASH(gv);
1081     if (!hv) {
1082         (void)SvOK_off(sv);
1083         return;
1084     }
1085     sv_setpv(sv, prefix ? prefix : "");
1086
1087     if (!HvNAME(hv))
1088         name = "__ANON__";
1089     else
1090         name = HvNAME(hv);
1091     if (keepmain || strNE(name, "main")) {
1092         sv_catpv(sv,name);
1093         sv_catpvn(sv,"::", 2);
1094     }
1095     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
1096 }
1097
1098 void
1099 Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1100 {
1101     gv_fullname4(sv, gv, prefix, TRUE);
1102 }
1103
1104 void
1105 Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
1106 {
1107     GV *egv = GvEGV(gv);
1108     if (!egv)
1109         egv = gv;
1110     gv_fullname4(sv, egv, prefix, keepmain);
1111 }
1112
1113 void
1114 Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
1115 {
1116     gv_efullname4(sv, gv, prefix, TRUE);
1117 }
1118
1119 /* XXX compatibility with versions <= 5.003. */
1120 void
1121 Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
1122 {
1123     gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1124 }
1125
1126 /* XXX compatibility with versions <= 5.003. */
1127 void
1128 Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
1129 {
1130     gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
1131 }
1132
1133 IO *
1134 Perl_newIO(pTHX)
1135 {
1136     IO *io;
1137     GV *iogv;
1138
1139     io = (IO*)NEWSV(0,0);
1140     sv_upgrade((SV *)io,SVt_PVIO);
1141     SvREFCNT(io) = 1;
1142     SvOBJECT_on(io);
1143     /* Clear the stashcache because a new IO could overrule a
1144        package name */
1145     hv_clear(PL_stashcache);
1146     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
1147     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
1148     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
1149       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
1150     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
1151     return io;
1152 }
1153
1154 void
1155 Perl_gv_check(pTHX_ HV *stash)
1156 {
1157     register HE *entry;
1158     register I32 i;
1159     register GV *gv;
1160     HV *hv;
1161
1162     if (!HvARRAY(stash))
1163         return;
1164     for (i = 0; i <= (I32) HvMAX(stash); i++) {
1165         for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
1166             if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
1167                 (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
1168             {
1169                 if (hv != PL_defstash && hv != stash)
1170                      gv_check(hv);              /* nested package */
1171             }
1172             else if (isALPHA(*HeKEY(entry))) {
1173                 char *file;
1174                 gv = (GV*)HeVAL(entry);
1175                 if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
1176                     continue;
1177                 file = GvFILE(gv);
1178                 /* performance hack: if filename is absolute and it's a standard
1179                  * module, don't bother warning */
1180                 if (file
1181                     && PERL_FILE_IS_ABSOLUTE(file)
1182 #ifdef MACOS_TRADITIONAL
1183                     && (instr(file, ":lib:")
1184 #else
1185                     && (instr(file, "/lib/")
1186 #endif
1187                     || instr(file, ".pm")))
1188                 {
1189                     continue;
1190                 }
1191                 CopLINE_set(PL_curcop, GvLINE(gv));
1192 #ifdef USE_ITHREADS
1193                 CopFILE(PL_curcop) = file;      /* set for warning */
1194 #else
1195                 CopFILEGV(PL_curcop) = gv_fetchfile(file);
1196 #endif
1197                 Perl_warner(aTHX_ packWARN(WARN_ONCE),
1198                         "Name \"%s::%s\" used only once: possible typo",
1199                         HvNAME(stash), GvNAME(gv));
1200             }
1201         }
1202     }
1203 }
1204
1205 GV *
1206 Perl_newGVgen(pTHX_ char *pack)
1207 {
1208     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
1209                       TRUE, SVt_PVGV);
1210 }
1211
1212 /* hopefully this is only called on local symbol table entries */
1213
1214 GP*
1215 Perl_gp_ref(pTHX_ GP *gp)
1216 {
1217     if (!gp)
1218         return (GP*)NULL;
1219     gp->gp_refcnt++;
1220     if (gp->gp_cv) {
1221         if (gp->gp_cvgen) {
1222             /* multi-named GPs cannot be used for method cache */
1223             SvREFCNT_dec(gp->gp_cv);
1224             gp->gp_cv = Nullcv;
1225             gp->gp_cvgen = 0;
1226         }
1227         else {
1228             /* Adding a new name to a subroutine invalidates method cache */
1229             PL_sub_generation++;
1230         }
1231     }
1232     return gp;
1233 }
1234
1235 void
1236 Perl_gp_free(pTHX_ GV *gv)
1237 {
1238     GP* gp;
1239
1240     if (!gv || !(gp = GvGP(gv)))
1241         return;
1242     if (gp->gp_refcnt == 0) {
1243         if (ckWARN_d(WARN_INTERNAL))
1244             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
1245                         "Attempt to free unreferenced glob pointers");
1246         return;
1247     }
1248     if (gp->gp_cv) {
1249         /* Deleting the name of a subroutine invalidates method cache */
1250         PL_sub_generation++;
1251     }
1252     if (--gp->gp_refcnt > 0) {
1253         if (gp->gp_egv == gv)
1254             gp->gp_egv = 0;
1255         return;
1256     }
1257
1258     if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
1259     if (gp->gp_sv) SvREFCNT_dec(gp->gp_av);
1260     if (gp->gp_hv) {
1261          if (PL_stashcache && HvNAME(gp->gp_hv))
1262               hv_delete(PL_stashcache,
1263                         HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)),
1264                         G_DISCARD);
1265          SvREFCNT_dec(gp->gp_hv);
1266     }
1267     if (gp->gp_io)   SvREFCNT_dec(gp->gp_io);
1268     if (gp->gp_cv)   SvREFCNT_dec(gp->gp_cv);
1269     if (gp->gp_form) SvREFCNT_dec(gp->gp_form);
1270
1271     Safefree(gp);
1272     GvGP(gv) = 0;
1273 }
1274
1275 int
1276 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
1277 {
1278     AMT *amtp = (AMT*)mg->mg_ptr;
1279     if (amtp && AMT_AMAGIC(amtp)) {
1280         int i;
1281         for (i = 1; i < NofAMmeth; i++) {
1282             CV *cv = amtp->table[i];
1283             if (cv != Nullcv) {
1284                 SvREFCNT_dec((SV *) cv);
1285                 amtp->table[i] = Nullcv;
1286             }
1287         }
1288     }
1289  return 0;
1290 }
1291
1292 /* Updates and caches the CV's */
1293
1294 bool
1295 Perl_Gv_AMupdate(pTHX_ HV *stash)
1296 {
1297   GV* gv;
1298   CV* cv;
1299   MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table);
1300   AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
1301   AMT amt;
1302
1303   if (mg && amtp->was_ok_am == PL_amagic_generation
1304       && amtp->was_ok_sub == PL_sub_generation)
1305       return (bool)AMT_OVERLOADED(amtp);
1306   sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
1307
1308   DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
1309
1310   Zero(&amt,1,AMT);
1311   amt.was_ok_am = PL_amagic_generation;
1312   amt.was_ok_sub = PL_sub_generation;
1313   amt.fallback = AMGfallNO;
1314   amt.flags = 0;
1315
1316   {
1317     int filled = 0, have_ovl = 0;
1318     int i, lim = 1;
1319     SV* sv = NULL;
1320
1321     /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
1322
1323     /* Try to find via inheritance. */
1324     gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1);
1325     if (gv)
1326         sv = GvSV(gv);
1327
1328     if (!gv)
1329         lim = DESTROY_amg;              /* Skip overloading entries. */
1330     else if (SvTRUE(sv))
1331         amt.fallback=AMGfallYES;
1332     else if (SvOK(sv))
1333         amt.fallback=AMGfallNEVER;
1334
1335     for (i = 1; i < lim; i++)
1336         amt.table[i] = Nullcv;
1337     for (; i < NofAMmeth; i++) {
1338         char *cooky = (char*)PL_AMG_names[i];
1339         /* Human-readable form, for debugging: */
1340         char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
1341         STRLEN l = strlen(cooky);
1342
1343         DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
1344                      cp, HvNAME(stash)) );
1345         /* don't fill the cache while looking up!
1346            Creation of inheritance stubs in intermediate packages may
1347            conflict with the logic of runtime method substitution.
1348            Indeed, for inheritance A -> B -> C, if C overloads "+0",
1349            then we could have created stubs for "(+0" in A and C too.
1350            But if B overloads "bool", we may want to use it for
1351            numifying instead of C's "+0". */
1352         if (i >= DESTROY_amg)
1353             gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
1354         else                            /* Autoload taken care of below */
1355             gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
1356         cv = 0;
1357         if (gv && (cv = GvCV(gv))) {
1358             if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
1359                 && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
1360                 /* This is a hack to support autoloading..., while
1361                    knowing *which* methods were declared as overloaded. */
1362                 /* GvSV contains the name of the method. */
1363                 GV *ngv = Nullgv;
1364
1365                 DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\
1366                         "' for overloaded `%s' in package `%.256s'\n",
1367                              GvSV(gv), cp, HvNAME(stash)) );
1368                 if (!SvPOK(GvSV(gv))
1369                     || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
1370                                                        FALSE)))
1371                 {
1372                     /* Can be an import stub (created by `can'). */
1373                     SV *gvsv = GvSV(gv);
1374                     const char *name = SvPOK(gvsv) ?  SvPVX(gvsv) : "???";
1375                     Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' "\
1376                                 "in package `%.256s'",
1377                                (GvCVGEN(gv) ? "Stub found while resolving"
1378                                 : "Can't resolve"),
1379                                name, cp, HvNAME(stash));
1380                 }
1381                 cv = GvCV(gv = ngv);
1382             }
1383             DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
1384                          cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
1385                          GvNAME(CvGV(cv))) );
1386             filled = 1;
1387             if (i < DESTROY_amg)
1388                 have_ovl = 1;
1389         } else if (gv) {                /* Autoloaded... */
1390             cv = (CV*)gv;
1391             filled = 1;
1392         }
1393         amt.table[i]=(CV*)SvREFCNT_inc(cv);
1394     }
1395     if (filled) {
1396       AMT_AMAGIC_on(&amt);
1397       if (have_ovl)
1398           AMT_OVERLOADED_on(&amt);
1399       sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1400                                                 (char*)&amt, sizeof(AMT));
1401       return have_ovl;
1402     }
1403   }
1404   /* Here we have no table: */
1405   /* no_table: */
1406   AMT_AMAGIC_off(&amt);
1407   sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table,
1408                                                 (char*)&amt, sizeof(AMTS));
1409   return FALSE;
1410 }
1411
1412
1413 CV*
1414 Perl_gv_handler(pTHX_ HV *stash, I32 id)
1415 {
1416     MAGIC *mg;
1417     AMT *amtp;
1418     CV *ret;
1419
1420     if (!stash || !HvNAME(stash))
1421         return Nullcv;
1422     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1423     if (!mg) {
1424       do_update:
1425         Gv_AMupdate(stash);
1426         mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
1427     }
1428     amtp = (AMT*)mg->mg_ptr;
1429     if ( amtp->was_ok_am != PL_amagic_generation
1430          || amtp->was_ok_sub != PL_sub_generation )
1431         goto do_update;
1432     if (AMT_AMAGIC(amtp)) {
1433         ret = amtp->table[id];
1434         if (ret && isGV(ret)) {         /* Autoloading stab */
1435             /* Passing it through may have resulted in a warning
1436                "Inherited AUTOLOAD for a non-method deprecated", since
1437                our caller is going through a function call, not a method call.
1438                So return the CV for AUTOLOAD, setting $AUTOLOAD. */
1439             GV *gv = gv_fetchmethod(stash, (char*)PL_AMG_names[id]);
1440
1441             if (gv && GvCV(gv))
1442                 return GvCV(gv);
1443         }
1444         return ret;
1445     }
1446
1447     return Nullcv;
1448 }
1449
1450
1451 SV*
1452 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
1453 {
1454   MAGIC *mg;
1455   CV *cv=NULL;
1456   CV **cvp=NULL, **ocvp=NULL;
1457   AMT *amtp=NULL, *oamtp=NULL;
1458   int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0;
1459   int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0;
1460 #ifdef DEBUGGING
1461   int fl=0;
1462 #endif
1463   HV* stash=NULL;
1464   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
1465       && (stash = SvSTASH(SvRV(left)))
1466       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1467       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1468                         ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
1469                         : (CV **) NULL))
1470       && ((cv = cvp[off=method+assignshift])
1471           || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
1472                                                           * usual method */
1473                   (
1474 #ifdef DEBUGGING
1475                    fl = 1,
1476 #endif
1477                    cv = cvp[off=method])))) {
1478     lr = -1;                    /* Call method for left argument */
1479   } else {
1480     if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) {
1481       int logic;
1482
1483       /* look for substituted methods */
1484       /* In all the covered cases we should be called with assign==0. */
1485          switch (method) {
1486          case inc_amg:
1487            force_cpy = 1;
1488            if ((cv = cvp[off=add_ass_amg])
1489                || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) {
1490              right = &PL_sv_yes; lr = -1; assign = 1;
1491            }
1492            break;
1493          case dec_amg:
1494            force_cpy = 1;
1495            if ((cv = cvp[off = subtr_ass_amg])
1496                || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) {
1497              right = &PL_sv_yes; lr = -1; assign = 1;
1498            }
1499            break;
1500          case bool__amg:
1501            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg]));
1502            break;
1503          case numer_amg:
1504            (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg]));
1505            break;
1506          case string_amg:
1507            (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
1508            break;
1509  case not_amg:
1510    (void)((cv = cvp[off=bool__amg])
1511           || (cv = cvp[off=numer_amg])
1512           || (cv = cvp[off=string_amg]));
1513    postpr = 1;
1514    break;
1515          case copy_amg:
1516            {
1517              /*
1518                   * SV* ref causes confusion with the interpreter variable of
1519                   * the same name
1520                   */
1521              SV* tmpRef=SvRV(left);
1522              if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) {
1523                 /*
1524                  * Just to be extra cautious.  Maybe in some
1525                  * additional cases sv_setsv is safe, too.
1526                  */
1527                 SV* newref = newSVsv(tmpRef);
1528                 SvOBJECT_on(newref);
1529                 SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
1530                 return newref;
1531              }
1532            }
1533            break;
1534          case abs_amg:
1535            if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg])
1536                && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) {
1537              SV* nullsv=sv_2mortal(newSViv(0));
1538              if (off1==lt_amg) {
1539                SV* lessp = amagic_call(left,nullsv,
1540                                        lt_amg,AMGf_noright);
1541                logic = SvTRUE(lessp);
1542              } else {
1543                SV* lessp = amagic_call(left,nullsv,
1544                                        ncmp_amg,AMGf_noright);
1545                logic = (SvNV(lessp) < 0);
1546              }
1547              if (logic) {
1548                if (off==subtr_amg) {
1549                  right = left;
1550                  left = nullsv;
1551                  lr = 1;
1552                }
1553              } else {
1554                return left;
1555              }
1556            }
1557            break;
1558          case neg_amg:
1559            if ((cv = cvp[off=subtr_amg])) {
1560              right = left;
1561              left = sv_2mortal(newSViv(0));
1562              lr = 1;
1563            }
1564            break;
1565          case int_amg:
1566          case iter_amg:                 /* XXXX Eventually should do to_gv. */
1567              /* FAIL safe */
1568              return NULL;       /* Delegate operation to standard mechanisms. */
1569              break;
1570          case to_sv_amg:
1571          case to_av_amg:
1572          case to_hv_amg:
1573          case to_gv_amg:
1574          case to_cv_amg:
1575              /* FAIL safe */
1576              return left;       /* Delegate operation to standard mechanisms. */
1577              break;
1578          default:
1579            goto not_found;
1580          }
1581          if (!cv) goto not_found;
1582     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
1583                && (stash = SvSTASH(SvRV(right)))
1584                && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
1585                && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
1586                           ? (amtp = (AMT*)mg->mg_ptr)->table
1587                           : (CV **) NULL))
1588                && (cv = cvp[off=method])) { /* Method for right
1589                                              * argument found */
1590       lr=1;
1591     } else if (((ocvp && oamtp->fallback > AMGfallNEVER
1592                  && (cvp=ocvp) && (lr = -1))
1593                 || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
1594                && !(flags & AMGf_unary)) {
1595                                 /* We look for substitution for
1596                                  * comparison operations and
1597                                  * concatenation */
1598       if (method==concat_amg || method==concat_ass_amg
1599           || method==repeat_amg || method==repeat_ass_amg) {
1600         return NULL;            /* Delegate operation to string conversion */
1601       }
1602       off = -1;
1603       switch (method) {
1604          case lt_amg:
1605          case le_amg:
1606          case gt_amg:
1607          case ge_amg:
1608          case eq_amg:
1609          case ne_amg:
1610            postpr = 1; off=ncmp_amg; break;
1611          case slt_amg:
1612          case sle_amg:
1613          case sgt_amg:
1614          case sge_amg:
1615          case seq_amg:
1616          case sne_amg:
1617            postpr = 1; off=scmp_amg; break;
1618          }
1619       if (off != -1) cv = cvp[off];
1620       if (!cv) {
1621         goto not_found;
1622       }
1623     } else {
1624     not_found:                  /* No method found, either report or croak */
1625       switch (method) {
1626          case to_sv_amg:
1627          case to_av_amg:
1628          case to_hv_amg:
1629          case to_gv_amg:
1630          case to_cv_amg:
1631              /* FAIL safe */
1632              return left;       /* Delegate operation to standard mechanisms. */
1633              break;
1634       }
1635       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
1636         notfound = 1; lr = -1;
1637       } else if (cvp && (cv=cvp[nomethod_amg])) {
1638         notfound = 1; lr = 1;
1639       } else {
1640         SV *msg;
1641         if (off==-1) off=method;
1642         msg = sv_2mortal(Perl_newSVpvf(aTHX_
1643                       "Operation `%s': no method found,%sargument %s%s%s%s",
1644                       AMG_id2name(method + assignshift),
1645                       (flags & AMGf_unary ? " " : "\n\tleft "),
1646                       SvAMAGIC(left)?
1647                         "in overloaded package ":
1648                         "has no overloaded magic",
1649                       SvAMAGIC(left)?
1650                         HvNAME(SvSTASH(SvRV(left))):
1651                         "",
1652                       SvAMAGIC(right)?
1653                         ",\n\tright argument in overloaded package ":
1654                         (flags & AMGf_unary
1655                          ? ""
1656                          : ",\n\tright argument has no overloaded magic"),
1657                       SvAMAGIC(right)?
1658                         HvNAME(SvSTASH(SvRV(right))):
1659                         ""));
1660         if (amtp && amtp->fallback >= AMGfallYES) {
1661           DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) );
1662         } else {
1663           Perl_croak(aTHX_ "%"SVf, msg);
1664         }
1665         return NULL;
1666       }
1667       force_cpy = force_cpy || assign;
1668     }
1669   }
1670 #ifdef DEBUGGING
1671   if (!notfound) {
1672     DEBUG_o(Perl_deb(aTHX_
1673                      "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
1674                      AMG_id2name(off),
1675                      method+assignshift==off? "" :
1676                      " (initially `",
1677                      method+assignshift==off? "" :
1678                      AMG_id2name(method+assignshift),
1679                      method+assignshift==off? "" : "')",
1680                      flags & AMGf_unary? "" :
1681                      lr==1 ? " for right argument": " for left argument",
1682                      flags & AMGf_unary? " for argument" : "",
1683                      stash ? HvNAME(stash) : "null",
1684                      fl? ",\n\tassignment variant used": "") );
1685   }
1686 #endif
1687     /* Since we use shallow copy during assignment, we need
1688      * to dublicate the contents, probably calling user-supplied
1689      * version of copy operator
1690      */
1691     /* We need to copy in following cases:
1692      * a) Assignment form was called.
1693      *          assignshift==1,  assign==T, method + 1 == off
1694      * b) Increment or decrement, called directly.
1695      *          assignshift==0,  assign==0, method + 0 == off
1696      * c) Increment or decrement, translated to assignment add/subtr.
1697      *          assignshift==0,  assign==T,
1698      *          force_cpy == T
1699      * d) Increment or decrement, translated to nomethod.
1700      *          assignshift==0,  assign==0,
1701      *          force_cpy == T
1702      * e) Assignment form translated to nomethod.
1703      *          assignshift==1,  assign==T, method + 1 != off
1704      *          force_cpy == T
1705      */
1706     /*  off is method, method+assignshift, or a result of opcode substitution.
1707      *  In the latter case assignshift==0, so only notfound case is important.
1708      */
1709   if (( (method + assignshift == off)
1710         && (assign || (method == inc_amg) || (method == dec_amg)))
1711       || force_cpy)
1712     RvDEEPCP(left);
1713   {
1714     dSP;
1715     BINOP myop;
1716     SV* res;
1717     bool oldcatch = CATCH_GET;
1718
1719     CATCH_SET(TRUE);
1720     Zero(&myop, 1, BINOP);
1721     myop.op_last = (OP *) &myop;
1722     myop.op_next = Nullop;
1723     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
1724
1725     PUSHSTACKi(PERLSI_OVERLOAD);
1726     ENTER;
1727     SAVEOP();
1728     PL_op = (OP *) &myop;
1729     if (PERLDB_SUB && PL_curstash != PL_debstash)
1730         PL_op->op_private |= OPpENTERSUB_DB;
1731     PUTBACK;
1732     pp_pushmark();
1733
1734     EXTEND(SP, notfound + 5);
1735     PUSHs(lr>0? right: left);
1736     PUSHs(lr>0? left: right);
1737     PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no ));
1738     if (notfound) {
1739       PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0)));
1740     }
1741     PUSHs((SV*)cv);
1742     PUTBACK;
1743
1744     if ((PL_op = Perl_pp_entersub(aTHX)))
1745       CALLRUNOPS(aTHX);
1746     LEAVE;
1747     SPAGAIN;
1748
1749     res=POPs;
1750     PUTBACK;
1751     POPSTACK;
1752     CATCH_SET(oldcatch);
1753
1754     if (postpr) {
1755       int ans=0;
1756       switch (method) {
1757       case le_amg:
1758       case sle_amg:
1759         ans=SvIV(res)<=0; break;
1760       case lt_amg:
1761       case slt_amg:
1762         ans=SvIV(res)<0; break;
1763       case ge_amg:
1764       case sge_amg:
1765         ans=SvIV(res)>=0; break;
1766       case gt_amg:
1767       case sgt_amg:
1768         ans=SvIV(res)>0; break;
1769       case eq_amg:
1770       case seq_amg:
1771         ans=SvIV(res)==0; break;
1772       case ne_amg:
1773       case sne_amg:
1774         ans=SvIV(res)!=0; break;
1775       case inc_amg:
1776       case dec_amg:
1777         SvSetSV(left,res); return left;
1778       case not_amg:
1779         ans=!SvTRUE(res); break;
1780       }
1781       return boolSV(ans);
1782     } else if (method==copy_amg) {
1783       if (!SvROK(res)) {
1784         Perl_croak(aTHX_ "Copy method did not return a reference");
1785       }
1786       return SvREFCNT_inc(SvRV(res));
1787     } else {
1788       return res;
1789     }
1790   }
1791 }
1792
1793 /*
1794 =for apidoc is_gv_magical
1795
1796 Returns C<TRUE> if given the name of a magical GV.
1797
1798 Currently only useful internally when determining if a GV should be
1799 created even in rvalue contexts.
1800
1801 C<flags> is not used at present but available for future extension to
1802 allow selecting particular classes of magical variable.
1803
1804 =cut
1805 */
1806 bool
1807 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
1808 {
1809     if (!len)
1810         return FALSE;
1811
1812     switch (*name) {
1813     case 'I':
1814         if (len == 3 && strEQ(name, "ISA"))
1815             goto yes;
1816         break;
1817     case 'O':
1818         if (len == 8 && strEQ(name, "OVERLOAD"))
1819             goto yes;
1820         break;
1821     case 'S':
1822         if (len == 3 && strEQ(name, "SIG"))
1823             goto yes;
1824         break;
1825     case '\017':   /* $^O & $^OPEN */
1826         if (len == 1
1827             || (len == 4 && strEQ(name, "\017PEN")))
1828         {
1829             goto yes;
1830         }
1831         break;
1832     case '\025':
1833         if (len > 1 && strEQ(name, "\025NICODE"))
1834             goto yes;
1835     case '\027':   /* $^W & $^WARNING_BITS */
1836         if (len == 1
1837             || (len == 12 && strEQ(name, "\027ARNING_BITS"))
1838             )
1839         {
1840             goto yes;
1841         }
1842         break;
1843
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 '+':
1867     case ';':
1868     case ']':
1869     case '\001':   /* $^A */
1870     case '\003':   /* $^C */
1871     case '\004':   /* $^D */
1872     case '\005':   /* $^E */
1873     case '\006':   /* $^F */
1874     case '\010':   /* $^H */
1875     case '\011':   /* $^I, NOT \t in EBCDIC */
1876     case '\014':   /* $^L */
1877     case '\016':   /* $^N */
1878     case '\020':   /* $^P */
1879     case '\023':   /* $^S */
1880     case '\026':   /* $^V */
1881         if (len == 1)
1882             goto yes;
1883         break;
1884     case '\024':   /* $^T, ${^TAINT} */
1885         if (len == 1 || strEQ(name, "\024AINT"))
1886             goto yes;
1887         break;
1888     case '1':
1889     case '2':
1890     case '3':
1891     case '4':
1892     case '5':
1893     case '6':
1894     case '7':
1895     case '8':
1896     case '9':
1897         if (len > 1) {
1898             char *end = name + len;
1899             while (--end > name) {
1900                 if (!isDIGIT(*end))
1901                     return FALSE;
1902             }
1903         }
1904     yes:
1905         return TRUE;
1906     default:
1907         break;
1908     }
1909     return FALSE;
1910 }