perl 5.0 alpha 3
[perl.git] / perl.c
1 char rcsid[] = "$RCSfile: perl.c,v $$Revision: 5.0 $$Date: 92/08/07 18:25:50 $\nPatch level: ###\n";
2 /*
3  *    Copyright (c) 1991, Larry Wall
4  *
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.
7  *
8  * $Log:        perl.c,v $
9  * Revision 4.1  92/08/07  18:25:50  lwall
10  * 
11  * Revision 4.0.1.7  92/06/08  14:50:39  lwall
12  * patch20: PERLLIB now supports multiple directories
13  * patch20: running taintperl explicitly now does checks even if $< == $>
14  * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space
15  * patch20: perl -P now uses location of sed determined by Configure
16  * patch20: form feed for formats is now specifiable via $^L
17  * patch20: paragraph mode now skips extra newlines automatically
18  * patch20: oldeval "1 #comment" didn't work
19  * patch20: couldn't require . files
20  * patch20: semantic compilation errors didn't abort execution
21  * 
22  * Revision 4.0.1.6  91/11/11  16:38:45  lwall
23  * patch19: default arg for shift was wrong after first subroutine definition
24  * patch19: op/regexp.t failed from missing arg to bcmp()
25  * 
26  * Revision 4.0.1.5  91/11/05  18:03:32  lwall
27  * patch11: random cleanup
28  * patch11: $0 was being truncated at times
29  * patch11: cppstdin now installed outside of source directory
30  * patch11: -P didn't allow use of #elif or #undef
31  * patch11: prepared for ctype implementations that don't define isascii()
32  * patch11: added oldeval {}
33  * patch11: oldeval confused by string containing null
34  * 
35  * Revision 4.0.1.4  91/06/10  01:23:07  lwall
36  * patch10: perl -v printed incorrect copyright notice
37  * 
38  * Revision 4.0.1.3  91/06/07  11:40:18  lwall
39  * patch4: changed old $^P to $^X
40  * 
41  * Revision 4.0.1.2  91/06/07  11:26:16  lwall
42  * patch4: new copyright notice
43  * patch4: added $^P variable to control calling of perldb routines
44  * patch4: added $^F variable to specify maximum system fd, default 2
45  * patch4: debugger lost track of lines in oldeval
46  * 
47  * Revision 4.0.1.1  91/04/11  17:49:05  lwall
48  * patch1: fixed undefined environ problem
49  * 
50  * Revision 4.0  91/03/20  01:37:44  lwall
51  * 4.0 baseline.
52  * 
53  */
54
55 /*SUPPRESS 560*/
56
57 #include "EXTERN.h"
58 #include "perl.h"
59 #include "perly.h"
60 #include "patchlevel.h"
61
62 #ifdef IAMSUID
63 #ifndef DOSUID
64 #define DOSUID
65 #endif
66 #endif
67
68 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
69 #ifdef DOSUID
70 #undef DOSUID
71 #endif
72 #endif
73
74 static void incpush();
75 static void validate_suid();
76 static void find_beginning();
77 static void init_main_stash();
78 static void open_script();
79 static void init_debugger();
80 static void init_stack();
81 static void init_lexer();
82 static void init_context_stack();
83 static void init_predump_symbols();
84 static void init_postdump_symbols();
85 static void init_perllib();
86
87 PerlInterpreter *
88 perl_alloc()
89 {
90     PerlInterpreter *sv_interp;
91     PerlInterpreter junk;
92
93     curinterp = &junk;
94     Zero(&junk, 1, PerlInterpreter);
95     New(53, sv_interp, 1, PerlInterpreter);
96     return sv_interp;
97 }
98
99 void
100 perl_construct( sv_interp )
101 register PerlInterpreter *sv_interp;
102 {
103     if (!(curinterp = sv_interp))
104         return;
105
106     Zero(sv_interp, 1, PerlInterpreter);
107
108     /* Init the real globals? */
109     if (!linestr) {
110         linestr = NEWSV(65,80);
111
112         SvREADONLY_on(&sv_undef);
113
114         sv_setpv(&sv_no,No);
115         SvNVn(&sv_no);
116         SvREADONLY_on(&sv_no);
117
118         sv_setpv(&sv_yes,Yes);
119         SvNVn(&sv_yes);
120         SvREADONLY_on(&sv_yes);
121
122 #ifdef MSDOS
123         /*
124          * There is no way we can refer to them from Perl so close them to save
125          * space.  The other alternative would be to provide STDAUX and STDPRN
126          * filehandles.
127          */
128         (void)fclose(stdaux);
129         (void)fclose(stdprn);
130 #endif
131     }
132
133 #ifdef EMBEDDED
134     chopset     = " \n-";
135     cmdline     = NOLINE;
136     curcop      = &compiling;
137     cxstack_ix  = -1;
138     cxstack_max = 128;
139     dlmax       = 128;
140     laststatval = -1;
141     laststype   = OP_STAT;
142     maxscream   = -1;
143     maxsysfd    = MAXSYSFD;
144     nrs         = "\n";
145     nrschar     = '\n';
146     nrslen      = 1;
147     rs          = "\n";
148     rschar      = '\n';
149     rsfp        = Nullfp;
150     rslen       = 1;
151     statname    = Nullstr;
152     tmps_floor  = -1;
153     tmps_ix     = -1;
154     tmps_max    = -1;
155 #endif
156
157     uid = (int)getuid();
158     euid = (int)geteuid();
159     gid = (int)getgid();
160     egid = (int)getegid();
161     sprintf(patchlevel,"%3.3s%2.2d", strchr(rcsid,'4'), PATCHLEVEL);
162
163     (void)sprintf(strchr(rcsid,'#'), "%d\n", PATCHLEVEL);
164
165     fdpid = newAV();    /* for remembering popen pids by fd */
166     pidstatus = newHV(COEFFSIZE);/* for remembering status of dead pids */
167
168 #ifdef TAINT
169 #ifndef DOSUID
170     if (uid == euid && gid == egid)
171         taintanyway = TRUE;             /* running taintperl explicitly */
172 #endif
173 #endif
174
175 }
176
177 void
178 perl_destruct(sv_interp)
179 register PerlInterpreter *sv_interp;
180 {
181     if (!(curinterp = sv_interp))
182         return;
183 #ifdef EMBEDDED
184     if (main_root)
185         op_free(main_root);
186     main_root = 0;
187 #endif
188 }
189
190 void
191 perl_free(sv_interp)
192 PerlInterpreter *sv_interp;
193 {
194     if (!(curinterp = sv_interp))
195         return;
196     Safefree(sv_interp);
197 }
198
199 int
200 perl_parse(sv_interp, argc, argv, env)
201 PerlInterpreter *sv_interp;
202 register int argc;
203 register char **argv;
204 char **env;
205 {
206     register SV *sv;
207     register char *s;
208     char *scriptname;
209     char *getenv();
210     bool dosearch = FALSE;
211     char *validarg = "";
212
213 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
214 #ifdef IAMSUID
215 #undef IAMSUID
216     fatal("suidperl is no longer needed since the kernel can now execute\n\
217 setuid perl scripts securely.\n");
218 #endif
219 #endif
220
221     if (!(curinterp = sv_interp))
222         return 255;
223
224     if (main_root)
225         op_free(main_root);
226     main_root = 0;
227
228     origargv = argv;
229     origargc = argc;
230     origenviron = environ;
231
232     switch (setjmp(top_env)) {
233     case 1:
234         statusvalue = 255;
235     case 2:
236         return(statusvalue);    /* my_exit() was called */
237     case 3:
238         fprintf(stderr, "panic: top_env\n");
239         exit(1);
240     }
241
242     if (do_undump) {
243         origfilename = savestr(argv[0]);
244         do_undump = FALSE;
245         cxstack_ix = -1;                /* start label stack again */
246         goto just_doit;
247     }
248     sv_setpvn(linestr,"",0);
249     sv = newSVpv("",0);         /* first used for -I flags */
250     init_main_stash();
251     for (argc--,argv++; argc > 0; argc--,argv++) {
252         if (argv[0][0] != '-' || !argv[0][1])
253             break;
254 #ifdef DOSUID
255     if (*validarg)
256         validarg = " PHOOEY ";
257     else
258         validarg = argv[0];
259 #endif
260         s = argv[0]+1;
261       reswitch:
262         switch (*s) {
263         case '0':
264         case 'a':
265         case 'c':
266         case 'd':
267         case 'D':
268         case 'i':
269         case 'l':
270         case 'n':
271         case 'p':
272         case 's':
273         case 'u':
274         case 'U':
275         case 'v':
276         case 'w':
277             if (s = moreswitches(s))
278                 goto reswitch;
279             break;
280
281         case 'e':
282 #ifdef TAINT
283             if (euid != uid || egid != gid)
284                 fatal("No -e allowed in setuid scripts");
285 #endif
286             if (!e_fp) {
287                 e_tmpname = savestr(TMPPATH);
288                 (void)mktemp(e_tmpname);
289                 if (!*e_tmpname)
290                     fatal("Can't mktemp()");
291                 e_fp = fopen(e_tmpname,"w");
292                 if (!e_fp)
293                     fatal("Cannot open temporary file");
294             }
295             if (argv[1]) {
296                 fputs(argv[1],e_fp);
297                 argc--,argv++;
298             }
299             (void)putc('\n', e_fp);
300             break;
301         case 'I':
302 #ifdef TAINT
303             if (euid != uid || egid != gid)
304                 fatal("No -I allowed in setuid scripts");
305 #endif
306             sv_catpv(sv,"-");
307             sv_catpv(sv,s);
308             sv_catpv(sv," ");
309             if (*++s) {
310                 (void)av_push(GvAVn(incgv),newSVpv(s,0));
311             }
312             else if (argv[1]) {
313                 (void)av_push(GvAVn(incgv),newSVpv(argv[1],0));
314                 sv_catpv(sv,argv[1]);
315                 argc--,argv++;
316                 sv_catpv(sv," ");
317             }
318             break;
319         case 'P':
320 #ifdef TAINT
321             if (euid != uid || egid != gid)
322                 fatal("No -P allowed in setuid scripts");
323 #endif
324             preprocess = TRUE;
325             s++;
326             goto reswitch;
327         case 'S':
328 #ifdef TAINT
329             if (euid != uid || egid != gid)
330                 fatal("No -S allowed in setuid scripts");
331 #endif
332             dosearch = TRUE;
333             s++;
334             goto reswitch;
335         case 'x':
336             doextract = TRUE;
337             s++;
338             if (*s)
339                 cddir = savestr(s);
340             break;
341         case '-':
342             argc--,argv++;
343             goto switch_end;
344         case 0:
345             break;
346         default:
347             fatal("Unrecognized switch: -%s",s);
348         }
349     }
350   switch_end:
351     scriptname = argv[0];
352     if (e_fp) {
353         if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
354             fatal("Can't write to temp file for -e: %s", strerror(errno));
355         argc++,argv--;
356         scriptname = e_tmpname;
357     }
358     else if (scriptname == Nullch) {
359 #ifdef MSDOS
360         if ( isatty(fileno(stdin)) )
361             moreswitches("v");
362 #endif
363         scriptname = "-";
364     }
365
366     init_perllib();
367
368     open_script(scriptname,dosearch,sv);
369
370     sv_free(sv);                /* free -I directories */
371     sv = Nullsv;
372
373     validate_suid(validarg);
374
375     if (doextract)
376         find_beginning();
377
378     if (perldb)
379         init_debugger();
380
381     pad = newAV();
382     comppad = pad;
383     av_push(comppad, Nullsv);
384     curpad = AvARRAY(comppad);
385     padname = newAV();
386     comppadname = padname;
387     comppadnamefill = -1;
388     padix = 0;
389
390     init_stack();
391
392     init_context_stack();
393
394     userinit();         /* in case linked C routines want magical variables */
395
396     allgvs = TRUE;
397     init_predump_symbols();
398
399     init_lexer();
400
401     /* now parse the script */
402
403     error_count = 0;
404     if (yyparse() || error_count) {
405         if (minus_c)
406             fatal("%s had compilation errors.\n", origfilename);
407         else {
408             fatal("Execution of %s aborted due to compilation errors.\n",
409                 origfilename);
410         }
411     }
412     curcop->cop_line = 0;
413     curstash = defstash;
414     preprocess = FALSE;
415     if (e_fp) {
416         e_fp = Nullfp;
417         (void)UNLINK(e_tmpname);
418     }
419
420     /* now that script is parsed, we can modify record separator */
421
422     rs = nrs;
423     rslen = nrslen;
424     rschar = nrschar;
425     rspara = (nrslen == 2);
426     sv_setpvn(GvSV(gv_fetchpv("/", TRUE)), rs, rslen);
427
428     if (do_undump)
429         my_unexec();
430
431   just_doit:            /* come here if running an undumped a.out */
432     init_postdump_symbols(argc,argv,env);
433     return 0;
434 }
435
436 int
437 perl_run(sv_interp)
438 PerlInterpreter *sv_interp;
439 {
440     if (!(curinterp = sv_interp))
441         return 255;
442     if (beginav)
443         calllist(beginav);
444     switch (setjmp(top_env)) {
445     case 1:
446         cxstack_ix = -1;                /* start context stack again */
447         break;
448     case 2:
449         curstash = defstash;
450         if (endav)
451             calllist(endav);
452         return(statusvalue);            /* my_exit() was called */
453     case 3:
454         if (!restartop) {
455             fprintf(stderr, "panic: restartop\n");
456             exit(1);
457         }
458         if (stack != mainstack) {
459             dSP;
460             SWITCHSTACK(stack, mainstack);
461         }
462         break;
463     }
464
465     if (!restartop) {
466         DEBUG_x(dump_all());
467         DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
468
469         if (minus_c) {
470             fprintf(stderr,"%s syntax OK\n", origfilename);
471             my_exit(0);
472         }
473     }
474
475     /* do it */
476
477     if (restartop) {
478         op = restartop;
479         restartop = 0;
480         run();
481     }
482     else if (main_start) {
483         op = main_start;
484         run();
485     }
486
487     my_exit(0);
488 }
489
490 void
491 my_exit(status)
492 int status;
493 {
494     statusvalue = (unsigned short)(status & 0xffff);
495     longjmp(top_env, 2);
496 }
497
498 /* Be sure to refetch the stack pointer after calling these routines. */
499
500 int
501 perl_callback(subname, sp, gimme, hasargs, numargs)
502 char *subname;
503 I32 sp;                 /* stack pointer after args are pushed */
504 I32 gimme;              /* called in array or scalar context */
505 I32 hasargs;            /* whether to create a @_ array for routine */
506 I32 numargs;            /* how many args are pushed on the stack */
507 {
508     BINOP myop;         /* fake syntax tree node */
509     
510     ENTER;
511     SAVESPTR(op);
512     stack_base = AvARRAY(stack);
513     stack_sp = stack_base + sp - numargs - 1;
514     op = (OP*)&myop;
515     pp_pushmark();      /* doesn't look at op, actually, except to return */
516     *++stack_sp = (SV*)gv_fetchpv(subname, FALSE);
517     stack_sp += numargs;
518
519     myop.op_last = hasargs ? (OP*)&myop : Nullop;
520     myop.op_next = Nullop;
521
522     op = pp_entersubr();
523     run();
524     LEAVE;
525     return stack_sp - stack_base;
526 }
527
528 int
529 perl_callv(subname, sp, gimme, argv)
530 char *subname;
531 register I32 sp;        /* current stack pointer */
532 I32 gimme;              /* called in array or scalar context */
533 register char **argv;   /* null terminated arg list, NULL for no arglist */
534 {
535     register I32 items = 0;
536     I32 hasargs = (argv != 0);
537
538     av_store(stack, ++sp, Nullsv);      /* reserve spot for 1st return arg */
539     if (hasargs) {
540         while (*argv) {
541             av_store(stack, ++sp, sv_2mortal(newSVpv(*argv,0)));
542             items++;
543             argv++;
544         }
545     }
546     return perl_callback(subname, sp, gimme, hasargs, items);
547 }
548
549 void
550 magicname(sym,name,namlen)
551 char *sym;
552 char *name;
553 I32 namlen;
554 {
555     register GV *gv;
556
557     if (gv = gv_fetchpv(sym,allgvs))
558         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
559 }
560
561 #ifdef DOSISH
562 #define PERLLIB_SEP ';'
563 #else
564 #define PERLLIB_SEP ':'
565 #endif
566
567 static void
568 incpush(p)
569 char *p;
570 {
571     char *s;
572
573     if (!p)
574         return;
575
576     /* Break at all separators */
577     while (*p) {
578         /* First, skip any consecutive separators */
579         while ( *p == PERLLIB_SEP ) {
580             /* Uncomment the next line for PATH semantics */
581             /* (void)av_push(GvAVn(incgv), newSVpv(".", 1)); */
582             p++;
583         }
584         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
585             (void)av_push(GvAVn(incgv), newSVpv(p, (I32)(s - p)));
586             p = s + 1;
587         } else {
588             (void)av_push(GvAVn(incgv), newSVpv(p, 0));
589             break;
590         }
591     }
592 }
593
594 /* This routine handles any switches that can be given during run */
595
596 char *
597 moreswitches(s)
598 char *s;
599 {
600     I32 numlen;
601
602     switch (*s) {
603     case '0':
604         nrschar = scan_oct(s, 4, &numlen);
605         nrs = nsavestr("\n",1);
606         *nrs = nrschar;
607         if (nrschar > 0377) {
608             nrslen = 0;
609             nrs = "";
610         }
611         else if (!nrschar && numlen >= 2) {
612             nrslen = 2;
613             nrs = "\n\n";
614             nrschar = '\n';
615         }
616         return s + numlen;
617     case 'a':
618         minus_a = TRUE;
619         s++;
620         return s;
621     case 'c':
622         minus_c = TRUE;
623         s++;
624         return s;
625     case 'd':
626 #ifdef TAINT
627         if (euid != uid || egid != gid)
628             fatal("No -d allowed in setuid scripts");
629 #endif
630         perldb = TRUE;
631         s++;
632         return s;
633     case 'D':
634 #ifdef DEBUGGING
635 #ifdef TAINT
636         if (euid != uid || egid != gid)
637             fatal("No -D allowed in setuid scripts");
638 #endif
639         if (isALPHA(s[1])) {
640             static char debopts[] = "psltocPmfrxuLHX";
641             char *d;
642
643             for (s++; *s && (d = strchr(debopts,*s)); s++)
644                 debug |= 1 << (d - debopts);
645         }
646         else {
647             debug = atoi(s+1);
648             for (s++; isDIGIT(*s); s++) ;
649         }
650         debug |= 32768;
651 #else
652         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
653         for (s++; isDIGIT(*s); s++) ;
654 #endif
655         /*SUPPRESS 530*/
656         return s;
657     case 'i':
658         if (inplace)
659             Safefree(inplace);
660         inplace = savestr(s+1);
661         /*SUPPRESS 530*/
662         for (s = inplace; *s && !isSPACE(*s); s++) ;
663         *s = '\0';
664         break;
665     case 'I':
666 #ifdef TAINT
667         if (euid != uid || egid != gid)
668             fatal("No -I allowed in setuid scripts");
669 #endif
670         if (*++s) {
671             (void)av_push(GvAVn(incgv),newSVpv(s,0));
672         }
673         else
674             fatal("No space allowed after -I");
675         break;
676     case 'l':
677         minus_l = TRUE;
678         s++;
679         if (isDIGIT(*s)) {
680             ors = savestr("\n");
681             orslen = 1;
682             *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
683             s += numlen;
684         }
685         else {
686             ors = nsavestr(nrs,nrslen);
687             orslen = nrslen;
688         }
689         return s;
690     case 'n':
691         minus_n = TRUE;
692         s++;
693         return s;
694     case 'p':
695         minus_p = TRUE;
696         s++;
697         return s;
698     case 's':
699 #ifdef TAINT
700         if (euid != uid || egid != gid)
701             fatal("No -s allowed in setuid scripts");
702 #endif
703         doswitches = TRUE;
704         s++;
705         return s;
706     case 'u':
707         do_undump = TRUE;
708         s++;
709         return s;
710     case 'U':
711         unsafe = TRUE;
712         s++;
713         return s;
714     case 'v':
715         fputs("\nThis is perl, version 5.0, Alpha 2 (unsupported)\n\n",stdout);
716         fputs(rcsid,stdout);
717         fputs("\nCopyright (c) 1989, 1990, 1991, 1992, 1993 Larry Wall\n",stdout);
718 #ifdef MSDOS
719         fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
720         stdout);
721 #ifdef OS2
722         fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
723         stdout);
724 #endif
725 #endif
726 #ifdef atarist
727         fputs("atariST series port, ++jrb  bammi@cadence.com\n", stdout);
728 #endif
729         fputs("\n\
730 Perl may be copied only under the terms of either the Artistic License or the\n\
731 GNU General Public License, which may be found in the Perl 5.0 source kit.\n",stdout);
732 #ifdef MSDOS
733         usage(origargv[0]);
734 #endif
735         exit(0);
736     case 'w':
737         dowarn = TRUE;
738         s++;
739         return s;
740     case ' ':
741         if (s[1] == '-')        /* Additional switches on #! line. */
742             return s+2;
743         break;
744     case 0:
745     case '\n':
746     case '\t':
747         break;
748     default:
749         fatal("Switch meaningless after -x: -%s",s);
750     }
751     return Nullch;
752 }
753
754 /* compliments of Tom Christiansen */
755
756 /* unexec() can be found in the Gnu emacs distribution */
757
758 void
759 my_unexec()
760 {
761 #ifdef UNEXEC
762     int    status;
763     extern int etext;
764
765     sprintf (buf, "%s.perldump", origfilename);
766     sprintf (tokenbuf, "%s/perl", BIN);
767
768     status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
769     if (status)
770         fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
771     my_exit(status);
772 #else
773     ABORT();            /* for use with undump */
774 #endif
775 }
776
777 static void
778 init_main_stash()
779 {
780     curstash = defstash = newHV(0);
781     curstname = newSVpv("main",4);
782     GvHV(gv_fetchpv("_main",TRUE)) = defstash;
783     HvNAME(defstash) = "main";
784     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE)));
785     SvMULTI_on(incgv);
786     defgv = gv_fetchpv("_",TRUE);
787 }
788
789 static void
790 open_script(scriptname,dosearch,sv)
791 char *scriptname;
792 bool dosearch;
793 SV *sv;
794 {
795     char *xfound = Nullch;
796     char *xfailed = Nullch;
797     register char *s;
798     I32 len;
799
800     if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
801
802         bufend = s + strlen(s);
803         while (*s) {
804 #ifndef DOSISH
805             s = cpytill(tokenbuf,s,bufend,':',&len);
806 #else
807 #ifdef atarist
808             for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
809             tokenbuf[len] = '\0';
810 #else
811             for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
812             tokenbuf[len] = '\0';
813 #endif
814 #endif
815             if (*s)
816                 s++;
817 #ifndef DOSISH
818             if (len && tokenbuf[len-1] != '/')
819 #else
820 #ifdef atarist
821             if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
822 #else
823             if (len && tokenbuf[len-1] != '\\')
824 #endif
825 #endif
826                 (void)strcat(tokenbuf+len,"/");
827             (void)strcat(tokenbuf+len,scriptname);
828             DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
829             if (stat(tokenbuf,&statbuf) < 0)            /* not there? */
830                 continue;
831             if (S_ISREG(statbuf.st_mode)
832              && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
833                 xfound = tokenbuf;              /* bingo! */
834                 break;
835             }
836             if (!xfailed)
837                 xfailed = savestr(tokenbuf);
838         }
839         if (!xfound)
840             fatal("Can't execute %s", xfailed ? xfailed : scriptname );
841         if (xfailed)
842             Safefree(xfailed);
843         scriptname = xfound;
844     }
845
846     origfilename = savestr(scriptname);
847     curcop->cop_filegv = gv_fetchfile(origfilename);
848     if (strEQ(origfilename,"-"))
849         scriptname = "";
850     if (preprocess) {
851         char *cpp = CPPSTDIN;
852
853         if (strEQ(cpp,"cppstdin"))
854             sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
855         else
856             sprintf(tokenbuf, "%s", cpp);
857         sv_catpv(sv,"-I");
858         sv_catpv(sv,PRIVLIB);
859 #ifdef MSDOS
860         (void)sprintf(buf, "\
861 sed %s -e \"/^[^#]/b\" \
862  -e \"/^#[      ]*include[      ]/b\" \
863  -e \"/^#[      ]*define[       ]/b\" \
864  -e \"/^#[      ]*if[   ]/b\" \
865  -e \"/^#[      ]*ifdef[        ]/b\" \
866  -e \"/^#[      ]*ifndef[       ]/b\" \
867  -e \"/^#[      ]*else/b\" \
868  -e \"/^#[      ]*elif[         ]/b\" \
869  -e \"/^#[      ]*undef[        ]/b\" \
870  -e \"/^#[      ]*endif/b\" \
871  -e \"s/^#.*//\" \
872  %s | %s -C %s %s",
873           (doextract ? "-e \"1,/^#/d\n\"" : ""),
874 #else
875         (void)sprintf(buf, "\
876 %s %s -e '/^[^#]/b' \
877  -e '/^#[       ]*include[      ]/b' \
878  -e '/^#[       ]*define[       ]/b' \
879  -e '/^#[       ]*if[   ]/b' \
880  -e '/^#[       ]*ifdef[        ]/b' \
881  -e '/^#[       ]*ifndef[       ]/b' \
882  -e '/^#[       ]*else/b' \
883  -e '/^#[       ]*elif[         ]/b' \
884  -e '/^#[       ]*undef[        ]/b' \
885  -e '/^#[       ]*endif/b' \
886  -e 's/^[       ]*#.*//' \
887  %s | %s -C %s %s",
888 #ifdef LOC_SED
889           LOC_SED,
890 #else
891           "sed",
892 #endif
893           (doextract ? "-e '1,/^#/d\n'" : ""),
894 #endif
895           scriptname, tokenbuf, SvPVn(sv), CPPMINUS);
896         DEBUG_P(fprintf(stderr, "%s\n", buf));
897         doextract = FALSE;
898 #ifdef IAMSUID                          /* actually, this is caught earlier */
899         if (euid != uid && !euid) {     /* if running suidperl */
900 #ifdef HAS_SETEUID
901             (void)seteuid(uid);         /* musn't stay setuid root */
902 #else
903 #ifdef HAS_SETREUID
904             (void)setreuid(-1, uid);
905 #else
906             setuid(uid);
907 #endif
908 #endif
909             if (geteuid() != uid)
910                 fatal("Can't do seteuid!\n");
911         }
912 #endif /* IAMSUID */
913         rsfp = my_popen(buf,"r");
914     }
915     else if (!*scriptname) {
916 #ifdef TAINT
917         if (euid != uid || egid != gid)
918             fatal("Can't take set-id script from stdin");
919 #endif
920         rsfp = stdin;
921     }
922     else
923         rsfp = fopen(scriptname,"r");
924     if ((FILE*)rsfp == Nullfp) {
925 #ifdef DOSUID
926 #ifndef IAMSUID         /* in case script is not readable before setuid */
927         if (euid && stat(SvPV(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
928           statbuf.st_mode & (S_ISUID|S_ISGID)) {
929             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
930             execv(buf, origargv);       /* try again */
931             fatal("Can't do setuid\n");
932         }
933 #endif
934 #endif
935         fatal("Can't open perl script \"%s\": %s\n",
936           SvPV(GvSV(curcop->cop_filegv)), strerror(errno));
937     }
938 }
939
940 static void
941 validate_suid(validarg)
942 char *validarg;
943 {
944     char *s;
945     /* do we need to emulate setuid on scripts? */
946
947     /* This code is for those BSD systems that have setuid #! scripts disabled
948      * in the kernel because of a security problem.  Merely defining DOSUID
949      * in perl will not fix that problem, but if you have disabled setuid
950      * scripts in the kernel, this will attempt to emulate setuid and setgid
951      * on scripts that have those now-otherwise-useless bits set.  The setuid
952      * root version must be called suidperl or sperlN.NNN.  If regular perl
953      * discovers that it has opened a setuid script, it calls suidperl with
954      * the same argv that it had.  If suidperl finds that the script it has
955      * just opened is NOT setuid root, it sets the effective uid back to the
956      * uid.  We don't just make perl setuid root because that loses the
957      * effective uid we had before invoking perl, if it was different from the
958      * uid.
959      *
960      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
961      * be defined in suidperl only.  suidperl must be setuid root.  The
962      * Configure script will set this up for you if you want it.
963      *
964      * There is also the possibility of have a script which is running
965      * set-id due to a C wrapper.  We want to do the TAINT checks
966      * on these set-id scripts, but don't want to have the overhead of
967      * them in normal perl, and can't use suidperl because it will lose
968      * the effective uid info, so we have an additional non-setuid root
969      * version called taintperl or tperlN.NNN that just does the TAINT checks.
970      */
971
972 #ifdef DOSUID
973     if (fstat(fileno(rsfp),&statbuf) < 0)       /* normal stat is insecure */
974         fatal("Can't stat script \"%s\"",origfilename);
975     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
976         I32 len;
977
978 #ifdef IAMSUID
979 #ifndef HAS_SETREUID
980         /* On this access check to make sure the directories are readable,
981          * there is actually a small window that the user could use to make
982          * filename point to an accessible directory.  So there is a faint
983          * chance that someone could execute a setuid script down in a
984          * non-accessible directory.  I don't know what to do about that.
985          * But I don't think it's too important.  The manual lies when
986          * it says access() is useful in setuid programs.
987          */
988         if (access(SvPV(GvSV(curcop->cop_filegv)),1))   /*double check*/
989             fatal("Permission denied");
990 #else
991         /* If we can swap euid and uid, then we can determine access rights
992          * with a simple stat of the file, and then compare device and
993          * inode to make sure we did stat() on the same file we opened.
994          * Then we just have to make sure he or she can execute it.
995          */
996         {
997             struct stat tmpstatbuf;
998
999             if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
1000                 fatal("Can't swap uid and euid");       /* really paranoid */
1001             if (stat(SvPV(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1002                 fatal("Permission denied");     /* testing full pathname here */
1003             if (tmpstatbuf.st_dev != statbuf.st_dev ||
1004                 tmpstatbuf.st_ino != statbuf.st_ino) {
1005                 (void)fclose(rsfp);
1006                 if (rsfp = my_popen("/bin/mail root","w")) {    /* heh, heh */
1007                     fprintf(rsfp,
1008 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1009 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1010                         uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1011                         statbuf.st_dev, statbuf.st_ino,
1012                         SvPV(GvSV(curcop->cop_filegv)),
1013                         statbuf.st_uid, statbuf.st_gid);
1014                     (void)my_pclose(rsfp);
1015                 }
1016                 fatal("Permission denied\n");
1017             }
1018             if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
1019                 fatal("Can't reswap uid and euid");
1020             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
1021                 fatal("Permission denied\n");
1022         }
1023 #endif /* HAS_SETREUID */
1024 #endif /* IAMSUID */
1025
1026         if (!S_ISREG(statbuf.st_mode))
1027             fatal("Permission denied");
1028         if (statbuf.st_mode & S_IWOTH)
1029             fatal("Setuid/gid script is writable by world");
1030         doswitches = FALSE;             /* -s is insecure in suid */
1031         curcop->cop_line++;
1032         if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1033           strnNE(tokenbuf,"#!",2) )     /* required even on Sys V */
1034             fatal("No #! line");
1035         s = tokenbuf+2;
1036         if (*s == ' ') s++;
1037         while (!isSPACE(*s)) s++;
1038         if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
1039             fatal("Not a perl script");
1040         while (*s == ' ' || *s == '\t') s++;
1041         /*
1042          * #! arg must be what we saw above.  They can invoke it by
1043          * mentioning suidperl explicitly, but they may not add any strange
1044          * arguments beyond what #! says if they do invoke suidperl that way.
1045          */
1046         len = strlen(validarg);
1047         if (strEQ(validarg," PHOOEY ") ||
1048             strnNE(s,validarg,len) || !isSPACE(s[len]))
1049             fatal("Args must match #! line");
1050
1051 #ifndef IAMSUID
1052         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1053             euid == statbuf.st_uid)
1054             if (!do_undump)
1055                 fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1056 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1057 #endif /* IAMSUID */
1058
1059         if (euid) {     /* oops, we're not the setuid root perl */
1060             (void)fclose(rsfp);
1061 #ifndef IAMSUID
1062             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1063             execv(buf, origargv);       /* try again */
1064 #endif
1065             fatal("Can't do setuid\n");
1066         }
1067
1068         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1069 #ifdef HAS_SETEGID
1070             (void)setegid(statbuf.st_gid);
1071 #else
1072 #ifdef HAS_SETREGID
1073             (void)setregid((GIDTYPE)-1,statbuf.st_gid);
1074 #else
1075             setgid(statbuf.st_gid);
1076 #endif
1077 #endif
1078             if (getegid() != statbuf.st_gid)
1079                 fatal("Can't do setegid!\n");
1080         }
1081         if (statbuf.st_mode & S_ISUID) {
1082             if (statbuf.st_uid != euid)
1083 #ifdef HAS_SETEUID
1084                 (void)seteuid(statbuf.st_uid);  /* all that for this */
1085 #else
1086 #ifdef HAS_SETREUID
1087                 (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
1088 #else
1089                 setuid(statbuf.st_uid);
1090 #endif
1091 #endif
1092             if (geteuid() != statbuf.st_uid)
1093                 fatal("Can't do seteuid!\n");
1094         }
1095         else if (uid) {                 /* oops, mustn't run as root */
1096 #ifdef HAS_SETEUID
1097             (void)seteuid((UIDTYPE)uid);
1098 #else
1099 #ifdef HAS_SETREUID
1100             (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
1101 #else
1102             setuid((UIDTYPE)uid);
1103 #endif
1104 #endif
1105             if (geteuid() != uid)
1106                 fatal("Can't do seteuid!\n");
1107         }
1108         uid = (int)getuid();
1109         euid = (int)geteuid();
1110         gid = (int)getgid();
1111         egid = (int)getegid();
1112         if (!cando(S_IXUSR,TRUE,&statbuf))
1113             fatal("Permission denied\n");       /* they can't do this */
1114     }
1115 #ifdef IAMSUID
1116     else if (preprocess)
1117         fatal("-P not allowed for setuid/setgid script\n");
1118     else
1119         fatal("Script is not setuid/setgid in suidperl\n");
1120 #else
1121 #ifndef TAINT           /* we aren't taintperl or suidperl */
1122     /* script has a wrapper--can't run suidperl or we lose euid */
1123     else if (euid != uid || egid != gid) {
1124         (void)fclose(rsfp);
1125         (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
1126         execv(buf, origargv);   /* try again */
1127         fatal("Can't run setuid script with taint checks");
1128     }
1129 #endif /* TAINT */
1130 #endif /* IAMSUID */
1131 #else /* !DOSUID */
1132 #ifndef TAINT           /* we aren't taintperl or suidperl */
1133     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
1134 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1135         fstat(fileno(rsfp),&statbuf);   /* may be either wrapped or real suid */
1136         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1137             ||
1138             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1139            )
1140             if (!do_undump)
1141                 fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1142 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1143 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1144         /* not set-id, must be wrapped */
1145         (void)fclose(rsfp);
1146         (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
1147         execv(buf, origargv);   /* try again */
1148         fatal("Can't run setuid script with taint checks");
1149     }
1150 #endif /* TAINT */
1151 #endif /* DOSUID */
1152 }
1153
1154 static void
1155 find_beginning()
1156 {
1157 #if !defined(IAMSUID) && !defined(TAINT)
1158     register char *s;
1159
1160     /* skip forward in input to the real script? */
1161
1162     while (doextract) {
1163         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1164             fatal("No Perl script found in input\n");
1165         if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1166             ungetc('\n',rsfp);          /* to keep line count right */
1167             doextract = FALSE;
1168             if (s = instr(s,"perl -")) {
1169                 s += 6;
1170                 /*SUPPRESS 530*/
1171                 while (s = moreswitches(s)) ;
1172             }
1173             if (cddir && chdir(cddir) < 0)
1174                 fatal("Can't chdir to %s",cddir);
1175         }
1176     }
1177 #endif /* !defined(IAMSUID) && !defined(TAINT) */
1178 }
1179
1180 static void
1181 init_debugger()
1182 {
1183     GV* tmpgv;
1184
1185     debstash = newHV(0);
1186     GvHV(gv_fetchpv("_DB",TRUE)) = debstash;
1187     curstash = debstash;
1188     dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args",TRUE))));
1189     SvMULTI_on(tmpgv);
1190     AvREAL_off(dbargs);
1191     DBgv = gv_fetchpv("DB",TRUE);
1192     SvMULTI_on(DBgv);
1193     DBline = gv_fetchpv("dbline",TRUE);
1194     SvMULTI_on(DBline);
1195     DBsub = gv_HVadd(tmpgv = gv_fetchpv("sub",TRUE));
1196     SvMULTI_on(tmpgv);
1197     DBsingle = GvSV((tmpgv = gv_fetchpv("single",TRUE)));
1198     SvMULTI_on(tmpgv);
1199     DBtrace = GvSV((tmpgv = gv_fetchpv("trace",TRUE)));
1200     SvMULTI_on(tmpgv);
1201     DBsignal = GvSV((tmpgv = gv_fetchpv("signal",TRUE)));
1202     SvMULTI_on(tmpgv);
1203     curstash = defstash;
1204 }
1205
1206 static void
1207 init_stack()
1208 {
1209     stack = newAV();
1210     mainstack = stack;                  /* remember in case we switch stacks */
1211     AvREAL_off(stack);                  /* not a real array */
1212     av_fill(stack,127); av_fill(stack,-1);      /* preextend stack */
1213
1214     stack_base = AvARRAY(stack);
1215     stack_sp = stack_base;
1216     stack_max = stack_base + 128;
1217
1218     New(54,markstack,64,int);
1219     markstack_ptr = markstack;
1220     markstack_max = markstack + 64;
1221
1222     New(54,scopestack,32,int);
1223     scopestack_ix = 0;
1224     scopestack_max = 32;
1225
1226     New(54,savestack,128,ANY);
1227     savestack_ix = 0;
1228     savestack_max = 128;
1229
1230     New(54,retstack,16,OP*);
1231     retstack_ix = 0;
1232     retstack_max = 16;
1233 }
1234
1235 static void
1236 init_lexer()
1237 {
1238     bufend = bufptr = SvPVn(linestr);
1239     subname = newSVpv("main",4);
1240 }
1241
1242 static void
1243 init_context_stack()
1244 {
1245     New(50,cxstack,128,CONTEXT);
1246     DEBUG( {
1247         New(51,debname,128,char);
1248         New(52,debdelim,128,char);
1249     } )
1250 }
1251
1252 static void
1253 init_predump_symbols()
1254 {
1255     GV *tmpgv;
1256
1257     sv_setpvn(GvSV(gv_fetchpv("\"", TRUE)), " ", 1);
1258
1259     stdingv = gv_fetchpv("STDIN",TRUE);
1260     SvMULTI_on(stdingv);
1261     if (!GvIO(stdingv))
1262         GvIO(stdingv) = newIO();
1263     GvIO(stdingv)->ifp = stdin;
1264     tmpgv = gv_fetchpv("stdin",TRUE);
1265     GvIO(tmpgv) = GvIO(stdingv);
1266     SvMULTI_on(tmpgv);
1267
1268     tmpgv = gv_fetchpv("STDOUT",TRUE);
1269     SvMULTI_on(tmpgv);
1270     if (!GvIO(tmpgv))
1271         GvIO(tmpgv) = newIO();
1272     GvIO(tmpgv)->ofp = GvIO(tmpgv)->ifp = stdout;
1273     defoutgv = tmpgv;
1274     tmpgv = gv_fetchpv("stdout",TRUE);
1275     GvIO(tmpgv) = GvIO(defoutgv);
1276     SvMULTI_on(tmpgv);
1277
1278     curoutgv = gv_fetchpv("STDERR",TRUE);
1279     SvMULTI_on(curoutgv);
1280     if (!GvIO(curoutgv))
1281         GvIO(curoutgv) = newIO();
1282     GvIO(curoutgv)->ofp = GvIO(curoutgv)->ifp = stderr;
1283     tmpgv = gv_fetchpv("stderr",TRUE);
1284     GvIO(tmpgv) = GvIO(curoutgv);
1285     SvMULTI_on(tmpgv);
1286     curoutgv = defoutgv;                /* switch back to STDOUT */
1287
1288     statname = NEWSV(66,0);             /* last filename we did stat on */
1289 }
1290
1291 static void
1292 init_postdump_symbols(argc,argv,env)
1293 register int argc;
1294 register char **argv;
1295 register char **env;
1296 {
1297     char *s;
1298     SV *sv;
1299     GV* tmpgv;
1300
1301     argc--,argv++;      /* skip name of script */
1302     if (doswitches) {
1303         for (; argc > 0 && **argv == '-'; argc--,argv++) {
1304             if (!argv[0][1])
1305                 break;
1306             if (argv[0][1] == '-') {
1307                 argc--,argv++;
1308                 break;
1309             }
1310             if (s = strchr(argv[0], '=')) {
1311                 *s++ = '\0';
1312                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE)),s);
1313             }
1314             else
1315                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE)),1);
1316         }
1317     }
1318     toptarget = NEWSV(0,0);
1319     sv_upgrade(toptarget, SVt_PVFM);
1320     sv_setpvn(toptarget, "", 0);
1321     bodytarget = NEWSV(0,0);
1322     sv_upgrade(bodytarget, SVt_PVFM);
1323     sv_setpvn(bodytarget, "", 0);
1324     formtarget = bodytarget;
1325
1326 #ifdef TAINT
1327     tainted = 1;
1328 #endif
1329     if (tmpgv = gv_fetchpv("0",allgvs)) {
1330         sv_setpv(GvSV(tmpgv),origfilename);
1331         magicname("0", "0", 1);
1332     }
1333     if (tmpgv = gv_fetchpv("\024",allgvs))
1334         time(&basetime);
1335     if (tmpgv = gv_fetchpv("\030",allgvs))
1336         sv_setpv(GvSV(tmpgv),origargv[0]);
1337     if (argvgv = gv_fetchpv("ARGV",allgvs)) {
1338         SvMULTI_on(argvgv);
1339         (void)gv_AVadd(argvgv);
1340         av_clear(GvAVn(argvgv));
1341         for (; argc > 0; argc--,argv++) {
1342             (void)av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1343         }
1344     }
1345 #ifdef TAINT
1346     (void) gv_fetchpv("ENV",TRUE);              /* must test PATH and IFS */
1347 #endif
1348     if (envgv = gv_fetchpv("ENV",allgvs)) {
1349         HV *hv;
1350         SvMULTI_on(envgv);
1351         hv = GvHVn(envgv);
1352         hv_clear(hv, FALSE);
1353         hv_magic(hv, envgv, 'E');
1354         if (env != environ)
1355             environ[0] = Nullch;
1356         for (; *env; env++) {
1357             if (!(s = strchr(*env,'=')))
1358                 continue;
1359             *s++ = '\0';
1360             sv = newSVpv(s--,0);
1361             (void)hv_store(hv, *env, s - *env, sv, 0);
1362             *s = '=';
1363         }
1364     }
1365 #ifdef TAINT
1366     tainted = 0;
1367 #endif
1368     if (tmpgv = gv_fetchpv("$",allgvs))
1369         sv_setiv(GvSV(tmpgv),(I32)getpid());
1370
1371     if (dowarn) {
1372         gv_check('A','Z');
1373         gv_check('a','z');
1374     }
1375 }
1376
1377 static void
1378 init_perllib()
1379 {
1380 #ifndef TAINT           /* Can't allow arbitrary PERLLIB in setuid script */
1381     incpush(getenv("PERLLIB"));
1382 #endif /* TAINT */
1383
1384 #ifndef PRIVLIB
1385 #define PRIVLIB "/usr/local/lib/perl"
1386 #endif
1387     incpush(PRIVLIB);
1388     (void)av_push(GvAVn(incgv),newSVpv(".",1));
1389 }
1390
1391 void
1392 calllist(list)
1393 AV* list;
1394 {
1395     I32 i;
1396     I32 fill = AvFILL(list);
1397     jmp_buf oldtop;
1398     I32 sp = stack_sp - stack_base;
1399
1400     av_store(stack, ++sp, Nullsv);      /* reserve spot for 1st return arg */
1401     Copy(top_env, oldtop, 1, jmp_buf);
1402
1403     for (i = 0; i <= fill; i++)
1404     {
1405         GV *gv = (GV*)av_shift(list);
1406         SV* tmpsv = NEWSV(0,0);
1407
1408         if (gv && GvCV(gv)) {
1409             gv_efullname(tmpsv, gv);
1410             if (setjmp(top_env)) {
1411                 if (list == beginav)
1412                     exit(1);
1413             }
1414             else {
1415                 perl_callback(SvPV(tmpsv), sp, G_SCALAR, 0, 0);
1416             }
1417         }
1418         sv_free(tmpsv);
1419         sv_free(gv);
1420     }
1421
1422     Copy(oldtop, top_env, 1, jmp_buf);
1423 }
1424