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