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