This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Updated
[perl5.git] / perl.c
CommitLineData
a0d0e21e
LW
1/* perl.c
2 *
4633a7c4 3 * Copyright (c) 1987-1995 Larry Wall
a687059c 4 *
352d5a3a
LW
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.
a687059c 7 *
8d063cd8
LW
8 */
9
a0d0e21e
LW
10/*
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
12 */
45d8adaa 13
378cc40b
LW
14#include "EXTERN.h"
15#include "perl.h"
a687059c 16#include "patchlevel.h"
378cc40b 17
a0d0e21e
LW
18/* Omit -- it causes too much grief on mixed systems.
19#ifdef I_UNISTD
20#include <unistd.h>
21#endif
22*/
23
4633a7c4 24dEXT char rcsid[] = "perl.c\nPatch level: ###\n";
463ee0b2 25
a687059c
LW
26#ifdef IAMSUID
27#ifndef DOSUID
28#define DOSUID
29#endif
30#endif
378cc40b 31
a687059c
LW
32#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
33#ifdef DOSUID
34#undef DOSUID
35#endif
36#endif
8d063cd8 37
a0d0e21e
LW
38static void find_beginning _((void));
39static void incpush _((char *));
748a9306 40static void init_ids _((void));
a0d0e21e
LW
41static void init_debugger _((void));
42static void init_lexer _((void));
43static void init_main_stash _((void));
44static void init_perllib _((void));
45static void init_postdump_symbols _((int, char **, char **));
46static void init_predump_symbols _((void));
47static void init_stacks _((void));
48static void open_script _((char *, bool, SV *));
49static void validate_suid _((char *));
79072805 50
93a17b20 51PerlInterpreter *
79072805
LW
52perl_alloc()
53{
93a17b20 54 PerlInterpreter *sv_interp;
79072805 55
8990e307 56 curinterp = 0;
93a17b20 57 New(53, sv_interp, 1, PerlInterpreter);
79072805
LW
58 return sv_interp;
59}
60
61void
62perl_construct( sv_interp )
93a17b20 63register PerlInterpreter *sv_interp;
79072805
LW
64{
65 if (!(curinterp = sv_interp))
66 return;
67
8990e307 68#ifdef MULTIPLICITY
93a17b20 69 Zero(sv_interp, 1, PerlInterpreter);
8990e307 70#endif
79072805
LW
71
72 /* Init the real globals? */
73 if (!linestr) {
74 linestr = NEWSV(65,80);
ed6116ce 75 sv_upgrade(linestr,SVt_PVIV);
79072805
LW
76
77 SvREADONLY_on(&sv_undef);
78
79 sv_setpv(&sv_no,No);
463ee0b2 80 SvNV(&sv_no);
79072805
LW
81 SvREADONLY_on(&sv_no);
82
83 sv_setpv(&sv_yes,Yes);
463ee0b2 84 SvNV(&sv_yes);
79072805
LW
85 SvREADONLY_on(&sv_yes);
86
87#ifdef MSDOS
88 /*
89 * There is no way we can refer to them from Perl so close them to save
90 * space. The other alternative would be to provide STDAUX and STDPRN
91 * filehandles.
92 */
93 (void)fclose(stdaux);
94 (void)fclose(stdprn);
95#endif
96 }
97
8990e307 98#ifdef MULTIPLICITY
79072805 99 chopset = " \n-";
463ee0b2 100 copline = NOLINE;
79072805 101 curcop = &compiling;
79072805
LW
102 dlmax = 128;
103 laststatval = -1;
104 laststype = OP_STAT;
105 maxscream = -1;
106 maxsysfd = MAXSYSFD;
107 nrs = "\n";
108 nrschar = '\n';
109 nrslen = 1;
110 rs = "\n";
111 rschar = '\n';
112 rsfp = Nullfp;
113 rslen = 1;
463ee0b2 114 statname = Nullsv;
79072805 115 tmps_floor = -1;
79072805
LW
116#endif
117
748a9306 118 init_ids();
a0d0e21e 119 sprintf(patchlevel, "%5.3f", 5.0 + (PATCHLEVEL / 1000.0));
79072805
LW
120
121 fdpid = newAV(); /* for remembering popen pids by fd */
463ee0b2 122 pidstatus = newHV();/* for remembering status of dead pids */
8990e307
LW
123
124 init_stacks();
125 ENTER;
79072805
LW
126}
127
128void
748a9306 129perl_destruct(sv_interp)
93a17b20 130register PerlInterpreter *sv_interp;
79072805 131{
748a9306 132 int destruct_level; /* 0=none, 1=full, 2=full with checks */
8990e307 133 I32 last_sv_count;
a0d0e21e 134 HV *hv;
8990e307 135
79072805
LW
136 if (!(curinterp = sv_interp))
137 return;
748a9306
LW
138
139 destruct_level = perl_destruct_level;
4633a7c4
LW
140#ifdef DEBUGGING
141 {
142 char *s;
143 if (s = getenv("PERL_DESTRUCT_LEVEL"))
144 destruct_level = atoi(s);
145 }
146#endif
147
8990e307 148 LEAVE;
a0d0e21e
LW
149 FREETMPS;
150
151 if (sv_objcount) {
152 /* We must account for everything. First the syntax tree. */
153 if (main_root) {
154 curpad = AvARRAY(comppad);
155 op_free(main_root);
156 main_root = 0;
157 }
158 }
159 if (sv_objcount) {
160 /*
161 * Try to destruct global references. We do this first so that the
162 * destructors and destructees still exist. Some sv's might remain.
163 * Non-referenced objects are on their own.
164 */
165
166 dirty = TRUE;
167 sv_clean_objs();
8990e307
LW
168 }
169
a0d0e21e 170 if (destruct_level == 0){
8990e307 171
a0d0e21e
LW
172 DEBUG_P(debprofdump());
173
174 /* The exit() function will do everything that needs doing. */
175 return;
176 }
177
178 /* Prepare to destruct main symbol table. */
179 hv = defstash;
85e6fe83 180 defstash = 0;
a0d0e21e
LW
181 SvREFCNT_dec(hv);
182
183 FREETMPS;
184 if (destruct_level >= 2) {
185 if (scopestack_ix != 0)
186 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
187 if (savestack_ix != 0)
188 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
189 if (tmps_floor != -1)
190 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
191 if (cxstack_ix != -1)
192 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
193 }
8990e307
LW
194
195 /* Now absolutely destruct everything, somehow or other, loops or no. */
8990e307
LW
196 last_sv_count = 0;
197 while (sv_count != 0 && sv_count != last_sv_count) {
198 last_sv_count = sv_count;
199 sv_clean_all();
200 }
201 if (sv_count != 0)
202 warn("Scalars leaked: %d\n", sv_count);
4633a7c4 203 sv_free_arenas();
a0d0e21e
LW
204
205 DEBUG_P(debprofdump());
79072805
LW
206}
207
208void
209perl_free(sv_interp)
93a17b20 210PerlInterpreter *sv_interp;
79072805
LW
211{
212 if (!(curinterp = sv_interp))
213 return;
214 Safefree(sv_interp);
215}
ecfc5424 216#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
a0d0e21e
LW
217char *getenv _((char *)); /* Usually in <stdlib.h> */
218#endif
79072805
LW
219
220int
a0d0e21e 221perl_parse(sv_interp, xsinit, argc, argv, env)
93a17b20 222PerlInterpreter *sv_interp;
a0d0e21e
LW
223void (*xsinit)_((void));
224int argc;
225char **argv;
79072805 226char **env;
8d063cd8 227{
79072805 228 register SV *sv;
8d063cd8 229 register char *s;
45d8adaa 230 char *scriptname;
a0d0e21e 231 VOL bool dosearch = FALSE;
13281fa4 232 char *validarg = "";
748a9306 233 AV* comppadlist;
8d063cd8 234
a687059c
LW
235#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
236#ifdef IAMSUID
237#undef IAMSUID
463ee0b2 238 croak("suidperl is no longer needed since the kernel can now execute\n\
a687059c
LW
239setuid perl scripts securely.\n");
240#endif
241#endif
242
79072805
LW
243 if (!(curinterp = sv_interp))
244 return 255;
245
ac58e20f
LW
246 origargv = argv;
247 origargc = argc;
a0d0e21e 248#ifndef VMS /* VMS doesn't have environ array */
fe14fcc3 249 origenviron = environ;
a0d0e21e
LW
250#endif
251
252 if (do_undump) {
253
254 /* Come here if running an undumped a.out. */
255
256 origfilename = savepv(argv[0]);
257 do_undump = FALSE;
258 cxstack_ix = -1; /* start label stack again */
748a9306 259 init_ids();
a0d0e21e
LW
260 init_postdump_symbols(argc,argv,env);
261 return 0;
262 }
263
264 if (main_root)
265 op_free(main_root);
266 main_root = 0;
79072805
LW
267
268 switch (setjmp(top_env)) {
269 case 1:
748a9306 270#ifdef VMS
79072805 271 statusvalue = 255;
748a9306
LW
272#else
273 statusvalue = 1;
274#endif
79072805 275 case 2:
8990e307
LW
276 curstash = defstash;
277 if (endav)
278 calllist(endav);
79072805
LW
279 return(statusvalue); /* my_exit() was called */
280 case 3:
281 fprintf(stderr, "panic: top_env\n");
8990e307 282 return 1;
79072805
LW
283 }
284
79072805
LW
285 sv_setpvn(linestr,"",0);
286 sv = newSVpv("",0); /* first used for -I flags */
8990e307 287 SAVEFREESV(sv);
79072805 288 init_main_stash();
33b78306 289 for (argc--,argv++; argc > 0; argc--,argv++) {
8d063cd8
LW
290 if (argv[0][0] != '-' || !argv[0][1])
291 break;
13281fa4
LW
292#ifdef DOSUID
293 if (*validarg)
294 validarg = " PHOOEY ";
295 else
296 validarg = argv[0];
297#endif
298 s = argv[0]+1;
8d063cd8 299 reswitch:
13281fa4 300 switch (*s) {
27e2fb84 301 case '0':
2304df62 302 case 'F':
378cc40b 303 case 'a':
33b78306 304 case 'c':
a687059c 305 case 'd':
8d063cd8 306 case 'D':
4633a7c4 307 case 'h':
33b78306 308 case 'i':
fe14fcc3 309 case 'l':
33b78306
LW
310 case 'n':
311 case 'p':
79072805 312 case 's':
463ee0b2 313 case 'T':
33b78306
LW
314 case 'u':
315 case 'U':
316 case 'v':
317 case 'w':
318 if (s = moreswitches(s))
319 goto reswitch;
8d063cd8 320 break;
33b78306 321
8d063cd8 322 case 'e':
a687059c 323 if (euid != uid || egid != gid)
463ee0b2 324 croak("No -e allowed in setuid scripts");
8d063cd8 325 if (!e_fp) {
a0d0e21e 326 e_tmpname = savepv(TMPPATH);
a687059c 327 (void)mktemp(e_tmpname);
83025b21 328 if (!*e_tmpname)
463ee0b2 329 croak("Can't mktemp()");
8d063cd8 330 e_fp = fopen(e_tmpname,"w");
33b78306 331 if (!e_fp)
463ee0b2 332 croak("Cannot open temporary file");
8d063cd8 333 }
33b78306 334 if (argv[1]) {
8d063cd8 335 fputs(argv[1],e_fp);
33b78306
LW
336 argc--,argv++;
337 }
a687059c 338 (void)putc('\n', e_fp);
8d063cd8
LW
339 break;
340 case 'I':
463ee0b2 341 taint_not("-I");
79072805
LW
342 sv_catpv(sv,"-");
343 sv_catpv(sv,s);
344 sv_catpv(sv," ");
a687059c 345 if (*++s) {
a0d0e21e 346 av_push(GvAVn(incgv),newSVpv(s,0));
378cc40b 347 }
33b78306 348 else if (argv[1]) {
a0d0e21e 349 av_push(GvAVn(incgv),newSVpv(argv[1],0));
79072805 350 sv_catpv(sv,argv[1]);
8d063cd8 351 argc--,argv++;
79072805 352 sv_catpv(sv," ");
8d063cd8
LW
353 }
354 break;
8d063cd8 355 case 'P':
463ee0b2 356 taint_not("-P");
8d063cd8 357 preprocess = TRUE;
13281fa4 358 s++;
8d063cd8 359 goto reswitch;
378cc40b 360 case 'S':
463ee0b2 361 taint_not("-S");
378cc40b 362 dosearch = TRUE;
13281fa4 363 s++;
378cc40b 364 goto reswitch;
33b78306
LW
365 case 'x':
366 doextract = TRUE;
13281fa4 367 s++;
33b78306 368 if (*s)
a0d0e21e 369 cddir = savepv(s);
33b78306 370 break;
8d063cd8
LW
371 case '-':
372 argc--,argv++;
373 goto switch_end;
374 case 0:
375 break;
376 default:
463ee0b2 377 croak("Unrecognized switch: -%s",s);
8d063cd8
LW
378 }
379 }
380 switch_end:
45d8adaa 381 scriptname = argv[0];
8d063cd8 382 if (e_fp) {
83025b21 383 if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
2304df62 384 croak("Can't write to temp file for -e: %s", Strerror(errno));
8d063cd8 385 argc++,argv--;
45d8adaa 386 scriptname = e_tmpname;
8d063cd8 387 }
79072805
LW
388 else if (scriptname == Nullch) {
389#ifdef MSDOS
390 if ( isatty(fileno(stdin)) )
391 moreswitches("v");
fe14fcc3 392#endif
79072805
LW
393 scriptname = "-";
394 }
fe14fcc3 395
79072805 396 init_perllib();
8d063cd8 397
79072805 398 open_script(scriptname,dosearch,sv);
8d063cd8 399
79072805 400 validate_suid(validarg);
378cc40b 401
79072805
LW
402 if (doextract)
403 find_beginning();
404
748a9306
LW
405 compcv = (CV*)NEWSV(1104,0);
406 sv_upgrade((SV *)compcv, SVt_PVCV);
407
79072805
LW
408 pad = newAV();
409 comppad = pad;
410 av_push(comppad, Nullsv);
411 curpad = AvARRAY(comppad);
93a17b20 412 padname = newAV();
8990e307
LW
413 comppad_name = padname;
414 comppad_name_fill = 0;
415 min_intro_pending = 0;
79072805
LW
416 padix = 0;
417
748a9306
LW
418 comppadlist = newAV();
419 AvREAL_off(comppadlist);
8e07c86e
AD
420 av_store(comppadlist, 0, (SV*)comppad_name);
421 av_store(comppadlist, 1, (SV*)comppad);
748a9306
LW
422 CvPADLIST(compcv) = comppadlist;
423
a0d0e21e
LW
424 if (xsinit)
425 (*xsinit)(); /* in case linked C routines want magical variables */
748a9306
LW
426#ifdef VMS
427 init_os_extras();
428#endif
93a17b20 429
93a17b20 430 init_predump_symbols();
8990e307
LW
431 if (!do_undump)
432 init_postdump_symbols(argc,argv,env);
93a17b20 433
79072805
LW
434 init_lexer();
435
436 /* now parse the script */
437
438 error_count = 0;
439 if (yyparse() || error_count) {
440 if (minus_c)
463ee0b2 441 croak("%s had compilation errors.\n", origfilename);
79072805 442 else {
463ee0b2 443 croak("Execution of %s aborted due to compilation errors.\n",
79072805 444 origfilename);
378cc40b 445 }
79072805
LW
446 }
447 curcop->cop_line = 0;
448 curstash = defstash;
449 preprocess = FALSE;
450 if (e_fp) {
451 e_fp = Nullfp;
452 (void)UNLINK(e_tmpname);
378cc40b 453 }
a687059c 454
93a17b20 455 /* now that script is parsed, we can modify record separator */
a687059c 456
93a17b20
LW
457 rs = nrs;
458 rslen = nrslen;
459 rschar = nrschar;
460 rspara = (nrslen == 2);
85e6fe83 461 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs, rslen);
45d8adaa 462
79072805
LW
463 if (do_undump)
464 my_unexec();
465
8990e307
LW
466 if (dowarn)
467 gv_check(defstash);
468
a0d0e21e
LW
469 LEAVE;
470 FREETMPS;
471 ENTER;
472 restartop = 0;
79072805
LW
473 return 0;
474}
475
476int
477perl_run(sv_interp)
93a17b20 478PerlInterpreter *sv_interp;
79072805
LW
479{
480 if (!(curinterp = sv_interp))
481 return 255;
482 switch (setjmp(top_env)) {
483 case 1:
484 cxstack_ix = -1; /* start context stack again */
485 break;
486 case 2:
487 curstash = defstash;
93a17b20
LW
488 if (endav)
489 calllist(endav);
a0d0e21e 490 FREETMPS;
93a17b20 491 return(statusvalue); /* my_exit() was called */
79072805
LW
492 case 3:
493 if (!restartop) {
494 fprintf(stderr, "panic: restartop\n");
a0d0e21e 495 FREETMPS;
8990e307 496 return 1;
83025b21 497 }
79072805
LW
498 if (stack != mainstack) {
499 dSP;
500 SWITCHSTACK(stack, mainstack);
501 }
502 break;
8d063cd8 503 }
79072805
LW
504
505 if (!restartop) {
506 DEBUG_x(dump_all());
507 DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
508
509 if (minus_c) {
510 fprintf(stderr,"%s syntax OK\n", origfilename);
511 my_exit(0);
512 }
a0d0e21e
LW
513 if (perldb && DBsingle)
514 sv_setiv(DBsingle, 1);
45d8adaa 515 }
79072805
LW
516
517 /* do it */
518
519 if (restartop) {
520 op = restartop;
521 restartop = 0;
522 run();
523 }
524 else if (main_start) {
525 op = main_start;
526 run();
527 }
79072805
LW
528
529 my_exit(0);
a0d0e21e 530 return 0;
79072805
LW
531}
532
533void
534my_exit(status)
748a9306 535U32 status;
79072805 536{
a0d0e21e
LW
537 register CONTEXT *cx;
538 I32 gimme;
539 SV **newsp;
540
748a9306 541 statusvalue = FIXSTATUS(status);
a0d0e21e
LW
542 if (cxstack_ix >= 0) {
543 if (cxstack_ix > 0)
544 dounwind(0);
545 POPBLOCK(cx,curpm);
546 LEAVE;
547 }
79072805
LW
548 longjmp(top_env, 2);
549}
550
a0d0e21e
LW
551SV*
552perl_get_sv(name, create)
553char* name;
554I32 create;
555{
556 GV* gv = gv_fetchpv(name, create, SVt_PV);
557 if (gv)
558 return GvSV(gv);
559 return Nullsv;
560}
561
562AV*
563perl_get_av(name, create)
564char* name;
565I32 create;
566{
567 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
568 if (create)
569 return GvAVn(gv);
570 if (gv)
571 return GvAV(gv);
572 return Nullav;
573}
574
575HV*
576perl_get_hv(name, create)
577char* name;
578I32 create;
579{
580 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
581 if (create)
582 return GvHVn(gv);
583 if (gv)
584 return GvHV(gv);
585 return Nullhv;
586}
587
588CV*
589perl_get_cv(name, create)
590char* name;
591I32 create;
592{
593 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
594 if (create && !GvCV(gv))
595 return newSUB(start_subparse(),
596 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 597 Nullop,
a0d0e21e
LW
598 Nullop);
599 if (gv)
600 return GvCV(gv);
601 return Nullcv;
602}
603
79072805
LW
604/* Be sure to refetch the stack pointer after calling these routines. */
605
a0d0e21e
LW
606I32
607perl_call_argv(subname, flags, argv)
8990e307 608char *subname;
a0d0e21e
LW
609I32 flags; /* See G_* flags in cop.h */
610register char **argv; /* null terminated arg list */
8990e307 611{
a0d0e21e 612 dSP;
8990e307 613
a0d0e21e
LW
614 PUSHMARK(sp);
615 if (argv) {
8990e307 616 while (*argv) {
a0d0e21e 617 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW
618 argv++;
619 }
a0d0e21e 620 PUTBACK;
8990e307 621 }
a0d0e21e 622 return perl_call_pv(subname, flags);
8990e307
LW
623}
624
a0d0e21e
LW
625I32
626perl_call_pv(subname, flags)
627char *subname; /* name of the subroutine */
628I32 flags; /* See G_* flags in cop.h */
629{
630 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
631}
632
633I32
634perl_call_method(methname, flags)
635char *methname; /* name of the subroutine */
636I32 flags; /* See G_* flags in cop.h */
637{
638 dSP;
639 OP myop;
640 if (!op)
641 op = &myop;
642 XPUSHs(sv_2mortal(newSVpv(methname,0)));
643 PUTBACK;
644 pp_method();
645 return perl_call_sv(*stack_sp--, flags);
646}
647
648/* May be called with any of a CV, a GV, or an SV containing the name. */
649I32
650perl_call_sv(sv, flags)
651SV* sv;
652I32 flags; /* See G_* flags in cop.h */
653{
654 LOGOP myop; /* fake syntax tree node */
655 SV** sp = stack_sp;
656 I32 oldmark = TOPMARK;
657 I32 retval;
658 jmp_buf oldtop;
659 I32 oldscope;
660
661 if (flags & G_DISCARD) {
662 ENTER;
663 SAVETMPS;
664 }
665
666 SAVESPTR(op);
667 op = (OP*)&myop;
668 Zero(op, 1, LOGOP);
669 EXTEND(stack_sp, 1);
670 *++stack_sp = sv;
671 oldscope = scopestack_ix;
672
673 if (!(flags & G_NOARGS))
674 myop.op_flags = OPf_STACKED;
675 myop.op_next = Nullop;
676 myop.op_flags |= OPf_KNOW;
677 if (flags & G_ARRAY)
678 myop.op_flags |= OPf_LIST;
679
680 if (flags & G_EVAL) {
681 Copy(top_env, oldtop, 1, jmp_buf);
682
683 cLOGOP->op_other = op;
684 markstack_ptr--;
4633a7c4
LW
685 /* we're trying to emulate pp_entertry() here */
686 {
687 register CONTEXT *cx;
688 I32 gimme = GIMME;
689
690 ENTER;
691 SAVETMPS;
692
693 push_return(op->op_next);
694 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
695 PUSHEVAL(cx, 0, 0);
696 eval_root = op; /* Only needed so that goto works right. */
697
698 in_eval = 1;
699 if (flags & G_KEEPERR)
700 in_eval |= 4;
701 else
702 sv_setpv(GvSV(errgv),"");
703 }
a0d0e21e
LW
704 markstack_ptr++;
705
706 restart:
707 switch (setjmp(top_env)) {
708 case 0:
709 break;
710 case 1:
748a9306 711#ifdef VMS
a0d0e21e 712 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
748a9306
LW
713#else
714 statusvalue = 1;
715#endif
a0d0e21e
LW
716 /* FALL THROUGH */
717 case 2:
718 /* my_exit() was called */
719 curstash = defstash;
720 FREETMPS;
721 Copy(oldtop, top_env, 1, jmp_buf);
722 if (statusvalue)
723 croak("Callback called exit");
724 my_exit(statusvalue);
725 /* NOTREACHED */
726 case 3:
727 if (restartop) {
728 op = restartop;
729 restartop = 0;
730 goto restart;
731 }
732 stack_sp = stack_base + oldmark;
733 if (flags & G_ARRAY)
734 retval = 0;
735 else {
736 retval = 1;
737 *++stack_sp = &sv_undef;
738 }
739 goto cleanup;
740 }
741 }
742
743 if (op == (OP*)&myop)
744 op = pp_entersub();
745 if (op)
746 run();
747 retval = stack_sp - (stack_base + oldmark);
4633a7c4
LW
748 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
749 sv_setpv(GvSV(errgv),"");
a0d0e21e
LW
750
751 cleanup:
752 if (flags & G_EVAL) {
753 if (scopestack_ix > oldscope) {
a0a2876f
LW
754 SV **newsp;
755 PMOP *newpm;
756 I32 gimme;
757 register CONTEXT *cx;
758 I32 optype;
759
760 POPBLOCK(cx,newpm);
761 POPEVAL(cx);
762 pop_return();
763 curpm = newpm;
764 LEAVE;
a0d0e21e
LW
765 }
766 Copy(oldtop, top_env, 1, jmp_buf);
767 }
768 if (flags & G_DISCARD) {
769 stack_sp = stack_base + oldmark;
770 retval = 0;
771 FREETMPS;
772 LEAVE;
773 }
774 return retval;
775}
776
4633a7c4 777/* Eval a string. */
8990e307 778
a0d0e21e 779I32
4633a7c4 780perl_eval_sv(sv, flags)
8990e307 781SV* sv;
4633a7c4 782I32 flags; /* See G_* flags in cop.h */
a0d0e21e
LW
783{
784 UNOP myop; /* fake syntax tree node */
4633a7c4
LW
785 SV** sp = stack_sp;
786 I32 oldmark = sp - stack_base;
787 I32 retval;
788 jmp_buf oldtop;
789 I32 oldscope;
79072805 790
4633a7c4
LW
791 if (flags & G_DISCARD) {
792 ENTER;
793 SAVETMPS;
794 }
795
79072805 796 SAVESPTR(op);
79072805 797 op = (OP*)&myop;
a0d0e21e 798 Zero(op, 1, UNOP);
4633a7c4
LW
799 EXTEND(stack_sp, 1);
800 *++stack_sp = sv;
801 oldscope = scopestack_ix;
79072805 802
4633a7c4
LW
803 if (!(flags & G_NOARGS))
804 myop.op_flags = OPf_STACKED;
79072805 805 myop.op_next = Nullop;
4633a7c4
LW
806 myop.op_flags |= OPf_KNOW;
807 if (flags & G_ARRAY)
808 myop.op_flags |= OPf_LIST;
79072805 809
4633a7c4
LW
810 Copy(top_env, oldtop, 1, jmp_buf);
811
812restart:
813 switch (setjmp(top_env)) {
814 case 0:
815 break;
816 case 1:
817#ifdef VMS
818 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
819#else
820 statusvalue = 1;
821#endif
822 /* FALL THROUGH */
823 case 2:
824 /* my_exit() was called */
825 curstash = defstash;
826 FREETMPS;
827 Copy(oldtop, top_env, 1, jmp_buf);
828 if (statusvalue)
829 croak("Callback called exit");
830 my_exit(statusvalue);
831 /* NOTREACHED */
832 case 3:
833 if (restartop) {
834 op = restartop;
835 restartop = 0;
836 goto restart;
837 }
838 stack_sp = stack_base + oldmark;
839 if (flags & G_ARRAY)
840 retval = 0;
841 else {
842 retval = 1;
843 *++stack_sp = &sv_undef;
844 }
845 goto cleanup;
846 }
847
848 if (op == (OP*)&myop)
849 op = pp_entereval();
850 if (op)
463ee0b2 851 run();
4633a7c4
LW
852 retval = stack_sp - (stack_base + oldmark);
853 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
854 sv_setpv(GvSV(errgv),"");
855
856 cleanup:
857 Copy(oldtop, top_env, 1, jmp_buf);
858 if (flags & G_DISCARD) {
859 stack_sp = stack_base + oldmark;
860 retval = 0;
861 FREETMPS;
862 LEAVE;
863 }
864 return retval;
865}
866
867/* Require a module. */
868
869void
870perl_require_pv(pv)
871char* pv;
872{
873 SV* sv = sv_newmortal();
874 sv_setpv(sv, "require '");
875 sv_catpv(sv, pv);
876 sv_catpv(sv, "'");
877 perl_eval_sv(sv, G_DISCARD);
79072805
LW
878}
879
79072805 880void
79072805
LW
881magicname(sym,name,namlen)
882char *sym;
883char *name;
884I32 namlen;
885{
886 register GV *gv;
887
85e6fe83 888 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
79072805
LW
889 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
890}
891
748a9306
LW
892#if defined(DOSISH)
893# define PERLLIB_SEP ';'
79072805 894#else
232e078e
AD
895# if defined(VMS)
896# define PERLLIB_SEP '|'
897# else
748a9306 898# define PERLLIB_SEP ':'
232e078e 899# endif
79072805
LW
900#endif
901
902static void
903incpush(p)
904char *p;
905{
906 char *s;
907
908 if (!p)
909 return;
910
911 /* Break at all separators */
912 while (*p) {
913 /* First, skip any consecutive separators */
914 while ( *p == PERLLIB_SEP ) {
915 /* Uncomment the next line for PATH semantics */
a0d0e21e 916 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
79072805
LW
917 p++;
918 }
93a17b20 919 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
a0d0e21e 920 av_push(GvAVn(incgv), newSVpv(p, (STRLEN)(s - p)));
79072805
LW
921 p = s + 1;
922 } else {
a0d0e21e 923 av_push(GvAVn(incgv), newSVpv(p, 0));
79072805
LW
924 break;
925 }
926 }
927}
928
4633a7c4
LW
929void
930usage(name)
931char *name;
932{
933 printf("\nUsage: %s [switches] [filename] [arguments]\n",name);
934 printf("\n -0[octal] specify record separator (\\0, if no argument)");
935 printf("\n -a autosplit mode with -n or -p");
936 printf("\n -c check syntax only (runs BEGIN and END blocks)");
937 printf("\n -d run scripts under debugger");
938 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
939 printf("\n -e command one line of script, multiple -e options are allowed");
940 printf("\n [filename] can be ommitted when -e is used");
941 printf("\n -F regexp regular expression for autosplit (-a)");
942 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
943 printf("\n -Idirectory specify include directory (may be used more then once)");
944 printf("\n -l[octal] enable line ending processing, specifies line teminator");
945 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
946 printf("\n -p assume loop like -n but print line also like sed");
947 printf("\n -P run script through C preprocessor before compilation");
948#ifdef OS2
949 printf("\n -R enable REXX variable pool");
950#endif
951 printf("\n -s enable some switch parsing for switches after script name");
952 printf("\n -S look for the script using PATH environment variable");
953 printf("\n -T turn on tainting checks");
954 printf("\n -u dump core after parsing script");
955 printf("\n -U allow unsafe operations");
956 printf("\n -v print version number and patchlevel of perl");
957 printf("\n -w turn warnings on for compilation of your script");
958 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
959}
960
79072805
LW
961/* This routine handles any switches that can be given during run */
962
963char *
964moreswitches(s)
965char *s;
966{
967 I32 numlen;
968
969 switch (*s) {
970 case '0':
971 nrschar = scan_oct(s, 4, &numlen);
a0d0e21e 972 nrs = savepvn("\n",1);
79072805
LW
973 *nrs = nrschar;
974 if (nrschar > 0377) {
975 nrslen = 0;
976 nrs = "";
977 }
978 else if (!nrschar && numlen >= 2) {
979 nrslen = 2;
980 nrs = "\n\n";
981 nrschar = '\n';
982 }
983 return s + numlen;
2304df62
AD
984 case 'F':
985 minus_F = TRUE;
a0d0e21e 986 splitstr = savepv(s + 1);
2304df62
AD
987 s += strlen(s);
988 return s;
79072805
LW
989 case 'a':
990 minus_a = TRUE;
991 s++;
992 return s;
993 case 'c':
994 minus_c = TRUE;
995 s++;
996 return s;
997 case 'd':
463ee0b2 998 taint_not("-d");
4633a7c4
LW
999 s++;
1000 if (*s == ':') {
1001 sprintf(buf, "use Devel::%s;", ++s);
1002 s += strlen(s);
1003 my_setenv("PERL5DB",buf);
1004 }
a0d0e21e
LW
1005 if (!perldb) {
1006 perldb = TRUE;
1007 init_debugger();
1008 }
79072805
LW
1009 return s;
1010 case 'D':
1011#ifdef DEBUGGING
463ee0b2 1012 taint_not("-D");
79072805 1013 if (isALPHA(s[1])) {
8990e307 1014 static char debopts[] = "psltocPmfrxuLHXD";
79072805
LW
1015 char *d;
1016
93a17b20 1017 for (s++; *s && (d = strchr(debopts,*s)); s++)
79072805
LW
1018 debug |= 1 << (d - debopts);
1019 }
1020 else {
1021 debug = atoi(s+1);
1022 for (s++; isDIGIT(*s); s++) ;
1023 }
8990e307 1024 debug |= 0x80000000;
79072805
LW
1025#else
1026 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
a0d0e21e 1027 for (s++; isALNUM(*s); s++) ;
79072805
LW
1028#endif
1029 /*SUPPRESS 530*/
1030 return s;
4633a7c4
LW
1031 case 'h':
1032 usage(origargv[0]);
1033 exit(0);
79072805
LW
1034 case 'i':
1035 if (inplace)
1036 Safefree(inplace);
a0d0e21e 1037 inplace = savepv(s+1);
79072805
LW
1038 /*SUPPRESS 530*/
1039 for (s = inplace; *s && !isSPACE(*s); s++) ;
1040 *s = '\0';
1041 break;
1042 case 'I':
463ee0b2 1043 taint_not("-I");
79072805 1044 if (*++s) {
748a9306
LW
1045 char *e;
1046 for (e = s; *e && !isSPACE(*e); e++) ;
1047 av_push(GvAVn(incgv),newSVpv(s,e-s));
1048 if (*e)
1049 return e;
79072805
LW
1050 }
1051 else
463ee0b2 1052 croak("No space allowed after -I");
79072805
LW
1053 break;
1054 case 'l':
1055 minus_l = TRUE;
1056 s++;
a0d0e21e
LW
1057 if (ors)
1058 Safefree(ors);
79072805 1059 if (isDIGIT(*s)) {
a0d0e21e 1060 ors = savepv("\n");
79072805
LW
1061 orslen = 1;
1062 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1063 s += numlen;
1064 }
1065 else {
a0d0e21e 1066 ors = savepvn(nrs,nrslen);
79072805
LW
1067 orslen = nrslen;
1068 }
1069 return s;
1070 case 'n':
1071 minus_n = TRUE;
1072 s++;
1073 return s;
1074 case 'p':
1075 minus_p = TRUE;
1076 s++;
1077 return s;
1078 case 's':
463ee0b2 1079 taint_not("-s");
79072805
LW
1080 doswitches = TRUE;
1081 s++;
1082 return s;
463ee0b2
LW
1083 case 'T':
1084 tainting = TRUE;
1085 s++;
1086 return s;
79072805
LW
1087 case 'u':
1088 do_undump = TRUE;
1089 s++;
1090 return s;
1091 case 'U':
1092 unsafe = TRUE;
1093 s++;
1094 return s;
1095 case 'v':
cb1a09d0 1096 printf("\nThis is perl, version %s beta1g\n\n",patchlevel);
4633a7c4 1097 fputs("\nCopyright 1987-1995, Larry Wall\n",stdout);
79072805
LW
1098#ifdef MSDOS
1099 fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
1100 stdout);
4633a7c4 1101#endif
79072805 1102#ifdef OS2
4633a7c4
LW
1103 fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1104 "Version 5 port Copyright (c) 1994-1995, Andreas Kaiser\n",
79072805
LW
1105 stdout);
1106#endif
79072805
LW
1107#ifdef atarist
1108 fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
1109#endif
1110 fputs("\n\
1111Perl may be copied only under the terms of either the Artistic License or the\n\
1112GNU General Public License, which may be found in the Perl 5.0 source kit.\n",stdout);
1113#ifdef MSDOS
1114 usage(origargv[0]);
1115#endif
1116 exit(0);
1117 case 'w':
1118 dowarn = TRUE;
1119 s++;
1120 return s;
a0d0e21e 1121 case '*':
79072805
LW
1122 case ' ':
1123 if (s[1] == '-') /* Additional switches on #! line. */
1124 return s+2;
1125 break;
a0d0e21e 1126 case '-':
79072805
LW
1127 case 0:
1128 case '\n':
1129 case '\t':
1130 break;
a0d0e21e
LW
1131 case 'P':
1132 if (preprocess)
1133 return s+1;
1134 /* FALL THROUGH */
79072805 1135 default:
a0d0e21e 1136 croak("Can't emulate -%.1s on #! line",s);
79072805
LW
1137 }
1138 return Nullch;
1139}
1140
1141/* compliments of Tom Christiansen */
1142
1143/* unexec() can be found in the Gnu emacs distribution */
1144
1145void
1146my_unexec()
1147{
1148#ifdef UNEXEC
1149 int status;
1150 extern int etext;
1151
1152 sprintf (buf, "%s.perldump", origfilename);
1153 sprintf (tokenbuf, "%s/perl", BIN);
1154
1155 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1156 if (status)
1157 fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
a0d0e21e 1158 exit(status);
79072805
LW
1159#else
1160 ABORT(); /* for use with undump */
1161#endif
1162}
1163
1164static void
1165init_main_stash()
1166{
463ee0b2
LW
1167 GV *gv;
1168 curstash = defstash = newHV();
79072805 1169 curstname = newSVpv("main",4);
adbc6bb1
LW
1170 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1171 SvREFCNT_dec(GvHV(gv));
1172 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
463ee0b2 1173 SvREADONLY_on(gv);
a0d0e21e 1174 HvNAME(defstash) = savepv("main");
85e6fe83 1175 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
79072805 1176 SvMULTI_on(incgv);
a0d0e21e 1177 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
4633a7c4
LW
1178 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1179 SvMULTI_on(errgv);
8990e307
LW
1180 curstash = defstash;
1181 compiling.cop_stash = defstash;
adbc6bb1 1182 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
4633a7c4
LW
1183 /* We must init $/ before switches are processed. */
1184 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
79072805
LW
1185}
1186
a0d0e21e
LW
1187#ifdef CAN_PROTOTYPE
1188static void
1189open_script(char *scriptname, bool dosearch, SV *sv)
1190#else
79072805
LW
1191static void
1192open_script(scriptname,dosearch,sv)
1193char *scriptname;
1194bool dosearch;
1195SV *sv;
a0d0e21e 1196#endif
79072805
LW
1197{
1198 char *xfound = Nullch;
1199 char *xfailed = Nullch;
1200 register char *s;
1201 I32 len;
1202
93a17b20 1203 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
79072805
LW
1204
1205 bufend = s + strlen(s);
1206 while (*s) {
1207#ifndef DOSISH
1208 s = cpytill(tokenbuf,s,bufend,':',&len);
1209#else
1210#ifdef atarist
1211 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1212 tokenbuf[len] = '\0';
1213#else
1214 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1215 tokenbuf[len] = '\0';
1216#endif
1217#endif
1218 if (*s)
1219 s++;
1220#ifndef DOSISH
1221 if (len && tokenbuf[len-1] != '/')
1222#else
1223#ifdef atarist
1224 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1225#else
1226 if (len && tokenbuf[len-1] != '\\')
1227#endif
1228#endif
1229 (void)strcat(tokenbuf+len,"/");
1230 (void)strcat(tokenbuf+len,scriptname);
1231 DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
a0d0e21e 1232 if (Stat(tokenbuf,&statbuf) < 0) /* not there? */
79072805
LW
1233 continue;
1234 if (S_ISREG(statbuf.st_mode)
1235 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1236 xfound = tokenbuf; /* bingo! */
1237 break;
1238 }
1239 if (!xfailed)
a0d0e21e 1240 xfailed = savepv(tokenbuf);
79072805
LW
1241 }
1242 if (!xfound)
463ee0b2 1243 croak("Can't execute %s", xfailed ? xfailed : scriptname );
79072805
LW
1244 if (xfailed)
1245 Safefree(xfailed);
1246 scriptname = xfound;
1247 }
1248
a0d0e21e 1249 origfilename = savepv(e_fp ? "-e" : scriptname);
79072805
LW
1250 curcop->cop_filegv = gv_fetchfile(origfilename);
1251 if (strEQ(origfilename,"-"))
1252 scriptname = "";
1253 if (preprocess) {
1254 char *cpp = CPPSTDIN;
1255
1256 if (strEQ(cpp,"cppstdin"))
1257 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1258 else
1259 sprintf(tokenbuf, "%s", cpp);
1260 sv_catpv(sv,"-I");
fed7345c 1261 sv_catpv(sv,PRIVLIB_EXP);
79072805
LW
1262#ifdef MSDOS
1263 (void)sprintf(buf, "\
1264sed %s -e \"/^[^#]/b\" \
1265 -e \"/^#[ ]*include[ ]/b\" \
1266 -e \"/^#[ ]*define[ ]/b\" \
1267 -e \"/^#[ ]*if[ ]/b\" \
1268 -e \"/^#[ ]*ifdef[ ]/b\" \
1269 -e \"/^#[ ]*ifndef[ ]/b\" \
1270 -e \"/^#[ ]*else/b\" \
1271 -e \"/^#[ ]*elif[ ]/b\" \
1272 -e \"/^#[ ]*undef[ ]/b\" \
1273 -e \"/^#[ ]*endif/b\" \
1274 -e \"s/^#.*//\" \
1275 %s | %s -C %s %s",
1276 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1277#else
1278 (void)sprintf(buf, "\
1279%s %s -e '/^[^#]/b' \
1280 -e '/^#[ ]*include[ ]/b' \
1281 -e '/^#[ ]*define[ ]/b' \
1282 -e '/^#[ ]*if[ ]/b' \
1283 -e '/^#[ ]*ifdef[ ]/b' \
1284 -e '/^#[ ]*ifndef[ ]/b' \
1285 -e '/^#[ ]*else/b' \
1286 -e '/^#[ ]*elif[ ]/b' \
1287 -e '/^#[ ]*undef[ ]/b' \
1288 -e '/^#[ ]*endif/b' \
1289 -e 's/^[ ]*#.*//' \
1290 %s | %s -C %s %s",
1291#ifdef LOC_SED
1292 LOC_SED,
1293#else
1294 "sed",
1295#endif
1296 (doextract ? "-e '1,/^#/d\n'" : ""),
1297#endif
463ee0b2 1298 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
79072805
LW
1299 doextract = FALSE;
1300#ifdef IAMSUID /* actually, this is caught earlier */
1301 if (euid != uid && !euid) { /* if running suidperl */
1302#ifdef HAS_SETEUID
1303 (void)seteuid(uid); /* musn't stay setuid root */
1304#else
1305#ifdef HAS_SETREUID
85e6fe83
LW
1306 (void)setreuid((Uid_t)-1, uid);
1307#else
1308#ifdef HAS_SETRESUID
1309 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
79072805
LW
1310#else
1311 setuid(uid);
1312#endif
1313#endif
85e6fe83 1314#endif
79072805 1315 if (geteuid() != uid)
463ee0b2 1316 croak("Can't do seteuid!\n");
79072805
LW
1317 }
1318#endif /* IAMSUID */
1319 rsfp = my_popen(buf,"r");
1320 }
1321 else if (!*scriptname) {
463ee0b2 1322 taint_not("program input from stdin");
79072805
LW
1323 rsfp = stdin;
1324 }
1325 else
1326 rsfp = fopen(scriptname,"r");
45d8adaa 1327 if ((FILE*)rsfp == Nullfp) {
13281fa4 1328#ifdef DOSUID
a687059c 1329#ifndef IAMSUID /* in case script is not readable before setuid */
a0d0e21e 1330 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
13281fa4 1331 statbuf.st_mode & (S_ISUID|S_ISGID)) {
27e2fb84 1332 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
a687059c 1333 execv(buf, origargv); /* try again */
463ee0b2 1334 croak("Can't do setuid\n");
13281fa4
LW
1335 }
1336#endif
1337#endif
463ee0b2 1338 croak("Can't open perl script \"%s\": %s\n",
2304df62 1339 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
13281fa4 1340 }
79072805 1341}
8d063cd8 1342
79072805
LW
1343static void
1344validate_suid(validarg)
1345char *validarg;
1346{
13281fa4
LW
1347 /* do we need to emulate setuid on scripts? */
1348
1349 /* This code is for those BSD systems that have setuid #! scripts disabled
1350 * in the kernel because of a security problem. Merely defining DOSUID
1351 * in perl will not fix that problem, but if you have disabled setuid
1352 * scripts in the kernel, this will attempt to emulate setuid and setgid
1353 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW
1354 * root version must be called suidperl or sperlN.NNN. If regular perl
1355 * discovers that it has opened a setuid script, it calls suidperl with
1356 * the same argv that it had. If suidperl finds that the script it has
1357 * just opened is NOT setuid root, it sets the effective uid back to the
1358 * uid. We don't just make perl setuid root because that loses the
1359 * effective uid we had before invoking perl, if it was different from the
1360 * uid.
13281fa4
LW
1361 *
1362 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1363 * be defined in suidperl only. suidperl must be setuid root. The
1364 * Configure script will set this up for you if you want it.
1365 */
a687059c 1366
13281fa4 1367#ifdef DOSUID
a0d0e21e
LW
1368 char *s;
1369
1370 if (Fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
463ee0b2 1371 croak("Can't stat script \"%s\"",origfilename);
13281fa4 1372 if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 1373 I32 len;
13281fa4 1374
a687059c 1375#ifdef IAMSUID
fe14fcc3 1376#ifndef HAS_SETREUID
a687059c
LW
1377 /* On this access check to make sure the directories are readable,
1378 * there is actually a small window that the user could use to make
1379 * filename point to an accessible directory. So there is a faint
1380 * chance that someone could execute a setuid script down in a
1381 * non-accessible directory. I don't know what to do about that.
1382 * But I don't think it's too important. The manual lies when
1383 * it says access() is useful in setuid programs.
1384 */
463ee0b2
LW
1385 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1386 croak("Permission denied");
a687059c
LW
1387#else
1388 /* If we can swap euid and uid, then we can determine access rights
1389 * with a simple stat of the file, and then compare device and
1390 * inode to make sure we did stat() on the same file we opened.
1391 * Then we just have to make sure he or she can execute it.
1392 */
1393 {
1394 struct stat tmpstatbuf;
1395
85e6fe83
LW
1396 if (
1397#ifdef HAS_SETREUID
1398 setreuid(euid,uid) < 0
a0d0e21e
LW
1399#else
1400# if HAS_SETRESUID
85e6fe83 1401 setresuid(euid,uid,(Uid_t)-1) < 0
a0d0e21e 1402# endif
85e6fe83
LW
1403#endif
1404 || getuid() != euid || geteuid() != uid)
463ee0b2 1405 croak("Can't swap uid and euid"); /* really paranoid */
a0d0e21e 1406 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
463ee0b2 1407 croak("Permission denied"); /* testing full pathname here */
a687059c
LW
1408 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1409 tmpstatbuf.st_ino != statbuf.st_ino) {
1410 (void)fclose(rsfp);
79072805 1411 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
a687059c
LW
1412 fprintf(rsfp,
1413"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1414(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1415 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1416 statbuf.st_dev, statbuf.st_ino,
463ee0b2 1417 SvPVX(GvSV(curcop->cop_filegv)),
20188a90 1418 statbuf.st_uid, statbuf.st_gid);
79072805 1419 (void)my_pclose(rsfp);
a687059c 1420 }
463ee0b2 1421 croak("Permission denied\n");
a687059c 1422 }
85e6fe83
LW
1423 if (
1424#ifdef HAS_SETREUID
1425 setreuid(uid,euid) < 0
a0d0e21e
LW
1426#else
1427# if defined(HAS_SETRESUID)
85e6fe83 1428 setresuid(uid,euid,(Uid_t)-1) < 0
a0d0e21e 1429# endif
85e6fe83
LW
1430#endif
1431 || getuid() != uid || geteuid() != euid)
463ee0b2 1432 croak("Can't reswap uid and euid");
27e2fb84 1433 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
463ee0b2 1434 croak("Permission denied\n");
a687059c 1435 }
fe14fcc3 1436#endif /* HAS_SETREUID */
a687059c
LW
1437#endif /* IAMSUID */
1438
27e2fb84 1439 if (!S_ISREG(statbuf.st_mode))
463ee0b2 1440 croak("Permission denied");
27e2fb84 1441 if (statbuf.st_mode & S_IWOTH)
463ee0b2 1442 croak("Setuid/gid script is writable by world");
13281fa4 1443 doswitches = FALSE; /* -s is insecure in suid */
79072805 1444 curcop->cop_line++;
13281fa4
LW
1445 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1446 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
463ee0b2 1447 croak("No #! line");
663a0e37
LW
1448 s = tokenbuf+2;
1449 if (*s == ' ') s++;
45d8adaa 1450 while (!isSPACE(*s)) s++;
27e2fb84 1451 if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
463ee0b2 1452 croak("Not a perl script");
a687059c 1453 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW
1454 /*
1455 * #! arg must be what we saw above. They can invoke it by
1456 * mentioning suidperl explicitly, but they may not add any strange
1457 * arguments beyond what #! says if they do invoke suidperl that way.
1458 */
1459 len = strlen(validarg);
1460 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 1461 strnNE(s,validarg,len) || !isSPACE(s[len]))
463ee0b2 1462 croak("Args must match #! line");
a687059c
LW
1463
1464#ifndef IAMSUID
1465 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1466 euid == statbuf.st_uid)
1467 if (!do_undump)
463ee0b2 1468 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
1469FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1470#endif /* IAMSUID */
13281fa4
LW
1471
1472 if (euid) { /* oops, we're not the setuid root perl */
a687059c 1473 (void)fclose(rsfp);
13281fa4 1474#ifndef IAMSUID
27e2fb84 1475 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
a687059c 1476 execv(buf, origargv); /* try again */
13281fa4 1477#endif
463ee0b2 1478 croak("Can't do setuid\n");
13281fa4
LW
1479 }
1480
83025b21 1481 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
fe14fcc3 1482#ifdef HAS_SETEGID
a687059c
LW
1483 (void)setegid(statbuf.st_gid);
1484#else
fe14fcc3 1485#ifdef HAS_SETREGID
85e6fe83
LW
1486 (void)setregid((Gid_t)-1,statbuf.st_gid);
1487#else
1488#ifdef HAS_SETRESGID
1489 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
a687059c
LW
1490#else
1491 setgid(statbuf.st_gid);
1492#endif
1493#endif
85e6fe83 1494#endif
83025b21 1495 if (getegid() != statbuf.st_gid)
463ee0b2 1496 croak("Can't do setegid!\n");
83025b21 1497 }
a687059c
LW
1498 if (statbuf.st_mode & S_ISUID) {
1499 if (statbuf.st_uid != euid)
fe14fcc3 1500#ifdef HAS_SETEUID
a687059c
LW
1501 (void)seteuid(statbuf.st_uid); /* all that for this */
1502#else
fe14fcc3 1503#ifdef HAS_SETREUID
85e6fe83
LW
1504 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1505#else
1506#ifdef HAS_SETRESUID
1507 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
a687059c
LW
1508#else
1509 setuid(statbuf.st_uid);
1510#endif
1511#endif
85e6fe83 1512#endif
83025b21 1513 if (geteuid() != statbuf.st_uid)
463ee0b2 1514 croak("Can't do seteuid!\n");
a687059c 1515 }
83025b21 1516 else if (uid) { /* oops, mustn't run as root */
fe14fcc3 1517#ifdef HAS_SETEUID
85e6fe83 1518 (void)seteuid((Uid_t)uid);
a687059c 1519#else
fe14fcc3 1520#ifdef HAS_SETREUID
85e6fe83 1521 (void)setreuid((Uid_t)-1,(Uid_t)uid);
a687059c 1522#else
85e6fe83
LW
1523#ifdef HAS_SETRESUID
1524 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1525#else
1526 setuid((Uid_t)uid);
1527#endif
a687059c
LW
1528#endif
1529#endif
83025b21 1530 if (geteuid() != uid)
463ee0b2 1531 croak("Can't do seteuid!\n");
83025b21 1532 }
748a9306 1533 init_ids();
27e2fb84 1534 if (!cando(S_IXUSR,TRUE,&statbuf))
463ee0b2 1535 croak("Permission denied\n"); /* they can't do this */
13281fa4
LW
1536 }
1537#ifdef IAMSUID
1538 else if (preprocess)
463ee0b2 1539 croak("-P not allowed for setuid/setgid script\n");
13281fa4 1540 else
463ee0b2 1541 croak("Script is not setuid/setgid in suidperl\n");
13281fa4 1542#endif /* IAMSUID */
a687059c 1543#else /* !DOSUID */
a687059c
LW
1544 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1545#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
a0d0e21e 1546 Fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
a687059c
LW
1547 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1548 ||
1549 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1550 )
1551 if (!do_undump)
463ee0b2 1552 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
1553FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1554#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1555 /* not set-id, must be wrapped */
a687059c 1556 }
13281fa4 1557#endif /* DOSUID */
79072805 1558}
13281fa4 1559
79072805
LW
1560static void
1561find_beginning()
1562{
79072805 1563 register char *s;
33b78306
LW
1564
1565 /* skip forward in input to the real script? */
1566
463ee0b2 1567 taint_not("-x");
33b78306 1568 while (doextract) {
79072805 1569 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
463ee0b2 1570 croak("No Perl script found in input\n");
33b78306
LW
1571 if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1572 ungetc('\n',rsfp); /* to keep line count right */
1573 doextract = FALSE;
1574 if (s = instr(s,"perl -")) {
1575 s += 6;
45d8adaa 1576 /*SUPPRESS 530*/
33b78306
LW
1577 while (s = moreswitches(s)) ;
1578 }
79072805 1579 if (cddir && chdir(cddir) < 0)
463ee0b2 1580 croak("Can't chdir to %s",cddir);
83025b21
LW
1581 }
1582 }
1583}
1584
79072805 1585static void
748a9306 1586init_ids()
352d5a3a 1587{
748a9306
LW
1588 uid = (int)getuid();
1589 euid = (int)geteuid();
1590 gid = (int)getgid();
1591 egid = (int)getegid();
1592#ifdef VMS
1593 uid |= gid << 16;
1594 euid |= egid << 16;
1595#endif
4633a7c4 1596 tainting |= (uid && (euid != uid || egid != gid));
748a9306 1597}
79072805 1598
748a9306
LW
1599static void
1600init_debugger()
1601{
79072805 1602 curstash = debstash;
748a9306 1603 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
79072805 1604 AvREAL_off(dbargs);
a0d0e21e
LW
1605 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1606 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
748a9306
LW
1607 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1608 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1609 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1610 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
79072805 1611 curstash = defstash;
352d5a3a
LW
1612}
1613
79072805 1614static void
8990e307 1615init_stacks()
79072805
LW
1616{
1617 stack = newAV();
1618 mainstack = stack; /* remember in case we switch stacks */
1619 AvREAL_off(stack); /* not a real array */
a0d0e21e 1620 av_extend(stack,127);
79072805
LW
1621
1622 stack_base = AvARRAY(stack);
1623 stack_sp = stack_base;
8990e307 1624 stack_max = stack_base + 127;
79072805 1625
a0d0e21e 1626 New(54,markstack,64,I32);
79072805
LW
1627 markstack_ptr = markstack;
1628 markstack_max = markstack + 64;
1629
a0d0e21e 1630 New(54,scopestack,32,I32);
79072805
LW
1631 scopestack_ix = 0;
1632 scopestack_max = 32;
1633
1634 New(54,savestack,128,ANY);
1635 savestack_ix = 0;
1636 savestack_max = 128;
1637
1638 New(54,retstack,16,OP*);
1639 retstack_ix = 0;
1640 retstack_max = 16;
8d063cd8 1641
79072805 1642 New(50,cxstack,128,CONTEXT);
8990e307
LW
1643 cxstack_ix = -1;
1644 cxstack_max = 128;
1645
1646 New(50,tmps_stack,128,SV*);
1647 tmps_ix = -1;
1648 tmps_max = 128;
1649
79072805
LW
1650 DEBUG( {
1651 New(51,debname,128,char);
1652 New(52,debdelim,128,char);
1653 } )
378cc40b 1654}
33b78306 1655
a0d0e21e 1656static FILE *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
79072805 1657static void
8990e307
LW
1658init_lexer()
1659{
a0d0e21e 1660 tmpfp = rsfp;
8990e307
LW
1661
1662 lex_start(linestr);
1663 rsfp = tmpfp;
1664 subname = newSVpv("main",4);
1665}
1666
1667static void
79072805 1668init_predump_symbols()
45d8adaa 1669{
93a17b20 1670 GV *tmpgv;
a0d0e21e 1671 GV *othergv;
79072805 1672
85e6fe83 1673 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
79072805 1674
85e6fe83 1675 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
79072805 1676 SvMULTI_on(stdingv);
a0d0e21e 1677 IoIFP(GvIOp(stdingv)) = stdin;
adbc6bb1 1678 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a0d0e21e 1679 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
79072805
LW
1680 SvMULTI_on(tmpgv);
1681
85e6fe83 1682 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
79072805 1683 SvMULTI_on(tmpgv);
a0d0e21e 1684 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout;
4633a7c4 1685 setdefout(tmpgv);
adbc6bb1 1686 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a0d0e21e 1687 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
79072805
LW
1688 SvMULTI_on(tmpgv);
1689
a0d0e21e
LW
1690 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
1691 SvMULTI_on(othergv);
1692 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr;
adbc6bb1 1693 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a0d0e21e 1694 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
79072805 1695 SvMULTI_on(tmpgv);
79072805
LW
1696
1697 statname = NEWSV(66,0); /* last filename we did stat on */
79072805 1698}
33b78306 1699
79072805
LW
1700static void
1701init_postdump_symbols(argc,argv,env)
1702register int argc;
1703register char **argv;
1704register char **env;
33b78306 1705{
79072805
LW
1706 char *s;
1707 SV *sv;
1708 GV* tmpgv;
fe14fcc3 1709
79072805
LW
1710 argc--,argv++; /* skip name of script */
1711 if (doswitches) {
1712 for (; argc > 0 && **argv == '-'; argc--,argv++) {
1713 if (!argv[0][1])
1714 break;
1715 if (argv[0][1] == '-') {
1716 argc--,argv++;
1717 break;
1718 }
93a17b20 1719 if (s = strchr(argv[0], '=')) {
79072805 1720 *s++ = '\0';
85e6fe83 1721 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW
1722 }
1723 else
85e6fe83 1724 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 1725 }
79072805
LW
1726 }
1727 toptarget = NEWSV(0,0);
1728 sv_upgrade(toptarget, SVt_PVFM);
1729 sv_setpvn(toptarget, "", 0);
748a9306 1730 bodytarget = NEWSV(0,0);
79072805
LW
1731 sv_upgrade(bodytarget, SVt_PVFM);
1732 sv_setpvn(bodytarget, "", 0);
1733 formtarget = bodytarget;
1734
79072805 1735 tainted = 1;
85e6fe83 1736 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
79072805
LW
1737 sv_setpv(GvSV(tmpgv),origfilename);
1738 magicname("0", "0", 1);
1739 }
85e6fe83 1740 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
79072805 1741 time(&basetime);
85e6fe83 1742 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
79072805 1743 sv_setpv(GvSV(tmpgv),origargv[0]);
85e6fe83 1744 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
79072805
LW
1745 SvMULTI_on(argvgv);
1746 (void)gv_AVadd(argvgv);
1747 av_clear(GvAVn(argvgv));
1748 for (; argc > 0; argc--,argv++) {
a0d0e21e 1749 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
79072805
LW
1750 }
1751 }
85e6fe83 1752 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
79072805
LW
1753 HV *hv;
1754 SvMULTI_on(envgv);
1755 hv = GvHVn(envgv);
463ee0b2 1756 hv_clear(hv);
a0d0e21e 1757#ifndef VMS /* VMS doesn't have environ array */
4633a7c4
LW
1758 /* Note that if the supplied env parameter is actually a copy
1759 of the global environ then it may now point to free'd memory
1760 if the environment has been modified since. To avoid this
1761 problem we treat env==NULL as meaning 'use the default'
1762 */
1763 if (!env)
1764 env = environ;
8990e307 1765 if (env != environ) {
79072805 1766 environ[0] = Nullch;
8990e307
LW
1767 hv_magic(hv, envgv, 'E');
1768 }
a0d0e21e
LW
1769#endif
1770#ifdef DYNAMIC_ENV_FETCH
1771 HvNAME(hv) = savepv(ENV_HV_NAME);
1772#endif
79072805 1773 for (; *env; env++) {
93a17b20 1774 if (!(s = strchr(*env,'=')))
79072805
LW
1775 continue;
1776 *s++ = '\0';
1777 sv = newSVpv(s--,0);
85e6fe83 1778 sv_magic(sv, sv, 'e', *env, s - *env);
79072805
LW
1779 (void)hv_store(hv, *env, s - *env, sv, 0);
1780 *s = '=';
fe14fcc3 1781 }
f511e57f 1782 hv_magic(hv, envgv, 'E');
79072805 1783 }
79072805 1784 tainted = 0;
85e6fe83 1785 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
79072805
LW
1786 sv_setiv(GvSV(tmpgv),(I32)getpid());
1787
33b78306 1788}
34de22dd 1789
79072805
LW
1790static void
1791init_perllib()
34de22dd 1792{
85e6fe83
LW
1793 char *s;
1794 if (!tainting) {
1795 s = getenv("PERL5LIB");
1796 if (s)
1797 incpush(s);
1798 else
1799 incpush(getenv("PERLLIB"));
1800 }
34de22dd 1801
4633a7c4
LW
1802#ifdef APPLLIB_EXP
1803 incpush(APPLLIB_EXP);
16d20bd9 1804#endif
4633a7c4 1805
fed7345c
AD
1806#ifdef ARCHLIB_EXP
1807 incpush(ARCHLIB_EXP);
a0d0e21e 1808#endif
fed7345c
AD
1809#ifndef PRIVLIB_EXP
1810#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 1811#endif
fed7345c 1812 incpush(PRIVLIB_EXP);
4633a7c4
LW
1813
1814#ifdef SITEARCH_EXP
1815 incpush(SITEARCH_EXP);
1816#endif
1817#ifdef SITELIB_EXP
1818 incpush(SITELIB_EXP);
1819#endif
1820#ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
1821 incpush(OLDARCHLIB_EXP);
1822#endif
a0d0e21e 1823
4633a7c4
LW
1824 if (!tainting)
1825 incpush(".");
34de22dd 1826}
93a17b20
LW
1827
1828void
1829calllist(list)
1830AV* list;
1831{
93a17b20 1832 jmp_buf oldtop;
a0d0e21e
LW
1833 STRLEN len;
1834 line_t oldline = curcop->cop_line;
93a17b20 1835
93a17b20
LW
1836 Copy(top_env, oldtop, 1, jmp_buf);
1837
8990e307
LW
1838 while (AvFILL(list) >= 0) {
1839 CV *cv = (CV*)av_shift(list);
93a17b20 1840
8990e307 1841 SAVEFREESV(cv);
a0d0e21e 1842
85e6fe83 1843 switch (setjmp(top_env)) {
748a9306 1844 case 0: {
4633a7c4 1845 SV* atsv = GvSV(errgv);
748a9306
LW
1846 PUSHMARK(stack_sp);
1847 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
1848 (void)SvPV(atsv, len);
1849 if (len) {
1850 Copy(oldtop, top_env, 1, jmp_buf);
1851 curcop = &compiling;
1852 curcop->cop_line = oldline;
1853 if (list == beginav)
1854 sv_catpv(atsv, "BEGIN failed--compilation aborted");
1855 else
1856 sv_catpv(atsv, "END failed--cleanup aborted");
1857 croak("%s", SvPVX(atsv));
1858 }
a0d0e21e 1859 }
85e6fe83
LW
1860 break;
1861 case 1:
748a9306 1862#ifdef VMS
85e6fe83 1863 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
748a9306
LW
1864#else
1865 statusvalue = 1;
1866#endif
85e6fe83
LW
1867 /* FALL THROUGH */
1868 case 2:
1869 /* my_exit() was called */
1870 curstash = defstash;
1871 if (endav)
1872 calllist(endav);
a0d0e21e
LW
1873 FREETMPS;
1874 Copy(oldtop, top_env, 1, jmp_buf);
1875 curcop = &compiling;
1876 curcop->cop_line = oldline;
85e6fe83
LW
1877 if (statusvalue) {
1878 if (list == beginav)
a0d0e21e 1879 croak("BEGIN failed--compilation aborted");
85e6fe83 1880 else
a0d0e21e 1881 croak("END failed--cleanup aborted");
85e6fe83 1882 }
85e6fe83
LW
1883 my_exit(statusvalue);
1884 /* NOTREACHED */
1885 return;
1886 case 3:
1887 if (!restartop) {
1888 fprintf(stderr, "panic: restartop\n");
a0d0e21e 1889 FREETMPS;
85e6fe83
LW
1890 break;
1891 }
a0d0e21e
LW
1892 Copy(oldtop, top_env, 1, jmp_buf);
1893 curcop = &compiling;
1894 curcop->cop_line = oldline;
1895 longjmp(top_env, 3);
8990e307 1896 }
93a17b20
LW
1897 }
1898
1899 Copy(oldtop, top_env, 1, jmp_buf);
1900}
1901