This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
$\1 and serious bug in evalling
[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 */
748a9306
LW
774#ifdef VMS
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
PP
817
818#ifdef DEBUGGING_MSTATS
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;
c07a80fd
PP
855#ifdef DEBUGGING_MSTATS
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
ab821d7f
PP
1628#ifdef VMS
1629# define SEARCH_EXTS ".pl", ".com", NULL
fc36a67e 1630# define MAX_EXT_LEN 4
ab821d7f 1631#endif
a38d6535
LW
1632 /* additional extensions to try in each dir if scriptname not found */
1633#ifdef SEARCH_EXTS
1634 char *ext[] = { SEARCH_EXTS };
1635 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
fc36a67e
PP
1636#else
1637# define MAX_EXT_LEN 0
a38d6535 1638#endif
79072805 1639
c07a80fd 1640#ifdef VMS
6e72f9df
PP
1641 if (dosearch) {
1642 int hasdir, idx = 0, deftypes = 1;
1643
1644 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1645 /* The first time through, just add SEARCH_EXTS to whatever we
1646 * already have, so we can check for default file types. */
fc36a67e
PP
1647 while (deftypes ||
1648 (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
1649 {
1650 if (deftypes) {
1651 deftypes = 0;
1652 *tokenbuf = '\0';
1653 }
1654 if ((strlen(tokenbuf) + strlen(scriptname)
1655 + MAX_EXT_LEN) >= sizeof tokenbuf)
1656 continue; /* don't search dir with too-long name */
1657 strcat(tokenbuf, scriptname);
c07a80fd 1658#else /* !VMS */
e92c4225
WJ
1659 if (dosearch && !strchr(scriptname, '/')
1660#ifdef DOSISH
1661 && !strchr(scriptname, '\\')
1662#endif
1663 && (s = getenv("PATH"))) {
79072805 1664 bufend = s + strlen(s);
fc36a67e
PP
1665 while (s < bufend) {
1666#ifndef atarist
1667 s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
1668#ifdef DOSISH
1669 ';',
79072805 1670#else
fc36a67e 1671 ':',
79072805 1672#endif
fc36a67e
PP
1673 &len);
1674#else /* atarist */
1675 for (len = 0; *s && *s != ',' && *s != ';'; len++, s++) {
1676 if (len < sizeof tokenbuf)
1677 tokenbuf[len] = *s;
1678 }
1679 if (len < sizeof tokenbuf)
1680 tokenbuf[len] = '\0';
1681#endif /* atarist */
1682 if (s < bufend)
79072805 1683 s++;
fc36a67e
PP
1684 if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
1685 continue; /* don't search dir with too-long name */
1686 if (len
1687#if defined(atarist) && !defined(DOSISH)
1688 && tokenbuf[len - 1] != '/'
79072805 1689#endif
fc36a67e
PP
1690#if defined(atarist) || defined(DOSISH)
1691 && tokenbuf[len - 1] != '\\'
79072805 1692#endif
fc36a67e
PP
1693 )
1694 tokenbuf[len++] = '/';
1695 (void)strcpy(tokenbuf + len, scriptname);
c07a80fd 1696#endif /* !VMS */
a38d6535
LW
1697
1698#ifdef SEARCH_EXTS
1699 len = strlen(tokenbuf);
1700 if (extidx > 0) /* reset after previous loop */
1701 extidx = 0;
1702 do {
1703#endif
760ac839 1704 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
a38d6535
LW
1705 retval = Stat(tokenbuf,&statbuf);
1706#ifdef SEARCH_EXTS
1707 } while ( retval < 0 /* not there */
1708 && extidx>=0 && ext[extidx] /* try an extension? */
1709 && strcpy(tokenbuf+len, ext[extidx++])
1710 );
1711#endif
1712 if (retval < 0)
79072805
LW
1713 continue;
1714 if (S_ISREG(statbuf.st_mode)
c90c0ff4
PP
1715 && cando(S_IRUSR,TRUE,&statbuf)
1716#ifndef DOSISH
1717 && cando(S_IXUSR,TRUE,&statbuf)
1718#endif
1719 )
1720 {
79072805
LW
1721 xfound = tokenbuf; /* bingo! */
1722 break;
1723 }
1724 if (!xfailed)
a0d0e21e 1725 xfailed = savepv(tokenbuf);
79072805
LW
1726 }
1727 if (!xfound)
463ee0b2 1728 croak("Can't execute %s", xfailed ? xfailed : scriptname );
79072805
LW
1729 if (xfailed)
1730 Safefree(xfailed);
1731 scriptname = xfound;
1732 }
1733
96436eeb
PP
1734 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1735 char *s = scriptname + 8;
1736 fdscript = atoi(s);
1737 while (isDIGIT(*s))
1738 s++;
1739 if (*s)
1740 scriptname = s + 1;
1741 }
1742 else
1743 fdscript = -1;
ab821d7f 1744 origfilename = savepv(e_tmpname ? "-e" : scriptname);
79072805
LW
1745 curcop->cop_filegv = gv_fetchfile(origfilename);
1746 if (strEQ(origfilename,"-"))
1747 scriptname = "";
96436eeb 1748 if (fdscript >= 0) {
760ac839 1749 rsfp = PerlIO_fdopen(fdscript,"r");
96436eeb 1750#if defined(HAS_FCNTL) && defined(F_SETFD)
7aa04957
CS
1751 if (rsfp)
1752 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb
PP
1753#endif
1754 }
1755 else if (preprocess) {
46fc3d4c
PP
1756 char *cpp_cfg = CPPSTDIN;
1757 SV *cpp = NEWSV(0,0);
1758 SV *cmd = NEWSV(0,0);
1759
1760 if (strEQ(cpp_cfg, "cppstdin"))
1761 sv_catpvf(cpp, "%s/", BIN_EXP);
1762 sv_catpv(cpp, cpp_cfg);
79072805 1763
79072805 1764 sv_catpv(sv,"-I");
fed7345c 1765 sv_catpv(sv,PRIVLIB_EXP);
46fc3d4c 1766
79072805 1767#ifdef MSDOS
46fc3d4c 1768 sv_setpvf(cmd, "\
79072805
LW
1769sed %s -e \"/^[^#]/b\" \
1770 -e \"/^#[ ]*include[ ]/b\" \
1771 -e \"/^#[ ]*define[ ]/b\" \
1772 -e \"/^#[ ]*if[ ]/b\" \
1773 -e \"/^#[ ]*ifdef[ ]/b\" \
1774 -e \"/^#[ ]*ifndef[ ]/b\" \
1775 -e \"/^#[ ]*else/b\" \
1776 -e \"/^#[ ]*elif[ ]/b\" \
1777 -e \"/^#[ ]*undef[ ]/b\" \
1778 -e \"/^#[ ]*endif/b\" \
1779 -e \"s/^#.*//\" \
fc36a67e 1780 %s | %_ -C %_ %s",
79072805
LW
1781 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1782#else
46fc3d4c 1783 sv_setpvf(cmd, "\
79072805
LW
1784%s %s -e '/^[^#]/b' \
1785 -e '/^#[ ]*include[ ]/b' \
1786 -e '/^#[ ]*define[ ]/b' \
1787 -e '/^#[ ]*if[ ]/b' \
1788 -e '/^#[ ]*ifdef[ ]/b' \
1789 -e '/^#[ ]*ifndef[ ]/b' \
1790 -e '/^#[ ]*else/b' \
1791 -e '/^#[ ]*elif[ ]/b' \
1792 -e '/^#[ ]*undef[ ]/b' \
1793 -e '/^#[ ]*endif/b' \
1794 -e 's/^[ ]*#.*//' \
fc36a67e 1795 %s | %_ -C %_ %s",
79072805
LW
1796#ifdef LOC_SED
1797 LOC_SED,
1798#else
1799 "sed",
1800#endif
1801 (doextract ? "-e '1,/^#/d\n'" : ""),
1802#endif
46fc3d4c 1803 scriptname, cpp, sv, CPPMINUS);
79072805
LW
1804 doextract = FALSE;
1805#ifdef IAMSUID /* actually, this is caught earlier */
1806 if (euid != uid && !euid) { /* if running suidperl */
1807#ifdef HAS_SETEUID
1808 (void)seteuid(uid); /* musn't stay setuid root */
1809#else
1810#ifdef HAS_SETREUID
85e6fe83
LW
1811 (void)setreuid((Uid_t)-1, uid);
1812#else
1813#ifdef HAS_SETRESUID
1814 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
79072805
LW
1815#else
1816 setuid(uid);
1817#endif
1818#endif
85e6fe83 1819#endif
79072805 1820 if (geteuid() != uid)
463ee0b2 1821 croak("Can't do seteuid!\n");
79072805
LW
1822 }
1823#endif /* IAMSUID */
46fc3d4c
PP
1824 rsfp = my_popen(SvPVX(cmd), "r");
1825 SvREFCNT_dec(cmd);
1826 SvREFCNT_dec(cpp);
79072805
LW
1827 }
1828 else if (!*scriptname) {
bbce6d69 1829 forbid_setid("program input from stdin");
760ac839 1830 rsfp = PerlIO_stdin();
79072805 1831 }
96436eeb 1832 else {
760ac839 1833 rsfp = PerlIO_open(scriptname,"r");
96436eeb 1834#if defined(HAS_FCNTL) && defined(F_SETFD)
7aa04957
CS
1835 if (rsfp)
1836 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb
PP
1837#endif
1838 }
5dd60ef7
PP
1839 if (e_tmpname) {
1840 e_fp = rsfp;
1841 }
7aa04957 1842 if (!rsfp) {
13281fa4 1843#ifdef DOSUID
a687059c 1844#ifndef IAMSUID /* in case script is not readable before setuid */
a0d0e21e 1845 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
13281fa4 1846 statbuf.st_mode & (S_ISUID|S_ISGID)) {
46fc3d4c
PP
1847 /* try again */
1848 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
463ee0b2 1849 croak("Can't do setuid\n");
13281fa4
LW
1850 }
1851#endif
1852#endif
463ee0b2 1853 croak("Can't open perl script \"%s\": %s\n",
2304df62 1854 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
13281fa4 1855 }
79072805 1856}
8d063cd8 1857
79072805 1858static void
96436eeb 1859validate_suid(validarg, scriptname)
79072805 1860char *validarg;
96436eeb 1861char *scriptname;
79072805 1862{
96436eeb
PP
1863 int which;
1864
13281fa4
LW
1865 /* do we need to emulate setuid on scripts? */
1866
1867 /* This code is for those BSD systems that have setuid #! scripts disabled
1868 * in the kernel because of a security problem. Merely defining DOSUID
1869 * in perl will not fix that problem, but if you have disabled setuid
1870 * scripts in the kernel, this will attempt to emulate setuid and setgid
1871 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW
1872 * root version must be called suidperl or sperlN.NNN. If regular perl
1873 * discovers that it has opened a setuid script, it calls suidperl with
1874 * the same argv that it had. If suidperl finds that the script it has
1875 * just opened is NOT setuid root, it sets the effective uid back to the
1876 * uid. We don't just make perl setuid root because that loses the
1877 * effective uid we had before invoking perl, if it was different from the
1878 * uid.
13281fa4
LW
1879 *
1880 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1881 * be defined in suidperl only. suidperl must be setuid root. The
1882 * Configure script will set this up for you if you want it.
1883 */
a687059c 1884
13281fa4 1885#ifdef DOSUID
6e72f9df 1886 char *s, *s2;
a0d0e21e 1887
760ac839 1888 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
463ee0b2 1889 croak("Can't stat script \"%s\"",origfilename);
96436eeb 1890 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 1891 I32 len;
13281fa4 1892
a687059c 1893#ifdef IAMSUID
fe14fcc3 1894#ifndef HAS_SETREUID
a687059c
LW
1895 /* On this access check to make sure the directories are readable,
1896 * there is actually a small window that the user could use to make
1897 * filename point to an accessible directory. So there is a faint
1898 * chance that someone could execute a setuid script down in a
1899 * non-accessible directory. I don't know what to do about that.
1900 * But I don't think it's too important. The manual lies when
1901 * it says access() is useful in setuid programs.
1902 */
463ee0b2
LW
1903 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1904 croak("Permission denied");
a687059c
LW
1905#else
1906 /* If we can swap euid and uid, then we can determine access rights
1907 * with a simple stat of the file, and then compare device and
1908 * inode to make sure we did stat() on the same file we opened.
1909 * Then we just have to make sure he or she can execute it.
1910 */
1911 {
1912 struct stat tmpstatbuf;
1913
85e6fe83
LW
1914 if (
1915#ifdef HAS_SETREUID
1916 setreuid(euid,uid) < 0
a0d0e21e
LW
1917#else
1918# if HAS_SETRESUID
85e6fe83 1919 setresuid(euid,uid,(Uid_t)-1) < 0
a0d0e21e 1920# endif
85e6fe83
LW
1921#endif
1922 || getuid() != euid || geteuid() != uid)
463ee0b2 1923 croak("Can't swap uid and euid"); /* really paranoid */
a0d0e21e 1924 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
463ee0b2 1925 croak("Permission denied"); /* testing full pathname here */
a687059c
LW
1926 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1927 tmpstatbuf.st_ino != statbuf.st_ino) {
760ac839 1928 (void)PerlIO_close(rsfp);
79072805 1929 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
760ac839 1930 PerlIO_printf(rsfp,
ff0cee69
PP
1931"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
1932(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
1933 (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
1934 (long)statbuf.st_dev, (long)statbuf.st_ino,
463ee0b2 1935 SvPVX(GvSV(curcop->cop_filegv)),
ff0cee69 1936 (long)statbuf.st_uid, (long)statbuf.st_gid);
79072805 1937 (void)my_pclose(rsfp);
a687059c 1938 }
463ee0b2 1939 croak("Permission denied\n");
a687059c 1940 }
85e6fe83
LW
1941 if (
1942#ifdef HAS_SETREUID
1943 setreuid(uid,euid) < 0
a0d0e21e
LW
1944#else
1945# if defined(HAS_SETRESUID)
85e6fe83 1946 setresuid(uid,euid,(Uid_t)-1) < 0
a0d0e21e 1947# endif
85e6fe83
LW
1948#endif
1949 || getuid() != uid || geteuid() != euid)
463ee0b2 1950 croak("Can't reswap uid and euid");
27e2fb84 1951 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
463ee0b2 1952 croak("Permission denied\n");
a687059c 1953 }
fe14fcc3 1954#endif /* HAS_SETREUID */
a687059c
LW
1955#endif /* IAMSUID */
1956
27e2fb84 1957 if (!S_ISREG(statbuf.st_mode))
463ee0b2 1958 croak("Permission denied");
27e2fb84 1959 if (statbuf.st_mode & S_IWOTH)
463ee0b2 1960 croak("Setuid/gid script is writable by world");
13281fa4 1961 doswitches = FALSE; /* -s is insecure in suid */
79072805 1962 curcop->cop_line++;
760ac839
LW
1963 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1964 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
463ee0b2 1965 croak("No #! line");
760ac839 1966 s = SvPV(linestr,na)+2;
663a0e37 1967 if (*s == ' ') s++;
45d8adaa 1968 while (!isSPACE(*s)) s++;
760ac839 1969 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
6e72f9df
PP
1970 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1971 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
463ee0b2 1972 croak("Not a perl script");
a687059c 1973 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW
1974 /*
1975 * #! arg must be what we saw above. They can invoke it by
1976 * mentioning suidperl explicitly, but they may not add any strange
1977 * arguments beyond what #! says if they do invoke suidperl that way.
1978 */
1979 len = strlen(validarg);
1980 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 1981 strnNE(s,validarg,len) || !isSPACE(s[len]))
463ee0b2 1982 croak("Args must match #! line");
a687059c
LW
1983
1984#ifndef IAMSUID
1985 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1986 euid == statbuf.st_uid)
1987 if (!do_undump)
463ee0b2 1988 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
1989FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1990#endif /* IAMSUID */
13281fa4
LW
1991
1992 if (euid) { /* oops, we're not the setuid root perl */
760ac839 1993 (void)PerlIO_close(rsfp);
13281fa4 1994#ifndef IAMSUID
46fc3d4c
PP
1995 /* try again */
1996 execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
13281fa4 1997#endif
463ee0b2 1998 croak("Can't do setuid\n");
13281fa4
LW
1999 }
2000
83025b21 2001 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
fe14fcc3 2002#ifdef HAS_SETEGID
a687059c
LW
2003 (void)setegid(statbuf.st_gid);
2004#else
fe14fcc3 2005#ifdef HAS_SETREGID
85e6fe83
LW
2006 (void)setregid((Gid_t)-1,statbuf.st_gid);
2007#else
2008#ifdef HAS_SETRESGID
2009 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
a687059c
LW
2010#else
2011 setgid(statbuf.st_gid);
2012#endif
2013#endif
85e6fe83 2014#endif
83025b21 2015 if (getegid() != statbuf.st_gid)
463ee0b2 2016 croak("Can't do setegid!\n");
83025b21 2017 }
a687059c
LW
2018 if (statbuf.st_mode & S_ISUID) {
2019 if (statbuf.st_uid != euid)
fe14fcc3 2020#ifdef HAS_SETEUID
a687059c
LW
2021 (void)seteuid(statbuf.st_uid); /* all that for this */
2022#else
fe14fcc3 2023#ifdef HAS_SETREUID
85e6fe83
LW
2024 (void)setreuid((Uid_t)-1,statbuf.st_uid);
2025#else
2026#ifdef HAS_SETRESUID
2027 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
a687059c
LW
2028#else
2029 setuid(statbuf.st_uid);
2030#endif
2031#endif
85e6fe83 2032#endif
83025b21 2033 if (geteuid() != statbuf.st_uid)
463ee0b2 2034 croak("Can't do seteuid!\n");
a687059c 2035 }
83025b21 2036 else if (uid) { /* oops, mustn't run as root */
fe14fcc3 2037#ifdef HAS_SETEUID
85e6fe83 2038 (void)seteuid((Uid_t)uid);
a687059c 2039#else
fe14fcc3 2040#ifdef HAS_SETREUID
85e6fe83 2041 (void)setreuid((Uid_t)-1,(Uid_t)uid);
a687059c 2042#else
85e6fe83
LW
2043#ifdef HAS_SETRESUID
2044 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
2045#else
2046 setuid((Uid_t)uid);
2047#endif
a687059c
LW
2048#endif
2049#endif
83025b21 2050 if (geteuid() != uid)
463ee0b2 2051 croak("Can't do seteuid!\n");
83025b21 2052 }
748a9306 2053 init_ids();
27e2fb84 2054 if (!cando(S_IXUSR,TRUE,&statbuf))
463ee0b2 2055 croak("Permission denied\n"); /* they can't do this */
13281fa4
LW
2056 }
2057#ifdef IAMSUID
2058 else if (preprocess)
463ee0b2 2059 croak("-P not allowed for setuid/setgid script\n");
96436eeb
PP
2060 else if (fdscript >= 0)
2061 croak("fd script not allowed in suidperl\n");
13281fa4 2062 else
463ee0b2 2063 croak("Script is not setuid/setgid in suidperl\n");
96436eeb
PP
2064
2065 /* We absolutely must clear out any saved ids here, so we */
2066 /* exec the real perl, substituting fd script for scriptname. */
2067 /* (We pass script name as "subdir" of fd, which perl will grok.) */
760ac839
LW
2068 PerlIO_rewind(rsfp);
2069 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
96436eeb
PP
2070 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
2071 if (!origargv[which])
2072 croak("Permission denied");
46fc3d4c
PP
2073 origargv[which] = savepv(form("/dev/fd/%d/%s",
2074 PerlIO_fileno(rsfp), origargv[which]));
96436eeb 2075#if defined(HAS_FCNTL) && defined(F_SETFD)
760ac839 2076 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 2077#endif
46fc3d4c 2078 execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
96436eeb 2079 croak("Can't do setuid\n");
13281fa4 2080#endif /* IAMSUID */
a687059c 2081#else /* !DOSUID */
a687059c
LW
2082 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
2083#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
760ac839 2084 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
a687059c
LW
2085 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
2086 ||
2087 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
2088 )
2089 if (!do_undump)
463ee0b2 2090 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
2091FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2092#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2093 /* not set-id, must be wrapped */
a687059c 2094 }
13281fa4 2095#endif /* DOSUID */
79072805 2096}
13281fa4 2097
79072805
LW
2098static void
2099find_beginning()
2100{
6e72f9df 2101 register char *s, *s2;
33b78306
LW
2102
2103 /* skip forward in input to the real script? */
2104
bbce6d69 2105 forbid_setid("-x");
33b78306 2106 while (doextract) {
79072805 2107 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
463ee0b2 2108 croak("No Perl script found in input\n");
6e72f9df 2109 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
760ac839 2110 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
33b78306 2111 doextract = FALSE;
6e72f9df
PP
2112 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2113 s2 = s;
2114 while (*s == ' ' || *s == '\t') s++;
2115 if (*s++ == '-') {
2116 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2117 if (strnEQ(s2-4,"perl",4))
2118 /*SUPPRESS 530*/
2119 while (s = moreswitches(s)) ;
33b78306 2120 }
79072805 2121 if (cddir && chdir(cddir) < 0)
463ee0b2 2122 croak("Can't chdir to %s",cddir);
83025b21
LW
2123 }
2124 }
2125}
2126
79072805 2127static void
748a9306 2128init_ids()
352d5a3a 2129{
748a9306
LW
2130 uid = (int)getuid();
2131 euid = (int)geteuid();
2132 gid = (int)getgid();
2133 egid = (int)getegid();
2134#ifdef VMS
2135 uid |= gid << 16;
2136 euid |= egid << 16;
2137#endif
4633a7c4 2138 tainting |= (uid && (euid != uid || egid != gid));
748a9306 2139}
79072805 2140
748a9306 2141static void
bbce6d69
PP
2142forbid_setid(s)
2143char *s;
2144{
2145 if (euid != uid)
2146 croak("No %s allowed while running setuid", s);
2147 if (egid != gid)
2148 croak("No %s allowed while running setgid", s);
2149}
2150
2151static void
748a9306
LW
2152init_debugger()
2153{
79072805 2154 curstash = debstash;
748a9306 2155 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
79072805 2156 AvREAL_off(dbargs);
a0d0e21e
LW
2157 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2158 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
748a9306
LW
2159 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2160 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
c07a80fd 2161 sv_setiv(DBsingle, 0);
748a9306 2162 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
c07a80fd 2163 sv_setiv(DBtrace, 0);
748a9306 2164 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
c07a80fd 2165 sv_setiv(DBsignal, 0);
79072805 2166 curstash = defstash;
352d5a3a
LW
2167}
2168
79072805 2169static void
8990e307 2170init_stacks()
79072805 2171{
6e72f9df 2172 curstack = newAV();
5f05dabc
PP
2173 mainstack = curstack; /* remember in case we switch stacks */
2174 AvREAL_off(curstack); /* not a real array */
6e72f9df 2175 av_extend(curstack,127);
79072805 2176
6e72f9df 2177 stack_base = AvARRAY(curstack);
79072805 2178 stack_sp = stack_base;
8990e307 2179 stack_max = stack_base + 127;
79072805 2180
5f05dabc
PP
2181 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
2182 New(50,cxstack,cxstack_max + 1,CONTEXT);
2183 cxstack_ix = -1;
2184
2185 New(50,tmps_stack,128,SV*);
2186 tmps_ix = -1;
2187 tmps_max = 128;
2188
2189 DEBUG( {
2190 New(51,debname,128,char);
2191 New(52,debdelim,128,char);
2192 } )
2193
2194 /*
2195 * The following stacks almost certainly should be per-interpreter,
2196 * but for now they're not. XXX
2197 */
2198
6e72f9df
PP
2199 if (markstack) {
2200 markstack_ptr = markstack;
2201 } else {
2202 New(54,markstack,64,I32);
2203 markstack_ptr = markstack;
2204 markstack_max = markstack + 64;
2205 }
79072805 2206
6e72f9df
PP
2207 if (scopestack) {
2208 scopestack_ix = 0;
2209 } else {
2210 New(54,scopestack,32,I32);
2211 scopestack_ix = 0;
2212 scopestack_max = 32;
2213 }
79072805 2214
6e72f9df
PP
2215 if (savestack) {
2216 savestack_ix = 0;
2217 } else {
2218 New(54,savestack,128,ANY);
2219 savestack_ix = 0;
2220 savestack_max = 128;
2221 }
79072805 2222
6e72f9df
PP
2223 if (retstack) {
2224 retstack_ix = 0;
2225 } else {
2226 New(54,retstack,16,OP*);
2227 retstack_ix = 0;
2228 retstack_max = 16;
5f05dabc 2229 }
378cc40b 2230}
33b78306 2231
6e72f9df
PP
2232static void
2233nuke_stacks()
2234{
2235 Safefree(cxstack);
2236 Safefree(tmps_stack);
5f05dabc
PP
2237 DEBUG( {
2238 Safefree(debname);
2239 Safefree(debdelim);
2240 } )
6e72f9df
PP
2241}
2242
760ac839 2243static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
7aa04957 2244
79072805 2245static void
8990e307
LW
2246init_lexer()
2247{
a0d0e21e 2248 tmpfp = rsfp;
8990e307
LW
2249 lex_start(linestr);
2250 rsfp = tmpfp;
2251 subname = newSVpv("main",4);
2252}
2253
2254static void
79072805 2255init_predump_symbols()
45d8adaa 2256{
93a17b20 2257 GV *tmpgv;
a0d0e21e 2258 GV *othergv;
79072805 2259
85e6fe83 2260 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
79072805 2261
85e6fe83 2262 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
a5f75d66 2263 GvMULTI_on(stdingv);
760ac839 2264 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
adbc6bb1 2265 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 2266 GvMULTI_on(tmpgv);
a0d0e21e 2267 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
79072805 2268
85e6fe83 2269 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 2270 GvMULTI_on(tmpgv);
760ac839 2271 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
4633a7c4 2272 setdefout(tmpgv);
adbc6bb1 2273 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 2274 GvMULTI_on(tmpgv);
a0d0e21e 2275 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
79072805 2276
a0d0e21e 2277 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
a5f75d66 2278 GvMULTI_on(othergv);
760ac839 2279 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
adbc6bb1 2280 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 2281 GvMULTI_on(tmpgv);
a0d0e21e 2282 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
79072805
LW
2283
2284 statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 2285
6e72f9df
PP
2286 if (!osname)
2287 osname = savepv(OSNAME);
79072805 2288}
33b78306 2289
79072805
LW
2290static void
2291init_postdump_symbols(argc,argv,env)
2292register int argc;
2293register char **argv;
2294register char **env;
33b78306 2295{
79072805
LW
2296 char *s;
2297 SV *sv;
2298 GV* tmpgv;
fe14fcc3 2299
79072805
LW
2300 argc--,argv++; /* skip name of script */
2301 if (doswitches) {
2302 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2303 if (!argv[0][1])
2304 break;
2305 if (argv[0][1] == '-') {
2306 argc--,argv++;
2307 break;
2308 }
93a17b20 2309 if (s = strchr(argv[0], '=')) {
79072805 2310 *s++ = '\0';
85e6fe83 2311 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW
2312 }
2313 else
85e6fe83 2314 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 2315 }
79072805
LW
2316 }
2317 toptarget = NEWSV(0,0);
2318 sv_upgrade(toptarget, SVt_PVFM);
2319 sv_setpvn(toptarget, "", 0);
748a9306 2320 bodytarget = NEWSV(0,0);
79072805
LW
2321 sv_upgrade(bodytarget, SVt_PVFM);
2322 sv_setpvn(bodytarget, "", 0);
2323 formtarget = bodytarget;
2324
bbce6d69 2325 TAINT;
85e6fe83 2326 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
79072805
LW
2327 sv_setpv(GvSV(tmpgv),origfilename);
2328 magicname("0", "0", 1);
2329 }
85e6fe83 2330 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
79072805 2331 sv_setpv(GvSV(tmpgv),origargv[0]);
85e6fe83 2332 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
a5f75d66 2333 GvMULTI_on(argvgv);
79072805
LW
2334 (void)gv_AVadd(argvgv);
2335 av_clear(GvAVn(argvgv));
2336 for (; argc > 0; argc--,argv++) {
a0d0e21e 2337 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
79072805
LW
2338 }
2339 }
85e6fe83 2340 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
79072805 2341 HV *hv;
a5f75d66 2342 GvMULTI_on(envgv);
79072805 2343 hv = GvHVn(envgv);
5aabfad6 2344 hv_magic(hv, envgv, 'E');
a0d0e21e 2345#ifndef VMS /* VMS doesn't have environ array */
4633a7c4
LW
2346 /* Note that if the supplied env parameter is actually a copy
2347 of the global environ then it may now point to free'd memory
2348 if the environment has been modified since. To avoid this
2349 problem we treat env==NULL as meaning 'use the default'
2350 */
2351 if (!env)
2352 env = environ;
5aabfad6 2353 if (env != environ)
79072805
LW
2354 environ[0] = Nullch;
2355 for (; *env; env++) {
93a17b20 2356 if (!(s = strchr(*env,'=')))
79072805
LW
2357 continue;
2358 *s++ = '\0';
137443ea
PP
2359#ifdef WIN32
2360 (void)strupr(*env);
2361#endif
79072805
LW
2362 sv = newSVpv(s--,0);
2363 (void)hv_store(hv, *env, s - *env, sv, 0);
2364 *s = '=';
3e3baf6d
TB
2365#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2366 /* Sins of the RTL. See note in my_setenv(). */
2367 (void)putenv(savepv(*env));
2368#endif
fe14fcc3 2369 }
4550b24a
PP
2370#endif
2371#ifdef DYNAMIC_ENV_FETCH
2372 HvNAME(hv) = savepv(ENV_HV_NAME);
2373#endif
79072805 2374 }
bbce6d69 2375 TAINT_NOT;
85e6fe83 2376 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1e422769 2377 sv_setiv(GvSV(tmpgv), (IV)getpid());
33b78306 2378}
34de22dd 2379
79072805
LW
2380static void
2381init_perllib()
34de22dd 2382{
85e6fe83
LW
2383 char *s;
2384 if (!tainting) {
552a7a9b 2385#ifndef VMS
85e6fe83
LW
2386 s = getenv("PERL5LIB");
2387 if (s)
774d564b 2388 incpush(s, TRUE);
85e6fe83 2389 else
774d564b 2390 incpush(getenv("PERLLIB"), FALSE);
552a7a9b
PP
2391#else /* VMS */
2392 /* Treat PERL5?LIB as a possible search list logical name -- the
2393 * "natural" VMS idiom for a Unix path string. We allow each
2394 * element to be a set of |-separated directories for compatibility.
2395 */
2396 char buf[256];
2397 int idx = 0;
2398 if (my_trnlnm("PERL5LIB",buf,0))
774d564b 2399 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 2400 else
774d564b 2401 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
552a7a9b 2402#endif /* VMS */
85e6fe83 2403 }
34de22dd 2404
c90c0ff4 2405/* Use the ~-expanded versions of APPLLIB (undocumented),
df5cef82
PP
2406 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2407*/
4633a7c4 2408#ifdef APPLLIB_EXP
774d564b 2409 incpush(APPLLIB_EXP, FALSE);
16d20bd9 2410#endif
4633a7c4 2411
fed7345c 2412#ifdef ARCHLIB_EXP
774d564b 2413 incpush(ARCHLIB_EXP, FALSE);
a0d0e21e 2414#endif
fed7345c
AD
2415#ifndef PRIVLIB_EXP
2416#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 2417#endif
774d564b 2418 incpush(PRIVLIB_EXP, FALSE);
4633a7c4
LW
2419
2420#ifdef SITEARCH_EXP
774d564b 2421 incpush(SITEARCH_EXP, FALSE);
4633a7c4
LW
2422#endif
2423#ifdef SITELIB_EXP
774d564b 2424 incpush(SITELIB_EXP, FALSE);
4633a7c4
LW
2425#endif
2426#ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
774d564b 2427 incpush(OLDARCHLIB_EXP, FALSE);
4633a7c4 2428#endif
a0d0e21e 2429
4633a7c4 2430 if (!tainting)
774d564b
PP
2431 incpush(".", FALSE);
2432}
2433
2434#if defined(DOSISH)
2435# define PERLLIB_SEP ';'
2436#else
2437# if defined(VMS)
2438# define PERLLIB_SEP '|'
2439# else
2440# define PERLLIB_SEP ':'
2441# endif
2442#endif
2443#ifndef PERLLIB_MANGLE
2444# define PERLLIB_MANGLE(s,n) (s)
2445#endif
2446
2447static void
2448incpush(p, addsubdirs)
2449char *p;
2450int addsubdirs;
2451{
2452 SV *subdir = Nullsv;
2453 static char *archpat_auto;
2454
2455 if (!p)
2456 return;
2457
2458 if (addsubdirs) {
2459 subdir = newSV(0);
2460 if (!archpat_auto) {
2461 STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
2462 + sizeof("//auto"));
2463 New(55, archpat_auto, len, char);
2464 sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
aa689395
PP
2465#ifdef VMS
2466 for (len = sizeof(ARCHNAME) + 2;
2467 archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
2468 if (archpat_auto[len] == '.') archpat_auto[len] = '_';
2469#endif
774d564b
PP
2470 }
2471 }
2472
2473 /* Break at all separators */
2474 while (p && *p) {
2475 SV *libdir = newSV(0);
2476 char *s;
2477
2478 /* skip any consecutive separators */
2479 while ( *p == PERLLIB_SEP ) {
2480 /* Uncomment the next line for PATH semantics */
2481 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
2482 p++;
2483 }
2484
2485 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2486 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2487 (STRLEN)(s - p));
2488 p = s + 1;
2489 }
2490 else {
2491 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2492 p = Nullch; /* break out */
2493 }
2494
2495 /*
2496 * BEFORE pushing libdir onto @INC we may first push version- and
2497 * archname-specific sub-directories.
2498 */
2499 if (addsubdirs) {
2500 struct stat tmpstatbuf;
aa689395
PP
2501#ifdef VMS
2502 char *unix;
2503 STRLEN len;
774d564b 2504
aa689395
PP
2505 if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
2506 len = strlen(unix);
2507 while (unix[len-1] == '/') len--; /* Cosmetic */
2508 sv_usepvn(libdir,unix,len);
2509 }
2510 else
2511 PerlIO_printf(PerlIO_stderr(),
2512 "Failed to unixify @INC element \"%s\"\n",
2513 SvPV(libdir,na));
2514#endif
4fdae800 2515 /* .../archname/version if -d .../archname/version/auto */
774d564b
PP
2516 sv_setsv(subdir, libdir);
2517 sv_catpv(subdir, archpat_auto);
2518 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2519 S_ISDIR(tmpstatbuf.st_mode))
2520 av_push(GvAVn(incgv),
2521 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2522
4fdae800 2523 /* .../archname if -d .../archname/auto */
774d564b
PP
2524 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2525 strlen(patchlevel) + 1, "", 0);
2526 if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2527 S_ISDIR(tmpstatbuf.st_mode))
2528 av_push(GvAVn(incgv),
2529 newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2530 }
2531
2532 /* finally push this lib directory on the end of @INC */
2533 av_push(GvAVn(incgv), libdir);
2534 }
2535
2536 SvREFCNT_dec(subdir);
34de22dd 2537}
93a17b20
LW
2538
2539void
68dc0745 2540call_list(oldscope, list)
2ae324a7 2541I32 oldscope;
93a17b20
LW
2542AV* list;
2543{
a0d0e21e 2544 line_t oldline = curcop->cop_line;
22921e25
CS
2545 STRLEN len;
2546 dJMPENV;
2547 int ret;
93a17b20 2548
8990e307
LW
2549 while (AvFILL(list) >= 0) {
2550 CV *cv = (CV*)av_shift(list);
93a17b20 2551
8990e307 2552 SAVEFREESV(cv);
a0d0e21e 2553
22921e25
CS
2554 JMPENV_PUSH(ret);
2555 switch (ret) {
748a9306 2556 case 0: {
4633a7c4 2557 SV* atsv = GvSV(errgv);
748a9306
LW
2558 PUSHMARK(stack_sp);
2559 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2560 (void)SvPV(atsv, len);
2561 if (len) {
54310121 2562 JMPENV_POP;
748a9306
LW
2563 curcop = &compiling;
2564 curcop->cop_line = oldline;
2565 if (list == beginav)
2566 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2567 else
2568 sv_catpv(atsv, "END failed--cleanup aborted");
2ae324a7
PP
2569 while (scopestack_ix > oldscope)
2570 LEAVE;
748a9306
LW
2571 croak("%s", SvPVX(atsv));
2572 }
a0d0e21e 2573 }
85e6fe83
LW
2574 break;
2575 case 1:
f86702cc 2576 STATUS_ALL_FAILURE;
85e6fe83
LW
2577 /* FALL THROUGH */
2578 case 2:
2579 /* my_exit() was called */
2ae324a7
PP
2580 while (scopestack_ix > oldscope)
2581 LEAVE;
85e6fe83
LW
2582 curstash = defstash;
2583 if (endav)
68dc0745 2584 call_list(oldscope, endav);
a0d0e21e 2585 FREETMPS;
54310121 2586 JMPENV_POP;
a0d0e21e
LW
2587 curcop = &compiling;
2588 curcop->cop_line = oldline;
85e6fe83
LW
2589 if (statusvalue) {
2590 if (list == beginav)
a0d0e21e 2591 croak("BEGIN failed--compilation aborted");
85e6fe83 2592 else
a0d0e21e 2593 croak("END failed--cleanup aborted");
85e6fe83 2594 }
f86702cc 2595 my_exit_jump();
85e6fe83 2596 /* NOTREACHED */
85e6fe83
LW
2597 case 3:
2598 if (!restartop) {
760ac839 2599 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
a0d0e21e 2600 FREETMPS;
85e6fe83
LW
2601 break;
2602 }
54310121 2603 JMPENV_POP;
a0d0e21e
LW
2604 curcop = &compiling;
2605 curcop->cop_line = oldline;
54310121 2606 JMPENV_JUMP(3);
8990e307 2607 }
54310121 2608 JMPENV_POP;
93a17b20 2609 }
93a17b20
LW
2610}
2611
f86702cc
PP
2612void
2613my_exit(status)
2614U32 status;
2615{
2616 switch (status) {
2617 case 0:
2618 STATUS_ALL_SUCCESS;
2619 break;
2620 case 1:
2621 STATUS_ALL_FAILURE;
2622 break;
2623 default:
2624 STATUS_NATIVE_SET(status);
2625 break;
2626 }
2627 my_exit_jump();
2628}
2629
2630void
2631my_failure_exit()
2632{
2633#ifdef VMS
2634 if (vaxc$errno & 1) {
4fdae800
PP
2635 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
2636 STATUS_NATIVE_SET(44);
f86702cc
PP
2637 }
2638 else {
ff0cee69 2639 if (!vaxc$errno && errno) /* unlikely */
4fdae800 2640 STATUS_NATIVE_SET(44);
f86702cc 2641 else
4fdae800 2642 STATUS_NATIVE_SET(vaxc$errno);
f86702cc
PP
2643 }
2644#else
2645 if (errno & 255)
2646 STATUS_POSIX_SET(errno);
2647 else if (STATUS_POSIX == 0)
2648 STATUS_POSIX_SET(255);
2649#endif
2650 my_exit_jump();
2651}
2652
2653static void
2654my_exit_jump()
2655{
2656 register CONTEXT *cx;
2657 I32 gimme;
2658 SV **newsp;
2659
2660 if (e_tmpname) {
2661 if (e_fp) {
2662 PerlIO_close(e_fp);
2663 e_fp = Nullfp;
2664 }
2665 (void)UNLINK(e_tmpname);
2666 Safefree(e_tmpname);
2667 e_tmpname = Nullch;
2668 }
2669
2670 if (cxstack_ix >= 0) {
2671 if (cxstack_ix > 0)
2672 dounwind(0);
2673 POPBLOCK(cx,curpm);
2674 LEAVE;
2675 }
ff0cee69 2676
54310121 2677 JMPENV_JUMP(2);
f86702cc 2678}