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