This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.0 alpha 5
[perl5.git] / perl.c
diff --git a/perl.c b/perl.c
index f93095d..c6c2bee 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1,11 +1,23 @@
-char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.6 $$Date: 91/11/11 16:38:45 $\nPatch level: ###\n";
 /*
- *    Copyright (c) 1991, Larry Wall
+ *    Copyright (c) 1991, 1992, 1993, 1994 Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
  *
  * $Log:       perl.c,v $
+ * Revision 4.1  92/08/07  18:25:50  lwall
+ * 
+ * Revision 4.0.1.7  92/06/08  14:50:39  lwall
+ * patch20: PERLLIB now supports multiple directories
+ * patch20: running taintperl explicitly now does checks even if $< == $>
+ * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space
+ * patch20: perl -P now uses location of sed determined by Configure
+ * patch20: form feed for formats is now specifiable via $^L
+ * patch20: paragraph mode now skips extra newlines automatically
+ * patch20: oldeval "1 #comment" didn't work
+ * patch20: couldn't require . files
+ * patch20: semantic compilation errors didn't abort execution
+ * 
  * Revision 4.0.1.6  91/11/11  16:38:45  lwall
  * patch19: default arg for shift was wrong after first subroutine definition
  * patch19: op/regexp.t failed from missing arg to bcmp()
@@ -16,8 +28,8 @@ char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.6 $$Date: 91/11/11 16:38:45
  * patch11: cppstdin now installed outside of source directory
  * patch11: -P didn't allow use of #elif or #undef
  * patch11: prepared for ctype implementations that don't define isascii()
- * patch11: added eval {}
- * patch11: eval confused by string containing null
+ * patch11: added oldeval {}
+ * patch11: oldeval confused by string containing null
  * 
  * Revision 4.0.1.4  91/06/10  01:23:07  lwall
  * patch10: perl -v printed incorrect copyright notice
@@ -29,7 +41,7 @@ char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.6 $$Date: 91/11/11 16:38:45
  * patch4: new copyright notice
  * patch4: added $^P variable to control calling of perldb routines
  * patch4: added $^F variable to specify maximum system fd, default 2
- * patch4: debugger lost track of lines in eval
+ * patch4: debugger lost track of lines in oldeval
  * 
  * Revision 4.0.1.1  91/04/11  17:49:05  lwall
  * patch1: fixed undefined environ problem
@@ -44,13 +56,9 @@ char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.6 $$Date: 91/11/11 16:38:45
 #include "EXTERN.h"
 #include "perl.h"
 #include "perly.h"
-#ifdef MSDOS
-#include "patchlev.h"
-#else
 #include "patchlevel.h"
-#endif
 
-char *getenv();
+char rcsid[] = "$RCSfile: perl.c,v $$Revision: 5.0 $$Date: 92/08/07 18:25:50 $\nPatch level: ###\n";
 
 #ifdef IAMSUID
 #ifndef DOSUID
@@ -64,69 +72,177 @@ char *getenv();
 #endif
 #endif
 
-static char* moreswitches();
-static char* cddir;
-static bool minus_c;
-static char patchlevel[6];
-static char *nrs = "\n";
-static int nrschar = '\n';      /* final char of rs, or 0777 if none */
-static int nrslen = 1;
+static void incpush();
+static void validate_suid();
+static void find_beginning();
+static void init_main_stash();
+static void open_script();
+static void init_debugger();
+static void init_stack();
+static void init_lexer();
+static void init_context_stack();
+static void init_predump_symbols();
+static void init_postdump_symbols();
+static void init_perllib();
+
+PerlInterpreter *
+perl_alloc()
+{
+    PerlInterpreter *sv_interp;
+    PerlInterpreter junk;
+
+    curinterp = &junk;
+    Zero(&junk, 1, PerlInterpreter);
+    New(53, sv_interp, 1, PerlInterpreter);
+    return sv_interp;
+}
+
+void
+perl_construct( sv_interp )
+register PerlInterpreter *sv_interp;
+{
+    if (!(curinterp = sv_interp))
+       return;
+
+    Zero(sv_interp, 1, PerlInterpreter);
+
+    /* Init the real globals? */
+    if (!linestr) {
+       linestr = NEWSV(65,80);
+       sv_upgrade(linestr,SVt_PVIV);
+
+       SvREADONLY_on(&sv_undef);
+
+       sv_setpv(&sv_no,No);
+       SvNV(&sv_no);
+       SvREADONLY_on(&sv_no);
+
+       sv_setpv(&sv_yes,Yes);
+       SvNV(&sv_yes);
+       SvREADONLY_on(&sv_yes);
+
+#ifdef MSDOS
+       /*
+        * There is no way we can refer to them from Perl so close them to save
+        * space.  The other alternative would be to provide STDAUX and STDPRN
+        * filehandles.
+        */
+       (void)fclose(stdaux);
+       (void)fclose(stdprn);
+#endif
+    }
+
+#ifdef EMBEDDED
+    chopset    = " \n-";
+    copline    = NOLINE;
+    curcop     = &compiling;
+    cxstack_ix = -1;
+    cxstack_max        = 128;
+    dlmax      = 128;
+    laststatval        = -1;
+    laststype  = OP_STAT;
+    maxscream  = -1;
+    maxsysfd   = MAXSYSFD;
+    nrs                = "\n";
+    nrschar    = '\n';
+    nrslen     = 1;
+    rs         = "\n";
+    rschar     = '\n';
+    rsfp       = Nullfp;
+    rslen      = 1;
+    statname   = Nullsv;
+    tmps_floor = -1;
+    tmps_ix    = -1;
+    tmps_max   = -1;
+#endif
+
+    uid = (int)getuid();
+    euid = (int)geteuid();
+    gid = (int)getgid();
+    egid = (int)getegid();
+    tainting = (euid != uid || egid != gid);
+    sprintf(patchlevel,"%3.3s%2.2d", strchr(rcsid,'5'), PATCHLEVEL);
+
+    (void)sprintf(strchr(rcsid,'#'), "%d\n", PATCHLEVEL);
+
+    fdpid = newAV();   /* for remembering popen pids by fd */
+    pidstatus = newHV();/* for remembering status of dead pids */
+}
+
+void
+perl_destruct(sv_interp)
+register PerlInterpreter *sv_interp;
+{
+    if (!(curinterp = sv_interp))
+       return;
+#ifdef EMBEDDED
+    if (main_root)
+       op_free(main_root);
+    main_root = 0;
+#endif
+}
+
+void
+perl_free(sv_interp)
+PerlInterpreter *sv_interp;
+{
+    if (!(curinterp = sv_interp))
+       return;
+    Safefree(sv_interp);
+}
 
-main(argc,argv,env)
+int
+perl_parse(sv_interp, argc, argv, env)
+PerlInterpreter *sv_interp;
 register int argc;
 register char **argv;
