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