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