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