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