-register char **env;
+char **env;
 {
-    register STR *str;
+    register SV *sv;
     register char *s;
     char *scriptname;
     char *getenv();
     bool dosearch = FALSE;
-#ifdef DOSUID
     char *validarg = "";
-#endif
 
 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 #ifdef IAMSUID
 #undef IAMSUID
-    fatal("suidperl is no longer needed since the kernel can now execute\n\
+    croak("suidperl is no longer needed since the kernel can now execute\n\
 setuid perl scripts securely.\n");
 #endif
 #endif
 
+    if (!(curinterp = sv_interp))
+       return 255;
+
+    if (main_root)
+       op_free(main_root);
+    main_root = 0;
+
     origargv = argv;
     origargc = argc;
     origenviron = environ;
-    uid = (int)getuid();
-    euid = (int)geteuid();
-    gid = (int)getgid();
-    egid = (int)getegid();
-    sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
-#ifdef MSDOS
-    /*
-     * There is no way we can refer to them from Perl so close them to save
-     * space.  The other alternative would be to provide STDAUX and STDPRN
-     * filehandles.
-     */
-    (void)fclose(stdaux);
-    (void)fclose(stdprn);
-#endif
+
+    switch (setjmp(top_env)) {
+    case 1:
+       statusvalue = 255;
+    case 2:
+       return(statusvalue);    /* my_exit() was called */
+    case 3:
+       fprintf(stderr, "panic: top_env\n");
+       exit(1);
+    }
+
     if (do_undump) {
        origfilename = savestr(argv[0]);
-       do_undump = 0;
-       loop_ptr = -1;          /* start label stack again */
+       do_undump = FALSE;
+       cxstack_ix = -1;                /* start label stack again */
        goto just_doit;
     }
-    (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
-    linestr = Str_new(65,80);
-    str_nset(linestr,"",0);
-    str = str_make("",0);              /* first used for -I flags */
-    curstash = defstash = hnew(0);
-    curstname = str_make("main",4);
-    stab_xhash(stabent("_main",TRUE)) = defstash;
-    defstash->tbl_name = "main";
-    incstab = hadd(aadd(stabent("INC",TRUE)));
-    incstab->str_pok |= SP_MULTI;
+    sv_setpvn(linestr,"",0);
+    sv = newSVpv("",0);                /* first used for -I flags */
+    init_main_stash();
     for (argc--,argv++; argc > 0; argc--,argv++) {
        if (argv[0][0] != '-' || !argv[0][1])
            break;
@@ -148,6 +264,8 @@ setuid perl scripts securely.\n");
        case 'l':
        case 'n':
        case 'p':
+       case 's':
+       case 'T':
        case 'u':
        case 'U':
        case 'v':
@@ -157,16 +275,16 @@ setuid perl scripts securely.\n");
            break;
 
        case 'e':
-#ifdef TAINT
            if (euid != uid || egid != gid)
-               fatal("No -e allowed in setuid scripts");
-#endif
+               croak("No -e allowed in setuid scripts");
            if (!e_fp) {
                e_tmpname = savestr(TMPPATH);
                (void)mktemp(e_tmpname);
+               if (!*e_tmpname)
+                   croak("Can't mktemp()");
                e_fp = fopen(e_tmpname,"w");
                if (!e_fp)
-                   fatal("Cannot open temporary file");
+                   croak("Cannot open temporary file");
            }
            if (argv[1]) {
                fputs(argv[1],e_fp);
@@ -175,44 +293,27 @@ setuid perl scripts securely.\n");
            (void)putc('\n', e_fp);
            break;
        case 'I':
-#ifdef TAINT
-           if (euid != uid || egid != gid)
-               fatal("No -I allowed in setuid scripts");
-#endif
-           str_cat(str,"-");
-           str_cat(str,s);
-           str_cat(str," ");
+           taint_not("-I");
+           sv_catpv(sv,"-");
+           sv_catpv(sv,s);
+           sv_catpv(sv," ");
            if (*++s) {
-               (void)apush(stab_array(incstab),str_make(s,0));
+               (void)av_push(GvAVn(incgv),newSVpv(s,0));
            }
            else if (argv[1]) {
-               (void)apush(stab_array(incstab),str_make(argv[1],0));
-               str_cat(str,argv[1]);
+               (void)av_push(GvAVn(incgv),newSVpv(argv[1],0));
+               sv_catpv(sv,argv[1]);
                argc--,argv++;
-               str_cat(str," ");
+               sv_catpv(sv," ");
            }
            break;
        case 'P':
-#ifdef TAINT
-           if (euid != uid || egid != gid)
-               fatal("No -P allowed in setuid scripts");
-#endif
+           taint_not("-P");
            preprocess = TRUE;
            s++;
            goto reswitch;
-       case 's':
-#ifdef TAINT
-           if (euid != uid || egid != gid)
-               fatal("No -s allowed in setuid scripts");
-#endif
-           doswitches = TRUE;
-           s++;
-           goto reswitch;
        case 'S':
-#ifdef TAINT
-           if (euid != uid || egid != gid)
-               fatal("No -S allowed in setuid scripts");
-#endif
+           taint_not("-S");
            dosearch = TRUE;
            s++;
            goto reswitch;
@@ -228,198 +329,605 @@ setuid perl scripts securely.\n");
        case 0:
            break;
        default:
-           fatal("Unrecognized switch: -%s",s);
+           croak("Unrecognized switch: -%s",s);
        }
     }
   switch_end:
     scriptname = argv[0];
     if (e_fp) {
-       (void)fclose(e_fp);
+       if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
+           croak("Can't write to temp file for -e: %s", strerror(errno));
        argc++,argv--;
        scriptname = e_tmpname;
     }
-
+    else if (scriptname == Nullch) {
 #ifdef MSDOS
-#define PERLLIB_SEP ';'
-#else
-#define PERLLIB_SEP ':'
+       if ( isatty(fileno(stdin)) )
+           moreswitches("v");
 #endif
-#ifndef TAINT          /* Can't allow arbitrary PERLLIB in setuid script */
-    {
-       char * s2 = getenv("PERLLIB");
-
-       if ( s2 ) {
-           /* Break at all separators */
-           while ( *s2 ) {
-               /* First, skip any consecutive separators */
-               while ( *s2 == PERLLIB_SEP ) {
-                   /* Uncomment the next line for PATH semantics */
-                   /* (void)apush(stab_array(incstab),str_make(".",1)); */
-                   s2++;
-               }
-               if ( (s = index(s2,PERLLIB_SEP)) != Nullch ) {
-                   (void)apush(stab_array(incstab),str_make(s2,(int)(s-s2)));
-                   s2 = s+1;
-               } else {
-                   (void)apush(stab_array(incstab),str_make(s2,0));
-                   break;
-               }
-           }
+       scriptname = "-";
+    }
+
+    init_perllib();
+
+    open_script(scriptname,dosearch,sv);
+
+    sv_free(sv);               /* free -I directories */
+    sv = Nullsv;
+
+    validate_suid(validarg);
+
+    if (doextract)
+       find_beginning();
+
+    if (perldb)
+       init_debugger();
+
+    pad = newAV();
+    comppad = pad;
+    av_push(comppad, Nullsv);
+    curpad = AvARRAY(comppad);
+    padname = newAV();
+    comppadname = padname;
+    comppadnamefill = -1;
+    padix = 0;
+
+    init_stack();
+
+    init_context_stack();
+
+    perl_init_ext();   /* in case linked C routines want magical variables */
+
+    init_predump_symbols();
+
+    init_lexer();
+
+    /* now parse the script */
+
+    error_count = 0;
+    if (yyparse() || error_count) {
+       if (minus_c)
+           croak("%s had compilation errors.\n", origfilename);
+       else {
+           croak("Execution of %s aborted due to compilation errors.\n",
+               origfilename);
        }
     }
-#endif /* TAINT */
+    curcop->cop_line = 0;
+    curstash = defstash;
+    preprocess = FALSE;
+    if (e_fp) {
+       e_fp = Nullfp;
+       (void)UNLINK(e_tmpname);
+    }
 
-#ifndef PRIVLIB
-#define PRIVLIB "/usr/local/lib/perl"
-#endif
-    (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
-    (void)apush(stab_array(incstab),str_make(".",1));
+    /* now that script is parsed, we can modify record separator */
+
+    rs = nrs;
+    rslen = nrslen;
+    rschar = nrschar;
+    rspara = (nrslen == 2);
+    sv_setpvn(GvSV(gv_fetchpv("/", TRUE)), rs, rslen);
 
-    str_set(&str_no,No);
-    str_set(&str_yes,Yes);
+    if (do_undump)
+       my_unexec();
 
-    /* open script */
+  just_doit:           /* come here if running an undumped a.out */
+    init_postdump_symbols(argc,argv,env);
+    return 0;
+}
 
-    if (scriptname == Nullch)
-#ifdef MSDOS
-    {
-       if ( isatty(fileno(stdin)) )
-         moreswitches("v");
-       scriptname = "-";
+int
+perl_run(sv_interp)
+PerlInterpreter *sv_interp;
+{
+    if (!(curinterp = sv_interp))
+       return 255;
+    if (beginav)
+       calllist(beginav);
+    switch (setjmp(top_env)) {
+    case 1:
+       cxstack_ix = -1;                /* start context stack again */
+       break;
+    case 2:
+       curstash = defstash;
+       if (endav)
+           calllist(endav);
+       return(statusvalue);            /* my_exit() was called */
+    case 3:
+       if (!restartop) {
+           fprintf(stderr, "panic: restartop\n");
+           exit(1);
+       }
+       if (stack != mainstack) {
+           dSP;
+           SWITCHSTACK(stack, mainstack);
+       }
+       break;
     }
-#else
-       scriptname = "-";
-#endif
-    if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) {
-       char *xfound = Nullch, *xfailed = Nullch;
-       int len;
 
-       bufend = s + strlen(s);
-       while (*s) {
-#ifndef MSDOS
-           s = cpytill(tokenbuf,s,bufend,':',&len);
-#else
-           for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
-           tokenbuf[len] = '\0';
-#endif
-           if (*s)
-               s++;
-#ifndef MSDOS
-           if (len && tokenbuf[len-1] != '/')
-#else
-           if (len && tokenbuf[len-1] != '\\')
-#endif
-               (void)strcat(tokenbuf+len,"/");
-           (void)strcat(tokenbuf+len,scriptname);
-#ifdef DEBUGGING
-           if (debug & 1)
-               fprintf(stderr,"Looking for %s\n",tokenbuf);
-#endif
-           if (stat(tokenbuf,&statbuf) < 0)            /* not there? */
-               continue;
-           if (S_ISREG(statbuf.st_mode)
-            && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
-               xfound = tokenbuf;              /* bingo! */
-               break;
-           }
-           if (!xfailed)
-               xfailed = savestr(tokenbuf);
+    if (!restartop) {
+       DEBUG_x(dump_all());
+       DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
+
+       if (minus_c) {
+           fprintf(stderr,"%s syntax OK\n", origfilename);
+           my_exit(0);
        }
-       if (!xfound)
-           fatal("Can't execute %s", xfailed ? xfailed : scriptname );
-       if (xfailed)
-           Safefree(xfailed);
-       scriptname = savestr(xfound);
     }
 
-    fdpid = anew(Nullstab);    /* for remembering popen pids by fd */
-    pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
+    /* do it */
 
-    origfilename = savestr(scriptname);
-    curcmd->c_filestab = fstab(origfilename);
-    if (strEQ(origfilename,"-"))
-       scriptname = "";
-    if (preprocess) {
-       char *cpp = CPPSTDIN;
+    if (restartop) {
+       op = restartop;
+       restartop = 0;
+       run();
+    }
+    else if (main_start) {
+       op = main_start;
+       run();
+    }
 
-       if (strEQ(cpp,"cppstdin"))
-           sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
-       else
-           sprintf(tokenbuf, "%s", cpp);
-       str_cat(str,"-I");
-       str_cat(str,PRIVLIB);
-       (void)sprintf(buf, "\
-%ssed %s -e '/^[^#]/b' \
- -e '/^#[      ]*include[      ]/b' \
- -e '/^#[      ]*define[       ]/b' \
- -e '/^#[      ]*if[   ]/b' \
- -e '/^#[      ]*ifdef[        ]/b' \
- -e '/^#[      ]*ifndef[       ]/b' \
- -e '/^#[      ]*else/b' \
- -e '/^#[      ]*elif[         ]/b' \
- -e '/^#[      ]*undef[        ]/b' \
- -e '/^#[      ]*endif/b' \
- -e 's/^[      ]*#.*//' \
- %s | %s -C %s %s",
-#ifdef MSDOS
-         "",
-#else
-         "/bin/",
-#endif
-         (doextract ? "-e '1,/^#/d\n'" : ""),
-         scriptname, tokenbuf, str_get(str), CPPMINUS);
-#ifdef DEBUGGING
-       if (debug & 64) {
-           fputs(buf,stderr);
-           fputs("\n",stderr);
+    my_exit(0);
+}
+
+void
+my_exit(status)
+int status;
+{
+    statusvalue = (unsigned short)(status & 0xffff);
+    longjmp(top_env, 2);
+}
+
+/* Be sure to refetch the stack pointer after calling these routines. */
+
+int
+perl_callback(subname, sp, gimme, hasargs, numargs)
+char *subname;
+I32 sp;                        /* stack pointer after args are pushed */
+I32 gimme;             /* called in array or scalar context */
+I32 hasargs;           /* whether to create a @_ array for routine */
+I32 numargs;           /* how many args are pushed on the stack */
+{
+    BINOP myop;                /* fake syntax tree node */
+    
+    ENTER;
+    SAVETMPS;
+    SAVESPTR(op);
+    stack_base = AvARRAY(stack);
+    stack_sp = stack_base + sp - numargs - 1;
+    op = (OP*)&myop;
+    Zero(op, 1, BINOP);
+    pp_pushmark();     /* doesn't look at op, actually, except to return */
+    *++stack_sp = (SV*)gv_fetchpv(subname, FALSE);
+    stack_sp += numargs;
+
+    if (hasargs) {
+       myop.op_flags = OPf_STACKED;
+       myop.op_last = (OP*)&myop;
+    }
+    myop.op_next = Nullop;
+
+    if (op = pp_entersubr())
+       run();
+    free_tmps();
+    LEAVE;
+    return stack_sp - stack_base;
+}
+
+int
+perl_callv(subname, sp, gimme, argv)
+char *subname;
+register I32 sp;       /* current stack pointer */
+I32 gimme;             /* called in array or scalar context */
+register char **argv;  /* null terminated arg list, NULL for no arglist */
+{
+    register I32 items = 0;
+    I32 hasargs = (argv != 0);
+
+    av_store(stack, ++sp, Nullsv);     /* reserve spot for 1st return arg */
+    if (hasargs) {
+       while (*argv) {
+           av_store(stack, ++sp, sv_2mortal(newSVpv(*argv,0)));
+           items++;
+           argv++;
        }
-#endif
-       doextract = FALSE;
-#ifdef IAMSUID                         /* actually, this is caught earlier */
-       if (euid != uid && !euid)       /* if running suidperl */
-#ifdef HAS_SETEUID
-           (void)seteuid(uid);         /* musn't stay setuid root */
-#else
-#ifdef HAS_SETREUID
-           (void)setreuid(-1, uid);
-#else
-           setuid(uid);
-#endif
-#endif
-#endif /* IAMSUID */
-       rsfp = mypopen(buf,"r");
     }
-    else if (!*scriptname) {
-#ifdef TAINT
-       if (euid != uid || egid != gid)
-           fatal("Can't take set-id script from stdin");
+    return perl_callback(subname, sp, gimme, hasargs, items);
+}
+
+void
+magicname(sym,name,namlen)
+char *sym;
+char *name;
+I32 namlen;
+{
+    register GV *gv;
+
+    if (gv = gv_fetchpv(sym,TRUE))
+       sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
+}
+
+#ifdef DOSISH
+#define PERLLIB_SEP ';'
+#else
+#define PERLLIB_SEP ':'
 #endif
-       rsfp = stdin;
-    }
-    else
-       rsfp = fopen(scriptname,"r");
-    if ((FILE*)rsfp == Nullfp) {
-#ifdef DOSUID
-#ifndef IAMSUID                /* in case script is not readable before setuid */
-       if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
-         statbuf.st_mode & (S_ISUID|S_ISGID)) {
-           (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
-           execv(buf, origargv);       /* try again */
-           fatal("Can't do setuid\n");
+
+static void
+incpush(p)
+char *p;
+{
+    char *s;
+
+    if (!p)
+       return;
+
+    /* Break at all separators */
+    while (*p) {
+       /* First, skip any consecutive separators */
+       while ( *p == PERLLIB_SEP ) {
+           /* Uncomment the next line for PATH semantics */
+           /* (void)av_push(GvAVn(incgv), newSVpv(".", 1)); */
+           p++;
+       }
+       if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
+           (void)av_push(GvAVn(incgv), newSVpv(p, (I32)(s - p)));
+           p = s + 1;
+       } else {
+           (void)av_push(GvAVn(incgv), newSVpv(p, 0));
+           break;
        }
-#endif
-#endif
-       fatal("Can't open perl script \"%s\": %s\n",
-         stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
     }
-    str_free(str);             /* free -I directories */
-    str = Nullstr;
+}
 
-    /* do we need to emulate setuid on scripts? */
+/* This routine handles any switches that can be given during run */
 
-    /* This code is for those BSD systems that have setuid #! scripts disabled
-     * in the kernel because of a security problem.  Merely defining DOSUID
-     * in perl will not fix that problem, but if you have disabled setuid
+char *
+moreswitches(s)
+char *s;
+{
+    I32 numlen;
+
+    switch (*s) {
+    case '0':
+       nrschar = scan_oct(s, 4, &numlen);
+       nrs = nsavestr("\n",1);
+       *nrs = nrschar;
+       if (nrschar > 0377) {
+           nrslen = 0;
+           nrs = "";
+       }
+       else if (!nrschar && numlen >= 2) {
+           nrslen = 2;
+           nrs = "\n\n";
+           nrschar = '\n';
+       }
+       return s + numlen;
+    case 'a':
+       minus_a = TRUE;
+       s++;
+       return s;
+    case 'c':
+       minus_c = TRUE;
+       s++;
+       return s;
+    case 'd':
+       taint_not("-d");
+       perldb = TRUE;
+       s++;
+       return s;
+    case 'D':
+#ifdef DEBUGGING
+       taint_not("-D");
+       if (isALPHA(s[1])) {
+           static char debopts[] = "psltocPmfrxuLHX";
+           char *d;
+
+           for (s++; *s && (d = strchr(debopts,*s)); s++)
+               debug |= 1 << (d - debopts);
+       }
+       else {
+           debug = atoi(s+1);
+           for (s++; isDIGIT(*s); s++) ;
+       }
+       debug |= 32768;
+#else
+       warn("Recompile perl with -DDEBUGGING to use -D switch\n");
+       for (s++; isDIGIT(*s); s++) ;
+#endif
+       /*SUPPRESS 530*/
+       return s;
+    case 'i':
+       if (inplace)
+           Safefree(inplace);
+       inplace = savestr(s+1);
+       /*SUPPRESS 530*/
+       for (s = inplace; *s && !isSPACE(*s); s++) ;
+       *s = '\0';
+       break;
+    case 'I':
+       taint_not("-I");
+       if (*++s) {
+           (void)av_push(GvAVn(incgv),newSVpv(s,0));
+       }
+       else
+           croak("No space allowed after -I");
+       break;
+    case 'l':
+       minus_l = TRUE;
+       s++;
+       if (isDIGIT(*s)) {
+           ors = savestr("\n");
+           orslen = 1;
+           *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
+           s += numlen;
+       }
+       else {
+           ors = nsavestr(nrs,nrslen);
+           orslen = nrslen;
+       }
+       return s;
+    case 'n':
+       minus_n = TRUE;
+       s++;
+       return s;
+    case 'p':
+       minus_p = TRUE;
+       s++;
+       return s;
+    case 's':
+       taint_not("-s");
+       doswitches = TRUE;
+       s++;
+       return s;
+    case 'T':
+       tainting = TRUE;
+       s++;
+       return s;
+    case 'u':
+       do_undump = TRUE;
+       s++;
+       return s;
+    case 'U':
+       unsafe = TRUE;
+       s++;
+       return s;
+    case 'v':
+       fputs("\nThis is perl, version 5.0, Alpha 5 (unsupported)\n\n",stdout);
+       fputs(rcsid,stdout);
+       fputs("\nCopyright (c) 1989, 1990, 1991, 1992, 1993, 1994 Larry Wall\n",stdout);
+#ifdef MSDOS
+       fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
+       stdout);
+#ifdef OS2
+        fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
+        stdout);
+#endif
+#endif
+#ifdef atarist
+        fputs("atariST series port, ++jrb  bammi@cadence.com\n", stdout);
+#endif
+       fputs("\n\
+Perl may be copied only under the terms of either the Artistic License or the\n\
+GNU General Public License, which may be found in the Perl 5.0 source kit.\n",stdout);
+#ifdef MSDOS
+        usage(origargv[0]);
+#endif
+       exit(0);
+    case 'w':
+       dowarn = TRUE;
+       s++;
+       return s;
+    case ' ':
+       if (s[1] == '-')        /* Additional switches on #! line. */
+           return s+2;
+       break;
+    case 0:
+    case '\n':
+    case '\t':
+       break;
+    default:
+       croak("Switch meaningless after -x: -%s",s);
+    }
+    return Nullch;
+}
+
+/* compliments of Tom Christiansen */
+
+/* unexec() can be found in the Gnu emacs distribution */
+
+void
+my_unexec()
+{
+#ifdef UNEXEC
+    int    status;
+    extern int etext;
+
+    sprintf (buf, "%s.perldump", origfilename);
+    sprintf (tokenbuf, "%s/perl", BIN);
+
+    status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
+    if (status)
+       fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
+    my_exit(status);
+#else
+    ABORT();           /* for use with undump */
+#endif
+}
+
+static void
+init_main_stash()
+{
+    GV *gv;
+    curstash = defstash = newHV();
+    curstname = newSVpv("main",4);
+    GvHV(gv = gv_fetchpv("_main",TRUE)) = defstash;
+    SvREADONLY_on(gv);
+    HvNAME(defstash) = "main";
+    incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE)));
+    SvMULTI_on(incgv);
+    defgv = gv_fetchpv("_",TRUE);
+}
+
+static void
+open_script(scriptname,dosearch,sv)
+char *scriptname;
+bool dosearch;
+SV *sv;
+{
+    char *xfound = Nullch;
+    char *xfailed = Nullch;
+    register char *s;
+    I32 len;
+
+    if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
+
+       bufend = s + strlen(s);
+       while (*s) {
+#ifndef DOSISH
+           s = cpytill(tokenbuf,s,bufend,':',&len);
+#else
+#ifdef atarist
+           for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
+           tokenbuf[len] = '\0';
+#else
+           for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
+           tokenbuf[len] = '\0';
+#endif
+#endif
+           if (*s)
+               s++;
+#ifndef DOSISH
+           if (len && tokenbuf[len-1] != '/')
+#else
+#ifdef atarist
+           if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
+#else
+           if (len && tokenbuf[len-1] != '\\')
+#endif
+#endif
+               (void)strcat(tokenbuf+len,"/");
+           (void)strcat(tokenbuf+len,scriptname);
+           DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
+           if (stat(tokenbuf,&statbuf) < 0)            /* not there? */
+               continue;
+           if (S_ISREG(statbuf.st_mode)
+            && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
+               xfound = tokenbuf;              /* bingo! */
+               break;
+           }
+           if (!xfailed)
+               xfailed = savestr(tokenbuf);
+       }
+       if (!xfound)
+           croak("Can't execute %s", xfailed ? xfailed : scriptname );
+       if (xfailed)
+           Safefree(xfailed);
+       scriptname = xfound;
+    }
+
+    origfilename = savestr(scriptname);
+    curcop->cop_filegv = gv_fetchfile(origfilename);
+    if (strEQ(origfilename,"-"))
+       scriptname = "";
+    if (preprocess) {
+       char *cpp = CPPSTDIN;
+
+       if (strEQ(cpp,"cppstdin"))
+           sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
+       else
+           sprintf(tokenbuf, "%s", cpp);
+       sv_catpv(sv,"-I");
+       sv_catpv(sv,PRIVLIB);
+#ifdef MSDOS
+       (void)sprintf(buf, "\
+sed %s -e \"/^[^#]/b\" \
+ -e \"/^#[     ]*include[      ]/b\" \
+ -e \"/^#[     ]*define[       ]/b\" \
+ -e \"/^#[     ]*if[   ]/b\" \
+ -e \"/^#[     ]*ifdef[        ]/b\" \
+ -e \"/^#[     ]*ifndef[       ]/b\" \
+ -e \"/^#[     ]*else/b\" \
+ -e \"/^#[     ]*elif[         ]/b\" \
+ -e \"/^#[     ]*undef[        ]/b\" \
+ -e \"/^#[     ]*endif/b\" \
+ -e \"s/^#.*//\" \
+ %s | %s -C %s %s",
+         (doextract ? "-e \"1,/^#/d\n\"" : ""),
+#else
+       (void)sprintf(buf, "\
+%s %s -e '/^[^#]/b' \
+ -e '/^#[      ]*include[      ]/b' \
+ -e '/^#[      ]*define[       ]/b' \
+ -e '/^#[      ]*if[   ]/b' \
+ -e '/^#[      ]*ifdef[        ]/b' \
+ -e '/^#[      ]*ifndef[       ]/b' \
+ -e '/^#[      ]*else/b' \
+ -e '/^#[      ]*elif[         ]/b' \
+ -e '/^#[      ]*undef[        ]/b' \
+ -e '/^#[      ]*endif/b' \
+ -e 's/^[      ]*#.*//' \
+ %s | %s -C %s %s",
+#ifdef LOC_SED
+         LOC_SED,
+#else
+         "sed",
+#endif
+         (doextract ? "-e '1,/^#/d\n'" : ""),
+#endif
+         scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
+       DEBUG_P(fprintf(stderr, "%s\n", buf));
+       doextract = FALSE;
+#ifdef IAMSUID                         /* actually, this is caught earlier */
+       if (euid != uid && !euid) {     /* if running suidperl */
+#ifdef HAS_SETEUID
+           (void)seteuid(uid);         /* musn't stay setuid root */
+#else
+#ifdef HAS_SETREUID
+           (void)setreuid(-1, uid);
+#else
+           setuid(uid);
+#endif
+#endif
+           if (geteuid() != uid)
+               croak("Can't do seteuid!\n");
+       }
+#endif /* IAMSUID */
+       rsfp = my_popen(buf,"r");
+    }
+    else if (!*scriptname) {
+       taint_not("program input from stdin");
+       rsfp = stdin;
+    }
+    else
+       rsfp = fopen(scriptname,"r");
+    if ((FILE*)rsfp == Nullfp) {
+#ifdef DOSUID
+#ifndef IAMSUID                /* in case script is not readable before setuid */
+       if (euid && stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
+         statbuf.st_mode & (S_ISUID|S_ISGID)) {
+           (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
+           execv(buf, origargv);       /* try again */
+           croak("Can't do setuid\n");
+       }
+#endif
+#endif
+       croak("Can't open perl script \"%s\": %s\n",
+         SvPVX(GvSV(curcop->cop_filegv)), strerror(errno));
+    }
+}
+
+static void
+validate_suid(validarg)
+char *validarg;
+{
+    char *s;
+    /* do we need to emulate setuid on scripts? */
+
+    /* This code is for those BSD systems that have setuid #! scripts disabled
+     * in the kernel because of a security problem.  Merely defining DOSUID
+     * in perl will not fix that problem, but if you have disabled setuid
      * scripts in the kernel, this will attempt to emulate setuid and setgid
      * on scripts that have those now-otherwise-useless bits set.  The setuid
      * root version must be called suidperl or sperlN.NNN.  If regular perl
@@ -433,20 +941,13 @@ setuid perl scripts securely.\n");
      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
      * be defined in suidperl only.  suidperl must be setuid root.  The
      * Configure script will set this up for you if you want it.
-     *
-     * There is also the possibility of have a script which is running
-     * set-id due to a C wrapper.  We want to do the TAINT checks
-     * on these set-id scripts, but don't want to have the overhead of
-     * them in normal perl, and can't use suidperl because it will lose
-     * the effective uid info, so we have an additional non-setuid root
-     * version called taintperl or tperlN.NNN that just does the TAINT checks.
      */
 
 #ifdef DOSUID
     if (fstat(fileno(rsfp),&statbuf) < 0)      /* normal stat is insecure */
-       fatal("Can't stat script \"%s\"",origfilename);
+       croak("Can't stat script \"%s\"",origfilename);
     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
-       int len;
+       I32 len;
 
 #ifdef IAMSUID
 #ifndef HAS_SETREUID
@@ -458,8 +959,8 @@ setuid perl scripts securely.\n");
         * But I don't think it's too important.  The manual lies when
         * it says access() is useful in setuid programs.
         */
-       if (access(stab_val(curcmd->c_filestab)->str_ptr,1))    /*double check*/
-           fatal("Permission denied");
+       if (access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
+           croak("Permission denied");
 #else
        /* If we can swap euid and uid, then we can determine access rights
         * with a simple stat of the file, and then compare device and
@@ -470,46 +971,46 @@ setuid perl scripts securely.\n");
            struct stat tmpstatbuf;
 
            if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
-               fatal("Can't swap uid and euid");       /* really paranoid */
-           if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0)
-               fatal("Permission denied");     /* testing full pathname here */
+               croak("Can't swap uid and euid");       /* really paranoid */
+           if (stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
+               croak("Permission denied");     /* testing full pathname here */
            if (tmpstatbuf.st_dev != statbuf.st_dev ||
                tmpstatbuf.st_ino != statbuf.st_ino) {
                (void)fclose(rsfp);
-               if (rsfp = mypopen("/bin/mail root","w")) {     /* heh, heh */
+               if (rsfp = my_popen("/bin/mail root","w")) {    /* heh, heh */
                    fprintf(rsfp,
 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
                        uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
                        statbuf.st_dev, statbuf.st_ino,
-                       stab_val(curcmd->c_filestab)->str_ptr,
+                       SvPVX(GvSV(curcop->cop_filegv)),
                        statbuf.st_uid, statbuf.st_gid);
-                   (void)mypclose(rsfp);
+                   (void)my_pclose(rsfp);
                }
-               fatal("Permission denied\n");
+               croak("Permission denied\n");
            }
            if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
-               fatal("Can't reswap uid and euid");
+               croak("Can't reswap uid and euid");
            if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
-               fatal("Permission denied\n");
+               croak("Permission denied\n");
        }
 #endif /* HAS_SETREUID */
 #endif /* IAMSUID */
 
        if (!S_ISREG(statbuf.st_mode))
-           fatal("Permission denied");
+           croak("Permission denied");
        if (statbuf.st_mode & S_IWOTH)
-           fatal("Setuid/gid script is writable by world");
+           croak("Setuid/gid script is writable by world");
        doswitches = FALSE;             /* -s is insecure in suid */
-       curcmd->c_line++;
+       curcop->cop_line++;
        if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
          strnNE(tokenbuf,"#!",2) )     /* required even on Sys V */
-           fatal("No #! line");
+           croak("No #! line");
        s = tokenbuf+2;
        if (*s == ' ') s++;
        while (!isSPACE(*s)) s++;
        if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
-           fatal("Not a perl script");
+           croak("Not a perl script");
        while (*s == ' ' || *s == '\t') s++;
        /*
         * #! arg must be what we saw above.  They can invoke it by
@@ -519,13 +1020,13 @@ setuid perl scripts securely.\n");
        len = strlen(validarg);
        if (strEQ(validarg," PHOOEY ") ||
            strnNE(s,validarg,len) || !isSPACE(s[len]))
-           fatal("Args must match #! line");
+           croak("Args must match #! line");
 
 #ifndef IAMSUID
        if (euid != uid && (statbuf.st_mode & S_ISUID) &&
            euid == statbuf.st_uid)
            if (!do_undump)
-               fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
+               croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 #endif /* IAMSUID */
 
@@ -535,10 +1036,10 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
            (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
            execv(buf, origargv);       /* try again */
 #endif
-           fatal("Can't do setuid\n");
+           croak("Can't do setuid\n");
        }
 
-       if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid)
+       if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
 #ifdef HAS_SETEGID
            (void)setegid(statbuf.st_gid);
 #else
@@ -548,6 +1049,9 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
            setgid(statbuf.st_gid);
 #endif
 #endif
+           if (getegid() != statbuf.st_gid)
+               croak("Can't do setegid!\n");
+       }
        if (statbuf.st_mode & S_ISUID) {
            if (statbuf.st_uid != euid)
 #ifdef HAS_SETEUID
@@ -559,8 +1063,10 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
                setuid(statbuf.st_uid);
 #endif
 #endif
+           if (geteuid() != statbuf.st_uid)
+               croak("Can't do seteuid!\n");
        }
-       else if (uid)                   /* oops, mustn't run as root */
+       else if (uid) {                 /* oops, mustn't run as root */
 #ifdef HAS_SETEUID
            (void)seteuid((UIDTYPE)uid);
 #else
@@ -570,31 +1076,24 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
            setuid((UIDTYPE)uid);
 #endif
 #endif
+           if (geteuid() != uid)
+               croak("Can't do seteuid!\n");
+       }
        uid = (int)getuid();
        euid = (int)geteuid();
        gid = (int)getgid();
        egid = (int)getegid();
+       tainting |= (euid != uid || egid != gid);
        if (!cando(S_IXUSR,TRUE,&statbuf))
-           fatal("Permission denied\n");       /* they can't do this */
+           croak("Permission denied\n");       /* they can't do this */
     }
 #ifdef IAMSUID
     else if (preprocess)
-       fatal("-P not allowed for setuid/setgid script\n");
+       croak("-P not allowed for setuid/setgid script\n");
     else
-       fatal("Script is not setuid/setgid in suidperl\n");
-#else
-#ifndef TAINT          /* we aren't taintperl or suidperl */
-    /* script has a wrapper--can't run suidperl or we lose euid */
-    else if (euid != uid || egid != gid) {
-       (void)fclose(rsfp);
-       (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
-       execv(buf, origargv);   /* try again */
-       fatal("Can't run setuid script with taint checks");
-    }
-#endif /* TAINT */
+       croak("Script is not setuid/setgid in suidperl\n");
 #endif /* IAMSUID */
 #else /* !DOSUID */
-#ifndef TAINT          /* we aren't taintperl or suidperl */
     if (euid != uid || egid != gid) {  /* (suidperl doesn't exist, in fact) */
 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
        fstat(fileno(rsfp),&statbuf);   /* may be either wrapped or real suid */
@@ -603,25 +1102,25 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
            (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
           )
            if (!do_undump)
-               fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
+               croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
        /* not set-id, must be wrapped */
-       (void)fclose(rsfp);
-       (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
-       execv(buf, origargv);   /* try again */
-       fatal("Can't run setuid script with taint checks");
     }
-#endif /* TAINT */
 #endif /* DOSUID */
+}
 
-#if !defined(IAMSUID) && !defined(TAINT)
+static void
+find_beginning()
+{
+    register char *s;
 
     /* skip forward in input to the real script? */
 
+    taint_not("-x");
     while (doextract) {
-       if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
-           fatal("No Perl script found in input\n");
+       if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
+           croak("No Perl script found in input\n");
        if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
            ungetc('\n',rsfp);          /* to keep line count right */
            doextract = FALSE;
@@ -631,732 +1130,244 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
                while (s = moreswitches(s)) ;
            }
            if (cddir && chdir(cddir) < 0)
-               fatal("Can't chdir to %s",cddir);
+               croak("Can't chdir to %s",cddir);
        }
     }
-#endif /* !defined(IAMSUID) && !defined(TAINT) */
-
-    defstab = stabent("_",TRUE);
-
-    subname = str_make("main",4);
-    if (perldb) {
-       debstash = hnew(0);
-       stab_xhash(stabent("_DB",TRUE)) = debstash;
-       curstash = debstash;
-       dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
-       tmpstab->str_pok |= SP_MULTI;
-       dbargs->ary_flags = 0;
-       DBstab = stabent("DB",TRUE);
-       DBstab->str_pok |= SP_MULTI;
-       DBline = stabent("dbline",TRUE);
-       DBline->str_pok |= SP_MULTI;
-       DBsub = hadd(tmpstab = stabent("sub",TRUE));
-       tmpstab->str_pok |= SP_MULTI;
-       DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
-       tmpstab->str_pok |= SP_MULTI;
-       DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
-       tmpstab->str_pok |= SP_MULTI;
-       DBsignal = stab_val((tmpstab = stabent("signal",TRUE)));
-       tmpstab->str_pok |= SP_MULTI;
-       curstash = defstash;
-    }
+}
 
-    /* init tokener */
+static void
+init_debugger()
+{
+    GV* tmpgv;
+
+    debstash = newHV();
+    GvHV(gv_fetchpv("_DB",TRUE)) = debstash;
+    curstash = debstash;
+    dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args",TRUE))));
+    SvMULTI_on(tmpgv);
+    AvREAL_off(dbargs);
+    DBgv = gv_fetchpv("DB",TRUE);
+    SvMULTI_on(DBgv);
+    DBline = gv_fetchpv("dbline",TRUE);
+    SvMULTI_on(DBline);
+    DBsub = gv_HVadd(tmpgv = gv_fetchpv("sub",TRUE));
+    SvMULTI_on(tmpgv);
+    DBsingle = GvSV((tmpgv = gv_fetchpv("single",TRUE)));
+    SvMULTI_on(tmpgv);
+    DBtrace = GvSV((tmpgv = gv_fetchpv("trace",TRUE)));
+    SvMULTI_on(tmpgv);
+    DBsignal = GvSV((tmpgv = gv_fetchpv("signal",TRUE)));
+    SvMULTI_on(tmpgv);
+    curstash = defstash;
+}
 
-    bufend = bufptr = str_get(linestr);
-
-    savestack = anew(Nullstab);                /* for saving non-local values */
-    stack = anew(Nullstab);            /* for saving non-local values */
-    stack->ary_flags = 0;              /* not a real array */
-    afill(stack,63); afill(stack,-1);  /* preextend stack */
-    afill(savestack,63); afill(savestack,-1);
-
-    /* now parse the script */
+static void
+init_stack()
+{
+    stack = newAV();
+    mainstack = stack;                 /* remember in case we switch stacks */
+    AvREAL_off(stack);                 /* not a real array */
+    av_fill(stack,127); av_fill(stack,-1);     /* preextend stack */
+
+    stack_base = AvARRAY(stack);
+    stack_sp = stack_base;
+    stack_max = stack_base + 128;
+
+    New(54,markstack,64,int);
+    markstack_ptr = markstack;
+    markstack_max = markstack + 64;
+
+    New(54,scopestack,32,int);
+    scopestack_ix = 0;
+    scopestack_max = 32;
+
+    New(54,savestack,128,ANY);
+    savestack_ix = 0;
+    savestack_max = 128;
+
+    New(54,retstack,16,OP*);
+    retstack_ix = 0;
+    retstack_max = 16;
+}
 
-    error_count = 0;
-    if (yyparse() || error_count) {
-       if (minus_c)
-           fatal("%s had compilation errors.\n", origfilename);
-       else {
-           fatal("Execution of %s aborted due to compilation errors.\n",
-               origfilename);
-       }
-    }
+static void
+init_lexer()
+{
+    bufend = bufptr = SvPV(linestr, na);
+    subname = newSVpv("main",4);
+    lex_start();               /* we never leave */
+}
 
-    New(50,loop_stack,128,struct loop);
-#ifdef DEBUGGING
-    if (debug) {
+static void
+init_context_stack()
+{
+    New(50,cxstack,128,CONTEXT);
+    DEBUG( {
        New(51,debname,128,char);
        New(52,debdelim,128,char);
-    }
-#endif
-    curstash = defstash;
-
-    preprocess = FALSE;
-    if (e_fp) {
-       e_fp = Nullfp;
-       (void)UNLINK(e_tmpname);
-    }
-
-    /* initialize everything that won't change if we undump */
-
-    if (sigstab = stabent("SIG",allstabs)) {
-       sigstab->str_pok |= SP_MULTI;
-       (void)hadd(sigstab);
-    }
-
-    magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
-    userinit();                /* in case linked C routines want magical variables */
-
-    amperstab = stabent("&",allstabs);
-    leftstab = stabent("`",allstabs);
-    rightstab = stabent("'",allstabs);
-    sawampersand = (amperstab || leftstab || rightstab);
-    if (tmpstab = stabent(":",allstabs))
-       str_set(STAB_STR(tmpstab),chopset);
-    if (tmpstab = stabent("\024",allstabs))
-       time(&basetime);
-
-    /* these aren't necessarily magical */
-    if (tmpstab = stabent(";",allstabs))
-       str_set(STAB_STR(tmpstab),"\034");
-    if (tmpstab = stabent("]",allstabs)) {
-       str = STAB_STR(tmpstab);
-       str_set(str,rcsid);
-       str->str_u.str_nval = atof(patchlevel);
-       str->str_nok = 1;
-    }
-    str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
-
-    stdinstab = stabent("STDIN",TRUE);
-    stdinstab->str_pok |= SP_MULTI;
-    stab_io(stdinstab) = stio_new();
-    stab_io(stdinstab)->ifp = stdin;
-    tmpstab = stabent("stdin",TRUE);
-    stab_io(tmpstab) = stab_io(stdinstab);
-    tmpstab->str_pok |= SP_MULTI;
-
-    tmpstab = stabent("STDOUT",TRUE);
-    tmpstab->str_pok |= SP_MULTI;
-    stab_io(tmpstab) = stio_new();
-    stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
-    defoutstab = tmpstab;
-    tmpstab = stabent("stdout",TRUE);
-    stab_io(tmpstab) = stab_io(defoutstab);
-    tmpstab->str_pok |= SP_MULTI;
-
-    curoutstab = stabent("STDERR",TRUE);
-    curoutstab->str_pok |= SP_MULTI;
-    stab_io(curoutstab) = stio_new();
-    stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
-    tmpstab = stabent("stderr",TRUE);
-    stab_io(tmpstab) = stab_io(curoutstab);
-    tmpstab->str_pok |= SP_MULTI;
-    curoutstab = defoutstab;           /* switch back to STDOUT */
-
-    statname = Str_new(66,0);          /* last filename we did stat on */
-
-    /* now that script is parsed, we can modify record separator */
+    } )
+}
 
-    rs = nrs;
-    rslen = nrslen;
-    rschar = nrschar;
-    str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
+static void
+init_predump_symbols()
+{
+    GV *tmpgv;
+
+    sv_setpvn(GvSV(gv_fetchpv("\"", TRUE)), " ", 1);
+
+    stdingv = gv_fetchpv("STDIN",TRUE);
+    SvMULTI_on(stdingv);
+    if (!GvIO(stdingv))
+       GvIO(stdingv) = newIO();
+    GvIO(stdingv)->ifp = stdin;
+    tmpgv = gv_fetchpv("stdin",TRUE);
+    GvIO(tmpgv) = GvIO(stdingv);
+    SvMULTI_on(tmpgv);
+
+    tmpgv = gv_fetchpv("STDOUT",TRUE);
+    SvMULTI_on(tmpgv);
+    if (!GvIO(tmpgv))
+       GvIO(tmpgv) = newIO();
+    GvIO(tmpgv)->ofp = GvIO(tmpgv)->ifp = stdout;
+    defoutgv = tmpgv;
+    tmpgv = gv_fetchpv("stdout",TRUE);
+    GvIO(tmpgv) = GvIO(defoutgv);
+    SvMULTI_on(tmpgv);
+
+    curoutgv = gv_fetchpv("STDERR",TRUE);
+    SvMULTI_on(curoutgv);
+    if (!GvIO(curoutgv))
+       GvIO(curoutgv) = newIO();
+    GvIO(curoutgv)->ofp = GvIO(curoutgv)->ifp = stderr;
+    tmpgv = gv_fetchpv("stderr",TRUE);
+    GvIO(tmpgv) = GvIO(curoutgv);
+    SvMULTI_on(tmpgv);
+    curoutgv = defoutgv;               /* switch back to STDOUT */
+
+    statname = NEWSV(66,0);            /* last filename we did stat on */
+}
 
-    if (do_undump)
-       my_unexec();
+static void
+init_postdump_symbols(argc,argv,env)
+register int argc;
+register char **argv;
+register char **env;
+{
+    char *s;
+    SV *sv;
+    GV* tmpgv;
 
-  just_doit:           /* come here if running an undumped a.out */
     argc--,argv++;     /* skip name of script */
     if (doswitches) {
        for (; argc > 0 && **argv == '-'; argc--,argv++) {
+           if (!argv[0][1])
+               break;
            if (argv[0][1] == '-') {
                argc--,argv++;
                break;
            }
-           if (s = index(argv[0], '=')) {
+           if (s = strchr(argv[0], '=')) {
                *s++ = '\0';
-               str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
+               sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE)),s);
            }
            else
-               str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
+               sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE)),1);
        }
     }
