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