gv.c

   1 /* $RCSfile: gv.c,v $$Revision: 4.1 $$Date: 92/08/07 18:26:39 $
   2  *
   3  *    Copyright (c) 1991, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  * $Log:        gv.c,v $
   9  * Revision 4.1  92/08/07  18:26:39  lwall
  10  *
  11  * Revision 4.0.1.4  92/06/08  15:32:19  lwall
  12  * patch20: fixed confusion between a *var's real name and its effective name
  13  * patch20: the debugger now warns you on lines that can't set a breakpoint
  14  * patch20: the debugger made perl forget the last pattern used by //
  15  * patch20: paragraph mode now skips extra newlines automatically
  16  * patch20: ($<,$>) = ... didn't work on some architectures
  17  *
  18  * Revision 4.0.1.3  91/11/05  18:35:33  lwall
  19  * patch11: length($x) was sometimes wrong for numeric $x
  20  * patch11: perl now issues warning if $SIG{'ALARM'} is referenced
  21  * patch11: *foo = undef coredumped
  22  * patch11: solitary subroutine references no longer trigger typo warnings
  23  * patch11: local(*FILEHANDLE) had a memory leak
  24  *
  25  * Revision 4.0.1.2  91/06/07  11:55:53  lwall
  26  * patch4: new copyright notice
  27  * patch4: added $^P variable to control calling of perldb routines
  28  * patch4: added $^F variable to specify maximum system fd, default 2
  29  * patch4: $` was busted inside s///
  30  * patch4: default top-of-form run_format is now FILEHANDLE_TOP
  31  * patch4: length($`), length($&), length($') now optimized to avoid string copy
  32  * patch4: $^D |= 1024 now does syntax tree dump at run-time
  33  *
  34  * Revision 4.0.1.1  91/04/12  09:10:24  lwall
  35  * patch1: Configure now differentiates getgroups() type from getgid() type
  36  * patch1: you may now use "die" and "caller" in a signal handler
  37  *
  38  * Revision 4.0  91/03/20  01:39:41  lwall
  39  * 4.0 baseline.
  40  *
  41  */
  42
  43 #include "EXTERN.h"
  44 #include "perl.h"
  45
  46 extern char rcsid[];
  47
  48 GV *
  49 gv_AVadd(gv)
  50 register GV *gv;
  51 {
  52     if (!GvAV(gv))
  53         GvAV(gv) = newAV();
  54     return gv;
  55 }
  56
  57 GV *
  58 gv_HVadd(gv)
  59 register GV *gv;
  60 {
  61     if (!GvHV(gv))
  62         GvHV(gv) = newHV();
  63     return gv;
  64 }
  65
  66 GV *
  67 gv_fetchfile(name)
  68 char *name;
  69 {
  70     char tmpbuf[1200];
  71     GV *gv;
  72
  73     sprintf(tmpbuf,"::_<%s", name);
  74     gv = gv_fetchpv(tmpbuf, TRUE, SVt_PVGV);
  75     sv_setpv(GvSV(gv), name);
  76     if (*name == '/')
  77         SvMULTI_on(gv);
  78     if (perldb)
  79         hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
  80     return gv;
  81 }
  82
  83 void
  84 gv_init(gv, stash, name, len, multi)
  85 GV *gv;
  86 HV *stash;
  87 char *name;
  88 STRLEN len;
  89 int multi;
  90 {
  91     register GP *gp;
  92
  93     sv_upgrade(gv, SVt_PVGV);
  94     if (SvLEN(gv))
  95         Safefree(SvPVX(gv));
  96     Newz(602,gp, 1, GP);
  97     GvGP(gv) = gp_ref(gp);
  98     GvREFCNT(gv) = 1;
  99     GvSV(gv) = NEWSV(72,0);
 100     GvLINE(gv) = curcop->cop_line;
 101     GvFILEGV(gv) = curcop->cop_filegv;
 102     GvEGV(gv) = gv;
 103     sv_magic((SV*)gv, (SV*)gv, '*', name, len);
 104     GvSTASH(gv) = stash;
 105     GvNAME(gv) = nsavestr(name, len);
 106     GvNAMELEN(gv) = len;
 107     if (multi)
 108         SvMULTI_on(gv);
 109 }
 110
 111 GV *
 112 gv_fetchmeth(stash, name, len)
 113 HV* stash;
 114 char* name;
 115 STRLEN len;
 116 {
 117     AV* av;
 118     GV* topgv;
 119     GV* gv;
 120     GV** gvp;
 121
 122     gvp = (GV**)hv_fetch(stash, name, len, TRUE);
 123
 124     DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) );
 125     topgv = *gvp;
 126     if (SvTYPE(topgv) != SVt_PVGV)
 127         gv_init(topgv, stash, name, len, TRUE);
 128
 129     if (GvCV(topgv)) {
 130         if (!GvCVGEN(topgv) || GvCVGEN(topgv) >= sub_generation)
 131             return topgv;
 132     }
 133
 134     gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
 135     if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
 136         SV** svp = AvARRAY(av);
 137         I32 items = AvFILL(av) + 1;
 138         while (items--) {
 139             SV* sv = *svp++;
 140             HV* basestash = fetch_stash(sv, FALSE);
 141             if (!basestash) {
 142                 if (dowarn)
 143                     warn("Can't locate package %s for @%s'ISA",
 144                         SvPVX(sv), HvNAME(stash));
 145                 continue;
 146             }
 147             gv = gv_fetchmeth(basestash, name, len);
 148             if (gv) {
 149                 GvCV(topgv) = GvCV(gv);                 /* cache the CV */
 150                 GvCVGEN(topgv) = sub_generation;        /* valid for now */
 151                 return gv;
 152             }
 153         }
 154     }
 155     return 0;
 156 }
 157
 158 GV *
 159 gv_fetchmethod(stash, name)
 160 HV* stash;
 161 char* name;
 162 {
 163     register char *nend;
 164
 165     for (nend = name; *nend; nend++) {
 166         if (*nend == ':' || *nend == '\'') {
 167             return gv_fetchpv(name, FALSE, SVt_PVCV);
 168         }
 169     }
 170     return gv_fetchmeth(stash, name, nend - name);
 171 }
 172
 173 GV *
 174 gv_fetchpv(nambeg,add,svtype)
 175 char *nambeg;
 176 I32 add;
 177 I32 svtype;
 178 {
 179     register char *name = nambeg;
 180     register GV *gv = 0;
 181     GV**gvp;
 182     I32 len;
 183     register char *namend;
 184     HV *stash = 0;
 185     bool global = FALSE;
 186     char *tmpbuf;
 187
 188     for (namend = name; *namend; namend++) {
 189         if ((*namend == '\'' && namend[1]) ||
 190             (*namend == ':' && namend[1] == ':'))
 191         {
 192             if (!stash)
 193                 stash = defstash;
 194
 195             len = namend - name;
 196             if (len > 0) {
 197                 New(601, tmpbuf, len+2, char);
 198                 *tmpbuf = '_';
 199                 Copy(name, tmpbuf+1, len, char);
 200                 tmpbuf[++len] = '\0';
 201                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
 202                 Safefree(tmpbuf);
 203                 if (!gvp || *gvp == (GV*)&sv_undef)
 204                     return Nullgv;
 205                 gv = *gvp;
 206
 207                 if (SvTYPE(gv) == SVt_PVGV)
 208                     SvMULTI_on(gv);
 209                 else
 210                     gv_init(gv, stash, nambeg, namend - nambeg, (add & 2));
 211
 212                 if (!(stash = GvHV(gv)))
 213                     stash = GvHV(gv) = newHV();
 214
 215                 if (!HvNAME(stash))
 216                     HvNAME(stash) = nsavestr(nambeg, namend - nambeg);
 217             }
 218
 219             if (*namend == ':')
 220                 namend++;
 221             namend++;
 222             name = namend;
 223             if (!*name)
 224                 return gv ? gv : defgv;
 225         }
 226     }
 227
 228     /* No stash in name, so see how we can default */
 229
 230     if (!stash) {
 231         if (isIDFIRST(*name)) {
 232             if (isUPPER(*name)) {
 233                 if (*name > 'I') {
 234                     if (*name == 'S' && (
 235                       strEQ(name, "SIG") ||
 236                       strEQ(name, "STDIN") ||
 237                       strEQ(name, "STDOUT") ||
 238                       strEQ(name, "STDERR") ))
 239                         global = TRUE;
 240                 }
 241                 else if (*name > 'E') {
 242                     if (*name == 'I' && strEQ(name, "INC"))
 243                         global = TRUE;
 244                 }
 245                 else if (*name > 'A') {
 246                     if (*name == 'E' && strEQ(name, "ENV"))
 247                         global = TRUE;
 248                 }
 249                 else if (*name == 'A' && (
 250                   strEQ(name, "ARGV") ||
 251                   strEQ(name, "ARGVOUT") ))
 252                     global = TRUE;
 253             }
 254             else if (*name == '_' && !name[1])
 255                 global = TRUE;
 256             if (global)
 257                 stash = defstash;
 258             else if ((COP*)curcop == &compiling) {
 259                 if (!(hints & HINT_STRICT_VARS) || svtype == SVt_PVCV)
 260                     stash = curstash;
 261             }
 262             else
 263                 stash = curcop->cop_stash;
 264         }
 265         else
 266             stash = defstash;
 267     }
 268
 269     /* By this point we should have a stash and a name */
 270
 271     if (!stash)
 272         croak("Global symbol \"%s\" requires explicit package name", name);
 273     len = namend - name;
 274     if (!len)
 275         len = 1;
 276     gvp = (GV**)hv_fetch(stash,name,len,add);
 277     if (!gvp || *gvp == (GV*)&sv_undef)
 278         return Nullgv;
 279     gv = *gvp;
 280     if (SvTYPE(gv) == SVt_PVGV) {
 281         SvMULTI_on(gv);
 282         return gv;
 283     }
 284
 285     /* Adding a new symbol */
 286
 287     gv_init(gv, stash, name, len, add & 2);
 288
 289     /* set up magic where warranted */
 290     switch (*name) {
 291     case 'a':
 292     case 'b':
 293         if (len == 1)
 294             SvMULTI_on(gv);
 295         break;
 296     case 'I':
 297         if (strEQ(name, "ISA")) {
 298             AV* av = GvAVn(gv);
 299             SvMULTI_on(gv);
 300             sv_magic((SV*)av, (SV*)gv, 'I', 0, 0);
 301             if (add & 2 && strEQ(nambeg,"Any_DBM_File::ISA") && AvFILL(av) == -1)
 302             {
 303                 av_push(av, newSVpv("NDBM_File",0));
 304                 av_push(av, newSVpv("DB_File",0));
 305                 av_push(av, newSVpv("GDBM_File",0));
 306                 av_push(av, newSVpv("SDBM_File",0));
 307                 av_push(av, newSVpv("ODBM_File",0));
 308             }
 309         }
 310         break;
 311     case 'S':
 312         if (strEQ(name, "SIG")) {
 313             HV *hv;
 314             siggv = gv;
 315             SvMULTI_on(siggv);
 316             hv = GvHVn(siggv);
 317             hv_magic(hv, siggv, 'S');
 318
 319             /* initialize signal stack */
 320             signalstack = newAV();
 321             av_store(signalstack, 32, Nullsv);
 322             av_clear(signalstack);
 323             AvREAL_off(signalstack);
 324         }
 325         break;
 326
 327     case '&':
 328         if (len > 1)
 329             break;
 330         ampergv = gv;
 331         sawampersand = TRUE;
 332         goto magicalize;
 333
 334     case '`':
 335         if (len > 1)
 336             break;
 337         leftgv = gv;
 338         sawampersand = TRUE;
 339         goto magicalize;
 340
 341     case '\'':
 342         if (len > 1)
 343             break;
 344         rightgv = gv;
 345         sawampersand = TRUE;
 346         goto magicalize;
 347
 348     case ':':
 349         if (len > 1)
 350             break;
 351         sv_setpv(GvSV(gv),chopset);
 352         goto magicalize;
 353
 354     case '!':
 355     case '#':
 356     case '?':
 357     case '^':
 358     case '~':
 359     case '=':
 360     case '-':
 361     case '%':
 362     case '.':
 363     case '+':
 364     case '*':
 365     case '(':
 366     case ')':
 367     case '<':
 368     case '>':
 369     case ',':
 370     case '\\':
 371     case '/':
 372     case '[':
 373     case '|':
 374     case '\004':
 375     case '\t':
 376     case '\020':
 377     case '\024':
 378     case '\027':
 379     case '\006':
 380         if (len > 1)
 381             break;
 382         goto magicalize;
 383
 384     case '1':
 385     case '2':
 386     case '3':
 387     case '4':
 388     case '5':
 389     case '6':
 390     case '7':
 391     case '8':
 392     case '9':
 393       magicalize:
 394         sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
 395         break;
 396
 397     case '\014':
 398         if (len > 1)
 399             break;
 400         sv_setpv(GvSV(gv),"\f");
 401         formfeed = GvSV(gv);
 402         break;
 403     case ';':
 404         if (len > 1)
 405             break;
 406         sv_setpv(GvSV(gv),"\034");
 407         break;
 408     case ']':
 409         if (len == 1) {
 410             SV *sv;
 411             sv = GvSV(gv);
 412             sv_upgrade(sv, SVt_PVNV);
 413             sv_setpv(sv,rcsid);
 414             SvNVX(sv) = atof(patchlevel);
 415             SvNOK_on(sv);
 416         }
 417         break;
 418     }
 419     return gv;
 420 }
 421
 422 void
 423 gv_fullname(sv,gv)
 424 SV *sv;
 425 GV *gv;
 426 {
 427     HV *hv = GvSTASH(gv);
 428
 429     if (!hv)
 430         return;
 431     sv_setpv(sv, sv == (SV*)gv ? "*" : "");
 432     sv_catpv(sv,HvNAME(hv));
 433     sv_catpvn(sv,"::", 2);
 434     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
 435 }
 436
 437 void
 438 gv_efullname(sv,gv)
 439 SV *sv;
 440 GV *gv;
 441 {
 442     GV* egv = GvEGV(gv);
 443     HV *hv = GvSTASH(egv);
 444
 445     if (!hv)
 446         return;
 447     sv_setpv(sv, sv == (SV*)gv ? "*" : "");
 448     sv_catpv(sv,HvNAME(hv));
 449     sv_catpvn(sv,"::", 2);
 450     sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv));
 451 }
 452
 453 IO *
 454 newIO()
 455 {
 456     IO *io;
 457     GV *iogv;
 458
 459     io = (IO*)NEWSV(0,0);
 460     sv_upgrade(io,SVt_PVIO);
 461     SvREFCNT(io) = 1;
 462     SvOBJECT_on(io);
 463     iogv = gv_fetchpv("FileHandle::", TRUE, SVt_PVIO);
 464     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
 465     return io;
 466 }
 467
 468 void
 469 gv_check(stash)
 470 HV* stash;
 471 {
 472     register HE *entry;
 473     register I32 i;
 474     register GV *gv;
 475     HV *hv;
 476
 477     if (!HvARRAY(stash))
 478         return;
 479     for (i = 0; i <= HvMAX(stash); i++) {
 480         for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) {
 481             if (isALPHA(*entry->hent_key)) {
 482                 gv = (GV*)entry->hent_val;
 483                 if (SvMULTI(gv))
 484                     continue;
 485                 curcop->cop_line = GvLINE(gv);
 486                 curcop->cop_filegv = GvFILEGV(gv);
 487                 if (SvMULTI(GvFILEGV(gv)))      /* Filename began with slash */
 488                     continue;
 489                 warn("Identifier \"%s::%s\" used only once: possible typo", HvNAME(stash), GvNAME(gv));
 490             }
 491             else if (*entry->hent_key == '_' &&
 492                 (gv = (GV*)entry->hent_val) &&
 493                 (hv = GvHV(gv)) && HvNAME(hv) && hv != defstash)
 494                      gv_check(hv);              /* nested package */
 495
 496         }
 497     }
 498 }
 499
 500 GV *
 501 newGVgen()
 502 {
 503     (void)sprintf(tokenbuf,"_GEN_%d",gensym++);
 504     return gv_fetchpv(tokenbuf,TRUE, SVt_PVGV);
 505 }
 506
 507 /* hopefully this is only called on local symbol table entries */
 508
 509 GP*
 510 gp_ref(gp)
 511 GP* gp;
 512 {
 513     gp->gp_refcnt++;
 514     return gp;
 515
 516 }
 517
 518 void
 519 gp_free(gv)
 520 GV* gv;
 521 {
 522     IO *io;
 523     CV *cv;
 524     GP* gp;
 525
 526     if (!gv || !(gp = GvGP(gv)))
 527         return;
 528     if (gp->gp_refcnt == 0) {
 529         warn("Attempt to free unreferenced glob pointers");
 530         return;
 531     }
 532     if (--gp->gp_refcnt > 0)
 533         return;
 534
 535     SvREFCNT_dec(gp->gp_sv);
 536     SvREFCNT_dec(gp->gp_av);
 537     SvREFCNT_dec(gp->gp_hv);
 538     if ((io = gp->gp_io) && SvTYPE(io) != SVTYPEMASK) {
 539         do_close(gv,FALSE);
 540         SvREFCNT_dec(io);
 541     }
 542     if ((cv = gp->gp_cv) && !GvCVGEN(gv))
 543         SvREFCNT_dec(cv);
 544     Safefree(gp);
 545     GvGP(gv) = 0;
 546 }
 547
 548 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
 549 #define MICROPORT
 550 #endif
 551
 552 #ifdef  MICROPORT       /* Microport 2.4 hack */
 553 AV *GvAVn(gv)
 554 register GV *gv;
 555 {
 556     if (GvGP(gv)->gp_av)
 557         return GvGP(gv)->gp_av;
 558     else
 559         return GvGP(gv_AVadd(gv))->gp_av;
 560 }
 561
 562 HV *GvHVn(gv)
 563 register GV *gv;
 564 {
 565     if (GvGP(gv)->gp_hv)
 566         return GvGP(gv)->gp_hv;
 567     else
 568         return GvGP(gv_HVadd(gv))->gp_hv;
 569 }
 570 #endif                  /* Microport 2.4 hack */