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