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