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