-#ifdef TAINT
+    toptarget = NEWSV(0,0);
+    sv_upgrade(toptarget, SVt_PVFM);
+    sv_setpvn(toptarget, "", 0);
+    bodytarget = NEWSV(0,0);
+    sv_upgrade(bodytarget, SVt_PVFM);
+    sv_setpvn(bodytarget, "", 0);
+    formtarget = bodytarget;
+
     tainted = 1;
-#endif
-    if (tmpstab = stabent("0",allstabs)) {
-       str_set(stab_val(tmpstab),origfilename);
-       magicname("0", Nullch, 0);
+    if (tmpgv = gv_fetchpv("0",TRUE)) {
+       sv_setpv(GvSV(tmpgv),origfilename);
+       magicname("0", "0", 1);
     }
-    if (tmpstab = stabent("\030",allstabs))
-       str_set(stab_val(tmpstab),origargv[0]);
-    if (argvstab = stabent("ARGV",allstabs)) {
-       argvstab->str_pok |= SP_MULTI;
-       (void)aadd(argvstab);
-       aclear(stab_array(argvstab));
+    if (tmpgv = gv_fetchpv("\024",TRUE))
+       time(&basetime);
+    if (tmpgv = gv_fetchpv("\030",TRUE))
+       sv_setpv(GvSV(tmpgv),origargv[0]);
+    if (argvgv = gv_fetchpv("ARGV",TRUE)) {
+       SvMULTI_on(argvgv);
+       (void)gv_AVadd(argvgv);
+       av_clear(GvAVn(argvgv));
        for (; argc > 0; argc--,argv++) {
-           (void)apush(stab_array(argvstab),str_make(argv[0],0));
+           (void)av_push(GvAVn(argvgv),newSVpv(argv[0],0));
        }
     }
-#ifdef TAINT
-    (void) stabent("ENV",TRUE);                /* must test PATH and IFS */
-#endif
-    if (envstab = stabent("ENV",allstabs)) {
-       envstab->str_pok |= SP_MULTI;
-       (void)hadd(envstab);
-       hclear(stab_hash(envstab), FALSE);
+    if (envgv = gv_fetchpv("ENV",TRUE)) {
+       HV *hv;
+       SvMULTI_on(envgv);
+       hv = GvHVn(envgv);
+       hv_clear(hv);
        if (env != environ)
            environ[0] = Nullch;
        for (; *env; env++) {
-           if (!(s = index(*env,'=')))
+           if (!(s = strchr(*env,'=')))
                continue;
            *s++ = '\0';
-           str = str_make(s--,0);
-           str_magic(str, envstab, 'E', *env, s - *env);
-           (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
+           sv = newSVpv(s--,0);
+           (void)hv_store(hv, *env, s - *env, sv, 0);
            *s = '=';
        }
+       hv_magic(hv, envgv, 'E');
     }
-#ifdef TAINT
     tainted = 0;
-#endif
-    if (tmpstab = stabent("$",allstabs))
-       str_numset(STAB_STR(tmpstab),(double)getpid());
-
-    if (dowarn) {
-       stab_check('A','Z');
-       stab_check('a','z');
-    }
-
-    if (setjmp(top_env))       /* sets goto_targ on longjump */
-       loop_ptr = -1;          /* start label stack again */
-
-#ifdef DEBUGGING
-    if (debug & 1024)
-       dump_all();
-    if (debug)
-       fprintf(stderr,"\nEXECUTING...\n\n");
-#endif
-
-    if (minus_c) {
-       fprintf(stderr,"%s syntax OK\n", origfilename);
-       exit(0);
-    }
-
-    /* do it */
-
-    (void) cmd_exec(main_root,G_SCALAR,-1);
+    if (tmpgv = gv_fetchpv("$",TRUE))
+       sv_setiv(GvSV(tmpgv),(I32)getpid());
 
-    if (goto_targ)
-       fatal("Can't find label \"%s\"--aborting",goto_targ);
-    exit(0);
-    /* NOTREACHED */
+    if (dowarn)
+       gv_check(defstash);
 }
 
-void
-magicalize(list)
-register char *list;
-{
-    char sym[2];
-
-    sym[1] = '\0';
-    while (*sym = *list++)
-       magicname(sym, Nullch, 0);
-}
-
-void
-magicname(sym,name,namlen)
-char *sym;
-char *name;
-int namlen;
+static void
+init_perllib()
 {
-    register STAB *stab;
+    if (!tainting)
+       incpush(getenv("PERLLIB"));
 
-    if (stab = stabent(sym,allstabs)) {
-       stab_flags(stab) = SF_VMAGIC;
-       str_magic(stab_val(stab), stab, 0, name, namlen);
-    }
+#ifndef PRIVLIB
+#define PRIVLIB "/usr/local/lib/perl"
+#endif
+    incpush(PRIVLIB);
+    (void)av_push(GvAVn(incgv),newSVpv(".",1));
 }
 
 void
-savelines(array, str)
-ARRAY *array;
-STR *str;
+calllist(list)
+AV* list;
 {
-    register char *s = str->str_ptr;
-    register char *send = str->str_ptr + str->str_cur;
-    register char *t;
-    register int line = 1;
+    I32 i;
+    I32 fill = AvFILL(list);
+    jmp_buf oldtop;
+    I32 sp = stack_sp - stack_base;
 
-    while (s && s < send) {
-       STR *tmpstr = Str_new(85,0);
+    av_store(stack, ++sp, Nullsv);     /* reserve spot for 1st return arg */
+    Copy(top_env, oldtop, 1, jmp_buf);
 
-       t = index(s, '\n');
-       if (t)
-           t++;
-       else
-           t = send;
-
-       str_nset(tmpstr, s, t - s);
-       astore(array, line++, tmpstr);
-       s = t;
-    }
-}
-
-/* this routine is in perl.c by virtue of being sort of an alternate main() */
-
-int
-do_eval(str,optype,stash,savecmd,gimme,arglast)
-STR *str;
-int optype;
-HASH *stash;
-int savecmd;
-int gimme;
-int *arglast;
-{
-    STR **st = stack->ary_array;
-    int retval;
-    CMD *myroot = Nullcmd;
-    ARRAY *ar;
-    int i;
-    CMD * VOLATILE oldcurcmd = curcmd;
-    VOLATILE int oldtmps_base = tmps_base;
-    VOLATILE int oldsave = savestack->ary_fill;
-    VOLATILE int oldperldb = perldb;
-    SPAT * VOLATILE oldspat = curspat;
-    SPAT * VOLATILE oldlspat = lastspat;
-    static char *last_eval = Nullch;
-    static long last_elen = 0;
-    static CMD *last_root = Nullcmd;
-    VOLATILE int sp = arglast[0];
-    char *specfilename;
-    char *tmpfilename;
-    int parsing = 1;
-
-    tmps_base = tmps_max;
-    if (curstash != stash) {
-       (void)savehptr(&curstash);
-       curstash = stash;
-    }
-    str_set(stab_val(stabent("@",TRUE)),"");
-    if (curcmd->c_line == 0)           /* don't debug debugger... */
-       perldb = FALSE;
-    curcmd = &compiling;
-    if (optype == O_EVAL) {            /* normal eval */
-       curcmd->c_filestab = fstab("(eval)");
-       curcmd->c_line = 1;
-       str_sset(linestr,str);
-       str_cat(linestr,";\n");         /* be kind to them */
-       if (perldb)
-           savelines(stab_xarray(curcmd->c_filestab), linestr);
-    }
-    else {
-       if (last_root && !in_eval) {
-           Safefree(last_eval);
-           last_eval = Nullch;
-           cmd_free(last_root);
-           last_root = Nullcmd;
-       }
-       specfilename = str_get(str);
-       str_set(linestr,"");
-       if (optype == O_REQUIRE && &str_undef !=
-         hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
-           curcmd = oldcurcmd;
-           tmps_base = oldtmps_base;
-           st[++sp] = &str_yes;
-           perldb = oldperldb;
-           return sp;
-       }
-       tmpfilename = savestr(specfilename);
-       if (index("/.", *tmpfilename))
-           rsfp = fopen(tmpfilename,"r");
-       else {
-           ar = stab_array(incstab);
-           for (i = 0; i <= ar->ary_fill; i++) {
-               (void)sprintf(buf, "%s/%s",
-                 str_get(afetch(ar,i,TRUE)), specfilename);
-               rsfp = fopen(buf,"r");
-               if (rsfp) {
-                   char *s = buf;
-
-                   if (*s == '.' && s[1] == '/')
-                       s += 2;
-                   Safefree(tmpfilename);
-                   tmpfilename = savestr(s);
-                   break;
-               }
-           }
-       }
-       curcmd->c_filestab = fstab(tmpfilename);
-       Safefree(tmpfilename);
-       tmpfilename = Nullch;
-       if (!rsfp) {
-           curcmd = oldcurcmd;
-           tmps_base = oldtmps_base;
-           if (optype == O_REQUIRE) {
-               sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
-               if (instr(tokenbuf,".h "))
-                   strcat(tokenbuf," (change .h to .ph maybe?)");
-               if (instr(tokenbuf,".ph "))
-                   strcat(tokenbuf," (did you run h2ph?)");
-               fatal("%s",tokenbuf);
-           }
-           if (gimme != G_ARRAY)
-               st[++sp] = &str_undef;
-           perldb = oldperldb;
-           return sp;
-       }
-       curcmd->c_line = 0;
-    }
-    in_eval++;
-    oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
-    bufend = bufptr + linestr->str_cur;
-    if (++loop_ptr >= loop_max) {
-       loop_max += 128;
-       Renew(loop_stack, loop_max, struct loop);
-    }
-    loop_stack[loop_ptr].loop_label = "_EVAL_";
-    loop_stack[loop_ptr].loop_sp = sp;
-#ifdef DEBUGGING
-    if (debug & 4) {
-       deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
-    }
-#endif
-    eval_root = Nullcmd;
-    if (setjmp(loop_stack[loop_ptr].loop_env)) {
-       retval = 1;
-    }
-    else {
-       error_count = 0;
-       if (rsfp) {
-           retval = yyparse();
-           retval |= error_count;
-       }
-       else if (last_root && last_elen == bufend - bufptr
-         && *bufptr == *last_eval && !bcmp(bufptr,last_eval,last_elen)){
-           retval = 0;
-           eval_root = last_root;      /* no point in reparsing */
-       }
-       else if (in_eval == 1 && !savecmd) {
-           if (last_root) {
-               Safefree(last_eval);
-               last_eval = Nullch;
-               cmd_free(last_root);
+    for (i = 0; i <= fill; i++)
+    {
+       GV *gv = (GV*)av_shift(list);
+       SV* tmpsv = NEWSV(0,0);
+
+       if (gv && GvCV(gv)) {
+           gv_efullname(tmpsv, gv);
+           if (setjmp(top_env)) {
+               if (list == beginav)
+                   exit(1);
            }
-           last_root = Nullcmd;
-           last_elen = bufend - bufptr;
-           last_eval = nsavestr(bufptr, last_elen);
-           retval = yyparse();
-           retval |= error_count;
-           if (!retval)
-               last_root = eval_root;
-           if (!last_root) {
-               Safefree(last_eval);
-               last_eval = Nullch;
+           else {
+               perl_callback(SvPVX(tmpsv), sp, G_SCALAR, 0, 0);
            }
        }
-       else
-           retval = yyparse();
-    }
-    myroot = eval_root;                /* in case cmd_exec does another eval! */
-
-    if (retval) {
-       st = stack->ary_array;
-       sp = arglast[0];
-       if (gimme != G_ARRAY)
-           st[++sp] = &str_undef;
-       if (parsing) {
-#ifndef MANGLEDPARSE
-#ifdef DEBUGGING
-           if (debug & 128)
-               fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
-#endif
-           cmd_free(eval_root);
-#endif
-           if ((CMD*)eval_root == last_root)
-               last_root = Nullcmd;
-           eval_root = myroot = Nullcmd;
-       }
-       if (rsfp) {
-           fclose(rsfp);
-           rsfp = 0;
-       }
-    }
-    else {
-       parsing = 0;
-       sp = cmd_exec(eval_root,gimme,sp);
-       st = stack->ary_array;
-       for (i = arglast[0] + 1; i <= sp; i++)
-           st[i] = str_mortal(st[i]);
-                               /* if we don't save result, free zaps it */
-       if (savecmd)
-           eval_root = myroot;
-       else if (in_eval != 1 && myroot != last_root)
-           cmd_free(myroot);
-    }
-
-    perldb = oldperldb;
-    in_eval--;
-#ifdef DEBUGGING
-    if (debug & 4) {
-       char *tmps = loop_stack[loop_ptr].loop_label;
-       deb("(Popping label #%d %s)\n",loop_ptr,
-           tmps ? tmps : "" );
-    }
-#endif
-    loop_ptr--;
-    tmps_base = oldtmps_base;
-    curspat = oldspat;
-    lastspat = oldlspat;
-    if (savestack->ary_fill > oldsave) /* let them use local() */
-       restorelist(oldsave);
-
-    if (optype != O_EVAL) {
-       if (retval) {
-           if (optype == O_REQUIRE)
-               fatal("%s", str_get(stab_val(stabent("@",TRUE))));
-       }
-       else {
-           curcmd = oldcurcmd;
-           if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
-               (void)hstore(stab_hash(incstab), specfilename,
-                 strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
-                     0 );
-           }
-           else if (optype == O_REQUIRE)
-               fatal("%s did not return a true value", specfilename);
-       }
-    }
-    curcmd = oldcurcmd;
-    return sp;
-}
-
-int
-do_try(cmd,gimme,arglast)
-CMD *cmd;
-int gimme;
-int *arglast;
-{
-    STR **st = stack->ary_array;
-
-    CMD * VOLATILE oldcurcmd = curcmd;
-    VOLATILE int oldtmps_base = tmps_base;
-    VOLATILE int oldsave = savestack->ary_fill;
-    SPAT * VOLATILE oldspat = curspat;
-    SPAT * VOLATILE oldlspat = lastspat;
-    VOLATILE int sp = arglast[0];
-
-    tmps_base = tmps_max;
-    str_set(stab_val(stabent("@",TRUE)),"");
-    in_eval++;
-    if (++loop_ptr >= loop_max) {
-       loop_max += 128;
-       Renew(loop_stack, loop_max, struct loop);
-    }
-    loop_stack[loop_ptr].loop_label = "_EVAL_";
-    loop_stack[loop_ptr].loop_sp = sp;
-#ifdef DEBUGGING
-    if (debug & 4) {
-       deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
-    }
-#endif
-    if (setjmp(loop_stack[loop_ptr].loop_env)) {
-       st = stack->ary_array;
-       sp = arglast[0];
-       if (gimme != G_ARRAY)
-           st[++sp] = &str_undef;
-    }
-    else {
-       sp = cmd_exec(cmd,gimme,sp);
-       st = stack->ary_array;
-/*     for (i = arglast[0] + 1; i <= sp; i++)
-           st[i] = str_mortal(st[i]);  not needed, I think */
-                               /* if we don't save result, free zaps it */
-    }
-
-    in_eval--;
-#ifdef DEBUGGING
-    if (debug & 4) {
-       char *tmps = loop_stack[loop_ptr].loop_label;
-       deb("(Popping label #%d %s)\n",loop_ptr,
-           tmps ? tmps : "" );
-    }
-#endif
-    loop_ptr--;
-    tmps_base = oldtmps_base;
-    curspat = oldspat;
-    lastspat = oldlspat;
-    curcmd = oldcurcmd;
-    if (savestack->ary_fill > oldsave) /* let them use local() */
-       restorelist(oldsave);
-
-    return sp;
-}
-
-/* This routine handles any switches that can be given during run */
-
-static char *
-moreswitches(s)
-char *s;
-{
-    int numlen;
-
-    switch (*s) {
-    case '0':
-       nrschar = scanoct(s, 4, &numlen);
-       nrs = nsavestr("\n",1);
-       *nrs = nrschar;
-       if (nrschar > 0377) {
-           nrslen = 0;
-           nrs = "";
-       }
-       else if (!nrschar && numlen >= 2) {
-           nrslen = 2;
-           nrs = "\n\n";
-           nrschar = '\n';
-       }
-       return s + numlen;
-    case 'a':
-       minus_a = TRUE;
-       s++;
-       return s;
-    case 'c':
-       minus_c = TRUE;
-       s++;
-       return s;
-    case 'd':
-#ifdef TAINT
-       if (euid != uid || egid != gid)
-           fatal("No -d allowed in setuid scripts");
-#endif
-       perldb = TRUE;
-       s++;
-       return s;
-    case 'D':
-#ifdef DEBUGGING
-#ifdef TAINT
-       if (euid != uid || egid != gid)
-           fatal("No -D allowed in setuid scripts");
-#endif
-       debug = atoi(s+1) | 32768;
-#else
-       warn("Recompile perl with -DDEBUGGING to use -D switch\n");
-#endif
-       /*SUPPRESS 530*/
-       for (s++; isDIGIT(*s); s++) ;
-       return s;
-    case 'i':
-       inplace = savestr(s+1);
-       /*SUPPRESS 530*/
-       for (s = inplace; *s && !isSPACE(*s); s++) ;
-       *s = '\0';
-       break;
-    case 'I':
-#ifdef TAINT
-       if (euid != uid || egid != gid)
-           fatal("No -I allowed in setuid scripts");
-#endif
-       if (*++s) {
-           (void)apush(stab_array(incstab),str_make(s,0));
-       }
-       else
-           fatal("No space allowed after -I");
-       break;
-    case 'l':
-       minus_l = TRUE;
-       s++;
-       if (isDIGIT(*s)) {
-           ors = savestr("\n");
-           orslen = 1;
-           *ors = scanoct(s, 3 + (*s == '0'), &numlen);
-           s += numlen;
-       }
-       else {
-           ors = nsavestr(nrs,nrslen);
-           orslen = nrslen;
-       }
-       return s;
-    case 'n':
-       minus_n = TRUE;
-       s++;
-       return s;
-    case 'p':
-       minus_p = TRUE;
-       s++;
-       return s;
-    case 'u':
-       do_undump = TRUE;
-       s++;
-       return s;
-    case 'U':
-       unsafe = TRUE;
-       s++;
-       return s;
-    case 'v':
-       fputs("\nThis is perl, version 4.0\n\n",stdout);
-       fputs(rcsid,stdout);
-       fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
-#ifdef MSDOS
-       fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
-       stdout);
-#ifdef OS2
-        fputs("OS/2 port Copyright (c) 1990, Raymond Chen, Kai Uwe Rommel\n",
-        stdout);
-#endif
-#endif
-       fputs("\n\
-Perl may be copied only under the terms of either the Artistic License or the\n\
-GNU General Public License, which may be found in the Perl 4.0 source kit.\n",stdout);
-#ifdef MSDOS
-        usage(origargv[0]);
-#endif
-       exit(0);
-    case 'w':
-       dowarn = TRUE;
-       s++;
-       return s;
-    case ' ':
-    case '\n':
-    case '\t':
-       break;
-    default:
-       fatal("Switch meaningless after -x: -%s",s);
+       sv_free(tmpsv);
+       sv_free(gv);
     }
-    return Nullch;
-}
-
-/* compliments of Tom Christiansen */
-
-/* unexec() can be found in the Gnu emacs distribution */
-
-my_unexec()
-{
-#ifdef UNEXEC
-    int    status;
-    extern int etext;
-    static char dumpname[BUFSIZ];
-    static char perlpath[256];
-
-    sprintf (dumpname, "%s.perldump", origfilename);
-    sprintf (perlpath, "%s/perl", BIN);
 
-    status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
-    if (status)
-       fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
-    exit(status);
-#else
-#ifdef MSDOS
-    abort();   /* nothing else to do */
-#else /* ! MSDOS */
-#   ifndef SIGABRT
-#      define SIGABRT SIGILL
-#   endif
-#   ifndef SIGILL
-#      define SIGILL 6         /* blech */
-#   endif
-    kill(getpid(),SIGABRT);    /* for use with undump */
-#endif /* ! MSDOS */
-#endif
+    Copy(oldtop, top_env, 1, jmp_buf);
 }