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