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