projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
perl 3.0 patch #6 patch 5 continued
[p5sagit/p5-mst-13.2.git] / perly.c
CommitLineData
ffed7fef 1char rcsid[] = "$Header: perly.c,v 3.0.1.2 89/11/17 15:34:42 lwall Locked $\nPatch level: ###\n";
8d063cd8 2/*
a687059c 3 * Copyright (c) 1989, Larry Wall
4 *
5 * You may distribute under the terms of the GNU General Public License
6 * as specified in the README file that comes with the perl 3.0 kit.
7 *
8d063cd8 8 * $Log: perly.c,v $
ffed7fef 9 * Revision 3.0.1.2 89/11/17 15:34:42 lwall
10 * patch5: fixed possible confusion about current effective gid
11 *
ae986130 12 * Revision 3.0.1.1 89/11/11 04:50:04 lwall
13 * patch2: moved yydebug to where its type didn't matter
14 *
a687059c 15 * Revision 3.0 89/10/18 15:22:21 lwall
16 * 3.0 baseline
8d063cd8 17 *
18 */
19
378cc40b 20#include "EXTERN.h"
21#include "perl.h"
22#include "perly.h"
a687059c 23#include "patchlevel.h"
378cc40b 24
a687059c 25#ifdef IAMSUID
26#ifndef DOSUID
27#define DOSUID
28#endif
29#endif
378cc40b 30
a687059c 31#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
32#ifdef DOSUID
33#undef DOSUID
34#endif
35#endif
8d063cd8 36
37main(argc,argv,env)
38register int argc;
39register char **argv;
40register char **env;
41{
42 register STR *str;
43 register char *s;
378cc40b 44 char *index(), *strcpy(), *getenv();
45 bool dosearch = FALSE;
13281fa4 46 char **origargv = argv;
a687059c 47#ifdef DOSUID
13281fa4 48 char *validarg = "";
49#endif
8d063cd8 50
a687059c 51#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
52#ifdef IAMSUID
53#undef IAMSUID
54 fatal("suidperl is no longer needed since the kernel can now execute\n\
55setuid perl scripts securely.\n");
56#endif
57#endif
58
378cc40b 59 uid = (int)getuid();
60 euid = (int)geteuid();
a687059c 61 gid = (int)getgid();
62 egid = (int)getegid();
63 if (do_undump) {
64 do_undump = 0;
65 loop_ptr = 0; /* start label stack again */
66 goto just_doit;
67 }
68 (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
69 linestr = Str_new(65,80);
378cc40b 70 str_nset(linestr,"",0);
a687059c 71 str = str_make("",0); /* first used for -I flags */
72 curstash = defstash = hnew(0);
73 curstname = str_make("main",4);
74 stab_xhash(stabent("_main",TRUE)) = defstash;
378cc40b 75 incstab = aadd(stabent("INC",TRUE));
a687059c 76 incstab->str_pok |= SP_MULTI;
8d063cd8 77 for (argc--,argv++; argc; argc--,argv++) {
78 if (argv[0][0] != '-' || !argv[0][1])
79 break;
13281fa4 80#ifdef DOSUID
81 if (*validarg)
82 validarg = " PHOOEY ";
83 else
84 validarg = argv[0];
85#endif
86 s = argv[0]+1;
8d063cd8 87 reswitch:
13281fa4 88 switch (*s) {
378cc40b 89 case 'a':
90 minus_a = TRUE;
13281fa4 91 s++;
378cc40b 92 goto reswitch;
a687059c 93 case 'd':
94#ifdef TAINT
95 if (euid != uid || egid != gid)
96 fatal("No -d allowed in setuid scripts");
97#endif
98 perldb = TRUE;
99 s++;
100 goto reswitch;
8d063cd8 101 case 'D':
ae986130 102#ifdef DEBUGGING
a687059c 103#ifdef TAINT
104 if (euid != uid || egid != gid)
105 fatal("No -D allowed in setuid scripts");
106#endif
13281fa4 107 debug = atoi(s+1);
ae986130 108#else
109 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
8d063cd8 110#endif
111 break;
8d063cd8 112 case 'e':
a687059c 113#ifdef TAINT
114 if (euid != uid || egid != gid)
115 fatal("No -e allowed in setuid scripts");
116#endif
8d063cd8 117 if (!e_fp) {
a687059c 118 e_tmpname = savestr(TMPPATH);
119 (void)mktemp(e_tmpname);
8d063cd8 120 e_fp = fopen(e_tmpname,"w");
121 }
122 if (argv[1])
123 fputs(argv[1],e_fp);
a687059c 124 (void)putc('\n', e_fp);
8d063cd8 125 argc--,argv++;
126 break;
127 case 'i':
13281fa4 128 inplace = savestr(s+1);
8d063cd8 129 argvoutstab = stabent("ARGVOUT",TRUE);
130 break;
131 case 'I':
a687059c 132#ifdef TAINT
133 if (euid != uid || egid != gid)
134 fatal("No -I allowed in setuid scripts");
135#endif
13281fa4 136 str_cat(str,"-");
137 str_cat(str,s);
8d063cd8 138 str_cat(str," ");
a687059c 139 if (*++s) {
140 (void)apush(stab_array(incstab),str_make(s,0));
378cc40b 141 }
142 else {
a687059c 143 (void)apush(stab_array(incstab),str_make(argv[1],0));
8d063cd8 144 str_cat(str,argv[1]);
145 argc--,argv++;
146 str_cat(str," ");
147 }
148 break;
149 case 'n':
378cc40b 150 minus_n = TRUE;
13281fa4 151 s++;
8d063cd8 152 goto reswitch;
153 case 'p':
378cc40b 154 minus_p = TRUE;
13281fa4 155 s++;
8d063cd8 156 goto reswitch;
157 case 'P':
a687059c 158#ifdef TAINT
159 if (euid != uid || egid != gid)
160 fatal("No -P allowed in setuid scripts");
161#endif
8d063cd8 162 preprocess = TRUE;
13281fa4 163 s++;
8d063cd8 164 goto reswitch;
165 case 's':
a687059c 166#ifdef TAINT
167 if (euid != uid || egid != gid)
168 fatal("No -s allowed in setuid scripts");
169#endif
8d063cd8 170 doswitches = TRUE;
13281fa4 171 s++;
8d063cd8 172 goto reswitch;
378cc40b 173 case 'S':
174 dosearch = TRUE;
13281fa4 175 s++;
378cc40b 176 goto reswitch;
a687059c 177 case 'u':
178 do_undump = TRUE;
179 s++;
180 goto reswitch;
378cc40b 181 case 'U':
182 unsafe = TRUE;
13281fa4 183 s++;
378cc40b 184 goto reswitch;
8d063cd8 185 case 'v':
a687059c 186 fputs(rcsid,stdout);
187 fputs("\nCopyright (c) 1989, Larry Wall\n\n\
188Perl may be copied only under the terms of the GNU General Public License,\n\
189a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout);
8d063cd8 190 exit(0);
378cc40b 191 case 'w':
192 dowarn = TRUE;
13281fa4 193 s++;
378cc40b 194 goto reswitch;
8d063cd8 195 case '-':
196 argc--,argv++;
197 goto switch_end;
198 case 0:
199 break;
200 default:
13281fa4 201 fatal("Unrecognized switch: -%s",s);
8d063cd8 202 }
203 }
204 switch_end:
205 if (e_fp) {
a687059c 206 (void)fclose(e_fp);
8d063cd8 207 argc++,argv--;
208 argv[0] = e_tmpname;
209 }
378cc40b 210#ifndef PRIVLIB
211#define PRIVLIB "/usr/local/lib/perl"
212#endif
a687059c 213 (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
8d063cd8 214
215 str_set(&str_no,No);
216 str_set(&str_yes,Yes);
8d063cd8 217
218 /* open script */
219
220 if (argv[0] == Nullch)
221 argv[0] = "-";
a687059c 222 if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) {
378cc40b 223 char *xfound = Nullch, *xfailed = Nullch;
a687059c 224 int len;
378cc40b 225
a687059c 226 bufend = s + strlen(s);
378cc40b 227 while (*s) {
a687059c 228 s = cpytill(tokenbuf,s,bufend,':',&len);
378cc40b 229 if (*s)
230 s++;
a687059c 231 if (len)
232 (void)strcat(tokenbuf+len,"/");
233 (void)strcat(tokenbuf+len,argv[0]);
378cc40b 234#ifdef DEBUGGING
235 if (debug & 1)
236 fprintf(stderr,"Looking for %s\n",tokenbuf);
237#endif
238 if (stat(tokenbuf,&statbuf) < 0) /* not there? */
239 continue;
240 if ((statbuf.st_mode & S_IFMT) == S_IFREG
a687059c 241 && cando(S_IREAD,TRUE,&statbuf) && cando(S_IEXEC,TRUE,&statbuf)) {
378cc40b 242 xfound = tokenbuf; /* bingo! */
243 break;
244 }
245 if (!xfailed)
246 xfailed = savestr(tokenbuf);
247 }
248 if (!xfound)
a687059c 249 fatal("Can't execute %s", xfailed ? xfailed : argv[0] );
378cc40b 250 if (xfailed)
a687059c 251 Safefree(xfailed);
378cc40b 252 argv[0] = savestr(xfound);
253 }
a687059c 254
255 pidstatary = anew(Nullstab); /* for remembering popen pids, status */
256
8d063cd8 257 filename = savestr(argv[0]);
378cc40b 258 origfilename = savestr(filename);
8d063cd8 259 if (strEQ(filename,"-"))
260 argv[0] = "";
261 if (preprocess) {
378cc40b 262 str_cat(str,"-I");
263 str_cat(str,PRIVLIB);
a687059c 264 (void)sprintf(buf, "\
8d063cd8 265/bin/sed -e '/^[^#]/b' \
266 -e '/^#[ ]*include[ ]/b' \
267 -e '/^#[ ]*define[ ]/b' \
268 -e '/^#[ ]*if[ ]/b' \
269 -e '/^#[ ]*ifdef[ ]/b' \
378cc40b 270 -e '/^#[ ]*ifndef[ ]/b' \
8d063cd8 271 -e '/^#[ ]*else/b' \
272 -e '/^#[ ]*endif/b' \
273 -e 's/^#.*//' \
378cc40b 274 %s | %s -C %s %s",
275 argv[0], CPPSTDIN, str_get(str), CPPMINUS);
a687059c 276#ifdef IAMSUID /* actually, this is caught earlier */
13281fa4 277 if (euid != uid && !euid) /* if running suidperl */
a687059c 278#ifdef SETEUID
279 (void)seteuid(uid); /* musn't stay setuid root */
280#else
281#ifdef SETREUID
282 (void)setreuid(-1, uid);
283#else
284 setuid(uid);
285#endif
13281fa4 286#endif
a687059c 287#endif /* IAMSUID */
288 rsfp = mypopen(buf,"r");
8d063cd8 289 }
290 else if (!*argv[0])
291 rsfp = stdin;
292 else
293 rsfp = fopen(argv[0],"r");
13281fa4 294 if (rsfp == Nullfp) {
a687059c 295 extern char *sys_errlist[];
296 extern int errno;
297
13281fa4 298#ifdef DOSUID
a687059c 299#ifndef IAMSUID /* in case script is not readable before setuid */
13281fa4 300 if (euid && stat(filename,&statbuf) >= 0 &&
301 statbuf.st_mode & (S_ISUID|S_ISGID)) {
a687059c 302 (void)sprintf(buf, "%s/%s", BIN, "suidperl");
303 execv(buf, origargv); /* try again */
13281fa4 304 fatal("Can't do setuid\n");
305 }
306#endif
307#endif
a687059c 308 fatal("Can't open perl script \"%s\": %s\n",
309 filename, sys_errlist[errno]);
13281fa4 310 }
8d063cd8 311 str_free(str); /* free -I directories */
312
13281fa4 313 /* do we need to emulate setuid on scripts? */
314
315 /* This code is for those BSD systems that have setuid #! scripts disabled
316 * in the kernel because of a security problem. Merely defining DOSUID
317 * in perl will not fix that problem, but if you have disabled setuid
318 * scripts in the kernel, this will attempt to emulate setuid and setgid
319 * on scripts that have those now-otherwise-useless bits set. The setuid
320 * root version must be called suidperl. If regular perl discovers that
321 * it has opened a setuid script, it calls suidperl with the same argv
322 * that it had. If suidperl finds that the script it has just opened
323 * is NOT setuid root, it sets the effective uid back to the uid. We
324 * don't just make perl setuid root because that loses the effective
325 * uid we had before invoking perl, if it was different from the uid.
326 *
327 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
328 * be defined in suidperl only. suidperl must be setuid root. The
329 * Configure script will set this up for you if you want it.
a687059c 330 *
331 * There is also the possibility of have a script which is running
332 * set-id due to a C wrapper. We want to do the TAINT checks
333 * on these set-id scripts, but don't want to have the overhead of
334 * them in normal perl, and can't use suidperl because it will lose
335 * the effective uid info, so we have an additional non-setuid root
336 * version called taintperl that just does the TAINT checks.
13281fa4 337 */
a687059c 338
13281fa4 339#ifdef DOSUID
340 if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
341 fatal("Can't stat script \"%s\"",filename);
342 if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
343 int len;
344
a687059c 345#ifdef IAMSUID
346#ifndef SETREUID
347 /* On this access check to make sure the directories are readable,
348 * there is actually a small window that the user could use to make
349 * filename point to an accessible directory. So there is a faint
350 * chance that someone could execute a setuid script down in a
351 * non-accessible directory. I don't know what to do about that.
352 * But I don't think it's too important. The manual lies when
353 * it says access() is useful in setuid programs.
354 */
13281fa4 355 if (access(filename,1)) /* as a double check */
356 fatal("Permission denied");
a687059c 357#else
358 /* If we can swap euid and uid, then we can determine access rights
359 * with a simple stat of the file, and then compare device and
360 * inode to make sure we did stat() on the same file we opened.
361 * Then we just have to make sure he or she can execute it.
362 */
363 {
364 struct stat tmpstatbuf;
365
366 if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
367 fatal("Can't swap uid and euid"); /* really paranoid */
368 if (stat(filename,&tmpstatbuf) < 0) /* testing full pathname here */
369 fatal("Permission denied");
370 if (tmpstatbuf.st_dev != statbuf.st_dev ||
371 tmpstatbuf.st_ino != statbuf.st_ino) {
372 (void)fclose(rsfp);
373 if (rsfp = mypopen("/bin/mail root","w")) { /* heh, heh */
374 fprintf(rsfp,
375"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
376(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
377 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
378 statbuf.st_dev, statbuf.st_ino,
379 filename, statbuf.st_uid, statbuf.st_gid);
380 (void)mypclose(rsfp);
381 }
382 fatal("Permission denied\n");
383 }
384 if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
385 fatal("Can't reswap uid and euid");
386 if (!cando(S_IEXEC,FALSE,&statbuf)) /* can real uid exec? */
387 fatal("Permission denied\n");
388 }
389#endif /* SETREUID */
390#endif /* IAMSUID */
391
13281fa4 392 if ((statbuf.st_mode & S_IFMT) != S_IFREG)
393 fatal("Permission denied");
a687059c 394 if ((statbuf.st_mode >> 6) & S_IWRITE)
395 fatal("Setuid/gid script is writable by world");
13281fa4 396 doswitches = FALSE; /* -s is insecure in suid */
397 line++;
398 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
399 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
400 fatal("No #! line");
401 for (s = tokenbuf+2; !isspace(*s); s++) ;
402 if (strnNE(s-4,"perl",4)) /* sanity check */
403 fatal("Not a perl script");
a687059c 404 while (*s == ' ' || *s == '\t') s++;
13281fa4 405 /*
406 * #! arg must be what we saw above. They can invoke it by
407 * mentioning suidperl explicitly, but they may not add any strange
408 * arguments beyond what #! says if they do invoke suidperl that way.
409 */
410 len = strlen(validarg);
411 if (strEQ(validarg," PHOOEY ") ||
412 strnNE(s,validarg,len) || !isspace(s[len]))
a687059c 413 fatal("Args must match #! line");
414
415#ifndef IAMSUID
416 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
417 euid == statbuf.st_uid)
418 if (!do_undump)
419 fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
420FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
421#endif /* IAMSUID */
13281fa4 422
423 if (euid) { /* oops, we're not the setuid root perl */
a687059c 424 (void)fclose(rsfp);
13281fa4 425#ifndef IAMSUID
a687059c 426 (void)sprintf(buf, "%s/%s", BIN, "suidperl");
427 execv(buf, origargv); /* try again */
13281fa4 428#endif
429 fatal("Can't do setuid\n");
430 }
431
ffed7fef 432 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid)
a687059c 433#ifdef SETEGID
434 (void)setegid(statbuf.st_gid);
435#else
436#ifdef SETREGID
437 (void)setregid((GIDTYPE)-1,statbuf.st_gid);
438#else
439 setgid(statbuf.st_gid);
440#endif
441#endif
442 if (statbuf.st_mode & S_ISUID) {
443 if (statbuf.st_uid != euid)
444#ifdef SETEUID
445 (void)seteuid(statbuf.st_uid); /* all that for this */
446#else
447#ifdef SETREUID
448 (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
449#else
450 setuid(statbuf.st_uid);
451#endif
452#endif
453 }
454 else if (uid) /* oops, mustn't run as root */
455#ifdef SETEUID
456 (void)seteuid((UIDTYPE)uid);
457#else
458#ifdef SETREUID
459 (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
460#else
461 setuid((UIDTYPE)uid);
462#endif
463#endif
ffed7fef 464 uid = (int)getuid();
13281fa4 465 euid = (int)geteuid();
ffed7fef 466 gid = (int)getgid();
467 egid = (int)getegid();
a687059c 468 if (!cando(S_IEXEC,TRUE,&statbuf))
13281fa4 469 fatal("Permission denied\n"); /* they can't do this */
470 }
471#ifdef IAMSUID
472 else if (preprocess)
473 fatal("-P not allowed for setuid/setgid script\n");
474 else
475 fatal("Script is not setuid/setgid in suidperl\n");
a687059c 476#else
477#ifndef TAINT /* we aren't taintperl or suidperl */
478 /* script has a wrapper--can't run suidperl or we lose euid */
479 else if (euid != uid || egid != gid) {
480 (void)fclose(rsfp);
481 (void)sprintf(buf, "%s/%s", BIN, "taintperl");
482 execv(buf, origargv); /* try again */
483 fatal("Can't run setuid script with taint checks");
484 }
485#endif /* TAINT */
13281fa4 486#endif /* IAMSUID */
a687059c 487#else /* !DOSUID */
488#ifndef TAINT /* we aren't taintperl or suidperl */
489 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
490#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
491 fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
492 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
493 ||
494 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
495 )
496 if (!do_undump)
497 fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
498FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
499#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
500 /* not set-id, must be wrapped */
501 (void)fclose(rsfp);
502 (void)sprintf(buf, "%s/%s", BIN, "taintperl");
503 execv(buf, origargv); /* try again */
504 fatal("Can't run setuid script with taint checks");
505 }
506#endif /* TAINT */
13281fa4 507#endif /* DOSUID */
508
8d063cd8 509 defstab = stabent("_",TRUE);
510
a687059c 511 if (perldb) {
512 debstash = hnew(0);
513 stab_xhash(stabent("_DB",TRUE)) = debstash;
514 curstash = debstash;
515 lineary = stab_xarray(aadd((tmpstab = stabent("line",TRUE))));
516 tmpstab->str_pok |= SP_MULTI;
517 subname = str_make("main",4);
518 DBstab = stabent("DB",TRUE);
519 DBstab->str_pok |= SP_MULTI;
520 DBsub = hadd(tmpstab = stabent("sub",TRUE));
521 tmpstab->str_pok |= SP_MULTI;
522 DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
523 tmpstab->str_pok |= SP_MULTI;
524 curstash = defstash;
525 }
526
8d063cd8 527 /* init tokener */
528
a687059c 529 bufend = bufptr = str_get(linestr);
530
531 savestack = anew(Nullstab); /* for saving non-local values */
532 stack = anew(Nullstab); /* for saving non-local values */
533 stack->ary_flags = 0; /* not a real array */
8d063cd8 534
a687059c 535 /* now parse the script */
8d063cd8 536
a687059c 537 error_count = 0;
538 if (yyparse() || error_count)
8d063cd8 539 fatal("Execution aborted due to compilation errors.\n");
540
a687059c 541 New(50,loop_stack,128,struct loop);
ae986130 542#ifdef DEBUGGING
543 if (debug) {
544 New(51,debname,128,char);
545 New(52,debdelim,128,char);
546 }
547#endif
a687059c 548 curstash = defstash;
378cc40b 549
550 preprocess = FALSE;
8d063cd8 551 if (e_fp) {
552 e_fp = Nullfp;
a687059c 553 (void)UNLINK(e_tmpname);
554 }
555
556 /* initialize everything that won't change if we undump */
557
558 if (sigstab = stabent("SIG",allstabs)) {
559 sigstab->str_pok |= SP_MULTI;
560 (void)hadd(sigstab);
561 }
562
563 magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':");
564
565 amperstab = stabent("&",allstabs);
566 leftstab = stabent("`",allstabs);
567 rightstab = stabent("'",allstabs);
568 sawampersand = (amperstab || leftstab || rightstab);
569 if (tmpstab = stabent(":",allstabs))
570 str_set(STAB_STR(tmpstab),chopset);
571
572 /* these aren't necessarily magical */
573 if (tmpstab = stabent(";",allstabs))
574 str_set(STAB_STR(tmpstab),"\034");
575#ifdef TAINT
576 tainted = 1;
577#endif
578 if (tmpstab = stabent("0",allstabs))
579 str_set(STAB_STR(tmpstab),origfilename);
580#ifdef TAINT
581 tainted = 0;
582#endif
583 if (tmpstab = stabent("]",allstabs))
584 str_set(STAB_STR(tmpstab),rcsid);
585 str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
586
587 stdinstab = stabent("STDIN",TRUE);
588 stdinstab->str_pok |= SP_MULTI;
589 stab_io(stdinstab) = stio_new();
590 stab_io(stdinstab)->ifp = stdin;
591 tmpstab = stabent("stdin",TRUE);
592 stab_io(tmpstab) = stab_io(stdinstab);
593 tmpstab->str_pok |= SP_MULTI;
594
595 tmpstab = stabent("STDOUT",TRUE);
596 tmpstab->str_pok |= SP_MULTI;
597 stab_io(tmpstab) = stio_new();
598 stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
599 defoutstab = tmpstab;
600 tmpstab = stabent("stdout",TRUE);
601 stab_io(tmpstab) = stab_io(defoutstab);
602 tmpstab->str_pok |= SP_MULTI;
603
604 curoutstab = stabent("STDERR",TRUE);
605 curoutstab->str_pok |= SP_MULTI;
606 stab_io(curoutstab) = stio_new();
607 stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
608 tmpstab = stabent("stderr",TRUE);
609 stab_io(tmpstab) = stab_io(curoutstab);
610 tmpstab->str_pok |= SP_MULTI;
611 curoutstab = defoutstab; /* switch back to STDOUT */
612
613 statname = Str_new(66,0); /* last filename we did stat on */
614
615 perldb = FALSE; /* don't try to instrument evals */
616
617 if (dowarn) {
618 stab_check('A','Z');
619 stab_check('a','z');
8d063cd8 620 }
a687059c 621
622 if (do_undump)
623 abort();
624
625 just_doit: /* come here if running an undumped a.out */
8d063cd8 626 argc--,argv++; /* skip name of script */
627 if (doswitches) {
628 for (; argc > 0 && **argv == '-'; argc--,argv++) {
629 if (argv[0][1] == '-') {
630 argc--,argv++;
631 break;
632 }
a687059c 633 str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
8d063cd8 634 }
635 }
a687059c 636#ifdef TAINT
637 tainted = 1;
638#endif
a559c259 639 if (argvstab = stabent("ARGV",allstabs)) {
a687059c 640 argvstab->str_pok |= SP_MULTI;
641 (void)aadd(argvstab);
8d063cd8 642 for (; argc > 0; argc--,argv++) {
a687059c 643 (void)apush(stab_array(argvstab),str_make(argv[0],0));
8d063cd8 644 }
645 }
a687059c 646#ifdef TAINT
647 (void) stabent("ENV",TRUE); /* must test PATH and IFS */
648#endif
a559c259 649 if (envstab = stabent("ENV",allstabs)) {
a687059c 650 envstab->str_pok |= SP_MULTI;
651 (void)hadd(envstab);
8d063cd8 652 for (; *env; env++) {
653 if (!(s = index(*env,'=')))
654 continue;
655 *s++ = '\0';
a687059c 656 str = str_make(s--,0);
657 str_magic(str, envstab, 'E', *env, s - *env);
658 (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
659 *s = '=';
8d063cd8 660 }
661 }
a687059c 662#ifdef TAINT
663 tainted = 0;
664#endif
378cc40b 665 if (tmpstab = stabent("$",allstabs))
8d063cd8 666 str_numset(STAB_STR(tmpstab),(double)getpid());
667
a687059c 668 if (setjmp(top_env)) /* sets goto_targ on longjump */
669 loop_ptr = 0; /* start label stack again */
8d063cd8 670
671#ifdef DEBUGGING
672 if (debug & 1024)
a687059c 673 dump_all();
8d063cd8 674 if (debug)
675 fprintf(stderr,"\nEXECUTING...\n\n");
676#endif
677
678 /* do it */
679
a687059c 680 (void) cmd_exec(main_root,G_SCALAR,-1);
8d063cd8 681
682 if (goto_targ)
378cc40b 683 fatal("Can't find label \"%s\"--aborting",goto_targ);
8d063cd8 684 exit(0);
378cc40b 685 /* NOTREACHED */
8d063cd8 686}
687
688magicalize(list)
689register char *list;
690{
691 register STAB *stab;
692 char sym[2];
693
694 sym[1] = '\0';
695 while (*sym = *list++) {
a559c259 696 if (stab = stabent(sym,allstabs)) {
a687059c 697 stab_flags(stab) = SF_VMAGIC;
698 str_magic(stab_val(stab), stab, 0, Nullch, 0);
378cc40b 699 }
378cc40b 700 }
8d063cd8 701}
702
a687059c 703/* this routine is in perly.c by virtue of being sort of an alternate main() */
8d063cd8 704
a687059c 705int
706do_eval(str,optype,stash,gimme,arglast)
707STR *str;
708int optype;
709HASH *stash;
710int gimme;
711int *arglast;
8d063cd8 712{
a687059c 713 STR **st = stack->ary_array;
714 int retval;
715 CMD *myroot;
716 ARRAY *ar;
717 int i;
718 char *oldfile = filename;
719 line_t oldline = line;
720 int oldtmps_base = tmps_base;
721 int oldsave = savestack->ary_fill;
722 SPAT *oldspat = curspat;
723 static char *last_eval = Nullch;
724 static CMD *last_root = Nullcmd;
725 int sp = arglast[0];
8d063cd8 726
a687059c 727 tmps_base = tmps_max;
728 if (curstash != stash) {
729 (void)savehptr(&curstash);
730 curstash = stash;
8d063cd8 731 }
a687059c 732 str_set(stab_val(stabent("@",TRUE)),"");
733 if (optype != O_DOFILE) { /* normal eval */
734 filename = "(eval)";
735 line = 1;
736 str_sset(linestr,str);
737 str_cat(linestr,";"); /* be kind to them */
8d063cd8 738 }
a687059c 739 else {
740 if (last_root) {
741 Safefree(last_eval);
742 cmd_free(last_root);
743 last_root = Nullcmd;
8d063cd8 744 }
a687059c 745 filename = savestr(str_get(str)); /* can't free this easily */
746 str_set(linestr,"");
747 rsfp = fopen(filename,"r");
748 ar = stab_array(incstab);
749 if (!rsfp && *filename != '/') {
750 for (i = 0; i <= ar->ary_fill; i++) {
751 (void)sprintf(buf,"%s/%s",str_get(afetch(ar,i,TRUE)),filename);
752 rsfp = fopen(buf,"r");
753 if (rsfp) {
754 filename = savestr(buf);
8d063cd8 755 break;
756 }
378cc40b 757 }
758 }
a687059c 759 if (!rsfp) {
760 filename = oldfile;
761 tmps_base = oldtmps_base;
762 if (gimme != G_ARRAY)
763 st[++sp] = &str_undef;
764 return sp;
8d063cd8 765 }
a687059c 766 line = 0;
8d063cd8 767 }
a687059c 768 in_eval++;
769 oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
770 bufend = bufptr + linestr->str_cur;
771 if (setjmp(eval_env)) {
772 retval = 1;
773 last_root = Nullcmd;
8d063cd8 774 }
a687059c 775 else {
776 error_count = 0;
777 if (rsfp)
778 retval = yyparse();
779 else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){
780 retval = 0;
781 eval_root = last_root; /* no point in reparsing */
782 }
783 else if (in_eval == 1) {
784 if (last_root) {
785 Safefree(last_eval);
786 cmd_free(last_root);
8d063cd8 787 }
a687059c 788 last_eval = savestr(bufptr);
789 last_root = Nullcmd;
790 retval = yyparse();
791 if (!retval)
792 last_root = eval_root;
8d063cd8 793 }
a687059c 794 else
795 retval = yyparse();
8d063cd8 796 }
a687059c 797 myroot = eval_root; /* in case cmd_exec does another eval! */
798 if (retval || error_count) {
799 str = &str_undef;
800 last_root = Nullcmd; /* can't free on error, for some reason */
801 if (rsfp) {
802 fclose(rsfp);
803 rsfp = 0;
804 }
8d063cd8 805 }
8d063cd8 806 else {
a687059c 807 sp = cmd_exec(eval_root,gimme,sp);
808 st = stack->ary_array;
809 for (i = arglast[0] + 1; i <= sp; i++)
810 st[i] = str_static(st[i]);
811 /* if we don't save result, free zaps it */
812 if (in_eval != 1 && myroot != last_root)
813 cmd_free(myroot);
a559c259 814 }
815 in_eval--;
378cc40b 816 filename = oldfile;
817 line = oldline;
818 tmps_base = oldtmps_base;
a687059c 819 curspat = oldspat;
378cc40b 820 if (savestack->ary_fill > oldsave) /* let them use local() */
821 restorelist(oldsave);
a687059c 822 return sp;
378cc40b 823}
Unnamed repository; edit this file to name it for gitweb.