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