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