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);
  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);
 168         }
 169     }
 170     return gv_fetchmeth(stash, name, nend - name);
 171 }
 172
 173 GV *
 174 gv_fetchpv(nambeg,add)
 175 char *nambeg;
 176 I32 add;
 177 {
 178     register char *name = nambeg;
 179     register GV *gv = 0;
 180     GV**gvp;
 181     I32 len;
 182     register char *namend;
 183     HV *stash = 0;
 184     bool global = FALSE;
 185     char tmpbuf[256];
 186
 187     for (namend = name; *namend; namend++) {
 188         if ((*namend == '\'' && namend[1]) ||
 189             (*namend == ':' && namend[1] == ':'))
 190         {
 191             len = namend - name;
 192             *tmpbuf = '_';
 193             Copy(name, tmpbuf+1, len, char);
 194             len++;
 195             tmpbuf[len] = '\0';
 196             if (!stash)
 197                 stash = defstash;
 198
 199             if (len > 1) {
 200                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
 201                 if (!gvp || *gvp == (GV*)&sv_undef)
 202                     return Nullgv;
 203                 gv = *gvp;
 204                 if (SvTYPE(gv) == SVt_PVGV)
 205                     SvMULTI_on(gv);
 206                 else
 207                     gv_init(gv, stash, nambeg, namend - nambeg, (add & 2));
 208                 if (!(stash = GvHV(gv)))
 209                     stash = GvHV(gv) = newHV();
 210                 if (!HvNAME(stash))
 211                     HvNAME(stash) = nsavestr(nambeg, namend - nambeg);
 212             }
 213
 214             if (*namend == ':')
 215                 namend++;
 216             namend++;
 217             name = namend;
 218             if (!*name)
 219                 return gv ? gv : defgv;
 220         }
 221     }
 222
 223     /* No stash in name, so see how we can default */
 224
 225     if (!stash) {
 226         if (isIDFIRST(*name)) {
 227             if (isUPPER(*name)) {
 228                 if (*name > 'I') {
 229                     if (*name == 'S' && (
 230                       strEQ(name, "SIG") ||
 231                       strEQ(name, "STDIN") ||
 232                       strEQ(name, "STDOUT") ||
 233                       strEQ(name, "STDERR") ))
 234                         global = TRUE;
 235                 }
 236                 else if (*name > 'E') {
 237                     if (*name == 'I' && strEQ(name, "INC"))
 238                         global = TRUE;
 239                 }
 240                 else if (*name > 'A') {
 241                     if (*name == 'E' && strEQ(name, "ENV"))
 242                         global = TRUE;
 243                 }
 244                 else if (*name == 'A' && (
 245                   strEQ(name, "ARGV") ||
 246                   strEQ(name, "ARGVOUT") ))
 247                     global = TRUE;
 248             }
 249             else if (*name == '_' && !name[1])
 250                 global = TRUE;
 251             if (global)
 252                 stash = defstash;
 253             else if ((COP*)curcop == &compiling)
 254                 stash = curstash;
 255             else
 256                 stash = curcop->cop_stash;
 257         }
 258         else
 259             stash = defstash;
 260     }
 261
 262     /* By this point we should have a stash and a name */
 263
 264     if (!stash)
 265         croak("Global symbol \"%s\" requires explicit package name", name);
 266     len = namend - name;
 267     if (!len)
 268         len = 1;
 269     gvp = (GV**)hv_fetch(stash,name,len,add);
 270     if (!gvp || *gvp == (GV*)&sv_undef)
 271         return Nullgv;
 272     gv = *gvp;
 273     if (SvTYPE(gv) == SVt_PVGV) {
 274         SvMULTI_on(gv);
 275         return gv;
 276     }
 277
 278     /* Adding a new symbol */
 279
 280     gv_init(gv, stash, name, len, add & 2);
 281
 282     /* set up magic where warranted */
 283     switch (*name) {
 284     case 'a':
 285     case 'b':
 286         if (len == 1)
 287             SvMULTI_on(gv);
 288         break;
 289     case 'I':
 290         if (strEQ(name, "ISA")) {
 291             AV* av = GvAVn(gv);
 292             SvMULTI_on(gv);
 293             sv_magic((SV*)av, (SV*)gv, 'I', 0, 0);
 294         }
 295         break;
 296     case 'S':
 297         if (strEQ(name, "SIG")) {
 298             HV *hv;
 299             siggv = gv;
 300             SvMULTI_on(siggv);
 301             hv = GvHVn(siggv);
 302             hv_magic(hv, siggv, 'S');
 303
 304             /* initialize signal stack */
 305             signalstack = newAV();
 306             av_store(signalstack, 32, Nullsv);
 307             av_clear(signalstack);
 308             AvREAL_off(signalstack);
 309         }
 310         break;
 311
 312     case '&':
 313         if (len > 1)
 314             break;
 315         ampergv = gv;
 316         sawampersand = TRUE;
 317         goto magicalize;
 318
 319     case '`':
 320         if (len > 1)
 321             break;
 322         leftgv = gv;
 323         sawampersand = TRUE;
 324         goto magicalize;
 325
 326     case '\'':
 327         if (len > 1)
 328             break;
 329         rightgv = gv;
 330         sawampersand = TRUE;
 331         goto magicalize;
 332
 333     case ':':
 334         if (len > 1)
 335             break;
 336         sv_setpv(GvSV(gv),chopset);
 337         goto magicalize;
 338
 339     case '!':
 340     case '#':
 341     case '?':
 342     case '^':
 343     case '~':
 344     case '=':
 345     case '-':
 346     case '%':
 347     case '.':
 348     case '+':
 349     case '*':
 350     case '(':
 351     case ')':
 352     case '<':
 353     case '>':
 354     case ',':
 355     case '\\':
 356     case '/':
 357     case '[':
 358     case '|':
 359     case '\004':
 360     case '\t':
 361     case '\020':
 362     case '\024':
 363     case '\027':
 364     case '\006':
 365         if (len > 1)
 366             break;
 367         goto magicalize;
 368
 369     case '1':
 370     case '2':
 371     case '3':
 372     case '4':
 373     case '5':
 374     case '6':
 375     case '7':
 376     case '8':
 377     case '9':
 378       magicalize:
 379         sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
 380         break;
 381
 382     case '\014':
 383         if (len > 1)
 384             break;
 385         sv_setpv(GvSV(gv),"\f");
 386         formfeed = GvSV(gv);
 387         break;
 388     case ';':
 389         if (len > 1)
 390             break;
 391         sv_setpv(GvSV(gv),"\034");
 392         break;
 393     case ']':
 394         if (len == 1) {
 395             SV *sv;
 396             sv = GvSV(gv);
 397             sv_upgrade(sv, SVt_PVNV);
 398             sv_setpv(sv,rcsid);
 399             SvNVX(sv) = atof(patchlevel);
 400             SvNOK_on(sv);
 401         }
 402         break;
 403     }
 404     return gv;
 405 }
 406
 407 void
 408 gv_fullname(sv,gv)
 409 SV *sv;
 410 GV *gv;
 411 {
 412     HV *hv = GvSTASH(gv);
 413
 414     if (!hv)
 415         return;
 416     sv_setpv(sv, sv == (SV*)gv ? "*" : "");
 417     sv_catpv(sv,HvNAME(hv));
 418     sv_catpvn(sv,"::", 2);
 419     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
 420 }
 421
 422 void
 423 gv_efullname(sv,gv)
 424 SV *sv;
 425 GV *gv;
 426 {
 427     GV* egv = GvEGV(gv);
 428     HV *hv = GvSTASH(egv);
 429
 430     if (!hv)
 431         return;
 432     sv_setpv(sv, sv == (SV*)gv ? "*" : "");
 433     sv_catpv(sv,HvNAME(hv));
 434     sv_catpvn(sv,"::", 2);
 435     sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv));
 436 }
 437
 438 IO *
 439 newIO()
 440 {
 441     IO *io;
 442     GV *iogv;
 443
 444     io = (IO*)NEWSV(0,0);
 445     sv_upgrade(io,SVt_PVIO);
 446     SvREFCNT(io) = 1;
 447     SvOBJECT_on(io);
 448     iogv = gv_fetchpv("FileHandle::", TRUE);
 449     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
 450     return io;
 451 }
 452
 453 void
 454 gv_check(stash)
 455 HV* stash;
 456 {
 457     register HE *entry;
 458     register I32 i;
 459     register GV *gv;
 460     HV *hv;
 461
 462     if (!HvARRAY(stash))
 463         return;
 464     for (i = 0; i <= HvMAX(stash); i++) {
 465         for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) {
 466             if (isALPHA(*entry->hent_key)) {
 467                 gv = (GV*)entry->hent_val;
 468                 if (SvMULTI(gv))
 469                     continue;
 470                 curcop->cop_line = GvLINE(gv);
 471                 curcop->cop_filegv = GvFILEGV(gv);
 472                 if (SvMULTI(GvFILEGV(gv)))      /* Filename began with slash */
 473                     continue;
 474                 warn("Possible typo: \"%s::%s\"", HvNAME(stash), GvNAME(gv));
 475             }
 476             else if (*entry->hent_key == '_' &&
 477                 (gv = (GV*)entry->hent_val) &&
 478                 (hv = GvHV(gv)) && HvNAME(hv) && hv != defstash)
 479                      gv_check(hv);              /* nested package */
 480
 481         }
 482     }
 483 }
 484
 485 GV *
 486 newGVgen()
 487 {
 488     (void)sprintf(tokenbuf,"_GEN_%d",gensym++);
 489     return gv_fetchpv(tokenbuf,TRUE);
 490 }
 491
 492 /* hopefully this is only called on local symbol table entries */
 493
 494 GP*
 495 gp_ref(gp)
 496 GP* gp;
 497 {
 498     gp->gp_refcnt++;
 499     return gp;
 500
 501 }
 502
 503 void
 504 gp_free(gv)
 505 GV* gv;
 506 {
 507     IO *io;
 508     CV *cv;
 509     GP* gp;
 510
 511     if (!gv || !(gp = GvGP(gv)))
 512         return;
 513     if (gp->gp_refcnt == 0) {
 514         warn("Attempt to free unreferenced glob pointers");
 515         return;
 516     }
 517     if (--gp->gp_refcnt > 0)
 518         return;
 519
 520     SvREFCNT_dec(gp->gp_sv);
 521     SvREFCNT_dec(gp->gp_av);
 522     SvREFCNT_dec(gp->gp_hv);
 523     if ((io = gp->gp_io) && SvTYPE(io) != SVTYPEMASK) {
 524         do_close(gv,FALSE);
 525         SvREFCNT_dec(io);
 526     }
 527     if ((cv = gp->gp_cv) && !GvCVGEN(gv))
 528         SvREFCNT_dec(cv);
 529     Safefree(gp);
 530     GvGP(gv) = 0;
 531 }
 532
 533 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
 534 #define MICROPORT
 535 #endif
 536
 537 #ifdef  MICROPORT       /* Microport 2.4 hack */
 538 AV *GvAVn(gv)
 539 register GV *gv;
 540 {
 541     if (GvGP(gv)->gp_av)
 542         return GvGP(gv)->gp_av;
 543     else
 544         return GvGP(gv_AVadd(gv))->gp_av;
 545 }
 546
 547 HV *GvHVn(gv)
 548 register GV *gv;
 549 {
 550     if (GvGP(gv)->gp_hv)
 551         return GvGP(gv)->gp_hv;
 552     else
 553         return GvGP(gv_HVadd(gv))->gp_hv;
 554 }
 555 #endif                  /* Microport 2.4 hack */
 556
 557 GV *
 558 fetch_gv(op,num)
 559 OP *op;
 560 I32 num;
 561 {
 562     if (op->op_private < num)
 563         return 0;
 564     if (op->op_flags & OPf_STACKED)
 565         return gv_fetchpv(SvPVx(*(stack_sp--), na),TRUE);
 566     else
 567         return cGVOP->op_gv;
 568 }
 569
 570 IO *
 571 fetch_io(op,num)
 572 OP *op;
 573 I32 num;
 574 {
 575     GV *gv;
 576
 577     if (op->op_private < num)
 578         return 0;
 579     if (op->op_flags & OPf_STACKED)
 580         gv = gv_fetchpv(SvPVx(*(stack_sp--), na),TRUE);
 581     else
 582         gv = cGVOP->op_gv;
 583
 584     if (!gv)
 585         return 0;
 586
 587     return GvIOn(gv);
 588 }