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