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