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