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 (perldb)
  77         hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
  78     return gv;
  79 }
  80
  81 void
  82 gv_init(gv, stash, name, len, multi)
  83 GV *gv;
  84 HV *stash;
  85 char *name;
  86 STRLEN len;
  87 int multi;
  88 {
  89     register GP *gp;
  90
  91     sv_upgrade(gv, SVt_PVGV);
  92     if (SvLEN(gv))
  93         Safefree(SvPVX(gv));
  94     Newz(602,gp, 1, GP);
  95     GvGP(gv) = gp;
  96     GvREFCNT(gv) = 1;
  97     GvSV(gv) = NEWSV(72,0);
  98     GvLINE(gv) = curcop->cop_line;
  99     GvEGV(gv) = gv;
 100     sv_magic((SV*)gv, (SV*)gv, '*', name, len);
 101     GvSTASH(gv) = stash;
 102     GvNAME(gv) = nsavestr(name, len);
 103     GvNAMELEN(gv) = len;
 104     if (multi)
 105         SvMULTI_on(gv);
 106 }
 107
 108 GV *
 109 gv_fetchmeth(stash, name, len)
 110 HV* stash;
 111 char* name;
 112 STRLEN len;
 113 {
 114     AV* av;
 115     GV* topgv;
 116     GV* gv;
 117     GV** gvp;
 118
 119     gvp = (GV**)hv_fetch(stash, name, len, TRUE);
 120
 121     DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) );
 122     topgv = *gvp;
 123     if (SvTYPE(topgv) != SVt_PVGV)
 124         gv_init(topgv, stash, name, len, TRUE);
 125
 126     if (GvCV(topgv)) {
 127         if (!GvCVGEN(topgv) || GvCVGEN(topgv) >= sub_generation)
 128             return topgv;
 129     }
 130
 131     gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
 132     if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
 133         SV** svp = AvARRAY(av);
 134         I32 items = AvFILL(av) + 1;
 135         while (items--) {
 136             SV* sv = *svp++;
 137             HV* basestash = fetch_stash(sv, FALSE);
 138             if (!basestash) {
 139                 if (dowarn)
 140                     warn("Can't locate package %s for @%s'ISA",
 141                         SvPVX(sv), HvNAME(stash));
 142                 continue;
 143             }
 144             gv = gv_fetchmeth(basestash, name, len);
 145             if (gv) {
 146                 GvCV(topgv) = GvCV(gv);                 /* cache the CV */
 147                 GvCVGEN(topgv) = sub_generation;        /* valid for now */
 148                 return gv;
 149             }
 150         }
 151     }
 152     return 0;
 153 }
 154
 155 GV *
 156 gv_fetchmethod(stash, name)
 157 HV* stash;
 158 char* name;
 159 {
 160     register char *nend;
 161
 162     for (nend = name; *nend; nend++) {
 163         if (*nend == ':' || *nend == '\'') {
 164             return gv_fetchpv(name, FALSE);
 165         }
 166     }
 167     return gv_fetchmeth(stash, name, nend - name);
 168 }
 169
 170 GV *
 171 gv_fetchpv(nambeg,add)
 172 char *nambeg;
 173 I32 add;
 174 {
 175     register char *name = nambeg;
 176     register GV *gv = 0;
 177     GV**gvp;
 178     I32 len;
 179     register char *namend;
 180     HV *stash = 0;
 181     bool global = FALSE;
 182     char tmpbuf[256];
 183
 184     for (namend = name; *namend; namend++) {
 185         if ((*namend == '\'' && namend[1]) ||
 186             (*namend == ':' && namend[1] == ':'))
 187         {
 188             len = namend - name;
 189             *tmpbuf = '_';
 190             Copy(name, tmpbuf+1, len, char);
 191             len++;
 192             tmpbuf[len] = '\0';
 193             if (!stash)
 194                 stash = defstash;
 195
 196             if (len > 1) {
 197                 gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
 198                 if (!gvp || *gvp == (GV*)&sv_undef)
 199                     return Nullgv;
 200                 gv = *gvp;
 201                 if (SvTYPE(gv) == SVt_PVGV)
 202                     SvMULTI_on(gv);
 203                 else
 204                     gv_init(gv, stash, nambeg, namend - nambeg, (add & 2));
 205                 if (!(stash = GvHV(gv)))
 206                     stash = GvHV(gv) = newHV();
 207                 if (!HvNAME(stash))
 208                     HvNAME(stash) = nsavestr(nambeg, namend - nambeg);
 209             }
 210
 211             if (*namend == ':')
 212                 namend++;
 213             namend++;
 214             name = namend;
 215             if (!*name)
 216                 return gv ? gv : defgv;
 217         }
 218     }
 219
 220     /* No stash in name, so see how we can default */
 221
 222     if (!stash) {
 223         if (isIDFIRST(*name)) {
 224             if (isUPPER(*name)) {
 225                 if (*name > 'I') {
 226                     if (*name == 'S' && (
 227                       strEQ(name, "SIG") ||
 228                       strEQ(name, "STDIN") ||
 229                       strEQ(name, "STDOUT") ||
 230                       strEQ(name, "STDERR") ))
 231                         global = TRUE;
 232                 }
 233                 else if (*name > 'E') {
 234                     if (*name == 'I' && strEQ(name, "INC"))
 235                         global = TRUE;
 236                 }
 237                 else if (*name > 'A') {
 238                     if (*name == 'E' && strEQ(name, "ENV"))
 239                         global = TRUE;
 240                 }
 241                 else if (*name == 'A' && (
 242                   strEQ(name, "ARGV") ||
 243                   strEQ(name, "ARGVOUT") ))
 244                     global = TRUE;
 245             }
 246             else if (*name == '_' && !name[1])
 247                 global = TRUE;
 248             if (global)
 249                 stash = defstash;
 250             else if ((COP*)curcop == &compiling)
 251                 stash = curstash;
 252             else
 253                 stash = curcop->cop_stash;
 254         }
 255         else
 256             stash = defstash;
 257     }
 258
 259     /* By this point we should have a stash and a name */
 260
 261     if (!stash)
 262         croak("Global symbol \"%s\" requires explicit package name", name);
 263     len = namend - name;
 264     if (!len)
 265         len = 1;
 266     gvp = (GV**)hv_fetch(stash,name,len,add);
 267     if (!gvp || *gvp == (GV*)&sv_undef)
 268         return Nullgv;
 269     gv = *gvp;
 270     if (SvTYPE(gv) == SVt_PVGV) {
 271         SvMULTI_on(gv);
 272         return gv;
 273     }
 274
 275     /* Adding a new symbol */
 276
 277     gv_init(gv, stash, name, len, add & 2);
 278
 279     /* set up magic where warranted */
 280     switch (*name) {
 281     case 'a':
 282     case 'b':
 283         if (len == 1)
 284             SvMULTI_on(gv);
 285         break;
 286     case 'I':
 287         if (strEQ(name, "ISA")) {
 288             AV* av = GvAVn(gv);
 289             sv_magic((SV*)av, (SV*)gv, 'I', 0, 0);
 290         }
 291         break;
 292     case 'S':
 293         if (strEQ(name, "SIG")) {
 294             HV *hv;
 295             siggv = gv;
 296             SvMULTI_on(siggv);
 297             hv = GvHVn(siggv);
 298             hv_magic(hv, siggv, 'S');
 299
 300             /* initialize signal stack */
 301             signalstack = newAV();
 302             av_store(signalstack, 32, Nullsv);
 303             av_clear(signalstack);
 304             AvREAL_off(signalstack);
 305         }
 306         break;
 307
 308     case '&':
 309         if (len > 1)
 310             break;
 311         ampergv = gv;
 312         sawampersand = TRUE;
 313         goto magicalize;
 314
 315     case '`':
 316         if (len > 1)
 317             break;
 318         leftgv = gv;
 319         sawampersand = TRUE;
 320         goto magicalize;
 321
 322     case '\'':
 323         if (len > 1)
 324             break;
 325         rightgv = gv;
 326         sawampersand = TRUE;
 327         goto magicalize;
 328
 329     case ':':
 330         if (len > 1)
 331             break;
 332         sv_setpv(GvSV(gv),chopset);
 333         goto magicalize;
 334
 335     case '!':
 336     case '#':
 337     case '?':
 338     case '^':
 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 '\004':
 356     case '\t':
 357     case '\020':
 358     case '\024':
 359     case '\027':
 360     case '\006':
 361         if (len > 1)
 362             break;
 363         goto magicalize;
 364
 365     case '1':
 366     case '2':
 367     case '3':
 368     case '4':
 369     case '5':
 370     case '6':
 371     case '7':
 372     case '8':
 373     case '9':
 374       magicalize:
 375         sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
 376         break;
 377
 378     case '\014':
 379         if (len > 1)
 380             break;
 381         sv_setpv(GvSV(gv),"\f");
 382         formfeed = GvSV(gv);
 383         break;
 384     case ';':
 385         if (len > 1)
 386             break;
 387         sv_setpv(GvSV(gv),"\034");
 388         break;
 389     case ']':
 390         if (len == 1) {
 391             SV *sv;
 392             sv = GvSV(gv);
 393             sv_upgrade(sv, SVt_PVNV);
 394             sv_setpv(sv,rcsid);
 395             SvNVX(sv) = atof(patchlevel);
 396             SvNOK_on(sv);
 397         }
 398         break;
 399     }
 400     return gv;
 401 }
 402
 403 void
 404 gv_fullname(sv,gv)
 405 SV *sv;
 406 GV *gv;
 407 {
 408     HV *hv = GvSTASH(gv);
 409
 410     if (!hv)
 411         return;
 412     sv_setpv(sv, sv == (SV*)gv ? "*" : "");
 413     sv_catpv(sv,HvNAME(hv));
 414     sv_catpvn(sv,"::", 2);
 415     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
 416 }
 417
 418 void
 419 gv_efullname(sv,gv)
 420 SV *sv;
 421 GV *gv;
 422 {
 423     GV* egv = GvEGV(gv);
 424     HV *hv = GvSTASH(egv);
 425
 426     if (!hv)
 427         return;
 428     sv_setpv(sv, sv == (SV*)gv ? "*" : "");
 429     sv_catpv(sv,HvNAME(hv));
 430     sv_catpvn(sv,"::", 2);
 431     sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv));
 432 }
 433
 434 IO *
 435 newIO()
 436 {
 437     IO *io;
 438
 439     Newz(603,io,1,IO);
 440     io->page_len = 60;
 441     return io;
 442 }
 443
 444 void
 445 gv_check(stash)
 446 HV* stash;
 447 {
 448     register HE *entry;
 449     register I32 i;
 450     register GV *gv;
 451     HV *hv;
 452
 453     for (i = 0; i <= HvMAX(stash); i++) {
 454         for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) {
 455             if (isALPHA(*entry->hent_key)) {
 456                 gv = (GV*)entry->hent_val;
 457                 if (SvMULTI(gv))
 458                     continue;
 459                 curcop->cop_line = GvLINE(gv);
 460                 warn("Possible typo: \"%s::%s\"", HvNAME(stash), GvNAME(gv));
 461             }
 462             else if (*entry->hent_key == '_' &&
 463                 (gv = (GV*)entry->hent_val) &&
 464                 (hv = GvHV(gv)) && HvNAME(hv) && hv != defstash)
 465                      gv_check(hv);              /* nested package */
 466
 467         }
 468     }
 469 }
 470
 471 GV *
 472 newGVgen()
 473 {
 474     (void)sprintf(tokenbuf,"_GEN_%d",gensym++);
 475     return gv_fetchpv(tokenbuf,TRUE);
 476 }
 477
 478 /* hopefully this is only called on local symbol table entries */
 479
 480 GP*
 481 gp_ref(gp)
 482 GP* gp;
 483 {
 484     gp->gp_refcnt++;
 485     return gp;
 486
 487 }
 488
 489 void
 490 gp_free(gv)
 491 GV* gv;
 492 {
 493     IO *io;
 494     CV *cv;
 495     GP* gp;
 496
 497     if (!gv || !(gp = GvGP(gv)))
 498         return;
 499     if (gp->gp_refcnt == 0) {
 500         warn("Attempt to free unreferenced glob pointers");
 501         return;
 502     }
 503     if (--gp->gp_refcnt > 0)
 504         return;
 505
 506     sv_free((SV*)gp->gp_sv);
 507     sv_free((SV*)gp->gp_av);
 508     sv_free((SV*)gp->gp_hv);
 509     if (io = gp->gp_io) {
 510         do_close(gv,FALSE);
 511         Safefree(io->top_name);
 512         Safefree(io->fmt_name);
 513         Safefree(io);
 514     }
 515     if (cv = gp->gp_cv)
 516         sv_free((SV*)cv);
 517     Safefree(gp);
 518     GvGP(gv) = 0;
 519 }
 520
 521 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
 522 #define MICROPORT
 523 #endif
 524
 525 #ifdef  MICROPORT       /* Microport 2.4 hack */
 526 AV *GvAVn(gv)
 527 register GV *gv;
 528 {
 529     if (GvGP(gv)->gp_av)
 530         return GvGP(gv)->gp_av;
 531     else
 532         return GvGP(gv_AVadd(gv))->gp_av;
 533 }
 534
 535 HV *GvHVn(gv)
 536 register GV *gv;
 537 {
 538     if (GvGP(gv)->gp_hv)
 539         return GvGP(gv)->gp_hv;
 540     else
 541         return GvGP(gv_HVadd(gv))->gp_hv;
 542 }
 543 #endif                  /* Microport 2.4 hack */
 544
 545 GV *
 546 fetch_gv(op,num)
 547 OP *op;
 548 I32 num;
 549 {
 550     if (op->op_private < num)
 551         return 0;
 552     if (op->op_flags & OPf_STACKED)
 553         return gv_fetchpv(SvPVx(*(stack_sp--), na),TRUE);
 554     else
 555         return cGVOP->op_gv;
 556 }
 557
 558 IO *
 559 fetch_io(op,num)
 560 OP *op;
 561 I32 num;
 562 {
 563     GV *gv;
 564
 565     if (op->op_private < num)
 566         return 0;
 567     if (op->op_flags & OPf_STACKED)
 568         gv = gv_fetchpv(SvPVx(*(stack_sp--), na),TRUE);
 569     else
 570         gv = cGVOP->op_gv;
 571
 572     if (!gv)
 573         return 0;
 574
 575     return GvIOn(gv);
 576 }