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