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