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