This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix example #4 in perlXStut
[perl5.git] / perl.c
CommitLineData
a0d0e21e
LW
1/* perl.c
2 *
1a30305b 3 * Copyright (c) 1987-1996 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
df5cef82 18/* XXX If this causes problems, set i_unistd=undef in the hint file. */
a0d0e21e
LW
19#ifdef I_UNISTD
20#include <unistd.h>
21#endif
a0d0e21e 22
71be2cbc 23dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
463ee0b2 24
a687059c
LW
25#ifdef IAMSUID
26#ifndef DOSUID
27#define DOSUID
28#endif
29#endif
378cc40b 30
a687059c
LW
31#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
32#ifdef DOSUID
33#undef DOSUID
34#endif
35#endif
8d063cd8 36
8ebc5c01
PP
37#define I_REINIT \
38 STMT_START { \
39 chopset = " \n-"; \
40 copline = NOLINE; \
41 curcop = &compiling; \
42 curcopdb = NULL; \
43 cxstack_ix = -1; \
44 cxstack_max = 128; \
45 dbargs = 0; \
46 dlmax = 128; \
47 laststatval = -1; \
48 laststype = OP_STAT; \
49 maxscream = -1; \
50 maxsysfd = MAXSYSFD; \
51 statname = Nullsv; \
52 tmps_floor = -1; \
53 tmps_ix = -1; \
54 op_mask = NULL; \
55 dlmax = 128; \
56 laststatval = -1; \
57 laststype = OP_STAT; \
58 } STMT_END
59
a0d0e21e 60static void find_beginning _((void));
bbce6d69 61static void forbid_setid _((char *));
a0d0e21e 62static void incpush _((char *));
748a9306 63static void init_ids _((void));
a0d0e21e
LW
64static void init_debugger _((void));
65static void init_lexer _((void));
66static void init_main_stash _((void));
67static void init_perllib _((void));
68static void init_postdump_symbols _((int, char **, char **));
69static void init_predump_symbols _((void));
70static void init_stacks _((void));
6e72f9df 71static void nuke_stacks _((void));
a0d0e21e 72static void open_script _((char *, bool, SV *));
ab821d7f 73static void usage _((char *));
96436eeb
PP
74static void validate_suid _((char *, char*));
75
76static int fdscript = -1;
79072805 77
93a17b20 78PerlInterpreter *
79072805
LW
79perl_alloc()
80{
93a17b20 81 PerlInterpreter *sv_interp;
79072805 82
8990e307 83 curinterp = 0;
93a17b20 84 New(53, sv_interp, 1, PerlInterpreter);
79072805
LW
85 return sv_interp;
86}
87
88void
89perl_construct( sv_interp )
93a17b20 90register PerlInterpreter *sv_interp;
79072805
LW
91{
92 if (!(curinterp = sv_interp))
93 return;
94
8990e307 95#ifdef MULTIPLICITY
93a17b20 96 Zero(sv_interp, 1, PerlInterpreter);
8990e307 97#endif
79072805
LW
98
99 /* Init the real globals? */
100 if (!linestr) {
101 linestr = NEWSV(65,80);
ed6116ce 102 sv_upgrade(linestr,SVt_PVIV);
79072805 103
6e72f9df
PP
104 if (!SvREADONLY(&sv_undef)) {
105 SvREADONLY_on(&sv_undef);
79072805 106
6e72f9df
PP
107 sv_setpv(&sv_no,No);
108 SvNV(&sv_no);
109 SvREADONLY_on(&sv_no);
79072805 110
6e72f9df
PP
111 sv_setpv(&sv_yes,Yes);
112 SvNV(&sv_yes);
113 SvREADONLY_on(&sv_yes);
114 }
79072805 115
c07a80fd
PP
116 nrs = newSVpv("\n", 1);
117 rs = SvREFCNT_inc(nrs);
118
79072805
LW
119#ifdef MSDOS
120 /*
121 * There is no way we can refer to them from Perl so close them to save
122 * space. The other alternative would be to provide STDAUX and STDPRN
123 * filehandles.
124 */
125 (void)fclose(stdaux);
126 (void)fclose(stdprn);
127#endif
128 }
129
8990e307 130#ifdef MULTIPLICITY
8ebc5c01
PP
131 I_REINIT;
132 perl_destruct_level = 1;
133#else
134 if(perl_destruct_level > 0)
135 I_REINIT;
79072805
LW
136#endif
137
748a9306 138 init_ids();
a5f75d66 139
36477c24 140 SET_NUMERIC_STANDARD();
a5f75d66 141#if defined(SUBVERSION) && SUBVERSION > 0
e2666263
PP
142 sprintf(patchlevel, "%7.5f", (double) 5
143 + ((double) PATCHLEVEL / (double) 1000)
144 + ((double) SUBVERSION / (double) 100000));
a5f75d66 145#else
e2666263
PP
146 sprintf(patchlevel, "%5.3f", (double) 5 +
147 ((double) PATCHLEVEL / (double) 1000));
a5f75d66 148#endif
79072805 149
ab821d7f 150#if defined(LOCAL_PATCH_COUNT)
6e72f9df 151 localpatches = local_patches; /* For possible -v */
ab821d7f
PP
152#endif
153
760ac839
LW
154 PerlIO_init(); /* Hook to IO system */
155
79072805 156 fdpid = newAV(); /* for remembering popen pids by fd */
463ee0b2 157 pidstatus = newHV();/* for remembering status of dead pids */
8990e307
LW
158
159 init_stacks();
160 ENTER;
79072805
LW
161}
162
163void
748a9306 164perl_destruct(sv_interp)
93a17b20 165register PerlInterpreter *sv_interp;
79072805 166{
748a9306 167 int destruct_level; /* 0=none, 1=full, 2=full with checks */
8990e307 168 I32 last_sv_count;
a0d0e21e 169 HV *hv;
8990e307 170
79072805
LW
171 if (!(curinterp = sv_interp))
172 return;
748a9306
LW
173
174 destruct_level = perl_destruct_level;
4633a7c4
LW
175#ifdef DEBUGGING
176 {
177 char *s;
5f05dabc
PP
178 if (s = getenv("PERL_DESTRUCT_LEVEL")) {
179 int i = atoi(s);
180 if (destruct_level < i)
181 destruct_level = i;
182 }
4633a7c4
LW
183 }
184#endif
185
5f05dabc
PP
186 /* unhook hooks which will soon be, or use, destroyed data */
187 SvREFCNT_dec(warnhook);
188 warnhook = Nullsv;
189 SvREFCNT_dec(diehook);
190 diehook = Nullsv;
191 SvREFCNT_dec(parsehook);
192 parsehook = Nullsv;
193
8990e307 194 LEAVE;
a0d0e21e
LW
195 FREETMPS;
196
6e72f9df
PP
197 /* We must account for everything. First the syntax tree. */
198 if (main_root) {
199 curpad = AvARRAY(comppad);
200 op_free(main_root);
201 main_root = 0;
a0d0e21e
LW
202 }
203 if (sv_objcount) {
204 /*
205 * Try to destruct global references. We do this first so that the
206 * destructors and destructees still exist. Some sv's might remain.
207 * Non-referenced objects are on their own.
208 */
209
210 dirty = TRUE;
211 sv_clean_objs();
8990e307
LW
212 }
213
a0d0e21e 214 if (destruct_level == 0){
8990e307 215
a0d0e21e
LW
216 DEBUG_P(debprofdump());
217
218 /* The exit() function will do everything that needs doing. */
219 return;
220 }
5dd60ef7 221
5f05dabc
PP
222 /* loosen bonds of global variables */
223
8ebc5c01
PP
224 if(rsfp) {
225 (void)PerlIO_close(rsfp);
226 rsfp = Nullfp;
227 }
228
229 /* Filters for program text */
230 SvREFCNT_dec(rsfp_filters);
231 rsfp_filters = Nullav;
232
233 /* switches */
234 preprocess = FALSE;
235 minus_n = FALSE;
236 minus_p = FALSE;
237 minus_l = FALSE;
238 minus_a = FALSE;
239 minus_F = FALSE;
240 doswitches = FALSE;
241 dowarn = FALSE;
242 doextract = FALSE;
243 sawampersand = FALSE; /* must save all match strings */
244 sawstudy = FALSE; /* do fbm_instr on all strings */
245 sawvec = FALSE;
246 unsafe = FALSE;
247
248 Safefree(inplace);
249 inplace = Nullch;
250
251 Safefree(e_tmpname);
252 e_tmpname = Nullch;
253
254 if (e_fp) {
255 PerlIO_close(e_fp);
256 e_fp = Nullfp;
257 }
258
259 /* magical thingies */
260
261 Safefree(ofs); /* $, */
262 ofs = Nullch;
5f05dabc 263
8ebc5c01
PP
264 Safefree(ors); /* $\ */
265 ors = Nullch;
266
267 SvREFCNT_dec(nrs); /* $\ helper */
5f05dabc
PP
268 nrs = Nullsv;
269
8ebc5c01 270 multiline = 0; /* $* */
5f05dabc 271
8ebc5c01 272 SvREFCNT_dec(statname);
5f05dabc
PP
273 statname = Nullsv;
274 statgv = Nullgv;
5f05dabc 275
8ebc5c01
PP
276 /* defgv, aka *_ should be taken care of elsewhere */
277
278#if 0 /* just about all regexp stuff, seems to be ok */
279
280 /* shortcuts to regexp stuff */
281 leftgv = Nullgv;
282 ampergv = Nullgv;
283
284 SAVEFREEOP(curpm);
285 SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
286
287 regprecomp = NULL; /* uncompiled string. */
288 regparse = NULL; /* Input-scan pointer. */
289 regxend = NULL; /* End of input for compile */
290 regnpar = 0; /* () count. */
291 regcode = NULL; /* Code-emit pointer; &regdummy = don't. */
292 regsize = 0; /* Code size. */
293 regnaughty = 0; /* How bad is this pattern? */
294 regsawback = 0; /* Did we see \1, ...? */
295
296 reginput = NULL; /* String-input pointer. */
297 regbol = NULL; /* Beginning of input, for ^ check. */
298 regeol = NULL; /* End of input, for $ check. */
299 regstartp = (char **)NULL; /* Pointer to startp array. */
300 regendp = (char **)NULL; /* Ditto for endp. */
301 reglastparen = 0; /* Similarly for lastparen. */
302 regtill = NULL; /* How far we are required to go. */
303 regflags = 0; /* are we folding, multilining? */
304 regprev = (char)NULL; /* char before regbol, \n if none */
305
306#endif /* if 0 */
307
308 /* clean up after study() */
309 SvREFCNT_dec(lastscream);
310 lastscream = Nullsv;
311 Safefree(screamfirst);
312 screamfirst = 0;
313 Safefree(screamnext);
314 screamnext = 0;
315
316 /* startup and shutdown function lists */
317 SvREFCNT_dec(beginav);
318 SvREFCNT_dec(endav);
5618dfe8 319 beginav = Nullav;
5618dfe8
CS
320 endav = Nullav;
321
8ebc5c01
PP
322 /* pid-to-status mappings for waitpid */
323 SvREFCNT_dec(pidstatus);
324 pidstatus = Nullhv;
325
326 /* temp stack during pp_sort() */
327 SvREFCNT_dec(sortstack);
328 sortstack = Nullav;
329
330 /* shortcuts just get cleared */
331 envgv = Nullgv;
332 siggv = Nullgv;
333 incgv = Nullgv;
334 errgv = Nullgv;
335 argvgv = Nullgv;
336 argvoutgv = Nullgv;
337 stdingv = Nullgv;
338 last_in_gv = Nullgv;
339
340 /* reset so print() ends up where we expect */
341 setdefout(Nullgv);
342
a0d0e21e 343 /* Prepare to destruct main symbol table. */
5f05dabc 344
a0d0e21e 345 hv = defstash;
85e6fe83 346 defstash = 0;
a0d0e21e
LW
347 SvREFCNT_dec(hv);
348
349 FREETMPS;
350 if (destruct_level >= 2) {
351 if (scopestack_ix != 0)
352 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
353 if (savestack_ix != 0)
354 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
355 if (tmps_floor != -1)
356 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
357 if (cxstack_ix != -1)
358 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
359 }
8990e307
LW
360
361 /* Now absolutely destruct everything, somehow or other, loops or no. */
8990e307 362 last_sv_count = 0;
6e72f9df 363 SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
8990e307
LW
364 while (sv_count != 0 && sv_count != last_sv_count) {
365 last_sv_count = sv_count;
366 sv_clean_all();
367 }
6e72f9df
PP
368 SvFLAGS(strtab) &= ~SVTYPEMASK;
369 SvFLAGS(strtab) |= SVt_PVHV;
370
371 /* Destruct the global string table. */
372 {
373 /* Yell and reset the HeVAL() slots that are still holding refcounts,
374 * so that sv_free() won't fail on them.
375 */
376 I32 riter;
377 I32 max;
378 HE *hent;
379 HE **array;
380
381 riter = 0;
382 max = HvMAX(strtab);
383 array = HvARRAY(strtab);
384 hent = array[0];
385 for (;;) {
386 if (hent) {
387 warn("Unbalanced string table refcount: (%d) for \"%s\"",
388 HeVAL(hent) - Nullsv, HeKEY(hent));
389 HeVAL(hent) = Nullsv;
390 hent = HeNEXT(hent);
391 }
392 if (!hent) {
393 if (++riter > max)
394 break;
395 hent = array[riter];
396 }
397 }
398 }
399 SvREFCNT_dec(strtab);
400
8990e307
LW
401 if (sv_count != 0)
402 warn("Scalars leaked: %d\n", sv_count);
6e72f9df 403
4633a7c4 404 sv_free_arenas();
a0d0e21e 405
6e72f9df
PP
406 linestr = NULL; /* No SVs have survived, need to clean out */
407 if (origfilename)
408 Safefree(origfilename);
409 nuke_stacks();
410 hints = 0; /* Reset hints. Should hints be per-interpreter ? */
411
a0d0e21e 412 DEBUG_P(debprofdump());
79072805
LW
413}
414
415void
416perl_free(sv_interp)
93a17b20 417PerlInterpreter *sv_interp;
79072805
LW
418{
419 if (!(curinterp = sv_interp))
420 return;
421 Safefree(sv_interp);
422}
ecfc5424 423#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
a0d0e21e
LW
424char *getenv _((char *)); /* Usually in <stdlib.h> */
425#endif
79072805
LW
426
427int
a0d0e21e 428perl_parse(sv_interp, xsinit, argc, argv, env)
93a17b20 429PerlInterpreter *sv_interp;
a0d0e21e
LW
430void (*xsinit)_((void));
431int argc;
432char **argv;
79072805 433char **env;
8d063cd8 434{
79072805 435 register SV *sv;
8d063cd8 436 register char *s;
1a30305b 437 char *scriptname = NULL;
a0d0e21e 438 VOL bool dosearch = FALSE;
13281fa4 439 char *validarg = "";
748a9306 440 AV* comppadlist;
8d063cd8 441
a687059c
LW
442#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
443#ifdef IAMSUID
444#undef IAMSUID
463ee0b2 445 croak("suidperl is no longer needed since the kernel can now execute\n\
a687059c
LW
446setuid perl scripts securely.\n");
447#endif
448#endif
449
79072805
LW
450 if (!(curinterp = sv_interp))
451 return 255;
452
6e72f9df
PP
453#if defined(NeXT) && defined(__DYNAMIC__)
454 _dyld_lookup_and_bind
455 ("__environ", (unsigned long *) &environ_pointer, NULL);
456#endif /* environ */
457
ac58e20f
LW
458 origargv = argv;
459 origargc = argc;
a0d0e21e 460#ifndef VMS /* VMS doesn't have environ array */
fe14fcc3 461 origenviron = environ;
a0d0e21e 462#endif
ab821d7f 463 e_tmpname = Nullch;
a0d0e21e
LW
464
465 if (do_undump) {
466
467 /* Come here if running an undumped a.out. */
468
469 origfilename = savepv(argv[0]);
470 do_undump = FALSE;
471 cxstack_ix = -1; /* start label stack again */
748a9306 472 init_ids();
a0d0e21e
LW
473 init_postdump_symbols(argc,argv,env);
474 return 0;
475 }
476
477 if (main_root)
478 op_free(main_root);
479 main_root = 0;
79072805 480
a5f75d66 481 switch (Sigsetjmp(top_env,1)) {
79072805 482 case 1:
748a9306 483#ifdef VMS
79072805 484 statusvalue = 255;
748a9306
LW
485#else
486 statusvalue = 1;
487#endif
79072805 488 case 2:
8990e307
LW
489 curstash = defstash;
490 if (endav)
491 calllist(endav);
79072805
LW
492 return(statusvalue); /* my_exit() was called */
493 case 3:
760ac839 494 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
8990e307 495 return 1;
79072805
LW
496 }
497
79072805
LW
498 sv_setpvn(linestr,"",0);
499 sv = newSVpv("",0); /* first used for -I flags */
8990e307 500 SAVEFREESV(sv);
79072805 501 init_main_stash();
33b78306 502 for (argc--,argv++; argc > 0; argc--,argv++) {
8d063cd8
LW
503 if (argv[0][0] != '-' || !argv[0][1])
504 break;
13281fa4
LW
505#ifdef DOSUID
506 if (*validarg)
507 validarg = " PHOOEY ";
508 else
509 validarg = argv[0];
510#endif
511 s = argv[0]+1;
8d063cd8 512 reswitch:
13281fa4 513 switch (*s) {
27e2fb84 514 case '0':
2304df62 515 case 'F':
378cc40b 516 case 'a':
33b78306 517 case 'c':
a687059c 518 case 'd':
8d063cd8 519 case 'D':
4633a7c4 520 case 'h':
33b78306 521 case 'i':
fe14fcc3 522 case 'l':
1a30305b
PP
523 case 'M':
524 case 'm':
33b78306
LW
525 case 'n':
526 case 'p':
79072805 527 case 's':
463ee0b2 528 case 'T':
33b78306
LW
529 case 'u':
530 case 'U':
531 case 'v':
532 case 'w':
533 if (s = moreswitches(s))
534 goto reswitch;
8d063cd8 535 break;
33b78306 536
8d063cd8 537 case 'e':
a687059c 538 if (euid != uid || egid != gid)
463ee0b2 539 croak("No -e allowed in setuid scripts");
8d063cd8 540 if (!e_fp) {
a0d0e21e 541 e_tmpname = savepv(TMPPATH);
a687059c 542 (void)mktemp(e_tmpname);
83025b21 543 if (!*e_tmpname)
463ee0b2 544 croak("Can't mktemp()");
760ac839 545 e_fp = PerlIO_open(e_tmpname,"w");
33b78306 546 if (!e_fp)
463ee0b2 547 croak("Cannot open temporary file");
8d063cd8 548 }
552a7a9b
PP
549 if (*++s)
550 PerlIO_puts(e_fp,s);
551 else if (argv[1]) {
760ac839 552 PerlIO_puts(e_fp,argv[1]);
33b78306
LW
553 argc--,argv++;
554 }
552a7a9b
PP
555 else
556 croak("No code specified for -e");
760ac839 557 (void)PerlIO_putc(e_fp,'\n');
8d063cd8
LW
558 break;
559 case 'I':
bbce6d69 560 forbid_setid("-I");
79072805
LW
561 sv_catpv(sv,"-");
562 sv_catpv(sv,s);
563 sv_catpv(sv," ");
a687059c 564 if (*++s) {
a0d0e21e 565 av_push(GvAVn(incgv),newSVpv(s,0));
378cc40b 566 }
33b78306 567 else if (argv[1]) {
a0d0e21e 568 av_push(GvAVn(incgv),newSVpv(argv[1],0));
79072805 569 sv_catpv(sv,argv[1]);
8d063cd8 570 argc--,argv++;
79072805 571 sv_catpv(sv," ");
8d063cd8
LW
572 }
573 break;
8d063cd8 574 case 'P':
bbce6d69 575 forbid_setid("-P");
8d063cd8 576 preprocess = TRUE;
13281fa4 577 s++;
8d063cd8 578 goto reswitch;
378cc40b 579 case 'S':
bbce6d69 580 forbid_setid("-S");
378cc40b 581 dosearch = TRUE;
13281fa4 582 s++;
378cc40b 583 goto reswitch;
1a30305b
PP
584 case 'V':
585 if (!preambleav)
586 preambleav = newAV();
587 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
588 if (*++s != ':') {
6e72f9df
PP
589 Sv = newSVpv("print myconfig();",0);
590#ifdef VMS
591 sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
592#else
593 sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
594#endif
595#if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
596 strcpy(buf,"\" Compile-time options:");
597# ifdef DEBUGGING
598 strcat(buf," DEBUGGING");
599# endif
600# ifdef NOEMBED
601 strcat(buf," NOEMBED");
602# endif
603# ifdef MULTIPLICITY
604 strcat(buf," MULTIPLICITY");
605# endif
606 strcat(buf,"\\n\",");
607 sv_catpv(Sv,buf);
608#endif
609#if defined(LOCAL_PATCH_COUNT)
610 if (LOCAL_PATCH_COUNT > 0)
611 { int i;
612 sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
613 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
614 if (localpatches[i]) {
615 sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
616 sv_catpv(Sv,buf);
617 }
618 }
619 }
620#endif
621 sprintf(buf,"\" Built under %s\\n\",",OSNAME);
622 sv_catpv(Sv,buf);
623#ifdef __DATE__
624# ifdef __TIME__
625 sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
626# else
627 sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
628# endif
629 sv_catpv(Sv,buf);
630#endif
631 sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
1a30305b
PP
632 }
633 else {
634 Sv = newSVpv("config_vars(qw(",0);
635 sv_catpv(Sv, ++s);
636 sv_catpv(Sv, "))");
637 s += strlen(s);
638 }
639 av_push(preambleav, Sv);
c07a80fd 640 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1a30305b 641 goto reswitch;
33b78306
LW
642 case 'x':
643 doextract = TRUE;
13281fa4 644 s++;
33b78306 645 if (*s)
a0d0e21e 646 cddir = savepv(s);
33b78306 647 break;
8d063cd8
LW
648 case '-':
649 argc--,argv++;
650 goto switch_end;
651 case 0:
652 break;
653 default:
463ee0b2 654 croak("Unrecognized switch: -%s",s);
8d063cd8
LW
655 }
656 }
657 switch_end:
1a30305b
PP
658 if (!scriptname)
659 scriptname = argv[0];
8d063cd8 660 if (e_fp) {
760ac839 661 if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp))
2304df62 662 croak("Can't write to temp file for -e: %s", Strerror(errno));
ab821d7f 663 e_fp = Nullfp;
8d063cd8 664 argc++,argv--;
45d8adaa 665 scriptname = e_tmpname;
8d063cd8 666 }
79072805
LW
667 else if (scriptname == Nullch) {
668#ifdef MSDOS
760ac839 669 if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
55497cff 670 moreswitches("h");
fe14fcc3 671#endif
79072805
LW
672 scriptname = "-";
673 }
fe14fcc3 674
79072805 675 init_perllib();
8d063cd8 676
79072805 677 open_script(scriptname,dosearch,sv);
8d063cd8 678
96436eeb 679 validate_suid(validarg, scriptname);
378cc40b 680
79072805
LW
681 if (doextract)
682 find_beginning();
683
748a9306
LW
684 compcv = (CV*)NEWSV(1104,0);
685 sv_upgrade((SV *)compcv, SVt_PVCV);
07055b4c 686 CvUNIQUE_on(compcv);
748a9306 687
6e72f9df 688 comppad = newAV();
79072805
LW
689 av_push(comppad, Nullsv);
690 curpad = AvARRAY(comppad);
6e72f9df 691 comppad_name = newAV();
8990e307
LW
692 comppad_name_fill = 0;
693 min_intro_pending = 0;
79072805
LW
694 padix = 0;
695
748a9306
LW
696 comppadlist = newAV();
697 AvREAL_off(comppadlist);
8e07c86e
AD
698 av_store(comppadlist, 0, (SV*)comppad_name);
699 av_store(comppadlist, 1, (SV*)comppad);
748a9306
LW
700 CvPADLIST(compcv) = comppadlist;
701
6e72f9df 702 boot_core_UNIVERSAL();
a0d0e21e
LW
703 if (xsinit)
704 (*xsinit)(); /* in case linked C routines want magical variables */
748a9306
LW
705#ifdef VMS
706 init_os_extras();
707#endif
93a17b20 708
93a17b20 709 init_predump_symbols();
8990e307
LW
710 if (!do_undump)
711 init_postdump_symbols(argc,argv,env);
93a17b20 712
79072805
LW
713 init_lexer();
714
715 /* now parse the script */
716
717 error_count = 0;
718 if (yyparse() || error_count) {
719 if (minus_c)
463ee0b2 720 croak("%s had compilation errors.\n", origfilename);
79072805 721 else {
463ee0b2 722 croak("Execution of %s aborted due to compilation errors.\n",
79072805 723 origfilename);
378cc40b 724 }
79072805
LW
725 }
726 curcop->cop_line = 0;
727 curstash = defstash;
728 preprocess = FALSE;
ab821d7f 729 if (e_tmpname) {
79072805 730 (void)UNLINK(e_tmpname);
ab821d7f
PP
731 Safefree(e_tmpname);
732 e_tmpname = Nullch;
378cc40b 733 }
a687059c 734
93a17b20 735 /* now that script is parsed, we can modify record separator */
c07a80fd
PP
736 SvREFCNT_dec(rs);
737 rs = SvREFCNT_inc(nrs);
738 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
45d8adaa 739
79072805
LW
740 if (do_undump)
741 my_unexec();
742
8990e307
LW
743 if (dowarn)
744 gv_check(defstash);
745
a0d0e21e
LW
746 LEAVE;
747 FREETMPS;
c07a80fd
PP
748
749#ifdef DEBUGGING_MSTATS
750 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
751 dump_mstats("after compilation:");
752#endif
753
a0d0e21e
LW
754 ENTER;
755 restartop = 0;
79072805
LW
756 return 0;
757}
758
759int
760perl_run(sv_interp)
93a17b20 761PerlInterpreter *sv_interp;
79072805
LW
762{
763 if (!(curinterp = sv_interp))
764 return 255;
a5f75d66 765 switch (Sigsetjmp(top_env,1)) {
79072805
LW
766 case 1:
767 cxstack_ix = -1; /* start context stack again */
768 break;
769 case 2:
770 curstash = defstash;
93a17b20
LW
771 if (endav)
772 calllist(endav);
a0d0e21e 773 FREETMPS;
c07a80fd
PP
774#ifdef DEBUGGING_MSTATS
775 if (getenv("PERL_DEBUG_MSTATS"))
776 dump_mstats("after execution: ");
777#endif
93a17b20 778 return(statusvalue); /* my_exit() was called */
79072805
LW
779 case 3:
780 if (!restartop) {
760ac839 781 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
a0d0e21e 782 FREETMPS;
8990e307 783 return 1;
83025b21 784 }
6e72f9df 785 if (curstack != mainstack) {
79072805 786 dSP;
6e72f9df 787 SWITCHSTACK(curstack, mainstack);
79072805
LW
788 }
789 break;
8d063cd8 790 }
79072805 791
760ac839 792 DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
6e72f9df
PP
793 sawampersand ? "Enabling" : "Omitting"));
794
79072805
LW
795 if (!restartop) {
796 DEBUG_x(dump_all());
760ac839 797 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
79072805
LW
798
799 if (minus_c) {
760ac839 800 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
79072805
LW
801 my_exit(0);
802 }
a0d0e21e
LW
803 if (perldb && DBsingle)
804 sv_setiv(DBsingle, 1);
45d8adaa 805 }
79072805
LW
806
807 /* do it */
808
809 if (restartop) {
810 op = restartop;
811 restartop = 0;
ab821d7f 812 runops();
79072805
LW
813 }
814 else if (main_start) {
815 op = main_start;
ab821d7f 816 runops();
79072805 817 }
79072805
LW
818
819 my_exit(0);
a0d0e21e 820 return 0;
79072805
LW
821}
822
823void
824my_exit(status)
748a9306 825U32 status;
79072805 826{
a0d0e21e
LW
827 register CONTEXT *cx;
828 I32 gimme;
829 SV **newsp;
830
748a9306 831 statusvalue = FIXSTATUS(status);
a0d0e21e
LW
832 if (cxstack_ix >= 0) {
833 if (cxstack_ix > 0)
834 dounwind(0);
835 POPBLOCK(cx,curpm);
836 LEAVE;
837 }
a5f75d66 838 Siglongjmp(top_env, 2);
79072805
LW
839}
840
a0d0e21e
LW
841SV*
842perl_get_sv(name, create)
843char* name;
844I32 create;
845{
846 GV* gv = gv_fetchpv(name, create, SVt_PV);
847 if (gv)
848 return GvSV(gv);
849 return Nullsv;
850}
851
852AV*
853perl_get_av(name, create)
854char* name;
855I32 create;
856{
857 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
858 if (create)
859 return GvAVn(gv);
860 if (gv)
861 return GvAV(gv);
862 return Nullav;
863}
864
865HV*
866perl_get_hv(name, create)
867char* name;
868I32 create;
869{
870 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
871 if (create)
872 return GvHVn(gv);
873 if (gv)
874 return GvHV(gv);
875 return Nullhv;
876}
877
878CV*
879perl_get_cv(name, create)
880char* name;
881I32 create;
882{
883 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
8ebc5c01 884 if (create && !GvCVu(gv))
a0d0e21e
LW
885 return newSUB(start_subparse(),
886 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 887 Nullop,
a0d0e21e
LW
888 Nullop);
889 if (gv)
8ebc5c01 890 return GvCVu(gv);
a0d0e21e
LW
891 return Nullcv;
892}
893
79072805
LW
894/* Be sure to refetch the stack pointer after calling these routines. */
895
a0d0e21e
LW
896I32
897perl_call_argv(subname, flags, argv)
8990e307 898char *subname;
a0d0e21e
LW
899I32 flags; /* See G_* flags in cop.h */
900register char **argv; /* null terminated arg list */
8990e307 901{
a0d0e21e 902 dSP;
8990e307 903
a0d0e21e
LW
904 PUSHMARK(sp);
905 if (argv) {
8990e307 906 while (*argv) {
a0d0e21e 907 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW
908 argv++;
909 }
a0d0e21e 910 PUTBACK;
8990e307 911 }
a0d0e21e 912 return perl_call_pv(subname, flags);
8990e307
LW
913}
914
a0d0e21e
LW
915I32
916perl_call_pv(subname, flags)
917char *subname; /* name of the subroutine */
918I32 flags; /* See G_* flags in cop.h */
919{
920 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
921}
922
923I32
924perl_call_method(methname, flags)
925char *methname; /* name of the subroutine */
926I32 flags; /* See G_* flags in cop.h */
927{
928 dSP;
929 OP myop;
930 if (!op)
931 op = &myop;
932 XPUSHs(sv_2mortal(newSVpv(methname,0)));
933 PUTBACK;
934 pp_method();
935 return perl_call_sv(*stack_sp--, flags);
936}
937
938/* May be called with any of a CV, a GV, or an SV containing the name. */
939I32
940perl_call_sv(sv, flags)
941SV* sv;
942I32 flags; /* See G_* flags in cop.h */
943{
944 LOGOP myop; /* fake syntax tree node */
945 SV** sp = stack_sp;
946 I32 oldmark = TOPMARK;
947 I32 retval;
a5f75d66 948 Sigjmp_buf oldtop;
a0d0e21e 949 I32 oldscope;
6e72f9df 950 static CV *DBcv;
a0d0e21e
LW
951
952 if (flags & G_DISCARD) {
953 ENTER;
954 SAVETMPS;
955 }
956
957 SAVESPTR(op);
958 op = (OP*)&myop;
959 Zero(op, 1, LOGOP);
960 EXTEND(stack_sp, 1);
961 *++stack_sp = sv;
962 oldscope = scopestack_ix;
963
964 if (!(flags & G_NOARGS))
965 myop.op_flags = OPf_STACKED;
966 myop.op_next = Nullop;
967 myop.op_flags |= OPf_KNOW;
968 if (flags & G_ARRAY)
969 myop.op_flags |= OPf_LIST;
970
36477c24
PP
971 if (perldb && curstash != debstash
972 /* Handle first BEGIN of -d. */
973 && (DBcv || (DBcv = GvCV(DBsub)))
974 /* Try harder, since this may have been a sighandler, thus
975 * curstash may be meaningless. */
976 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
6e72f9df
PP
977 op->op_private |= OPpENTERSUB_DB;
978
a0d0e21e 979 if (flags & G_EVAL) {
a5f75d66 980 Copy(top_env, oldtop, 1, Sigjmp_buf);
a0d0e21e
LW
981
982 cLOGOP->op_other = op;
983 markstack_ptr--;
4633a7c4
LW
984 /* we're trying to emulate pp_entertry() here */
985 {
986 register CONTEXT *cx;
987 I32 gimme = GIMME;
988
989 ENTER;
990 SAVETMPS;
991
992 push_return(op->op_next);
993 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
994 PUSHEVAL(cx, 0, 0);
995 eval_root = op; /* Only needed so that goto works right. */
996
997 in_eval = 1;
998 if (flags & G_KEEPERR)
999 in_eval |= 4;
1000 else
1001 sv_setpv(GvSV(errgv),"");
1002 }
a0d0e21e
LW
1003 markstack_ptr++;
1004
1005 restart:
a5f75d66 1006 switch (Sigsetjmp(top_env,1)) {
a0d0e21e
LW
1007 case 0:
1008 break;
1009 case 1:
748a9306 1010#ifdef VMS
a0d0e21e 1011 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
748a9306
LW
1012#else
1013 statusvalue = 1;
1014#endif
a0d0e21e
LW
1015 /* FALL THROUGH */
1016 case 2:
1017 /* my_exit() was called */
1018 curstash = defstash;
1019 FREETMPS;
a5f75d66 1020 Copy(oldtop, top_env, 1, Sigjmp_buf);
a0d0e21e
LW
1021 if (statusvalue)
1022 croak("Callback called exit");
1023 my_exit(statusvalue);
1024 /* NOTREACHED */
1025 case 3:
1026 if (restartop) {
1027 op = restartop;
1028 restartop = 0;
1029 goto restart;
1030 }
1031 stack_sp = stack_base + oldmark;
1032 if (flags & G_ARRAY)
1033 retval = 0;
1034 else {
1035 retval = 1;
1036 *++stack_sp = &sv_undef;
1037 }
1038 goto cleanup;
1039 }
1040 }
1041
1042 if (op == (OP*)&myop)
1043 op = pp_entersub();
1044 if (op)
ab821d7f 1045 runops();
a0d0e21e 1046 retval = stack_sp - (stack_base + oldmark);
4633a7c4
LW
1047 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
1048 sv_setpv(GvSV(errgv),"");
a0d0e21e
LW
1049
1050 cleanup:
1051 if (flags & G_EVAL) {
1052 if (scopestack_ix > oldscope) {
a0a2876f
LW
1053 SV **newsp;
1054 PMOP *newpm;
1055 I32 gimme;
1056 register CONTEXT *cx;
1057 I32 optype;
1058
1059 POPBLOCK(cx,newpm);
1060 POPEVAL(cx);
1061 pop_return();
1062 curpm = newpm;
1063 LEAVE;
a0d0e21e 1064 }
a5f75d66 1065 Copy(oldtop, top_env, 1, Sigjmp_buf);
a0d0e21e
LW
1066 }
1067 if (flags & G_DISCARD) {
1068 stack_sp = stack_base + oldmark;
1069 retval = 0;
1070 FREETMPS;
1071 LEAVE;
1072 }
1073 return retval;
1074}
1075
6e72f9df 1076/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 1077
a0d0e21e 1078I32
4633a7c4 1079perl_eval_sv(sv, flags)
8990e307 1080SV* sv;
4633a7c4 1081I32 flags; /* See G_* flags in cop.h */
a0d0e21e
LW
1082{
1083 UNOP myop; /* fake syntax tree node */
4633a7c4
LW
1084 SV** sp = stack_sp;
1085 I32 oldmark = sp - stack_base;
1086 I32 retval;
a5f75d66 1087 Sigjmp_buf oldtop;
4633a7c4 1088 I32 oldscope;
79072805 1089
4633a7c4
LW
1090 if (flags & G_DISCARD) {
1091 ENTER;
1092 SAVETMPS;
1093 }
1094
79072805 1095 SAVESPTR(op);
79072805 1096 op = (OP*)&myop;
a0d0e21e 1097 Zero(op, 1, UNOP);
4633a7c4
LW
1098 EXTEND(stack_sp, 1);
1099 *++stack_sp = sv;
1100 oldscope = scopestack_ix;
79072805 1101
4633a7c4
LW
1102 if (!(flags & G_NOARGS))
1103 myop.op_flags = OPf_STACKED;
79072805 1104 myop.op_next = Nullop;
6e72f9df 1105 myop.op_type = OP_ENTEREVAL;
4633a7c4 1106 myop.op_flags |= OPf_KNOW;
6e72f9df
PP
1107 if (flags & G_KEEPERR)
1108 myop.op_flags |= OPf_SPECIAL;
4633a7c4 1109 if (flags & G_ARRAY)
6e72f9df 1110 myop.op_flags |= OPf_LIST;
79072805 1111
a5f75d66 1112 Copy(top_env, oldtop, 1, Sigjmp_buf);
4633a7c4
LW
1113
1114restart:
a5f75d66 1115 switch (Sigsetjmp(top_env,1)) {
4633a7c4
LW
1116 case 0:
1117 break;
1118 case 1:
1119#ifdef VMS
1120 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
1121#else
1122 statusvalue = 1;
1123#endif
1124 /* FALL THROUGH */
1125 case 2:
1126 /* my_exit() was called */
1127 curstash = defstash;
1128 FREETMPS;
a5f75d66 1129 Copy(oldtop, top_env, 1, Sigjmp_buf);
4633a7c4
LW
1130 if (statusvalue)
1131 croak("Callback called exit");
1132 my_exit(statusvalue);
1133 /* NOTREACHED */
1134 case 3:
1135 if (restartop) {
1136 op = restartop;
1137 restartop = 0;
1138 goto restart;
1139 }
1140 stack_sp = stack_base + oldmark;
1141 if (flags & G_ARRAY)
1142 retval = 0;
1143 else {
1144 retval = 1;
1145 *++stack_sp = &sv_undef;
1146 }
1147 goto cleanup;
1148 }
1149
1150 if (op == (OP*)&myop)
1151 op = pp_entereval();
1152 if (op)
ab821d7f 1153 runops();
4633a7c4 1154 retval = stack_sp - (stack_base + oldmark);
6e72f9df 1155 if (!(flags & G_KEEPERR))
4633a7c4
LW
1156 sv_setpv(GvSV(errgv),"");
1157
1158 cleanup:
a5f75d66 1159 Copy(oldtop, top_env, 1, Sigjmp_buf);
4633a7c4
LW
1160 if (flags & G_DISCARD) {
1161 stack_sp = stack_base + oldmark;
1162 retval = 0;
1163 FREETMPS;
1164 LEAVE;
1165 }
1166 return retval;
1167}
1168
1169/* Require a module. */
1170
1171void
1172perl_require_pv(pv)
1173char* pv;
1174{
1175 SV* sv = sv_newmortal();
1176 sv_setpv(sv, "require '");
1177 sv_catpv(sv, pv);
1178 sv_catpv(sv, "'");
1179 perl_eval_sv(sv, G_DISCARD);
79072805
LW
1180}
1181
79072805 1182void
79072805
LW
1183magicname(sym,name,namlen)
1184char *sym;
1185char *name;
1186I32 namlen;
1187{
1188 register GV *gv;
1189
85e6fe83 1190 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
79072805
LW
1191 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1192}
1193
748a9306
LW
1194#if defined(DOSISH)
1195# define PERLLIB_SEP ';'
79072805 1196#else
232e078e
AD
1197# if defined(VMS)
1198# define PERLLIB_SEP '|'
1199# else
748a9306 1200# define PERLLIB_SEP ':'
232e078e 1201# endif
79072805 1202#endif
760ac839
LW
1203#ifndef PERLLIB_MANGLE
1204# define PERLLIB_MANGLE(s,n) (s)
1205#endif
79072805
LW
1206
1207static void
1208incpush(p)
1209char *p;
1210{
1211 char *s;
1212
1213 if (!p)
1214 return;
1215
1216 /* Break at all separators */
1217 while (*p) {
1218 /* First, skip any consecutive separators */
1219 while ( *p == PERLLIB_SEP ) {
1220 /* Uncomment the next line for PATH semantics */
a0d0e21e 1221 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
79072805
LW
1222 p++;
1223 }
93a17b20 1224 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
760ac839
LW
1225 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)),
1226 (STRLEN)(s - p)));
79072805
LW
1227 p = s + 1;
1228 } else {
760ac839 1229 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0));
79072805
LW
1230 break;
1231 }
1232 }
1233}
1234
ab821d7f 1235static void
1a30305b 1236usage(name) /* XXX move this out into a module ? */
4633a7c4
LW
1237char *name;
1238{
ab821d7f
PP
1239 /* This message really ought to be max 23 lines.
1240 * Removed -h because the user already knows that opton. Others? */
1241 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
4633a7c4 1242 printf("\n -0[octal] specify record separator (\\0, if no argument)");
ab821d7f 1243 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
4633a7c4 1244 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1a30305b 1245 printf("\n -d[:debugger] run scripts under debugger");
4633a7c4 1246 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
ab821d7f
PP
1247 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1248 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
4633a7c4 1249 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
ab821d7f 1250 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
4633a7c4 1251 printf("\n -l[octal] enable line ending processing, specifies line teminator");
ab821d7f 1252 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
4633a7c4
LW
1253 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1254 printf("\n -p assume loop like -n but print line also like sed");
1255 printf("\n -P run script through C preprocessor before compilation");
4633a7c4
LW
1256 printf("\n -s enable some switch parsing for switches after script name");
1257 printf("\n -S look for the script using PATH environment variable");
1258 printf("\n -T turn on tainting checks");
1259 printf("\n -u dump core after parsing script");
1260 printf("\n -U allow unsafe operations");
1261 printf("\n -v print version number and patchlevel of perl");
1a30305b 1262 printf("\n -V[:variable] print perl configuration information");
ab821d7f 1263 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
4633a7c4
LW
1264 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1265}
1266
79072805
LW
1267/* This routine handles any switches that can be given during run */
1268
1269char *
1270moreswitches(s)
1271char *s;
1272{
1273 I32 numlen;
c07a80fd 1274 U32 rschar;
79072805
LW
1275
1276 switch (*s) {
1277 case '0':
c07a80fd
PP
1278 rschar = scan_oct(s, 4, &numlen);
1279 SvREFCNT_dec(nrs);
1280 if (rschar & ~((U8)~0))
1281 nrs = &sv_undef;
1282 else if (!rschar && numlen >= 2)
1283 nrs = newSVpv("", 0);
1284 else {
1285 char ch = rschar;
1286 nrs = newSVpv(&ch, 1);
79072805
LW
1287 }
1288 return s + numlen;
2304df62
AD
1289 case 'F':
1290 minus_F = TRUE;
a0d0e21e 1291 splitstr = savepv(s + 1);
2304df62
AD
1292 s += strlen(s);
1293 return s;
79072805
LW
1294 case 'a':
1295 minus_a = TRUE;
1296 s++;
1297 return s;
1298 case 'c':
1299 minus_c = TRUE;
1300 s++;
1301 return s;
1302 case 'd':
bbce6d69 1303 forbid_setid("-d");
4633a7c4 1304 s++;
c07a80fd 1305 if (*s == ':' || *s == '=') {
4633a7c4
LW
1306 sprintf(buf, "use Devel::%s;", ++s);
1307 s += strlen(s);
1308 my_setenv("PERL5DB",buf);
1309 }
a0d0e21e
LW
1310 if (!perldb) {
1311 perldb = TRUE;
1312 init_debugger();
1313 }
79072805
LW
1314 return s;
1315 case 'D':
1316#ifdef DEBUGGING
bbce6d69 1317 forbid_setid("-D");
79072805 1318 if (isALPHA(s[1])) {
8990e307 1319 static char debopts[] = "psltocPmfrxuLHXD";
79072805
LW
1320 char *d;
1321
93a17b20 1322 for (s++; *s && (d = strchr(debopts,*s)); s++)
79072805
LW
1323 debug |= 1 << (d - debopts);
1324 }
1325 else {
1326 debug = atoi(s+1);
1327 for (s++; isDIGIT(*s); s++) ;
1328 }
8990e307 1329 debug |= 0x80000000;
79072805
LW
1330#else
1331 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
a0d0e21e 1332 for (s++; isALNUM(*s); s++) ;
79072805
LW
1333#endif
1334 /*SUPPRESS 530*/
1335 return s;
4633a7c4
LW
1336 case 'h':
1337 usage(origargv[0]);
1338 exit(0);
79072805
LW
1339 case 'i':
1340 if (inplace)
1341 Safefree(inplace);
a0d0e21e 1342 inplace = savepv(s+1);
79072805
LW
1343 /*SUPPRESS 530*/
1344 for (s = inplace; *s && !isSPACE(*s); s++) ;
1345 *s = '\0';
1346 break;
1347 case 'I':
bbce6d69 1348 forbid_setid("-I");
79072805 1349 if (*++s) {
748a9306
LW
1350 char *e;
1351 for (e = s; *e && !isSPACE(*e); e++) ;
1352 av_push(GvAVn(incgv),newSVpv(s,e-s));
1353 if (*e)
1354 return e;
79072805
LW
1355 }
1356 else
463ee0b2 1357 croak("No space allowed after -I");
79072805
LW
1358 break;
1359 case 'l':
1360 minus_l = TRUE;
1361 s++;
a0d0e21e
LW
1362 if (ors)
1363 Safefree(ors);
79072805 1364 if (isDIGIT(*s)) {
a0d0e21e 1365 ors = savepv("\n");
79072805
LW
1366 orslen = 1;
1367 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1368 s += numlen;
1369 }
1370 else {
c07a80fd 1371 if (RsPARA(nrs)) {
6e72f9df 1372 ors = "\n\n";
c07a80fd
PP
1373 orslen = 2;
1374 }
1375 else
1376 ors = SvPV(nrs, orslen);
6e72f9df 1377 ors = savepvn(ors, orslen);
79072805
LW
1378 }
1379 return s;
1a30305b 1380 case 'M':
bbce6d69 1381 forbid_setid("-M"); /* XXX ? */
1a30305b
PP
1382 /* FALL THROUGH */
1383 case 'm':
bbce6d69 1384 forbid_setid("-m"); /* XXX ? */
1a30305b 1385 if (*++s) {
a5f75d66
AD
1386 char *start;
1387 char *use = "use ";
1388 /* -M-foo == 'no foo' */
1389 if (*s == '-') { use = "no "; ++s; }
1390 Sv = newSVpv(use,0);
1391 start = s;
1a30305b 1392 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd
PP
1393 while(isALNUM(*s) || *s==':') ++s;
1394 if (*s != '=') {
1395 sv_catpv(Sv, start);
1396 if (*(start-1) == 'm') {
1397 if (*s != '\0')
1398 croak("Can't use '%c' after -mname", *s);
1399 sv_catpv( Sv, " ()");
1400 }
1401 } else {
1402 sv_catpvn(Sv, start, s-start);
a5f75d66 1403 sv_catpv(Sv, " split(/,/,q{");
c07a80fd 1404 sv_catpv(Sv, ++s);
a5f75d66 1405 sv_catpv(Sv, "})");
c07a80fd 1406 }
1a30305b 1407 s += strlen(s);
c07a80fd
PP
1408 if (preambleav == NULL)
1409 preambleav = newAV();
1410 av_push(preambleav, Sv);
1a30305b
PP
1411 }
1412 else
1413 croak("No space allowed after -%c", *(s-1));
1414 return s;
79072805
LW
1415 case 'n':
1416 minus_n = TRUE;
1417 s++;
1418 return s;
1419 case 'p':
1420 minus_p = TRUE;
1421 s++;
1422 return s;
1423 case 's':
bbce6d69 1424 forbid_setid("-s");
79072805
LW
1425 doswitches = TRUE;
1426 s++;
1427 return s;
463ee0b2
LW
1428 case 'T':
1429 tainting = TRUE;
1430 s++;
1431 return s;
79072805
LW
1432 case 'u':
1433 do_undump = TRUE;
1434 s++;
1435 return s;
1436 case 'U':
1437 unsafe = TRUE;
1438 s++;
1439 return s;
1440 case 'v':
a5f75d66
AD
1441#if defined(SUBVERSION) && SUBVERSION > 0
1442 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1443#else
1444 printf("\nThis is perl, version %s",patchlevel);
1445#endif
1a30305b 1446
760ac839
LW
1447 printf("\n\nCopyright 1987-1996, Larry Wall\n");
1448 printf("\n\t+ suidperl security patch");
79072805 1449#ifdef MSDOS
55497cff
PP
1450 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1451#endif
1452#ifdef DJGPP
1453 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
4633a7c4 1454#endif
79072805 1455#ifdef OS2
5dd60ef7 1456 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
760ac839 1457 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
79072805 1458#endif
79072805 1459#ifdef atarist
760ac839 1460 printf("atariST series port, ++jrb bammi@cadence.com\n");
79072805 1461#endif
760ac839 1462 printf("\n\
79072805 1463Perl may be copied only under the terms of either the Artistic License or the\n\
760ac839 1464GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
79072805
LW
1465 exit(0);
1466 case 'w':
1467 dowarn = TRUE;
1468 s++;
1469 return s;
a0d0e21e 1470 case '*':
79072805
LW
1471 case ' ':
1472 if (s[1] == '-') /* Additional switches on #! line. */
1473 return s+2;
1474 break;
a0d0e21e 1475 case '-':
79072805
LW
1476 case 0:
1477 case '\n':
1478 case '\t':
1479 break;
a0d0e21e
LW
1480 case 'P':
1481 if (preprocess)
1482 return s+1;
1483 /* FALL THROUGH */
79072805 1484 default:
a0d0e21e 1485 croak("Can't emulate -%.1s on #! line",s);
79072805
LW
1486 }
1487 return Nullch;
1488}
1489
1490/* compliments of Tom Christiansen */
1491
1492/* unexec() can be found in the Gnu emacs distribution */
1493
1494void
1495my_unexec()
1496{
1497#ifdef UNEXEC
1498 int status;
1499 extern int etext;
1500
1501 sprintf (buf, "%s.perldump", origfilename);
1502 sprintf (tokenbuf, "%s/perl", BIN);
1503
1504 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1505 if (status)
760ac839 1506 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
a0d0e21e 1507 exit(status);
79072805 1508#else
a5f75d66
AD
1509# ifdef VMS
1510# include <lib$routines.h>
1511 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1512#else
79072805
LW
1513 ABORT(); /* for use with undump */
1514#endif
a5f75d66 1515#endif
79072805
LW
1516}
1517
1518static void
1519init_main_stash()
1520{
463ee0b2 1521 GV *gv;
6e72f9df
PP
1522
1523 /* Note that strtab is a rather special HV. Assumptions are made
1524 about not iterating on it, and not adding tie magic to it.
1525 It is properly deallocated in perl_destruct() */
1526 strtab = newHV();
1527 HvSHAREKEYS_off(strtab); /* mandatory */
1528 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1529 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1530
463ee0b2 1531 curstash = defstash = newHV();
79072805 1532 curstname = newSVpv("main",4);
adbc6bb1
LW
1533 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1534 SvREFCNT_dec(GvHV(gv));
1535 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
463ee0b2 1536 SvREADONLY_on(gv);
a0d0e21e 1537 HvNAME(defstash) = savepv("main");
85e6fe83 1538 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
a5f75d66 1539 GvMULTI_on(incgv);
a0d0e21e 1540 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
4633a7c4 1541 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
a5f75d66 1542 GvMULTI_on(errgv);
552a7a9b 1543 sv_setpvn(GvSV(errgv), "", 0);
8990e307
LW
1544 curstash = defstash;
1545 compiling.cop_stash = defstash;
adbc6bb1 1546 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
4633a7c4
LW
1547 /* We must init $/ before switches are processed. */
1548 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
79072805
LW
1549}
1550
a0d0e21e
LW
1551#ifdef CAN_PROTOTYPE
1552static void
1553open_script(char *scriptname, bool dosearch, SV *sv)
1554#else
79072805
LW
1555static void
1556open_script(scriptname,dosearch,sv)
1557char *scriptname;
1558bool dosearch;
1559SV *sv;
a0d0e21e 1560#endif
79072805
LW
1561{
1562 char *xfound = Nullch;
1563 char *xfailed = Nullch;
1564 register char *s;
1565 I32 len;
a38d6535
LW
1566 int retval;
1567#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1568#define SEARCH_EXTS ".bat", ".cmd", NULL
1569#endif
ab821d7f
PP
1570#ifdef VMS
1571# define SEARCH_EXTS ".pl", ".com", NULL
1572#endif
a38d6535
LW
1573 /* additional extensions to try in each dir if scriptname not found */
1574#ifdef SEARCH_EXTS
1575 char *ext[] = { SEARCH_EXTS };
1576 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1577#endif
79072805 1578
c07a80fd 1579#ifdef VMS
6e72f9df
PP
1580 if (dosearch) {
1581 int hasdir, idx = 0, deftypes = 1;
1582
1583 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1584 /* The first time through, just add SEARCH_EXTS to whatever we
1585 * already have, so we can check for default file types. */
1586 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1587 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
c07a80fd
PP
1588 strcat(tokenbuf,scriptname);
1589#else /* !VMS */
93a17b20 1590 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
79072805
LW
1591
1592 bufend = s + strlen(s);
1593 while (*s) {
1594#ifndef DOSISH
1595 s = cpytill(tokenbuf,s,bufend,':',&len);
1596#else
1597#ifdef atarist
1598 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1599 tokenbuf[len] = '\0';
1600#else
1601 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1602 tokenbuf[len] = '\0';
1603#endif
1604#endif
1605 if (*s)
1606 s++;
1607#ifndef DOSISH
1608 if (len && tokenbuf[len-1] != '/')
1609#else
1610#ifdef atarist
1611 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1612#else
1613 if (len && tokenbuf[len-1] != '\\')
1614#endif
1615#endif
1616 (void)strcat(tokenbuf+len,"/");
1617 (void)strcat(tokenbuf+len,scriptname);
c07a80fd 1618#endif /* !VMS */
a38d6535
LW
1619
1620#ifdef SEARCH_EXTS
1621 len = strlen(tokenbuf);
1622 if (extidx > 0) /* reset after previous loop */
1623 extidx = 0;
1624 do {
1625#endif
760ac839 1626 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
a38d6535
LW
1627 retval = Stat(tokenbuf,&statbuf);
1628#ifdef SEARCH_EXTS
1629 } while ( retval < 0 /* not there */
1630 && extidx>=0 && ext[extidx] /* try an extension? */
1631 && strcpy(tokenbuf+len, ext[extidx++])
1632 );
1633#endif
1634 if (retval < 0)
79072805
LW
1635 continue;
1636 if (S_ISREG(statbuf.st_mode)
1637 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1638 xfound = tokenbuf; /* bingo! */
1639 break;
1640 }
1641 if (!xfailed)
a0d0e21e 1642 xfailed = savepv(tokenbuf);
79072805
LW
1643 }
1644 if (!xfound)
463ee0b2 1645 croak("Can't execute %s", xfailed ? xfailed : scriptname );
79072805
LW
1646 if (xfailed)
1647 Safefree(xfailed);
1648 scriptname = xfound;
1649 }
1650
96436eeb
PP
1651 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1652 char *s = scriptname + 8;
1653 fdscript = atoi(s);
1654 while (isDIGIT(*s))
1655 s++;
1656 if (*s)
1657 scriptname = s + 1;
1658 }
1659 else
1660 fdscript = -1;
ab821d7f 1661 origfilename = savepv(e_tmpname ? "-e" : scriptname);
79072805
LW
1662 curcop->cop_filegv = gv_fetchfile(origfilename);
1663 if (strEQ(origfilename,"-"))
1664 scriptname = "";
96436eeb 1665 if (fdscript >= 0) {
760ac839 1666 rsfp = PerlIO_fdopen(fdscript,"r");
96436eeb 1667#if defined(HAS_FCNTL) && defined(F_SETFD)
7aa04957
CS
1668 if (rsfp)
1669 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb
PP
1670#endif
1671 }
1672 else if (preprocess) {
79072805
LW
1673 char *cpp = CPPSTDIN;
1674
1675 if (strEQ(cpp,"cppstdin"))
1676 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1677 else
1678 sprintf(tokenbuf, "%s", cpp);
1679 sv_catpv(sv,"-I");
fed7345c 1680 sv_catpv(sv,PRIVLIB_EXP);
79072805
LW
1681#ifdef MSDOS
1682 (void)sprintf(buf, "\
1683sed %s -e \"/^[^#]/b\" \
1684 -e \"/^#[ ]*include[ ]/b\" \
1685 -e \"/^#[ ]*define[ ]/b\" \
1686 -e \"/^#[ ]*if[ ]/b\" \
1687 -e \"/^#[ ]*ifdef[ ]/b\" \
1688 -e \"/^#[ ]*ifndef[ ]/b\" \
1689 -e \"/^#[ ]*else/b\" \
1690 -e \"/^#[ ]*elif[ ]/b\" \
1691 -e \"/^#[ ]*undef[ ]/b\" \
1692 -e \"/^#[ ]*endif/b\" \
1693 -e \"s/^#.*//\" \
1694 %s | %s -C %s %s",
1695 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1696#else
1697 (void)sprintf(buf, "\
1698%s %s -e '/^[^#]/b' \
1699 -e '/^#[ ]*include[ ]/b' \
1700 -e '/^#[ ]*define[ ]/b' \
1701 -e '/^#[ ]*if[ ]/b' \
1702 -e '/^#[ ]*ifdef[ ]/b' \
1703 -e '/^#[ ]*ifndef[ ]/b' \
1704 -e '/^#[ ]*else/b' \
1705 -e '/^#[ ]*elif[ ]/b' \
1706 -e '/^#[ ]*undef[ ]/b' \
1707 -e '/^#[ ]*endif/b' \
1708 -e 's/^[ ]*#.*//' \
1709 %s | %s -C %s %s",
1710#ifdef LOC_SED
1711 LOC_SED,
1712#else
1713 "sed",
1714#endif
1715 (doextract ? "-e '1,/^#/d\n'" : ""),
1716#endif
463ee0b2 1717 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
79072805
LW
1718 doextract = FALSE;
1719#ifdef IAMSUID /* actually, this is caught earlier */
1720 if (euid != uid && !euid) { /* if running suidperl */
1721#ifdef HAS_SETEUID
1722 (void)seteuid(uid); /* musn't stay setuid root */
1723#else
1724#ifdef HAS_SETREUID
85e6fe83
LW
1725 (void)setreuid((Uid_t)-1, uid);
1726#else
1727#ifdef HAS_SETRESUID
1728 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
79072805
LW
1729#else
1730 setuid(uid);
1731#endif
1732#endif
85e6fe83 1733#endif
79072805 1734 if (geteuid() != uid)
463ee0b2 1735 croak("Can't do seteuid!\n");
79072805
LW
1736 }
1737#endif /* IAMSUID */
1738 rsfp = my_popen(buf,"r");
1739 }
1740 else if (!*scriptname) {
bbce6d69 1741 forbid_setid("program input from stdin");
760ac839 1742 rsfp = PerlIO_stdin();
79072805 1743 }
96436eeb 1744 else {
760ac839 1745 rsfp = PerlIO_open(scriptname,"r");
96436eeb 1746#if defined(HAS_FCNTL) && defined(F_SETFD)
7aa04957
CS
1747 if (rsfp)
1748 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb
PP
1749#endif
1750 }
5dd60ef7
PP
1751 if (e_tmpname) {
1752 e_fp = rsfp;
1753 }
7aa04957 1754 if (!rsfp) {
13281fa4 1755#ifdef DOSUID
a687059c 1756#ifndef IAMSUID /* in case script is not readable before setuid */
a0d0e21e 1757 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
13281fa4 1758 statbuf.st_mode & (S_ISUID|S_ISGID)) {
27e2fb84 1759 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
a687059c 1760 execv(buf, origargv); /* try again */
463ee0b2 1761 croak("Can't do setuid\n");
13281fa4
LW
1762 }
1763#endif
1764#endif
463ee0b2 1765 croak("Can't open perl script \"%s\": %s\n",
2304df62 1766 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
13281fa4 1767 }
79072805 1768}
8d063cd8 1769
79072805 1770static void
96436eeb 1771validate_suid(validarg, scriptname)
79072805 1772char *validarg;
96436eeb 1773char *scriptname;
79072805 1774{
96436eeb
PP
1775 int which;
1776
13281fa4
LW
1777 /* do we need to emulate setuid on scripts? */
1778
1779 /* This code is for those BSD systems that have setuid #! scripts disabled
1780 * in the kernel because of a security problem. Merely defining DOSUID
1781 * in perl will not fix that problem, but if you have disabled setuid
1782 * scripts in the kernel, this will attempt to emulate setuid and setgid
1783 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW
1784 * root version must be called suidperl or sperlN.NNN. If regular perl
1785 * discovers that it has opened a setuid script, it calls suidperl with
1786 * the same argv that it had. If suidperl finds that the script it has
1787 * just opened is NOT setuid root, it sets the effective uid back to the
1788 * uid. We don't just make perl setuid root because that loses the
1789 * effective uid we had before invoking perl, if it was different from the
1790 * uid.
13281fa4
LW
1791 *
1792 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1793 * be defined in suidperl only. suidperl must be setuid root. The
1794 * Configure script will set this up for you if you want it.
1795 */
a687059c 1796
13281fa4 1797#ifdef DOSUID
6e72f9df 1798 char *s, *s2;
a0d0e21e 1799
760ac839 1800 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
463ee0b2 1801 croak("Can't stat script \"%s\"",origfilename);
96436eeb 1802 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 1803 I32 len;
13281fa4 1804
a687059c 1805#ifdef IAMSUID
fe14fcc3 1806#ifndef HAS_SETREUID
a687059c
LW
1807 /* On this access check to make sure the directories are readable,
1808 * there is actually a small window that the user could use to make
1809 * filename point to an accessible directory. So there is a faint
1810 * chance that someone could execute a setuid script down in a
1811 * non-accessible directory. I don't know what to do about that.
1812 * But I don't think it's too important. The manual lies when
1813 * it says access() is useful in setuid programs.
1814 */
463ee0b2
LW
1815 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1816 croak("Permission denied");
a687059c
LW
1817#else
1818 /* If we can swap euid and uid, then we can determine access rights
1819 * with a simple stat of the file, and then compare device and
1820 * inode to make sure we did stat() on the same file we opened.
1821 * Then we just have to make sure he or she can execute it.
1822 */
1823 {
1824 struct stat tmpstatbuf;
1825
85e6fe83
LW
1826 if (
1827#ifdef HAS_SETREUID
1828 setreuid(euid,uid) < 0
a0d0e21e
LW
1829#else
1830# if HAS_SETRESUID
85e6fe83 1831 setresuid(euid,uid,(Uid_t)-1) < 0
a0d0e21e 1832# endif
85e6fe83
LW
1833#endif
1834 || getuid() != euid || geteuid() != uid)
463ee0b2 1835 croak("Can't swap uid and euid"); /* really paranoid */
a0d0e21e 1836 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
463ee0b2 1837 croak("Permission denied"); /* testing full pathname here */
a687059c
LW
1838 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1839 tmpstatbuf.st_ino != statbuf.st_ino) {
760ac839 1840 (void)PerlIO_close(rsfp);
79072805 1841 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
760ac839 1842 PerlIO_printf(rsfp,
a687059c
LW
1843"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1844(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1845 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1846 statbuf.st_dev, statbuf.st_ino,
463ee0b2 1847 SvPVX(GvSV(curcop->cop_filegv)),
20188a90 1848 statbuf.st_uid, statbuf.st_gid);
79072805 1849 (void)my_pclose(rsfp);
a687059c 1850 }
463ee0b2 1851 croak("Permission denied\n");
a687059c 1852 }
85e6fe83
LW
1853 if (
1854#ifdef HAS_SETREUID
1855 setreuid(uid,euid) < 0
a0d0e21e
LW
1856#else
1857# if defined(HAS_SETRESUID)
85e6fe83 1858 setresuid(uid,euid,(Uid_t)-1) < 0
a0d0e21e 1859# endif
85e6fe83
LW
1860#endif
1861 || getuid() != uid || geteuid() != euid)
463ee0b2 1862 croak("Can't reswap uid and euid");
27e2fb84 1863 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
463ee0b2 1864 croak("Permission denied\n");
a687059c 1865 }
fe14fcc3 1866#endif /* HAS_SETREUID */
a687059c
LW
1867#endif /* IAMSUID */
1868
27e2fb84 1869 if (!S_ISREG(statbuf.st_mode))
463ee0b2 1870 croak("Permission denied");
27e2fb84 1871 if (statbuf.st_mode & S_IWOTH)
463ee0b2 1872 croak("Setuid/gid script is writable by world");
13281fa4 1873 doswitches = FALSE; /* -s is insecure in suid */
79072805 1874 curcop->cop_line++;
760ac839
LW
1875 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1876 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
463ee0b2 1877 croak("No #! line");
760ac839 1878 s = SvPV(linestr,na)+2;
663a0e37 1879 if (*s == ' ') s++;
45d8adaa 1880 while (!isSPACE(*s)) s++;
760ac839 1881 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
6e72f9df
PP
1882 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1883 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
463ee0b2 1884 croak("Not a perl script");
a687059c 1885 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW
1886 /*
1887 * #! arg must be what we saw above. They can invoke it by
1888 * mentioning suidperl explicitly, but they may not add any strange
1889 * arguments beyond what #! says if they do invoke suidperl that way.
1890 */
1891 len = strlen(validarg);
1892 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 1893 strnNE(s,validarg,len) || !isSPACE(s[len]))
463ee0b2 1894 croak("Args must match #! line");
a687059c
LW
1895
1896#ifndef IAMSUID
1897 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1898 euid == statbuf.st_uid)
1899 if (!do_undump)
463ee0b2 1900 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
1901FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1902#endif /* IAMSUID */
13281fa4
LW
1903
1904 if (euid) { /* oops, we're not the setuid root perl */
760ac839 1905 (void)PerlIO_close(rsfp);
13281fa4 1906#ifndef IAMSUID
27e2fb84 1907 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
a687059c 1908 execv(buf, origargv); /* try again */
13281fa4 1909#endif
463ee0b2 1910 croak("Can't do setuid\n");
13281fa4
LW
1911 }
1912
83025b21 1913 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
fe14fcc3 1914#ifdef HAS_SETEGID
a687059c
LW
1915 (void)setegid(statbuf.st_gid);
1916#else
fe14fcc3 1917#ifdef HAS_SETREGID
85e6fe83
LW
1918 (void)setregid((Gid_t)-1,statbuf.st_gid);
1919#else
1920#ifdef HAS_SETRESGID
1921 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
a687059c
LW
1922#else
1923 setgid(statbuf.st_gid);
1924#endif
1925#endif
85e6fe83 1926#endif
83025b21 1927 if (getegid() != statbuf.st_gid)
463ee0b2 1928 croak("Can't do setegid!\n");
83025b21 1929 }
a687059c
LW
1930 if (statbuf.st_mode & S_ISUID) {
1931 if (statbuf.st_uid != euid)
fe14fcc3 1932#ifdef HAS_SETEUID
a687059c
LW
1933 (void)seteuid(statbuf.st_uid); /* all that for this */
1934#else
fe14fcc3 1935#ifdef HAS_SETREUID
85e6fe83
LW
1936 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1937#else
1938#ifdef HAS_SETRESUID
1939 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
a687059c
LW
1940#else
1941 setuid(statbuf.st_uid);
1942#endif
1943#endif
85e6fe83 1944#endif
83025b21 1945 if (geteuid() != statbuf.st_uid)
463ee0b2 1946 croak("Can't do seteuid!\n");
a687059c 1947 }
83025b21 1948 else if (uid) { /* oops, mustn't run as root */
fe14fcc3 1949#ifdef HAS_SETEUID
85e6fe83 1950 (void)seteuid((Uid_t)uid);
a687059c 1951#else
fe14fcc3 1952#ifdef HAS_SETREUID
85e6fe83 1953 (void)setreuid((Uid_t)-1,(Uid_t)uid);
a687059c 1954#else
85e6fe83
LW
1955#ifdef HAS_SETRESUID
1956 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1957#else
1958 setuid((Uid_t)uid);
1959#endif
a687059c
LW
1960#endif
1961#endif
83025b21 1962 if (geteuid() != uid)
463ee0b2 1963 croak("Can't do seteuid!\n");
83025b21 1964 }
748a9306 1965 init_ids();
27e2fb84 1966 if (!cando(S_IXUSR,TRUE,&statbuf))
463ee0b2 1967 croak("Permission denied\n"); /* they can't do this */
13281fa4
LW
1968 }
1969#ifdef IAMSUID
1970 else if (preprocess)
463ee0b2 1971 croak("-P not allowed for setuid/setgid script\n");
96436eeb
PP
1972 else if (fdscript >= 0)
1973 croak("fd script not allowed in suidperl\n");
13281fa4 1974 else
463ee0b2 1975 croak("Script is not setuid/setgid in suidperl\n");
96436eeb
PP
1976
1977 /* We absolutely must clear out any saved ids here, so we */
1978 /* exec the real perl, substituting fd script for scriptname. */
1979 /* (We pass script name as "subdir" of fd, which perl will grok.) */
760ac839
LW
1980 PerlIO_rewind(rsfp);
1981 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
96436eeb
PP
1982 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1983 if (!origargv[which])
1984 croak("Permission denied");
760ac839 1985 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
96436eeb
PP
1986 origargv[which] = buf;
1987
1988#if defined(HAS_FCNTL) && defined(F_SETFD)
760ac839 1989 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb
PP
1990#endif
1991
1992 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1993 execv(tokenbuf, origargv); /* try again */
1994 croak("Can't do setuid\n");
13281fa4 1995#endif /* IAMSUID */
a687059c 1996#else /* !DOSUID */
a687059c
LW
1997 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1998#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
760ac839 1999 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
a687059c
LW
2000 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2001 ||
2002 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2003 )
2004 if (!do_undump)
463ee0b2 2005 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
2006FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2007#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2008 /* not set-id, must be wrapped */
a687059c 2009 }
13281fa4 2010#endif /* DOSUID */
79072805 2011}
13281fa4 2012
79072805
LW
2013static void
2014find_beginning()
2015{
6e72f9df 2016 register char *s, *s2;
33b78306
LW
2017
2018 /* skip forward in input to the real script? */
2019
bbce6d69 2020 forbid_setid("-x");
33b78306 2021 while (doextract) {
79072805 2022 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
463ee0b2 2023 croak("No Perl script found in input\n");
6e72f9df 2024 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
760ac839 2025 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
33b78306 2026 doextract = FALSE;
6e72f9df
PP
2027 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2028 s2 = s;
2029 while (*s == ' ' || *s == '\t') s++;
2030 if (*s++ == '-') {
2031 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2032 if (strnEQ(s2-4,"perl",4))
2033 /*SUPPRESS 530*/
2034 while (s = moreswitches(s)) ;
33b78306 2035 }
79072805 2036 if (cddir && chdir(cddir) < 0)
463ee0b2 2037 croak("Can't chdir to %s",cddir);
83025b21
LW
2038 }
2039 }
2040}
2041
79072805 2042static void
748a9306 2043init_ids()
352d5a3a 2044{
748a9306
LW
2045 uid = (int)getuid();
2046 euid = (int)geteuid();
2047 gid = (int)getgid();
2048 egid = (int)getegid();
2049#ifdef VMS
2050 uid |= gid << 16;
2051 euid |= egid << 16;
2052#endif
4633a7c4 2053 tainting |= (uid && (euid != uid || egid != gid));
748a9306 2054}
79072805 2055
748a9306 2056static void
bbce6d69
PP
2057forbid_setid(s)
2058char *s;
2059{
2060 if (euid != uid)
2061 croak("No %s allowed while running setuid", s);
2062 if (egid != gid)
2063 croak("No %s allowed while running setgid", s);
2064}
2065
2066static void
748a9306
LW
2067init_debugger()
2068{
79072805 2069 curstash = debstash;
748a9306 2070 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
79072805 2071 AvREAL_off(dbargs);
a0d0e21e
LW
2072 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2073 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
748a9306
LW
2074 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2075 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
c07a80fd 2076 sv_setiv(DBsingle, 0);
748a9306 2077 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
c07a80fd 2078 sv_setiv(DBtrace, 0);
748a9306 2079 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
c07a80fd 2080 sv_setiv(DBsignal, 0);
79072805 2081 curstash = defstash;
352d5a3a
LW
2082}
2083
79072805 2084static void
8990e307 2085init_stacks()
79072805 2086{
6e72f9df 2087 curstack = newAV();
5f05dabc
PP
2088 mainstack = curstack; /* remember in case we switch stacks */
2089 AvREAL_off(curstack); /* not a real array */
6e72f9df 2090 av_extend(curstack,127);
79072805 2091
6e72f9df 2092 stack_base = AvARRAY(curstack);
79072805 2093 stack_sp = stack_base;
8990e307 2094 stack_max = stack_base + 127;
79072805 2095
5f05dabc
PP
2096 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2097 New(50,cxstack,cxstack_max + 1,CONTEXT);
2098 cxstack_ix = -1;
2099
2100 New(50,tmps_stack,128,SV*);
2101 tmps_ix = -1;
2102 tmps_max = 128;
2103
2104 DEBUG( {
2105 New(51,debname,128,char);
2106 New(52,debdelim,128,char);
2107 } )
2108
2109 /*
2110 * The following stacks almost certainly should be per-interpreter,
2111 * but for now they're not. XXX
2112 */
2113
6e72f9df
PP
2114 if (markstack) {
2115 markstack_ptr = markstack;
2116 } else {
2117 New(54,markstack,64,I32);
2118 markstack_ptr = markstack;
2119 markstack_max = markstack + 64;
2120 }
79072805 2121
6e72f9df
PP
2122 if (scopestack) {
2123 scopestack_ix = 0;
2124 } else {
2125 New(54,scopestack,32,I32);
2126 scopestack_ix = 0;
2127 scopestack_max = 32;
2128 }
79072805 2129
6e72f9df
PP
2130 if (savestack) {
2131 savestack_ix = 0;
2132 } else {
2133 New(54,savestack,128,ANY);
2134 savestack_ix = 0;
2135 savestack_max = 128;
2136 }
79072805 2137
6e72f9df
PP
2138 if (retstack) {
2139 retstack_ix = 0;
2140 } else {
2141 New(54,retstack,16,OP*);
2142 retstack_ix = 0;
2143 retstack_max = 16;
5f05dabc 2144 }
378cc40b 2145}
33b78306 2146
6e72f9df
PP
2147static void
2148nuke_stacks()
2149{
2150 Safefree(cxstack);
2151 Safefree(tmps_stack);
5f05dabc
PP
2152 DEBUG( {
2153 Safefree(debname);
2154 Safefree(debdelim);
2155 } )
6e72f9df
PP
2156}
2157
760ac839 2158static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
7aa04957 2159
79072805 2160static void
8990e307
LW
2161init_lexer()
2162{
a0d0e21e 2163 tmpfp = rsfp;
8990e307
LW
2164 lex_start(linestr);
2165 rsfp = tmpfp;
2166 subname = newSVpv("main",4);
2167}
2168
2169static void
79072805 2170init_predump_symbols()
45d8adaa 2171{
93a17b20 2172 GV *tmpgv;
a0d0e21e 2173 GV *othergv;
79072805 2174
85e6fe83 2175 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
79072805 2176
85e6fe83 2177 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
a5f75d66 2178 GvMULTI_on(stdingv);
760ac839 2179 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
adbc6bb1 2180 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 2181 GvMULTI_on(tmpgv);
a0d0e21e 2182 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
79072805 2183
85e6fe83 2184 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 2185 GvMULTI_on(tmpgv);
760ac839 2186 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
4633a7c4 2187 setdefout(tmpgv);
adbc6bb1 2188 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 2189 GvMULTI_on(tmpgv);
a0d0e21e 2190 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
79072805 2191
a0d0e21e 2192 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
a5f75d66 2193 GvMULTI_on(othergv);
760ac839 2194 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
adbc6bb1 2195 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 2196 GvMULTI_on(tmpgv);
a0d0e21e 2197 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
79072805
LW
2198
2199 statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 2200
6e72f9df
PP
2201 if (!osname)
2202 osname = savepv(OSNAME);
79072805 2203}
33b78306 2204
79072805
LW
2205static void
2206init_postdump_symbols(argc,argv,env)
2207register int argc;
2208register char **argv;
2209register char **env;
33b78306 2210{
79072805
LW
2211 char *s;
2212 SV *sv;
2213 GV* tmpgv;
fe14fcc3 2214
79072805
LW
2215 argc--,argv++; /* skip name of script */
2216 if (doswitches) {
2217 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2218 if (!argv[0][1])
2219 break;
2220 if (argv[0][1] == '-') {
2221 argc--,argv++;
2222 break;
2223 }
93a17b20 2224 if (s = strchr(argv[0], '=')) {
79072805 2225 *s++ = '\0';
85e6fe83 2226 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW
2227 }
2228 else
85e6fe83 2229 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 2230 }
79072805
LW
2231 }
2232 toptarget = NEWSV(0,0);
2233 sv_upgrade(toptarget, SVt_PVFM);
2234 sv_setpvn(toptarget, "", 0);
748a9306 2235 bodytarget = NEWSV(0,0);
79072805
LW
2236 sv_upgrade(bodytarget, SVt_PVFM);
2237 sv_setpvn(bodytarget, "", 0);
2238 formtarget = bodytarget;
2239
bbce6d69 2240 TAINT;
85e6fe83 2241 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
79072805
LW
2242 sv_setpv(GvSV(tmpgv),origfilename);
2243 magicname("0", "0", 1);
2244 }
85e6fe83 2245 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
79072805 2246 time(&basetime);
85e6fe83 2247 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
79072805 2248 sv_setpv(GvSV(tmpgv),origargv[0]);
85e6fe83 2249 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
a5f75d66 2250 GvMULTI_on(argvgv);
79072805
LW
2251 (void)gv_AVadd(argvgv);
2252 av_clear(GvAVn(argvgv));
2253 for (; argc > 0; argc--,argv++) {
a0d0e21e 2254 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
79072805
LW
2255 }
2256 }
85e6fe83 2257 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
79072805 2258 HV *hv;
a5f75d66 2259 GvMULTI_on(envgv);
79072805 2260 hv = GvHVn(envgv);
463ee0b2 2261 hv_clear(hv);
a0d0e21e 2262#ifndef VMS /* VMS doesn't have environ array */
4633a7c4
LW
2263 /* Note that if the supplied env parameter is actually a copy
2264 of the global environ then it may now point to free'd memory
2265 if the environment has been modified since. To avoid this
2266 problem we treat env==NULL as meaning 'use the default'
2267 */
2268 if (!env)
2269 env = environ;
8990e307 2270 if (env != environ) {
79072805 2271 environ[0] = Nullch;
8990e307
LW
2272 hv_magic(hv, envgv, 'E');
2273 }
79072805 2274 for (; *env; env++) {
93a17b20 2275 if (!(s = strchr(*env,'=')))
79072805
LW
2276 continue;
2277 *s++ = '\0';
2278 sv = newSVpv(s--,0);
85e6fe83 2279 sv_magic(sv, sv, 'e', *env, s - *env);
79072805
LW
2280 (void)hv_store(hv, *env, s - *env, sv, 0);
2281 *s = '=';
fe14fcc3 2282 }
4550b24a
PP
2283#endif
2284#ifdef DYNAMIC_ENV_FETCH
2285 HvNAME(hv) = savepv(ENV_HV_NAME);
2286#endif
f511e57f 2287 hv_magic(hv, envgv, 'E');
79072805 2288 }
bbce6d69 2289 TAINT_NOT;
85e6fe83 2290 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
79072805 2291 sv_setiv(GvSV(tmpgv),(I32)getpid());
33b78306 2292}
34de22dd 2293
79072805
LW
2294static void
2295init_perllib()
34de22dd 2296{
85e6fe83
LW
2297 char *s;
2298 if (!tainting) {
552a7a9b 2299#ifndef VMS
85e6fe83
LW
2300 s = getenv("PERL5LIB");
2301 if (s)
2302 incpush(s);
2303 else
2304 incpush(getenv("PERLLIB"));
552a7a9b
PP
2305#else /* VMS */
2306 /* Treat PERL5?LIB as a possible search list logical name -- the
2307 * "natural" VMS idiom for a Unix path string. We allow each
2308 * element to be a set of |-separated directories for compatibility.
2309 */
2310 char buf[256];
2311 int idx = 0;
2312 if (my_trnlnm("PERL5LIB",buf,0))
2313 do { incpush(buf); } while (my_trnlnm("PERL5LIB",buf,++idx));
2314 else
2315 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf);
2316#endif /* VMS */
85e6fe83 2317 }
34de22dd 2318
df5cef82
PP
2319/* Use the ~-expanded versions of APPLIB (undocumented),
2320 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2321*/
4633a7c4
LW
2322#ifdef APPLLIB_EXP
2323 incpush(APPLLIB_EXP);
16d20bd9 2324#endif
4633a7c4 2325
fed7345c
AD
2326#ifdef ARCHLIB_EXP
2327 incpush(ARCHLIB_EXP);
a0d0e21e 2328#endif
fed7345c
AD
2329#ifndef PRIVLIB_EXP
2330#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 2331#endif
fed7345c 2332 incpush(PRIVLIB_EXP);
4633a7c4
LW
2333
2334#ifdef SITEARCH_EXP
2335 incpush(SITEARCH_EXP);
2336#endif
2337#ifdef SITELIB_EXP
2338 incpush(SITELIB_EXP);
2339#endif
2340#ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2341 incpush(OLDARCHLIB_EXP);
2342#endif
a0d0e21e 2343
4633a7c4
LW
2344 if (!tainting)
2345 incpush(".");
34de22dd 2346}
93a17b20
LW
2347
2348void
2349calllist(list)
2350AV* list;
2351{
a5f75d66 2352 Sigjmp_buf oldtop;
a0d0e21e
LW
2353 STRLEN len;
2354 line_t oldline = curcop->cop_line;
93a17b20 2355
a5f75d66 2356 Copy(top_env, oldtop, 1, Sigjmp_buf);
93a17b20 2357
8990e307
LW
2358 while (AvFILL(list) >= 0) {
2359 CV *cv = (CV*)av_shift(list);
93a17b20 2360
8990e307 2361 SAVEFREESV(cv);
a0d0e21e 2362
a5f75d66 2363 switch (Sigsetjmp(top_env,1)) {
748a9306 2364 case 0: {
4633a7c4 2365 SV* atsv = GvSV(errgv);
748a9306
LW
2366 PUSHMARK(stack_sp);
2367 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2368 (void)SvPV(atsv, len);
2369 if (len) {
a5f75d66 2370 Copy(oldtop, top_env, 1, Sigjmp_buf);
748a9306
LW
2371 curcop = &compiling;
2372 curcop->cop_line = oldline;
2373 if (list == beginav)
2374 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2375 else
2376 sv_catpv(atsv, "END failed--cleanup aborted");
2377 croak("%s", SvPVX(atsv));
2378 }
a0d0e21e 2379 }
85e6fe83
LW
2380 break;
2381 case 1:
748a9306 2382#ifdef VMS
85e6fe83 2383 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
748a9306
LW
2384#else
2385 statusvalue = 1;
2386#endif
85e6fe83
LW
2387 /* FALL THROUGH */
2388 case 2:
2389 /* my_exit() was called */
2390 curstash = defstash;
2391 if (endav)
2392 calllist(endav);
a0d0e21e 2393 FREETMPS;
a5f75d66 2394 Copy(oldtop, top_env, 1, Sigjmp_buf);
a0d0e21e
LW
2395 curcop = &compiling;
2396 curcop->cop_line = oldline;
85e6fe83
LW
2397 if (statusvalue) {
2398 if (list == beginav)
a0d0e21e 2399 croak("BEGIN failed--compilation aborted");
85e6fe83 2400 else
a0d0e21e 2401 croak("END failed--cleanup aborted");
85e6fe83 2402 }
85e6fe83
LW
2403 my_exit(statusvalue);
2404 /* NOTREACHED */
2405 return;
2406 case 3:
2407 if (!restartop) {
760ac839 2408 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
a0d0e21e 2409 FREETMPS;
85e6fe83
LW
2410 break;
2411 }
a5f75d66 2412 Copy(oldtop, top_env, 1, Sigjmp_buf);
a0d0e21e
LW
2413 curcop = &compiling;
2414 curcop->cop_line = oldline;
a5f75d66 2415 Siglongjmp(top_env, 3);
8990e307 2416 }
93a17b20
LW
2417 }
2418
a5f75d66 2419 Copy(oldtop, top_env, 1, Sigjmp_buf);
93a17b20
LW
2420}
2421