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