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