This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pod/perlipc.pod patch
[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
36477c24 124 SET_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
36477c24
PP
829 if (perldb && curstash != debstash
830 /* Handle first BEGIN of -d. */
831 && (DBcv || (DBcv = GvCV(DBsub)))
832 /* Try harder, since this may have been a sighandler, thus
833 * curstash may be meaningless. */
834 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
6e72f9df
PP
835 op->op_private |= OPpENTERSUB_DB;
836
a0d0e21e 837 if (flags & G_EVAL) {
a5f75d66 838 Copy(top_env, oldtop, 1, Sigjmp_buf);
a0d0e21e
LW
839
840 cLOGOP->op_other = op;
841 markstack_ptr--;
4633a7c4
LW
842 /* we're trying to emulate pp_entertry() here */
843 {
844 register CONTEXT *cx;
845 I32 gimme = GIMME;
846
847 ENTER;
848 SAVETMPS;
849
850 push_return(op->op_next);
851 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
852 PUSHEVAL(cx, 0, 0);
853 eval_root = op; /* Only needed so that goto works right. */
854
855 in_eval = 1;
856 if (flags & G_KEEPERR)
857 in_eval |= 4;
858 else
859 sv_setpv(GvSV(errgv),"");
860 }
a0d0e21e
LW
861 markstack_ptr++;
862
863 restart:
a5f75d66 864 switch (Sigsetjmp(top_env,1)) {
a0d0e21e
LW
865 case 0:
866 break;
867 case 1:
748a9306 868#ifdef VMS
a0d0e21e 869 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
748a9306
LW
870#else
871 statusvalue = 1;
872#endif
a0d0e21e
LW
873 /* FALL THROUGH */
874 case 2:
875 /* my_exit() was called */
876 curstash = defstash;
877 FREETMPS;
a5f75d66 878 Copy(oldtop, top_env, 1, Sigjmp_buf);
a0d0e21e
LW
879 if (statusvalue)
880 croak("Callback called exit");
881 my_exit(statusvalue);
882 /* NOTREACHED */
883 case 3:
884 if (restartop) {
885 op = restartop;
886 restartop = 0;
887 goto restart;
888 }
889 stack_sp = stack_base + oldmark;
890 if (flags & G_ARRAY)
891 retval = 0;
892 else {
893 retval = 1;
894 *++stack_sp = &sv_undef;
895 }
896 goto cleanup;
897 }
898 }
899
900 if (op == (OP*)&myop)
901 op = pp_entersub();
902 if (op)
ab821d7f 903 runops();
a0d0e21e 904 retval = stack_sp - (stack_base + oldmark);
4633a7c4
LW
905 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
906 sv_setpv(GvSV(errgv),"");
a0d0e21e
LW
907
908 cleanup:
909 if (flags & G_EVAL) {
910 if (scopestack_ix > oldscope) {
a0a2876f
LW
911 SV **newsp;
912 PMOP *newpm;
913 I32 gimme;
914 register CONTEXT *cx;
915 I32 optype;
916
917 POPBLOCK(cx,newpm);
918 POPEVAL(cx);
919 pop_return();
920 curpm = newpm;
921 LEAVE;
a0d0e21e 922 }
a5f75d66 923 Copy(oldtop, top_env, 1, Sigjmp_buf);
a0d0e21e
LW
924 }
925 if (flags & G_DISCARD) {
926 stack_sp = stack_base + oldmark;
927 retval = 0;
928 FREETMPS;
929 LEAVE;
930 }
931 return retval;
932}
933
6e72f9df 934/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 935
a0d0e21e 936I32
4633a7c4 937perl_eval_sv(sv, flags)
8990e307 938SV* sv;
4633a7c4 939I32 flags; /* See G_* flags in cop.h */
a0d0e21e
LW
940{
941 UNOP myop; /* fake syntax tree node */
4633a7c4
LW
942 SV** sp = stack_sp;
943 I32 oldmark = sp - stack_base;
944 I32 retval;
a5f75d66 945 Sigjmp_buf oldtop;
4633a7c4 946 I32 oldscope;
79072805 947
4633a7c4
LW
948 if (flags & G_DISCARD) {
949 ENTER;
950 SAVETMPS;
951 }
952
79072805 953 SAVESPTR(op);
79072805 954 op = (OP*)&myop;
a0d0e21e 955 Zero(op, 1, UNOP);
4633a7c4
LW
956 EXTEND(stack_sp, 1);
957 *++stack_sp = sv;
958 oldscope = scopestack_ix;
79072805 959
4633a7c4
LW
960 if (!(flags & G_NOARGS))
961 myop.op_flags = OPf_STACKED;
79072805 962 myop.op_next = Nullop;
6e72f9df 963 myop.op_type = OP_ENTEREVAL;
4633a7c4 964 myop.op_flags |= OPf_KNOW;
6e72f9df
PP
965 if (flags & G_KEEPERR)
966 myop.op_flags |= OPf_SPECIAL;
4633a7c4 967 if (flags & G_ARRAY)
6e72f9df 968 myop.op_flags |= OPf_LIST;
79072805 969
a5f75d66 970 Copy(top_env, oldtop, 1, Sigjmp_buf);
4633a7c4
LW
971
972restart:
a5f75d66 973 switch (Sigsetjmp(top_env,1)) {
4633a7c4
LW
974 case 0:
975 break;
976 case 1:
977#ifdef VMS
978 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
979#else
980 statusvalue = 1;
981#endif
982 /* FALL THROUGH */
983 case 2:
984 /* my_exit() was called */
985 curstash = defstash;
986 FREETMPS;
a5f75d66 987 Copy(oldtop, top_env, 1, Sigjmp_buf);
4633a7c4
LW
988 if (statusvalue)
989 croak("Callback called exit");
990 my_exit(statusvalue);
991 /* NOTREACHED */
992 case 3:
993 if (restartop) {
994 op = restartop;
995 restartop = 0;
996 goto restart;
997 }
998 stack_sp = stack_base + oldmark;
999 if (flags & G_ARRAY)
1000 retval = 0;
1001 else {
1002 retval = 1;
1003 *++stack_sp = &sv_undef;
1004 }
1005 goto cleanup;
1006 }
1007
1008 if (op == (OP*)&myop)
1009 op = pp_entereval();
1010 if (op)
ab821d7f 1011 runops();
4633a7c4 1012 retval = stack_sp - (stack_base + oldmark);
6e72f9df 1013 if (!(flags & G_KEEPERR))
4633a7c4
LW
1014 sv_setpv(GvSV(errgv),"");
1015
1016 cleanup:
a5f75d66 1017 Copy(oldtop, top_env, 1, Sigjmp_buf);
4633a7c4
LW
1018 if (flags & G_DISCARD) {
1019 stack_sp = stack_base + oldmark;
1020 retval = 0;
1021 FREETMPS;
1022 LEAVE;
1023 }
1024 return retval;
1025}
1026
1027/* Require a module. */
1028
1029void
1030perl_require_pv(pv)
1031char* pv;
1032{
1033 SV* sv = sv_newmortal();
1034 sv_setpv(sv, "require '");
1035 sv_catpv(sv, pv);
1036 sv_catpv(sv, "'");
1037 perl_eval_sv(sv, G_DISCARD);
79072805
LW
1038}
1039
79072805 1040void
79072805
LW
1041magicname(sym,name,namlen)
1042char *sym;
1043char *name;
1044I32 namlen;
1045{
1046 register GV *gv;
1047
85e6fe83 1048 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
79072805
LW
1049 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1050}
1051
748a9306
LW
1052#if defined(DOSISH)
1053# define PERLLIB_SEP ';'
79072805 1054#else
232e078e
AD
1055# if defined(VMS)
1056# define PERLLIB_SEP '|'
1057# else
748a9306 1058# define PERLLIB_SEP ':'
232e078e 1059# endif
79072805 1060#endif
760ac839
LW
1061#ifndef PERLLIB_MANGLE
1062# define PERLLIB_MANGLE(s,n) (s)
1063#endif
79072805
LW
1064
1065static void
1066incpush(p)
1067char *p;
1068{
1069 char *s;
1070
1071 if (!p)
1072 return;
1073
1074 /* Break at all separators */
1075 while (*p) {
1076 /* First, skip any consecutive separators */
1077 while ( *p == PERLLIB_SEP ) {
1078 /* Uncomment the next line for PATH semantics */
a0d0e21e 1079 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
79072805
LW
1080 p++;
1081 }
93a17b20 1082 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
760ac839
LW
1083 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)),
1084 (STRLEN)(s - p)));
79072805
LW
1085 p = s + 1;
1086 } else {
760ac839 1087 av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0));
79072805
LW
1088 break;
1089 }
1090 }
1091}
1092
ab821d7f 1093static void
1a30305b 1094usage(name) /* XXX move this out into a module ? */
4633a7c4
LW
1095char *name;
1096{
ab821d7f
PP
1097 /* This message really ought to be max 23 lines.
1098 * Removed -h because the user already knows that opton. Others? */
1099 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
4633a7c4 1100 printf("\n -0[octal] specify record separator (\\0, if no argument)");
ab821d7f 1101 printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
4633a7c4 1102 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1a30305b 1103 printf("\n -d[:debugger] run scripts under debugger");
4633a7c4 1104 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
ab821d7f
PP
1105 printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
1106 printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
4633a7c4 1107 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
ab821d7f 1108 printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
4633a7c4 1109 printf("\n -l[octal] enable line ending processing, specifies line teminator");
ab821d7f 1110 printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
4633a7c4
LW
1111 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
1112 printf("\n -p assume loop like -n but print line also like sed");
1113 printf("\n -P run script through C preprocessor before compilation");
4633a7c4
LW
1114 printf("\n -s enable some switch parsing for switches after script name");
1115 printf("\n -S look for the script using PATH environment variable");
1116 printf("\n -T turn on tainting checks");
1117 printf("\n -u dump core after parsing script");
1118 printf("\n -U allow unsafe operations");
1119 printf("\n -v print version number and patchlevel of perl");
1a30305b 1120 printf("\n -V[:variable] print perl configuration information");
ab821d7f 1121 printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
4633a7c4
LW
1122 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
1123}
1124
79072805
LW
1125/* This routine handles any switches that can be given during run */
1126
1127char *
1128moreswitches(s)
1129char *s;
1130{
1131 I32 numlen;
c07a80fd 1132 U32 rschar;
79072805
LW
1133
1134 switch (*s) {
1135 case '0':
c07a80fd
PP
1136 rschar = scan_oct(s, 4, &numlen);
1137 SvREFCNT_dec(nrs);
1138 if (rschar & ~((U8)~0))
1139 nrs = &sv_undef;
1140 else if (!rschar && numlen >= 2)
1141 nrs = newSVpv("", 0);
1142 else {
1143 char ch = rschar;
1144 nrs = newSVpv(&ch, 1);
79072805
LW
1145 }
1146 return s + numlen;
2304df62
AD
1147 case 'F':
1148 minus_F = TRUE;
a0d0e21e 1149 splitstr = savepv(s + 1);
2304df62
AD
1150 s += strlen(s);
1151 return s;
79072805
LW
1152 case 'a':
1153 minus_a = TRUE;
1154 s++;
1155 return s;
1156 case 'c':
1157 minus_c = TRUE;
1158 s++;
1159 return s;
1160 case 'd':
bbce6d69 1161 forbid_setid("-d");
4633a7c4 1162 s++;
c07a80fd 1163 if (*s == ':' || *s == '=') {
4633a7c4
LW
1164 sprintf(buf, "use Devel::%s;", ++s);
1165 s += strlen(s);
1166 my_setenv("PERL5DB",buf);
1167 }
a0d0e21e
LW
1168 if (!perldb) {
1169 perldb = TRUE;
1170 init_debugger();
1171 }
79072805
LW
1172 return s;
1173 case 'D':
1174#ifdef DEBUGGING
bbce6d69 1175 forbid_setid("-D");
79072805 1176 if (isALPHA(s[1])) {
8990e307 1177 static char debopts[] = "psltocPmfrxuLHXD";
79072805
LW
1178 char *d;
1179
93a17b20 1180 for (s++; *s && (d = strchr(debopts,*s)); s++)
79072805
LW
1181 debug |= 1 << (d - debopts);
1182 }
1183 else {
1184 debug = atoi(s+1);
1185 for (s++; isDIGIT(*s); s++) ;
1186 }
8990e307 1187 debug |= 0x80000000;
79072805
LW
1188#else
1189 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
a0d0e21e 1190 for (s++; isALNUM(*s); s++) ;
79072805
LW
1191#endif
1192 /*SUPPRESS 530*/
1193 return s;
4633a7c4
LW
1194 case 'h':
1195 usage(origargv[0]);
1196 exit(0);
79072805
LW
1197 case 'i':
1198 if (inplace)
1199 Safefree(inplace);
a0d0e21e 1200 inplace = savepv(s+1);
79072805
LW
1201 /*SUPPRESS 530*/
1202 for (s = inplace; *s && !isSPACE(*s); s++) ;
1203 *s = '\0';
1204 break;
1205 case 'I':
bbce6d69 1206 forbid_setid("-I");
79072805 1207 if (*++s) {
748a9306
LW
1208 char *e;
1209 for (e = s; *e && !isSPACE(*e); e++) ;
1210 av_push(GvAVn(incgv),newSVpv(s,e-s));
1211 if (*e)
1212 return e;
79072805
LW
1213 }
1214 else
463ee0b2 1215 croak("No space allowed after -I");
79072805
LW
1216 break;
1217 case 'l':
1218 minus_l = TRUE;
1219 s++;
a0d0e21e
LW
1220 if (ors)
1221 Safefree(ors);
79072805 1222 if (isDIGIT(*s)) {
a0d0e21e 1223 ors = savepv("\n");
79072805
LW
1224 orslen = 1;
1225 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1226 s += numlen;
1227 }
1228 else {
c07a80fd 1229 if (RsPARA(nrs)) {
6e72f9df 1230 ors = "\n\n";
c07a80fd
PP
1231 orslen = 2;
1232 }
1233 else
1234 ors = SvPV(nrs, orslen);
6e72f9df 1235 ors = savepvn(ors, orslen);
79072805
LW
1236 }
1237 return s;
1a30305b 1238 case 'M':
bbce6d69 1239 forbid_setid("-M"); /* XXX ? */
1a30305b
PP
1240 /* FALL THROUGH */
1241 case 'm':
bbce6d69 1242 forbid_setid("-m"); /* XXX ? */
1a30305b 1243 if (*++s) {
a5f75d66
AD
1244 char *start;
1245 char *use = "use ";
1246 /* -M-foo == 'no foo' */
1247 if (*s == '-') { use = "no "; ++s; }
1248 Sv = newSVpv(use,0);
1249 start = s;
1a30305b 1250 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd
PP
1251 while(isALNUM(*s) || *s==':') ++s;
1252 if (*s != '=') {
1253 sv_catpv(Sv, start);
1254 if (*(start-1) == 'm') {
1255 if (*s != '\0')
1256 croak("Can't use '%c' after -mname", *s);
1257 sv_catpv( Sv, " ()");
1258 }
1259 } else {
1260 sv_catpvn(Sv, start, s-start);
a5f75d66 1261 sv_catpv(Sv, " split(/,/,q{");
c07a80fd 1262 sv_catpv(Sv, ++s);
a5f75d66 1263 sv_catpv(Sv, "})");
c07a80fd 1264 }
1a30305b 1265 s += strlen(s);
c07a80fd
PP
1266 if (preambleav == NULL)
1267 preambleav = newAV();
1268 av_push(preambleav, Sv);
1a30305b
PP
1269 }
1270 else
1271 croak("No space allowed after -%c", *(s-1));
1272 return s;
79072805
LW
1273 case 'n':
1274 minus_n = TRUE;
1275 s++;
1276 return s;
1277 case 'p':
1278 minus_p = TRUE;
1279 s++;
1280 return s;
1281 case 's':
bbce6d69 1282 forbid_setid("-s");
79072805
LW
1283 doswitches = TRUE;
1284 s++;
1285 return s;
463ee0b2
LW
1286 case 'T':
1287 tainting = TRUE;
1288 s++;
1289 return s;
79072805
LW
1290 case 'u':
1291 do_undump = TRUE;
1292 s++;
1293 return s;
1294 case 'U':
1295 unsafe = TRUE;
1296 s++;
1297 return s;
1298 case 'v':
a5f75d66
AD
1299#if defined(SUBVERSION) && SUBVERSION > 0
1300 printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1301#else
1302 printf("\nThis is perl, version %s",patchlevel);
1303#endif
1a30305b 1304
760ac839
LW
1305 printf("\n\nCopyright 1987-1996, Larry Wall\n");
1306 printf("\n\t+ suidperl security patch");
79072805 1307#ifdef MSDOS
55497cff
PP
1308 printf("\n\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1309#endif
1310#ifdef DJGPP
1311 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
4633a7c4 1312#endif
79072805 1313#ifdef OS2
5dd60ef7 1314 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
760ac839 1315 "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n");
79072805 1316#endif
79072805 1317#ifdef atarist
760ac839 1318 printf("atariST series port, ++jrb bammi@cadence.com\n");
79072805 1319#endif
760ac839 1320 printf("\n\
79072805 1321Perl may be copied only under the terms of either the Artistic License or the\n\
760ac839 1322GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
79072805
LW
1323 exit(0);
1324 case 'w':
1325 dowarn = TRUE;
1326 s++;
1327 return s;
a0d0e21e 1328 case '*':
79072805
LW
1329 case ' ':
1330 if (s[1] == '-') /* Additional switches on #! line. */
1331 return s+2;
1332 break;
a0d0e21e 1333 case '-':
79072805
LW
1334 case 0:
1335 case '\n':
1336 case '\t':
1337 break;
a0d0e21e
LW
1338 case 'P':
1339 if (preprocess)
1340 return s+1;
1341 /* FALL THROUGH */
79072805 1342 default:
a0d0e21e 1343 croak("Can't emulate -%.1s on #! line",s);
79072805
LW
1344 }
1345 return Nullch;
1346}
1347
1348/* compliments of Tom Christiansen */
1349
1350/* unexec() can be found in the Gnu emacs distribution */
1351
1352void
1353my_unexec()
1354{
1355#ifdef UNEXEC
1356 int status;
1357 extern int etext;
1358
1359 sprintf (buf, "%s.perldump", origfilename);
1360 sprintf (tokenbuf, "%s/perl", BIN);
1361
1362 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1363 if (status)
760ac839 1364 PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
a0d0e21e 1365 exit(status);
79072805 1366#else
a5f75d66
AD
1367# ifdef VMS
1368# include <lib$routines.h>
1369 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1370#else
79072805
LW
1371 ABORT(); /* for use with undump */
1372#endif
a5f75d66 1373#endif
79072805
LW
1374}
1375
1376static void
1377init_main_stash()
1378{
463ee0b2 1379 GV *gv;
6e72f9df
PP
1380
1381 /* Note that strtab is a rather special HV. Assumptions are made
1382 about not iterating on it, and not adding tie magic to it.
1383 It is properly deallocated in perl_destruct() */
1384 strtab = newHV();
1385 HvSHAREKEYS_off(strtab); /* mandatory */
1386 Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
1387 sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
1388
463ee0b2 1389 curstash = defstash = newHV();
79072805 1390 curstname = newSVpv("main",4);
adbc6bb1
LW
1391 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1392 SvREFCNT_dec(GvHV(gv));
1393 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
463ee0b2 1394 SvREADONLY_on(gv);
a0d0e21e 1395 HvNAME(defstash) = savepv("main");
85e6fe83 1396 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
a5f75d66 1397 GvMULTI_on(incgv);
a0d0e21e 1398 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
4633a7c4 1399 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
a5f75d66 1400 GvMULTI_on(errgv);
552a7a9b 1401 sv_setpvn(GvSV(errgv), "", 0);
8990e307
LW
1402 curstash = defstash;
1403 compiling.cop_stash = defstash;
adbc6bb1 1404 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
4633a7c4
LW
1405 /* We must init $/ before switches are processed. */
1406 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
79072805
LW
1407}
1408
a0d0e21e
LW
1409#ifdef CAN_PROTOTYPE
1410static void
1411open_script(char *scriptname, bool dosearch, SV *sv)
1412#else
79072805
LW
1413static void
1414open_script(scriptname,dosearch,sv)
1415char *scriptname;
1416bool dosearch;
1417SV *sv;
a0d0e21e 1418#endif
79072805
LW
1419{
1420 char *xfound = Nullch;
1421 char *xfailed = Nullch;
1422 register char *s;
1423 I32 len;
a38d6535
LW
1424 int retval;
1425#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1426#define SEARCH_EXTS ".bat", ".cmd", NULL
1427#endif
ab821d7f
PP
1428#ifdef VMS
1429# define SEARCH_EXTS ".pl", ".com", NULL
1430#endif
a38d6535
LW
1431 /* additional extensions to try in each dir if scriptname not found */
1432#ifdef SEARCH_EXTS
1433 char *ext[] = { SEARCH_EXTS };
1434 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1435#endif
79072805 1436
c07a80fd 1437#ifdef VMS
6e72f9df
PP
1438 if (dosearch) {
1439 int hasdir, idx = 0, deftypes = 1;
1440
1441 hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
1442 /* The first time through, just add SEARCH_EXTS to whatever we
1443 * already have, so we can check for default file types. */
1444 while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
1445 if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
c07a80fd
PP
1446 strcat(tokenbuf,scriptname);
1447#else /* !VMS */
93a17b20 1448 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
79072805
LW
1449
1450 bufend = s + strlen(s);
1451 while (*s) {
1452#ifndef DOSISH
1453 s = cpytill(tokenbuf,s,bufend,':',&len);
1454#else
1455#ifdef atarist
1456 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1457 tokenbuf[len] = '\0';
1458#else
1459 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1460 tokenbuf[len] = '\0';
1461#endif
1462#endif
1463 if (*s)
1464 s++;
1465#ifndef DOSISH
1466 if (len && tokenbuf[len-1] != '/')
1467#else
1468#ifdef atarist
1469 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1470#else
1471 if (len && tokenbuf[len-1] != '\\')
1472#endif
1473#endif
1474 (void)strcat(tokenbuf+len,"/");
1475 (void)strcat(tokenbuf+len,scriptname);
c07a80fd 1476#endif /* !VMS */
a38d6535
LW
1477
1478#ifdef SEARCH_EXTS
1479 len = strlen(tokenbuf);
1480 if (extidx > 0) /* reset after previous loop */
1481 extidx = 0;
1482 do {
1483#endif
760ac839 1484 DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
a38d6535
LW
1485 retval = Stat(tokenbuf,&statbuf);
1486#ifdef SEARCH_EXTS
1487 } while ( retval < 0 /* not there */
1488 && extidx>=0 && ext[extidx] /* try an extension? */
1489 && strcpy(tokenbuf+len, ext[extidx++])
1490 );
1491#endif
1492 if (retval < 0)
79072805
LW
1493 continue;
1494 if (S_ISREG(statbuf.st_mode)
1495 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1496 xfound = tokenbuf; /* bingo! */
1497 break;
1498 }
1499 if (!xfailed)
a0d0e21e 1500 xfailed = savepv(tokenbuf);
79072805
LW
1501 }
1502 if (!xfound)
463ee0b2 1503 croak("Can't execute %s", xfailed ? xfailed : scriptname );
79072805
LW
1504 if (xfailed)
1505 Safefree(xfailed);
1506 scriptname = xfound;
1507 }
1508
96436eeb
PP
1509 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1510 char *s = scriptname + 8;
1511 fdscript = atoi(s);
1512 while (isDIGIT(*s))
1513 s++;
1514 if (*s)
1515 scriptname = s + 1;
1516 }
1517 else
1518 fdscript = -1;
ab821d7f 1519 origfilename = savepv(e_tmpname ? "-e" : scriptname);
79072805
LW
1520 curcop->cop_filegv = gv_fetchfile(origfilename);
1521 if (strEQ(origfilename,"-"))
1522 scriptname = "";
96436eeb 1523 if (fdscript >= 0) {
760ac839 1524 rsfp = PerlIO_fdopen(fdscript,"r");
96436eeb 1525#if defined(HAS_FCNTL) && defined(F_SETFD)
7aa04957
CS
1526 if (rsfp)
1527 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb
PP
1528#endif
1529 }
1530 else if (preprocess) {
79072805
LW
1531 char *cpp = CPPSTDIN;
1532
1533 if (strEQ(cpp,"cppstdin"))
1534 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1535 else
1536 sprintf(tokenbuf, "%s", cpp);
1537 sv_catpv(sv,"-I");
fed7345c 1538 sv_catpv(sv,PRIVLIB_EXP);
79072805
LW
1539#ifdef MSDOS
1540 (void)sprintf(buf, "\
1541sed %s -e \"/^[^#]/b\" \
1542 -e \"/^#[ ]*include[ ]/b\" \
1543 -e \"/^#[ ]*define[ ]/b\" \
1544 -e \"/^#[ ]*if[ ]/b\" \
1545 -e \"/^#[ ]*ifdef[ ]/b\" \
1546 -e \"/^#[ ]*ifndef[ ]/b\" \
1547 -e \"/^#[ ]*else/b\" \
1548 -e \"/^#[ ]*elif[ ]/b\" \
1549 -e \"/^#[ ]*undef[ ]/b\" \
1550 -e \"/^#[ ]*endif/b\" \
1551 -e \"s/^#.*//\" \
1552 %s | %s -C %s %s",
1553 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1554#else
1555 (void)sprintf(buf, "\
1556%s %s -e '/^[^#]/b' \
1557 -e '/^#[ ]*include[ ]/b' \
1558 -e '/^#[ ]*define[ ]/b' \
1559 -e '/^#[ ]*if[ ]/b' \
1560 -e '/^#[ ]*ifdef[ ]/b' \
1561 -e '/^#[ ]*ifndef[ ]/b' \
1562 -e '/^#[ ]*else/b' \
1563 -e '/^#[ ]*elif[ ]/b' \
1564 -e '/^#[ ]*undef[ ]/b' \
1565 -e '/^#[ ]*endif/b' \
1566 -e 's/^[ ]*#.*//' \
1567 %s | %s -C %s %s",
1568#ifdef LOC_SED
1569 LOC_SED,
1570#else
1571 "sed",
1572#endif
1573 (doextract ? "-e '1,/^#/d\n'" : ""),
1574#endif
463ee0b2 1575 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
79072805
LW
1576 doextract = FALSE;
1577#ifdef IAMSUID /* actually, this is caught earlier */
1578 if (euid != uid && !euid) { /* if running suidperl */
1579#ifdef HAS_SETEUID
1580 (void)seteuid(uid); /* musn't stay setuid root */
1581#else
1582#ifdef HAS_SETREUID
85e6fe83
LW
1583 (void)setreuid((Uid_t)-1, uid);
1584#else
1585#ifdef HAS_SETRESUID
1586 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
79072805
LW
1587#else
1588 setuid(uid);
1589#endif
1590#endif
85e6fe83 1591#endif
79072805 1592 if (geteuid() != uid)
463ee0b2 1593 croak("Can't do seteuid!\n");
79072805
LW
1594 }
1595#endif /* IAMSUID */
1596 rsfp = my_popen(buf,"r");
1597 }
1598 else if (!*scriptname) {
bbce6d69 1599 forbid_setid("program input from stdin");
760ac839 1600 rsfp = PerlIO_stdin();
79072805 1601 }
96436eeb 1602 else {
760ac839 1603 rsfp = PerlIO_open(scriptname,"r");
96436eeb 1604#if defined(HAS_FCNTL) && defined(F_SETFD)
7aa04957
CS
1605 if (rsfp)
1606 fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb
PP
1607#endif
1608 }
5dd60ef7
PP
1609 if (e_tmpname) {
1610 e_fp = rsfp;
1611 }
7aa04957 1612 if (!rsfp) {
13281fa4 1613#ifdef DOSUID
a687059c 1614#ifndef IAMSUID /* in case script is not readable before setuid */
a0d0e21e 1615 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
13281fa4 1616 statbuf.st_mode & (S_ISUID|S_ISGID)) {
27e2fb84 1617 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
a687059c 1618 execv(buf, origargv); /* try again */
463ee0b2 1619 croak("Can't do setuid\n");
13281fa4
LW
1620 }
1621#endif
1622#endif
463ee0b2 1623 croak("Can't open perl script \"%s\": %s\n",
2304df62 1624 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
13281fa4 1625 }
79072805 1626}
8d063cd8 1627
79072805 1628static void
96436eeb 1629validate_suid(validarg, scriptname)
79072805 1630char *validarg;
96436eeb 1631char *scriptname;
79072805 1632{
96436eeb
PP
1633 int which;
1634
13281fa4
LW
1635 /* do we need to emulate setuid on scripts? */
1636
1637 /* This code is for those BSD systems that have setuid #! scripts disabled
1638 * in the kernel because of a security problem. Merely defining DOSUID
1639 * in perl will not fix that problem, but if you have disabled setuid
1640 * scripts in the kernel, this will attempt to emulate setuid and setgid
1641 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW
1642 * root version must be called suidperl or sperlN.NNN. If regular perl
1643 * discovers that it has opened a setuid script, it calls suidperl with
1644 * the same argv that it had. If suidperl finds that the script it has
1645 * just opened is NOT setuid root, it sets the effective uid back to the
1646 * uid. We don't just make perl setuid root because that loses the
1647 * effective uid we had before invoking perl, if it was different from the
1648 * uid.
13281fa4
LW
1649 *
1650 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1651 * be defined in suidperl only. suidperl must be setuid root. The
1652 * Configure script will set this up for you if you want it.
1653 */
a687059c 1654
13281fa4 1655#ifdef DOSUID
6e72f9df 1656 char *s, *s2;
a0d0e21e 1657
760ac839 1658 if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
463ee0b2 1659 croak("Can't stat script \"%s\"",origfilename);
96436eeb 1660 if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 1661 I32 len;
13281fa4 1662
a687059c 1663#ifdef IAMSUID
fe14fcc3 1664#ifndef HAS_SETREUID
a687059c
LW
1665 /* On this access check to make sure the directories are readable,
1666 * there is actually a small window that the user could use to make
1667 * filename point to an accessible directory. So there is a faint
1668 * chance that someone could execute a setuid script down in a
1669 * non-accessible directory. I don't know what to do about that.
1670 * But I don't think it's too important. The manual lies when
1671 * it says access() is useful in setuid programs.
1672 */
463ee0b2
LW
1673 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1674 croak("Permission denied");
a687059c
LW
1675#else
1676 /* If we can swap euid and uid, then we can determine access rights
1677 * with a simple stat of the file, and then compare device and
1678 * inode to make sure we did stat() on the same file we opened.
1679 * Then we just have to make sure he or she can execute it.
1680 */
1681 {
1682 struct stat tmpstatbuf;
1683
85e6fe83
LW
1684 if (
1685#ifdef HAS_SETREUID
1686 setreuid(euid,uid) < 0
a0d0e21e
LW
1687#else
1688# if HAS_SETRESUID
85e6fe83 1689 setresuid(euid,uid,(Uid_t)-1) < 0
a0d0e21e 1690# endif
85e6fe83
LW
1691#endif
1692 || getuid() != euid || geteuid() != uid)
463ee0b2 1693 croak("Can't swap uid and euid"); /* really paranoid */
a0d0e21e 1694 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
463ee0b2 1695 croak("Permission denied"); /* testing full pathname here */
a687059c
LW
1696 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1697 tmpstatbuf.st_ino != statbuf.st_ino) {
760ac839 1698 (void)PerlIO_close(rsfp);
79072805 1699 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
760ac839 1700 PerlIO_printf(rsfp,
a687059c
LW
1701"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1702(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1703 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1704 statbuf.st_dev, statbuf.st_ino,
463ee0b2 1705 SvPVX(GvSV(curcop->cop_filegv)),
20188a90 1706 statbuf.st_uid, statbuf.st_gid);
79072805 1707 (void)my_pclose(rsfp);
a687059c 1708 }
463ee0b2 1709 croak("Permission denied\n");
a687059c 1710 }
85e6fe83
LW
1711 if (
1712#ifdef HAS_SETREUID
1713 setreuid(uid,euid) < 0
a0d0e21e
LW
1714#else
1715# if defined(HAS_SETRESUID)
85e6fe83 1716 setresuid(uid,euid,(Uid_t)-1) < 0
a0d0e21e 1717# endif
85e6fe83
LW
1718#endif
1719 || getuid() != uid || geteuid() != euid)
463ee0b2 1720 croak("Can't reswap uid and euid");
27e2fb84 1721 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
463ee0b2 1722 croak("Permission denied\n");
a687059c 1723 }
fe14fcc3 1724#endif /* HAS_SETREUID */
a687059c
LW
1725#endif /* IAMSUID */
1726
27e2fb84 1727 if (!S_ISREG(statbuf.st_mode))
463ee0b2 1728 croak("Permission denied");
27e2fb84 1729 if (statbuf.st_mode & S_IWOTH)
463ee0b2 1730 croak("Setuid/gid script is writable by world");
13281fa4 1731 doswitches = FALSE; /* -s is insecure in suid */
79072805 1732 curcop->cop_line++;
760ac839
LW
1733 if (sv_gets(linestr, rsfp, 0) == Nullch ||
1734 strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
463ee0b2 1735 croak("No #! line");
760ac839 1736 s = SvPV(linestr,na)+2;
663a0e37 1737 if (*s == ' ') s++;
45d8adaa 1738 while (!isSPACE(*s)) s++;
760ac839 1739 for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
6e72f9df
PP
1740 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
1741 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
463ee0b2 1742 croak("Not a perl script");
a687059c 1743 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW
1744 /*
1745 * #! arg must be what we saw above. They can invoke it by
1746 * mentioning suidperl explicitly, but they may not add any strange
1747 * arguments beyond what #! says if they do invoke suidperl that way.
1748 */
1749 len = strlen(validarg);
1750 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 1751 strnNE(s,validarg,len) || !isSPACE(s[len]))
463ee0b2 1752 croak("Args must match #! line");
a687059c
LW
1753
1754#ifndef IAMSUID
1755 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1756 euid == statbuf.st_uid)
1757 if (!do_undump)
463ee0b2 1758 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
1759FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1760#endif /* IAMSUID */
13281fa4
LW
1761
1762 if (euid) { /* oops, we're not the setuid root perl */
760ac839 1763 (void)PerlIO_close(rsfp);
13281fa4 1764#ifndef IAMSUID
27e2fb84 1765 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
a687059c 1766 execv(buf, origargv); /* try again */
13281fa4 1767#endif
463ee0b2 1768 croak("Can't do setuid\n");
13281fa4
LW
1769 }
1770
83025b21 1771 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
fe14fcc3 1772#ifdef HAS_SETEGID
a687059c
LW
1773 (void)setegid(statbuf.st_gid);
1774#else
fe14fcc3 1775#ifdef HAS_SETREGID
85e6fe83
LW
1776 (void)setregid((Gid_t)-1,statbuf.st_gid);
1777#else
1778#ifdef HAS_SETRESGID
1779 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
a687059c
LW
1780#else
1781 setgid(statbuf.st_gid);
1782#endif
1783#endif
85e6fe83 1784#endif
83025b21 1785 if (getegid() != statbuf.st_gid)
463ee0b2 1786 croak("Can't do setegid!\n");
83025b21 1787 }
a687059c
LW
1788 if (statbuf.st_mode & S_ISUID) {
1789 if (statbuf.st_uid != euid)
fe14fcc3 1790#ifdef HAS_SETEUID
a687059c
LW
1791 (void)seteuid(statbuf.st_uid); /* all that for this */
1792#else
fe14fcc3 1793#ifdef HAS_SETREUID
85e6fe83
LW
1794 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1795#else
1796#ifdef HAS_SETRESUID
1797 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
a687059c
LW
1798#else
1799 setuid(statbuf.st_uid);
1800#endif
1801#endif
85e6fe83 1802#endif
83025b21 1803 if (geteuid() != statbuf.st_uid)
463ee0b2 1804 croak("Can't do seteuid!\n");
a687059c 1805 }
83025b21 1806 else if (uid) { /* oops, mustn't run as root */
fe14fcc3 1807#ifdef HAS_SETEUID
85e6fe83 1808 (void)seteuid((Uid_t)uid);
a687059c 1809#else
fe14fcc3 1810#ifdef HAS_SETREUID
85e6fe83 1811 (void)setreuid((Uid_t)-1,(Uid_t)uid);
a687059c 1812#else
85e6fe83
LW
1813#ifdef HAS_SETRESUID
1814 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1815#else
1816 setuid((Uid_t)uid);
1817#endif
a687059c
LW
1818#endif
1819#endif
83025b21 1820 if (geteuid() != uid)
463ee0b2 1821 croak("Can't do seteuid!\n");
83025b21 1822 }
748a9306 1823 init_ids();
27e2fb84 1824 if (!cando(S_IXUSR,TRUE,&statbuf))
463ee0b2 1825 croak("Permission denied\n"); /* they can't do this */
13281fa4
LW
1826 }
1827#ifdef IAMSUID
1828 else if (preprocess)
463ee0b2 1829 croak("-P not allowed for setuid/setgid script\n");
96436eeb
PP
1830 else if (fdscript >= 0)
1831 croak("fd script not allowed in suidperl\n");
13281fa4 1832 else
463ee0b2 1833 croak("Script is not setuid/setgid in suidperl\n");
96436eeb
PP
1834
1835 /* We absolutely must clear out any saved ids here, so we */
1836 /* exec the real perl, substituting fd script for scriptname. */
1837 /* (We pass script name as "subdir" of fd, which perl will grok.) */
760ac839
LW
1838 PerlIO_rewind(rsfp);
1839 lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
96436eeb
PP
1840 for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1841 if (!origargv[which])
1842 croak("Permission denied");
760ac839 1843 (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
96436eeb
PP
1844 origargv[which] = buf;
1845
1846#if defined(HAS_FCNTL) && defined(F_SETFD)
760ac839 1847 fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb
PP
1848#endif
1849
1850 (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1851 execv(tokenbuf, origargv); /* try again */
1852 croak("Can't do setuid\n");
13281fa4 1853#endif /* IAMSUID */
a687059c 1854#else /* !DOSUID */
a687059c
LW
1855 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1856#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
760ac839 1857 Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
a687059c
LW
1858 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1859 ||
1860 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1861 )
1862 if (!do_undump)
463ee0b2 1863 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
1864FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1865#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1866 /* not set-id, must be wrapped */
a687059c 1867 }
13281fa4 1868#endif /* DOSUID */
79072805 1869}
13281fa4 1870
79072805
LW
1871static void
1872find_beginning()
1873{
6e72f9df 1874 register char *s, *s2;
33b78306
LW
1875
1876 /* skip forward in input to the real script? */
1877
bbce6d69 1878 forbid_setid("-x");
33b78306 1879 while (doextract) {
79072805 1880 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
463ee0b2 1881 croak("No Perl script found in input\n");
6e72f9df 1882 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
760ac839 1883 PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
33b78306 1884 doextract = FALSE;
6e72f9df
PP
1885 while (*s && !(isSPACE (*s) || *s == '#')) s++;
1886 s2 = s;
1887 while (*s == ' ' || *s == '\t') s++;
1888 if (*s++ == '-') {
1889 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
1890 if (strnEQ(s2-4,"perl",4))
1891 /*SUPPRESS 530*/
1892 while (s = moreswitches(s)) ;
33b78306 1893 }
79072805 1894 if (cddir && chdir(cddir) < 0)
463ee0b2 1895 croak("Can't chdir to %s",cddir);
83025b21
LW
1896 }
1897 }
1898}
1899
79072805 1900static void
748a9306 1901init_ids()
352d5a3a 1902{
748a9306
LW
1903 uid = (int)getuid();
1904 euid = (int)geteuid();
1905 gid = (int)getgid();
1906 egid = (int)getegid();
1907#ifdef VMS
1908 uid |= gid << 16;
1909 euid |= egid << 16;
1910#endif
4633a7c4 1911 tainting |= (uid && (euid != uid || egid != gid));
748a9306 1912}
79072805 1913
748a9306 1914static void
bbce6d69
PP
1915forbid_setid(s)
1916char *s;
1917{
1918 if (euid != uid)
1919 croak("No %s allowed while running setuid", s);
1920 if (egid != gid)
1921 croak("No %s allowed while running setgid", s);
1922}
1923
1924static void
748a9306
LW
1925init_debugger()
1926{
79072805 1927 curstash = debstash;
748a9306 1928 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
79072805 1929 AvREAL_off(dbargs);
a0d0e21e
LW
1930 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1931 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
748a9306
LW
1932 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1933 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
c07a80fd 1934 sv_setiv(DBsingle, 0);
748a9306 1935 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
c07a80fd 1936 sv_setiv(DBtrace, 0);
748a9306 1937 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
c07a80fd 1938 sv_setiv(DBsignal, 0);
79072805 1939 curstash = defstash;
352d5a3a
LW
1940}
1941
79072805 1942static void
8990e307 1943init_stacks()
79072805 1944{
6e72f9df
PP
1945 curstack = newAV();
1946 mainstack = curstack; /* remember in case we switch stacks */
1947 AvREAL_off(curstack); /* not a real array */
1948 av_extend(curstack,127);
79072805 1949
6e72f9df 1950 stack_base = AvARRAY(curstack);
79072805 1951 stack_sp = stack_base;
8990e307 1952 stack_max = stack_base + 127;
79072805 1953
6e72f9df
PP
1954 /* Shouldn't these stacks be per-interpreter? */
1955 if (markstack) {
1956 markstack_ptr = markstack;
1957 } else {
1958 New(54,markstack,64,I32);
1959 markstack_ptr = markstack;
1960 markstack_max = markstack + 64;
1961 }
79072805 1962
6e72f9df
PP
1963 if (scopestack) {
1964 scopestack_ix = 0;
1965 } else {
1966 New(54,scopestack,32,I32);
1967 scopestack_ix = 0;
1968 scopestack_max = 32;
1969 }
79072805 1970
6e72f9df
PP
1971 if (savestack) {
1972 savestack_ix = 0;
1973 } else {
1974 New(54,savestack,128,ANY);
1975 savestack_ix = 0;
1976 savestack_max = 128;
1977 }
79072805 1978
6e72f9df
PP
1979 if (retstack) {
1980 retstack_ix = 0;
1981 } else {
1982 New(54,retstack,16,OP*);
1983 retstack_ix = 0;
1984 retstack_max = 16;
1985 }
8d063cd8 1986
a5f75d66
AD
1987 cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
1988 New(50,cxstack,cxstack_max + 1,CONTEXT);
8990e307 1989 cxstack_ix = -1;
8990e307
LW
1990
1991 New(50,tmps_stack,128,SV*);
1992 tmps_ix = -1;
1993 tmps_max = 128;
1994
79072805
LW
1995 DEBUG( {
1996 New(51,debname,128,char);
1997 New(52,debdelim,128,char);
1998 } )
378cc40b 1999}
33b78306 2000
6e72f9df
PP
2001static void
2002nuke_stacks()
2003{
2004 Safefree(cxstack);
2005 Safefree(tmps_stack);
2006}
2007
760ac839 2008static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
7aa04957 2009
79072805 2010static void
8990e307
LW
2011init_lexer()
2012{
a0d0e21e 2013 tmpfp = rsfp;
8990e307
LW
2014 lex_start(linestr);
2015 rsfp = tmpfp;
2016 subname = newSVpv("main",4);
2017}
2018
2019static void
79072805 2020init_predump_symbols()
45d8adaa 2021{
93a17b20 2022 GV *tmpgv;
a0d0e21e 2023 GV *othergv;
79072805 2024
85e6fe83 2025 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
79072805 2026
85e6fe83 2027 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
a5f75d66 2028 GvMULTI_on(stdingv);
760ac839 2029 IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
adbc6bb1 2030 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 2031 GvMULTI_on(tmpgv);
a0d0e21e 2032 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
79072805 2033
85e6fe83 2034 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 2035 GvMULTI_on(tmpgv);
760ac839 2036 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
4633a7c4 2037 setdefout(tmpgv);
adbc6bb1 2038 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 2039 GvMULTI_on(tmpgv);
a0d0e21e 2040 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
79072805 2041
a0d0e21e 2042 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
a5f75d66 2043 GvMULTI_on(othergv);
760ac839 2044 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
adbc6bb1 2045 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 2046 GvMULTI_on(tmpgv);
a0d0e21e 2047 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
79072805
LW
2048
2049 statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 2050
6e72f9df
PP
2051 if (!osname)
2052 osname = savepv(OSNAME);
79072805 2053}
33b78306 2054
79072805
LW
2055static void
2056init_postdump_symbols(argc,argv,env)
2057register int argc;
2058register char **argv;
2059register char **env;
33b78306 2060{
79072805
LW
2061 char *s;
2062 SV *sv;
2063 GV* tmpgv;
fe14fcc3 2064
79072805
LW
2065 argc--,argv++; /* skip name of script */
2066 if (doswitches) {
2067 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2068 if (!argv[0][1])
2069 break;
2070 if (argv[0][1] == '-') {
2071 argc--,argv++;
2072 break;
2073 }
93a17b20 2074 if (s = strchr(argv[0], '=')) {
79072805 2075 *s++ = '\0';
85e6fe83 2076 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW
2077 }
2078 else
85e6fe83 2079 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 2080 }
79072805
LW
2081 }
2082 toptarget = NEWSV(0,0);
2083 sv_upgrade(toptarget, SVt_PVFM);
2084 sv_setpvn(toptarget, "", 0);
748a9306 2085 bodytarget = NEWSV(0,0);
79072805
LW
2086 sv_upgrade(bodytarget, SVt_PVFM);
2087 sv_setpvn(bodytarget, "", 0);
2088 formtarget = bodytarget;
2089
bbce6d69 2090 TAINT;
85e6fe83 2091 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
79072805
LW
2092 sv_setpv(GvSV(tmpgv),origfilename);
2093 magicname("0", "0", 1);
2094 }
85e6fe83 2095 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
79072805 2096 time(&basetime);
85e6fe83 2097 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
79072805 2098 sv_setpv(GvSV(tmpgv),origargv[0]);
85e6fe83 2099 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
a5f75d66 2100 GvMULTI_on(argvgv);
79072805
LW
2101 (void)gv_AVadd(argvgv);
2102 av_clear(GvAVn(argvgv));
2103 for (; argc > 0; argc--,argv++) {
a0d0e21e 2104 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
79072805
LW
2105 }
2106 }
85e6fe83 2107 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
79072805 2108 HV *hv;
a5f75d66 2109 GvMULTI_on(envgv);
79072805 2110 hv = GvHVn(envgv);
463ee0b2 2111 hv_clear(hv);
a0d0e21e 2112#ifndef VMS /* VMS doesn't have environ array */
4633a7c4
LW
2113 /* Note that if the supplied env parameter is actually a copy
2114 of the global environ then it may now point to free'd memory
2115 if the environment has been modified since. To avoid this
2116 problem we treat env==NULL as meaning 'use the default'
2117 */
2118 if (!env)
2119 env = environ;
8990e307 2120 if (env != environ) {
79072805 2121 environ[0] = Nullch;
8990e307
LW
2122 hv_magic(hv, envgv, 'E');
2123 }
79072805 2124 for (; *env; env++) {
93a17b20 2125 if (!(s = strchr(*env,'=')))
79072805
LW
2126 continue;
2127 *s++ = '\0';
2128 sv = newSVpv(s--,0);
85e6fe83 2129 sv_magic(sv, sv, 'e', *env, s - *env);
79072805
LW
2130 (void)hv_store(hv, *env, s - *env, sv, 0);
2131 *s = '=';
fe14fcc3 2132 }
4550b24a
PP
2133#endif
2134#ifdef DYNAMIC_ENV_FETCH
2135 HvNAME(hv) = savepv(ENV_HV_NAME);
2136#endif
f511e57f 2137 hv_magic(hv, envgv, 'E');
79072805 2138 }
bbce6d69 2139 TAINT_NOT;
85e6fe83 2140 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
79072805 2141 sv_setiv(GvSV(tmpgv),(I32)getpid());
33b78306 2142}
34de22dd 2143
79072805
LW
2144static void
2145init_perllib()
34de22dd 2146{
85e6fe83
LW
2147 char *s;
2148 if (!tainting) {
552a7a9b 2149#ifndef VMS
85e6fe83
LW
2150 s = getenv("PERL5LIB");
2151 if (s)
2152 incpush(s);
2153 else
2154 incpush(getenv("PERLLIB"));
552a7a9b
PP
2155#else /* VMS */
2156 /* Treat PERL5?LIB as a possible search list logical name -- the
2157 * "natural" VMS idiom for a Unix path string. We allow each
2158 * element to be a set of |-separated directories for compatibility.
2159 */
2160 char buf[256];
2161 int idx = 0;
2162 if (my_trnlnm("PERL5LIB",buf,0))
2163 do { incpush(buf); } while (my_trnlnm("PERL5LIB",buf,++idx));
2164 else
2165 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf);
2166#endif /* VMS */
85e6fe83 2167 }
34de22dd 2168
df5cef82
PP
2169/* Use the ~-expanded versions of APPLIB (undocumented),
2170 ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
2171*/
4633a7c4
LW
2172#ifdef APPLLIB_EXP
2173 incpush(APPLLIB_EXP);
16d20bd9 2174#endif
4633a7c4 2175
fed7345c
AD
2176#ifdef ARCHLIB_EXP
2177 incpush(ARCHLIB_EXP);
a0d0e21e 2178#endif
fed7345c
AD
2179#ifndef PRIVLIB_EXP
2180#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 2181#endif
fed7345c 2182 incpush(PRIVLIB_EXP);
4633a7c4
LW
2183
2184#ifdef SITEARCH_EXP
2185 incpush(SITEARCH_EXP);
2186#endif
2187#ifdef SITELIB_EXP
2188 incpush(SITELIB_EXP);
2189#endif
2190#ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
2191 incpush(OLDARCHLIB_EXP);
2192#endif
a0d0e21e 2193
4633a7c4
LW
2194 if (!tainting)
2195 incpush(".");
34de22dd 2196}
93a17b20
LW
2197
2198void
2199calllist(list)
2200AV* list;
2201{
a5f75d66 2202 Sigjmp_buf oldtop;
a0d0e21e
LW
2203 STRLEN len;
2204 line_t oldline = curcop->cop_line;
93a17b20 2205
a5f75d66 2206 Copy(top_env, oldtop, 1, Sigjmp_buf);
93a17b20 2207
8990e307
LW
2208 while (AvFILL(list) >= 0) {
2209 CV *cv = (CV*)av_shift(list);
93a17b20 2210
8990e307 2211 SAVEFREESV(cv);
a0d0e21e 2212
a5f75d66 2213 switch (Sigsetjmp(top_env,1)) {
748a9306 2214 case 0: {
4633a7c4 2215 SV* atsv = GvSV(errgv);
748a9306
LW
2216 PUSHMARK(stack_sp);
2217 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2218 (void)SvPV(atsv, len);
2219 if (len) {
a5f75d66 2220 Copy(oldtop, top_env, 1, Sigjmp_buf);
748a9306
LW
2221 curcop = &compiling;
2222 curcop->cop_line = oldline;
2223 if (list == beginav)
2224 sv_catpv(atsv, "BEGIN failed--compilation aborted");
2225 else
2226 sv_catpv(atsv, "END failed--cleanup aborted");
2227 croak("%s", SvPVX(atsv));
2228 }
a0d0e21e 2229 }
85e6fe83
LW
2230 break;
2231 case 1:
748a9306 2232#ifdef VMS
85e6fe83 2233 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
748a9306
LW
2234#else
2235 statusvalue = 1;
2236#endif
85e6fe83
LW
2237 /* FALL THROUGH */
2238 case 2:
2239 /* my_exit() was called */
2240 curstash = defstash;
2241 if (endav)
2242 calllist(endav);
a0d0e21e 2243 FREETMPS;
a5f75d66 2244 Copy(oldtop, top_env, 1, Sigjmp_buf);
a0d0e21e
LW
2245 curcop = &compiling;
2246 curcop->cop_line = oldline;
85e6fe83
LW
2247 if (statusvalue) {
2248 if (list == beginav)
a0d0e21e 2249 croak("BEGIN failed--compilation aborted");
85e6fe83 2250 else
a0d0e21e 2251 croak("END failed--cleanup aborted");
85e6fe83 2252 }
85e6fe83
LW
2253 my_exit(statusvalue);
2254 /* NOTREACHED */
2255 return;
2256 case 3:
2257 if (!restartop) {
760ac839 2258 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
a0d0e21e 2259 FREETMPS;
85e6fe83
LW
2260 break;
2261 }
a5f75d66 2262 Copy(oldtop, top_env, 1, Sigjmp_buf);
a0d0e21e
LW
2263 curcop = &compiling;
2264 curcop->cop_line = oldline;
a5f75d66 2265 Siglongjmp(top_env, 3);
8990e307 2266 }
93a17b20
LW
2267 }
2268
a5f75d66 2269 Copy(oldtop, top_env, 1, Sigjmp_buf);
93a17b20
LW
2270}
2271