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(COEFFSIZE);
  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 GV *
  82 gv_fetchmethod(stash, name)
  83 HV* stash;
  84 char* name;
  85 {
  86     AV* av;
  87     GV* gv;
  88     GV** gvp = (GV**)hv_fetch(stash,name,strlen(name),FALSE);
  89     if (gvp && (gv = *gvp) != (GV*)&sv_undef && GvCV(gv))
  90         return gv;
  91
  92     gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
  93     if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
  94         SV** svp = AvARRAY(av);
  95         I32 items = AvFILL(av) + 1;
  96         while (items--) {
  97             char tmpbuf[512];
  98             SV* sv = *svp++;
  99             *tmpbuf = '_';
 100             SvUPGRADE(sv, SVt_PV);
 101             strcpy(tmpbuf+1,SvPVn(sv));
 102             gv = gv_fetchpv(tmpbuf,FALSE);
 103             if (!gv || !(stash = GvHV(gv))) {
 104                 if (dowarn)
 105                     warn("Can't locate package %s for @%s'ISA",
 106                         SvPV(sv), HvNAME(stash));
 107                 continue;
 108             }
 109             gv = gv_fetchmethod(stash, name);
 110             if (gv)
 111                 return gv;
 112         }
 113     }
 114     return 0;
 115 }
 116
 117 GV *
 118 gv_fetchpv(name,add)
 119 register char *name;
 120 I32 add;
 121 {
 122     register GV *gv;
 123     GV**gvp;
 124     register GP *gp;
 125     I32 len;
 126     register char *namend;
 127     HV *stash;
 128     char *sawquote = Nullch;
 129     char *prevquote = Nullch;
 130     bool global = FALSE;
 131
 132     if (isUPPER(*name)) {
 133         if (*name > 'I') {
 134             if (*name == 'S' && (
 135               strEQ(name, "SIG") ||
 136               strEQ(name, "STDIN") ||
 137               strEQ(name, "STDOUT") ||
 138               strEQ(name, "STDERR") ))
 139                 global = TRUE;
 140         }
 141         else if (*name > 'E') {
 142             if (*name == 'I' && strEQ(name, "INC"))
 143                 global = TRUE;
 144         }
 145         else if (*name > 'A') {
 146             if (*name == 'E' && strEQ(name, "ENV"))
 147                 global = TRUE;
 148         }
 149         else if (*name == 'A' && (
 150           strEQ(name, "ARGV") ||
 151           strEQ(name, "ARGVOUT") ))
 152             global = TRUE;
 153     }
 154     for (namend = name; *namend; namend++) {
 155         if (*namend == '\'' && namend[1])
 156             prevquote = sawquote, sawquote = namend;
 157     }
 158     if (sawquote == name && name[1]) {
 159         stash = defstash;
 160         sawquote = Nullch;
 161         name++;
 162     }
 163     else if (!isALPHA(*name) || global)
 164         stash = defstash;
 165     else if ((COP*)curcop == &compiling)
 166         stash = curstash;
 167     else
 168         stash = curcop->cop_stash;
 169     if (sawquote) {
 170         char tmpbuf[256];
 171         char *s, *d;
 172
 173         *sawquote = '\0';
 174         /*SUPPRESS 560*/
 175         if (s = prevquote) {
 176             strncpy(tmpbuf,name,s-name+1);
 177             d = tmpbuf+(s-name+1);
 178             *d++ = '_';
 179             strcpy(d,s+1);
 180         }
 181         else {
 182             *tmpbuf = '_';
 183             strcpy(tmpbuf+1,name);
 184         }
 185         gv = gv_fetchpv(tmpbuf,TRUE);
 186         if (!(stash = GvHV(gv)))
 187             stash = GvHV(gv) = newHV(0);
 188         if (!HvNAME(stash))
 189             HvNAME(stash) = savestr(name);
 190         name = sawquote+1;
 191         *sawquote = '\'';
 192     }
 193     if (!stash)
 194         fatal("Global symbol \"%s\" requires explicit package name", name);
 195     len = namend - name;
 196     gvp = (GV**)hv_fetch(stash,name,len,add);
 197     if (!gvp || *gvp == (GV*)&sv_undef)
 198         return Nullgv;
 199     gv = *gvp;
 200     if (SvTYPE(gv) == SVt_PVGV) {
 201         SvMULTI_on(gv);
 202         return gv;
 203     }
 204
 205     /* Adding a new symbol */
 206
 207     sv_upgrade(gv, SVt_PVGV);
 208     if (SvLEN(gv))
 209         Safefree(SvPV(gv));
 210     Newz(602,gp, 1, GP);
 211     GvGP(gv) = gp;
 212     GvREFCNT(gv) = 1;
 213     GvSV(gv) = NEWSV(72,0);
 214     GvLINE(gv) = curcop->cop_line;
 215     GvEGV(gv) = gv;
 216     sv_magic((SV*)gv, (SV*)gv, '*', name, len);
 217     GvSTASH(gv) = stash;
 218     GvNAME(gv) = nsavestr(name, len);
 219     GvNAMELEN(gv) = len;
 220     if (isDIGIT(*name) && *name != '0')
 221         sv_magic(GvSV(gv), (SV*)gv, 0, name, len);
 222     if (add & 2)
 223         SvMULTI_on(gv);
 224
 225     /* set up magic where warranted */
 226     switch (*name) {
 227     case 'S':
 228         if (strEQ(name, "SIG")) {
 229             HV *hv;
 230             siggv = gv;
 231             SvMULTI_on(siggv);
 232             hv = GvHVn(siggv);
 233             hv_magic(hv, siggv, 'S');
 234
 235             /* initialize signal stack */
 236             signalstack = newAV();
 237             av_store(signalstack, 32, Nullsv);
 238             av_clear(signalstack);
 239             AvREAL_off(signalstack);
 240         }
 241         break;
 242
 243     case '&':
 244         ampergv = gv;
 245         sawampersand = TRUE;
 246         goto magicalize;
 247
 248     case '`':
 249         leftgv = gv;
 250         sawampersand = TRUE;
 251         goto magicalize;
 252
 253     case '\'':
 254         rightgv = gv;
 255         sawampersand = TRUE;
 256         goto magicalize;
 257
 258     case ':':
 259         sv_setpv(GvSV(gv),chopset);
 260         goto magicalize;
 261
 262     case '!':
 263     case '#':
 264     case '?':
 265     case '^':
 266     case '~':
 267     case '=':
 268     case '-':
 269     case '%':
 270     case '.':
 271     case '+':
 272     case '*':
 273     case '(':
 274     case ')':
 275     case '<':
 276     case '>':
 277     case ',':
 278     case '\\':
 279     case '/':
 280     case '[':
 281     case '|':
 282     case '\004':
 283     case '\t':
 284     case '\020':
 285     case '\024':
 286     case '\027':
 287     case '\006':
 288       magicalize:
 289         sv_magic(GvSV(gv), (SV*)gv, 0, name, 1);
 290         break;
 291
 292     case '\014':
 293         sv_setpv(GvSV(gv),"\f");
 294         formfeed = GvSV(gv);
 295         break;
 296     case ';':
 297         sv_setpv(GvSV(gv),"\034");
 298         break;
 299     case ']': {
 300             SV *sv;
 301             sv = GvSV(gv);
 302             sv_upgrade(sv, SVt_PVNV);
 303             sv_setpv(sv,rcsid);
 304             SvNV(sv) = atof(patchlevel);
 305             SvNOK_on(sv);
 306         }
 307         break;
 308     }
 309     return gv;
 310 }
 311
 312 void
 313 gv_fullname(sv,gv)
 314 SV *sv;
 315 GV *gv;
 316 {
 317     HV *hv = GvSTASH(gv);
 318
 319     if (!hv)
 320         return;
 321     sv_setpv(sv, sv == (SV*)gv ? "*" : "");
 322     sv_catpv(sv,HvNAME(hv));
 323     sv_catpvn(sv,"'", 1);
 324     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
 325 }
 326
 327 void
 328 gv_efullname(sv,gv)
 329 SV *sv;
 330 GV *gv;
 331 {
 332     GV* egv = GvEGV(gv);
 333     HV *hv = GvSTASH(egv);
 334
 335     if (!hv)
 336         return;
 337     sv_setpv(sv, sv == (SV*)gv ? "*" : "");
 338     sv_catpv(sv,HvNAME(hv));
 339     sv_catpvn(sv,"'", 1);
 340     sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv));
 341 }
 342
 343 IO *
 344 newIO()
 345 {
 346     IO *io;
 347
 348     Newz(603,io,1,IO);
 349     io->page_len = 60;
 350     return io;
 351 }
 352
 353 void
 354 gv_check(min,max)
 355 I32 min;
 356 register I32 max;
 357 {
 358     register HE *entry;
 359     register I32 i;
 360     register GV *gv;
 361
 362     for (i = min; i <= max; i++) {
 363         for (entry = HvARRAY(defstash)[i]; entry; entry = entry->hent_next) {
 364             gv = (GV*)entry->hent_val;
 365             if (SvMULTI(gv))
 366                 continue;
 367             curcop->cop_line = GvLINE(gv);
 368             warn("Possible typo: \"%s\"", GvNAME(gv));
 369         }
 370     }
 371 }
 372
 373 GV *
 374 newGVgen()
 375 {
 376     (void)sprintf(tokenbuf,"_GEN_%d",gensym++);
 377     return gv_fetchpv(tokenbuf,TRUE);
 378 }
 379
 380 /* hopefully this is only called on local symbol table entries */
 381
 382 GP*
 383 gp_ref(gp)
 384 GP* gp;
 385 {
 386     gp->gp_refcnt++;
 387     return gp;
 388
 389 }
 390
 391 void
 392 gp_free(gv)
 393 GV* gv;
 394 {
 395     IO *io;
 396     CV *cv;
 397     GP* gp;
 398
 399     if (!gv || !(gp = GvGP(gv)))
 400         return;
 401     if (gp->gp_refcnt == 0) {
 402         warn("Attempt to free unreferenced glob pointers");
 403         return;
 404     }
 405     if (--gp->gp_refcnt > 0)
 406         return;
 407
 408     sv_free(gp->gp_sv);
 409     sv_free(gp->gp_av);
 410     sv_free(gp->gp_hv);
 411     if (io = gp->gp_io) {
 412         do_close(gv,FALSE);
 413         Safefree(io->top_name);
 414         Safefree(io->fmt_name);
 415         Safefree(io);
 416     }
 417     if (cv = gp->gp_cv)
 418         sv_free(cv);
 419     Safefree(gp);
 420     GvGP(gv) = 0;
 421 }
 422
 423 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
 424 #define MICROPORT
 425 #endif
 426
 427 #ifdef  MICROPORT       /* Microport 2.4 hack */
 428 AV *GvAVn(gv)
 429 register GV *gv;
 430 {
 431     if (GvGP(gv)->gp_av)
 432         return GvGP(gv)->gp_av;
 433     else
 434         return GvGP(gv_AVadd(gv))->gp_av;
 435 }
 436
 437 HV *GvHVn(gv)
 438 register GV *gv;
 439 {
 440     if (GvGP(gv)->gp_hv)
 441         return GvGP(gv)->gp_hv;
 442     else
 443         return GvGP(gv_HVadd(gv))->gp_hv;
 444 }
 445 #endif                  /* Microport 2.4 hack */
 446
 447 GV *
 448 fetch_gv(op,num)
 449 OP *op;
 450 I32 num;
 451 {
 452     if (op->op_private < num)
 453         return 0;
 454     if (op->op_flags & OPf_STACKED)
 455         return gv_fetchpv(SvPVnx(*(stack_sp--)),TRUE);
 456     else
 457         return cGVOP->op_gv;
 458 }
 459
 460 IO *
 461 fetch_io(op,num)
 462 OP *op;
 463 I32 num;
 464 {
 465     GV *gv;
 466
 467     if (op->op_private < num)
 468         return 0;
 469     if (op->op_flags & OPf_STACKED)
 470         gv = gv_fetchpv(SvPVnx(*(stack_sp--)),TRUE);
 471     else
 472         gv = cGVOP->op_gv;
 473
 474     if (!gv)
 475         return 0;
 476
 477     return GvIOn(gv);
 478 }