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