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