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 752121c..c6c2bee 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1,6 +1,5 @@
-char rcsid[] = "$RCSfile: perl.c,v $$Revision: 5.0 $$Date: 92/08/07 18:25:50 $\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.
@@ -59,6 +58,8 @@ char rcsid[] = "$RCSfile: perl.c,v $$Revision: 5.0 $$Date: 92/08/07 18:25:50 $\n
 #include "perly.h"
 #include "patchlevel.h"
 
+char rcsid[] = "$RCSfile: perl.c,v $$Revision: 5.0 $$Date: 92/08/07 18:25:50 $\nPatch level: ###\n";
+
 #ifdef IAMSUID
 #ifndef DOSUID
 #define DOSUID
@@ -84,39 +85,40 @@ static void init_predump_symbols();
 static void init_postdump_symbols();
 static void init_perllib();
 
-Interpreter *
+PerlInterpreter *
 perl_alloc()
 {
-    Interpreter *sv_interp;
-    Interpreter junk;
+    PerlInterpreter *sv_interp;
+    PerlInterpreter junk;
 
     curinterp = &junk;
-    Zero(&junk, 1, Interpreter);
-    New(53, sv_interp, 1, Interpreter);
+    Zero(&junk, 1, PerlInterpreter);
+    New(53, sv_interp, 1, PerlInterpreter);
     return sv_interp;
 }
 
 void
 perl_construct( sv_interp )
-register Interpreter *sv_interp;
+register PerlInterpreter *sv_interp;
 {
     if (!(curinterp = sv_interp))
        return;
 
-    Zero(sv_interp, 1, Interpreter);
+    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);
-       SvNVn(&sv_no);
+       SvNV(&sv_no);
        SvREADONLY_on(&sv_no);
 
        sv_setpv(&sv_yes,Yes);
-       SvNVn(&sv_yes);
+       SvNV(&sv_yes);
        SvREADONLY_on(&sv_yes);
 
 #ifdef MSDOS
@@ -132,7 +134,7 @@ register Interpreter *sv_interp;
 
 #ifdef EMBEDDED
     chopset    = " \n-";
-    cmdline    = NOLINE;
+    copline    = NOLINE;
     curcop     = &compiling;
     cxstack_ix = -1;
     cxstack_max        = 128;
@@ -148,7 +150,7 @@ register Interpreter *sv_interp;
     rschar     = '\n';
     rsfp       = Nullfp;
     rslen      = 1;
-    statname   = Nullstr;
+    statname   = Nullsv;
     tmps_floor = -1;
     tmps_ix    = -1;
     tmps_max   = -1;
@@ -158,25 +160,18 @@ register Interpreter *sv_interp;
     euid = (int)geteuid();
     gid = (int)getgid();
     egid = (int)getegid();
-    sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
+    tainting = (euid != uid || egid != gid);
+    sprintf(patchlevel,"%3.3s%2.2d", strchr(rcsid,'5'), PATCHLEVEL);
 
-    (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
+    (void)sprintf(strchr(rcsid,'#'), "%d\n", PATCHLEVEL);
 
     fdpid = newAV();   /* for remembering popen pids by fd */
-    pidstatus = newHV(COEFFSIZE);/* for remembering status of dead pids */
-
-#ifdef TAINT
-#ifndef DOSUID
-    if (uid == euid && gid == egid)
-       taintanyway = TRUE;             /* running taintperl explicitly */
-#endif
-#endif
-
+    pidstatus = newHV();/* for remembering status of dead pids */
 }
 
 void
 perl_destruct(sv_interp)
-register Interpreter *sv_interp;
+register PerlInterpreter *sv_interp;
 {
     if (!(curinterp = sv_interp))
        return;
@@ -184,15 +179,12 @@ register Interpreter *sv_interp;
     if (main_root)
        op_free(main_root);
     main_root = 0;
-    if (last_root)
-       op_free(last_root);
-    last_root = 0;
 #endif
 }
 
 void
 perl_free(sv_interp)
-Interpreter *sv_interp;
+PerlInterpreter *sv_interp;
 {
     if (!(curinterp = sv_interp))
        return;
@@ -201,7 +193,7 @@ Interpreter *sv_interp;
 
 int
 perl_parse(sv_interp, argc, argv, env)
-Interpreter *sv_interp;
+PerlInterpreter *sv_interp;
 register int argc;
 register char **argv;
 char **env;
@@ -216,7 +208,7 @@ char **env;
 #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
@@ -227,9 +219,6 @@ setuid perl scripts securely.\n");
     if (main_root)
        op_free(main_root);
     main_root = 0;
-    if (last_root)
-       op_free(last_root);
-    last_root = 0;
 
     origargv = argv;
     origargc = argc;
@@ -276,6 +265,7 @@ setuid perl scripts securely.\n");
        case 'n':
        case 'p':
        case 's':
+       case 'T':
        case 'u':
        case 'U':
        case 'v':
@@ -285,18 +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)
-                   fatal("Can't mktemp()");
+                   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);
@@ -305,10 +293,7 @@ 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
+           taint_not("-I");
            sv_catpv(sv,"-");
            sv_catpv(sv,s);
            sv_catpv(sv," ");
@@ -323,18 +308,12 @@ setuid perl scripts securely.\n");
            }
            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
+           taint_not("-S");
            dosearch = TRUE;
            s++;
            goto reswitch;
@@ -350,14 +329,14 @@ 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) {
        if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
-           fatal("Can't write to temp file for -e: %s", strerror(errno));
+           croak("Can't write to temp file for -e: %s", strerror(errno));
        argc++,argv--;
        scriptname = e_tmpname;
     }
@@ -388,10 +367,19 @@ setuid perl scripts securely.\n");
     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 */
@@ -399,9 +387,9 @@ setuid perl scripts securely.\n");
     error_count = 0;
     if (yyparse() || error_count) {
        if (minus_c)
-           fatal("%s had compilation errors.\n", origfilename);
+           croak("%s had compilation errors.\n", origfilename);
        else {
-           fatal("Execution of %s aborted due to compilation errors.\n",
+           croak("Execution of %s aborted due to compilation errors.\n",
                origfilename);
        }
     }
@@ -413,9 +401,13 @@ setuid perl scripts securely.\n");
        (void)UNLINK(e_tmpname);
     }
 
-    init_context_stack();
+    /* now that script is parsed, we can modify record separator */
 
-    init_predump_symbols();
+    rs = nrs;
+    rslen = nrslen;
+    rschar = nrschar;
+    rspara = (nrslen == 2);
+    sv_setpvn(GvSV(gv_fetchpv("/", TRUE)), rs, rslen);
 
     if (do_undump)
        my_unexec();
@@ -427,25 +419,21 @@ setuid perl scripts securely.\n");
 
 int
 perl_run(sv_interp)
-Interpreter *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;
-       {
-           GV *gv = gv_fetchpv("END", FALSE);
-
-           if (gv && GvCV(gv)) {
-               if (!setjmp(top_env))
-                   perl_callback("END", 0, G_SCALAR, 0, 0);
-           }
-           return(statusvalue);                /* my_exit() was called */
-       }
+       if (endav)
+           calllist(endav);
+       return(statusvalue);            /* my_exit() was called */
     case 3:
        if (!restartop) {
            fprintf(stderr, "panic: restartop\n");
@@ -479,8 +467,6 @@ Interpreter *sv_interp;
        op = main_start;
        run();
     }
-    else
-       fatal("panic: perl_run");
 
     my_exit(0);
 }
@@ -506,19 +492,25 @@ 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;
+    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 = (SV*)gv_fetchpv(subname, FALSE);
     stack_sp += numargs;
 
-    myop.op_last = hasargs ? (OP*)&myop : Nullop;
+    if (hasargs) {
+       myop.op_flags = OPf_STACKED;
+       myop.op_last = (OP*)&myop;
+    }
     myop.op_next = Nullop;
 
-    op = pp_entersubr();
-    run();
+    if (op = pp_entersubr())
+       run();
+    free_tmps();
     LEAVE;
     return stack_sp - stack_base;
 }
@@ -545,17 +537,6 @@ register char **argv;      /* null terminated arg list, NULL for no arglist */
 }
 
 void
-magicalize(list)
-register char *list;
-{
-    char sym[2];
-
-    sym[1] = '\0';
-    while (*sym = *list++)
-       magicname(sym, sym, 1);
-}
-
-void
 magicname(sym,name,namlen)
 char *sym;
 char *name;
@@ -563,7 +544,7 @@ I32 namlen;
 {
     register GV *gv;
 
-    if (gv = gv_fetchpv(sym,allgvs))
+    if (gv = gv_fetchpv(sym,TRUE))
        sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
 }
 
@@ -590,7 +571,7 @@ char *p;
            /* (void)av_push(GvAVn(incgv), newSVpv(".", 1)); */
            p++;
        }
-       if ( (s = index(p, PERLLIB_SEP)) != Nullch ) {
+       if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
            (void)av_push(GvAVn(incgv), newSVpv(p, (I32)(s - p)));
            p = s + 1;
        } else {
@@ -632,24 +613,18 @@ char *s;
        s++;
        return s;
     case 'd':
-#ifdef TAINT
-       if (euid != uid || egid != gid)
-           fatal("No -d allowed in setuid scripts");
-#endif
+       taint_not("-d");
        perldb = TRUE;
        s++;
        return s;
     case 'D':
 #ifdef DEBUGGING
-#ifdef TAINT
-       if (euid != uid || egid != gid)
-           fatal("No -D allowed in setuid scripts");
-#endif
+       taint_not("-D");
        if (isALPHA(s[1])) {
            static char debopts[] = "psltocPmfrxuLHX";
            char *d;
 
-           for (s++; *s && (d = index(debopts,*s)); s++)
+           for (s++; *s && (d = strchr(debopts,*s)); s++)
                debug |= 1 << (d - debopts);
        }
        else {
@@ -672,15 +647,12 @@ char *s;
        *s = '\0';
        break;
     case 'I':
-#ifdef TAINT
-       if (euid != uid || egid != gid)
-           fatal("No -I allowed in setuid scripts");
-#endif
+       taint_not("-I");
        if (*++s) {
            (void)av_push(GvAVn(incgv),newSVpv(s,0));
        }
        else
-           fatal("No space allowed after -I");
+           croak("No space allowed after -I");
        break;
     case 'l':
        minus_l = TRUE;
@@ -705,13 +677,14 @@ char *s;
        s++;
        return s;
     case 's':
-#ifdef TAINT
-       if (euid != uid || egid != gid)
-           fatal("No -s allowed in setuid scripts");
-#endif
+       taint_not("-s");
        doswitches = TRUE;
        s++;
        return s;
+    case 'T':
+       tainting = TRUE;
+       s++;
+       return s;
     case 'u':
        do_undump = TRUE;
        s++;
@@ -721,9 +694,9 @@ char *s;
        s++;
        return s;
     case 'v':
-       fputs("\nThis is perl, version 5.0, Alpha 2 (unsupported)\n\n",stdout);
+       fputs("\nThis is perl, version 5.0, Alpha 5 (unsupported)\n\n",stdout);
        fputs(rcsid,stdout);
-       fputs("\nCopyright (c) 1989, 1990, 1991, 1992, 1993 Larry Wall\n",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);
@@ -755,7 +728,7 @@ GNU General Public License, which may be found in the Perl 5.0 source kit.\n",st
     case '\t':
        break;
     default:
-       fatal("Switch meaningless after -x: -%s",s);
+       croak("Switch meaningless after -x: -%s",s);
     }
     return Nullch;
 }
@@ -786,9 +759,11 @@ my_unexec()
 static void
 init_main_stash()
 {
-    curstash = defstash = newHV(0);
+    GV *gv;
+    curstash = defstash = newHV();
     curstname = newSVpv("main",4);
-    GvHV(gv_fetchpv("_main",TRUE)) = defstash;
+    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);
@@ -806,7 +781,7 @@ SV *sv;
     register char *s;
     I32 len;
 
-    if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) {
+    if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
 
        bufend = s + strlen(s);
        while (*s) {
@@ -846,7 +821,7 @@ SV *sv;
                xfailed = savestr(tokenbuf);
        }
        if (!xfound)
-           fatal("Can't execute %s", xfailed ? xfailed : scriptname );
+           croak("Can't execute %s", xfailed ? xfailed : scriptname );
        if (xfailed)
            Safefree(xfailed);
        scriptname = xfound;
@@ -901,7 +876,7 @@ sed %s -e \"/^[^#]/b\" \
 #endif
          (doextract ? "-e '1,/^#/d\n'" : ""),
 #endif
-         scriptname, tokenbuf, SvPVn(sv), CPPMINUS);
+         scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
        DEBUG_P(fprintf(stderr, "%s\n", buf));
        doextract = FALSE;
 #ifdef IAMSUID                         /* actually, this is caught earlier */
@@ -916,16 +891,13 @@ sed %s -e \"/^[^#]/b\" \
 #endif
 #endif
            if (geteuid() != uid)
-               fatal("Can't do seteuid!\n");
+               croak("Can't do seteuid!\n");
        }
 #endif /* IAMSUID */
        rsfp = my_popen(buf,"r");
     }
     else if (!*scriptname) {
-#ifdef TAINT
-       if (euid != uid || egid != gid)
-           fatal("Can't take set-id script from stdin");
-#endif
+       taint_not("program input from stdin");
        rsfp = stdin;
     }
     else
@@ -933,16 +905,16 @@ sed %s -e \"/^[^#]/b\" \
     if ((FILE*)rsfp == Nullfp) {
 #ifdef DOSUID
 #ifndef IAMSUID                /* in case script is not readable before setuid */
-       if (euid && stat(SvPV(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
+       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 */
-           fatal("Can't do setuid\n");
+           croak("Can't do setuid\n");
        }
 #endif
 #endif
-       fatal("Can't open perl script \"%s\": %s\n",
-         SvPV(GvSV(curcop->cop_filegv)), strerror(errno));
+       croak("Can't open perl script \"%s\": %s\n",
+         SvPVX(GvSV(curcop->cop_filegv)), strerror(errno));
     }
 }
 
@@ -950,6 +922,7 @@ 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
@@ -968,18 +941,11 @@ char *validarg;
      * 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)) {
        I32 len;
 
@@ -993,8 +959,8 @@ char *validarg;
         * But I don't think it's too important.  The manual lies when
         * it says access() is useful in setuid programs.
         */
-       if (access(SvPV(GvSV(curcop->cop_filegv)),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
@@ -1005,9 +971,9 @@ char *validarg;
            struct stat tmpstatbuf;
 
            if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
-               fatal("Can't swap uid and euid");       /* really paranoid */
-           if (stat(SvPV(GvSV(curcop->cop_filegv)),&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);
@@ -1017,34 +983,34 @@ char *validarg;
 (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,
-                       SvPV(GvSV(curcop->cop_filegv)),
+                       SvPVX(GvSV(curcop->cop_filegv)),
                        statbuf.st_uid, statbuf.st_gid);
                    (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 */
        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
@@ -1054,13 +1020,13 @@ char *validarg;
        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 */
 
@@ -1070,7 +1036,7 @@ 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) {
@@ -1084,7 +1050,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 #endif
 #endif
            if (getegid() != statbuf.st_gid)
-               fatal("Can't do setegid!\n");
+               croak("Can't do setegid!\n");
        }
        if (statbuf.st_mode & S_ISUID) {
            if (statbuf.st_uid != euid)
@@ -1098,7 +1064,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 #endif
 #endif
            if (geteuid() != statbuf.st_uid)
-               fatal("Can't do seteuid!\n");
+               croak("Can't do seteuid!\n");
        }
        else if (uid) {                 /* oops, mustn't run as root */
 #ifdef HAS_SETEUID
@@ -1111,33 +1077,23 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 #endif
 #endif
            if (geteuid() != uid)
-               fatal("Can't do seteuid!\n");
+               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 */
@@ -1146,30 +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 */
 }
 
 static void
 find_beginning()
 {
-#if !defined(IAMSUID) && !defined(TAINT)
     register char *s;
 
     /* skip forward in input to the real script? */
 
+    taint_not("-x");
     while (doextract) {
        if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
-           fatal("No Perl script found in input\n");
+           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;
@@ -1179,10 +1130,9 @@ find_beginning()
                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) */
 }
 
 static void
@@ -1190,7 +1140,7 @@ init_debugger()
 {
     GV* tmpgv;
 
-    debstash = newHV(0);
+    debstash = newHV();
     GvHV(gv_fetchpv("_DB",TRUE)) = debstash;
     curstash = debstash;
     dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args",TRUE))));
@@ -1243,8 +1193,9 @@ init_stack()
 static void
 init_lexer()
 {
-    bufend = bufptr = SvPVn(linestr);
+    bufend = bufptr = SvPV(linestr, na);
     subname = newSVpv("main",4);
+    lex_start();               /* we never leave */
 }
 
 static void
@@ -1260,48 +1211,8 @@ init_context_stack()
 static void
 init_predump_symbols()
 {
-    SV *sv;
-    GV* tmpgv;
-
-    /* initialize everything that won't change if we undump */
+    GV *tmpgv;
 
-    if (siggv = gv_fetchpv("SIG",allgvs)) {
-       HV *hv;
-       SvMULTI_on(siggv);
-       hv = GvHVn(siggv);
-       hv_magic(hv, siggv, 'S');
-
-       /* initialize signal stack */
-        signalstack = newAV();
-        av_store(signalstack, 32, Nullsv);
-        av_clear(signalstack);
-        AvREAL_off(signalstack);
-    }
-
-    magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
-    userinit();                /* in case linked C routines want magical variables */
-
-    ampergv = gv_fetchpv("&",allgvs);
-    leftgv = gv_fetchpv("`",allgvs);
-    rightgv = gv_fetchpv("'",allgvs);
-    sawampersand = (ampergv || leftgv || rightgv);
-    if (tmpgv = gv_fetchpv(":",allgvs))
-       sv_setpv(GvSV(tmpgv),chopset);
-
-    /* these aren't necessarily magical */
-    if (tmpgv = gv_fetchpv("\014",allgvs)) {
-       sv_setpv(GvSV(tmpgv),"\f");
-       formfeed = GvSV(tmpgv);
-    }
-    if (tmpgv = gv_fetchpv(";",allgvs))
-       sv_setpv(GvSV(tmpgv),"\034");
-    if (tmpgv = gv_fetchpv("]",allgvs)) {
-       sv = GvSV(tmpgv);
-       sv_upgrade(sv, SVt_PVNV);
-       sv_setpv(sv,rcsid);
-       SvNV(sv) = atof(patchlevel);
-       SvNOK_on(sv);
-    }
     sv_setpvn(GvSV(gv_fetchpv("\"", TRUE)), " ", 1);
 
     stdingv = gv_fetchpv("STDIN",TRUE);
@@ -1334,14 +1245,6 @@ init_predump_symbols()
     curoutgv = defoutgv;               /* switch back to STDOUT */
 
     statname = NEWSV(66,0);            /* last filename we did stat on */
-
-    /* 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);
 }
 
 static void
@@ -1363,7 +1266,7 @@ register char **env;
                argc--,argv++;
                break;
            }
-           if (s = index(argv[0], '=')) {
+           if (s = strchr(argv[0], '=')) {
                *s++ = '\0';
                sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE)),s);
            }
@@ -1379,18 +1282,16 @@ register char **env;
     sv_setpvn(bodytarget, "", 0);
     formtarget = bodytarget;
 
-#ifdef TAINT
     tainted = 1;
-#endif
-    if (tmpgv = gv_fetchpv("0",allgvs)) {
+    if (tmpgv = gv_fetchpv("0",TRUE)) {
        sv_setpv(GvSV(tmpgv),origfilename);
        magicname("0", "0", 1);
     }
-    if (tmpgv = gv_fetchpv("\024",allgvs))
+    if (tmpgv = gv_fetchpv("\024",TRUE))
        time(&basetime);
-    if (tmpgv = gv_fetchpv("\030",allgvs))
+    if (tmpgv = gv_fetchpv("\030",TRUE))
        sv_setpv(GvSV(tmpgv),origargv[0]);
-    if (argvgv = gv_fetchpv("ARGV",allgvs)) {
+    if (argvgv = gv_fetchpv("ARGV",TRUE)) {
        SvMULTI_on(argvgv);
        (void)gv_AVadd(argvgv);
        av_clear(GvAVn(argvgv));
@@ -1398,44 +1299,36 @@ register char **env;
            (void)av_push(GvAVn(argvgv),newSVpv(argv[0],0));
        }
     }
-#ifdef TAINT
-    (void) gv_fetchpv("ENV",TRUE);             /* must test PATH and IFS */
-#endif
-    if (envgv = gv_fetchpv("ENV",allgvs)) {
+    if (envgv = gv_fetchpv("ENV",TRUE)) {
        HV *hv;
        SvMULTI_on(envgv);
        hv = GvHVn(envgv);
-       hv_clear(hv, FALSE);
-       hv_magic(hv, envgv, 'E');
+       hv_clear(hv);
        if (env != environ)
            environ[0] = Nullch;
        for (; *env; env++) {
-           if (!(s = index(*env,'=')))
+           if (!(s = strchr(*env,'=')))
                continue;
            *s++ = '\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 (tmpgv = gv_fetchpv("$",allgvs))
+    if (tmpgv = gv_fetchpv("$",TRUE))
        sv_setiv(GvSV(tmpgv),(I32)getpid());
 
-    if (dowarn) {
-       gv_check('A','Z');
-       gv_check('a','z');
-    }
+    if (dowarn)
+       gv_check(defstash);
 }
 
 static void
 init_perllib()
 {
-#ifndef TAINT          /* Can't allow arbitrary PERLLIB in setuid script */
-    incpush(getenv("PERLLIB"));
-#endif /* TAINT */
+    if (!tainting)
+       incpush(getenv("PERLLIB"));
 
 #ifndef PRIVLIB
 #define PRIVLIB "/usr/local/lib/perl"
@@ -1443,3 +1336,38 @@ init_perllib()
     incpush(PRIVLIB);
     (void)av_push(GvAVn(incgv),newSVpv(".",1));
 }
+
+void
+calllist(list)
+AV* list;
+{
+    I32 i;
+    I32 fill = AvFILL(list);
+    jmp_buf oldtop;
+    I32 sp = stack_sp - stack_base;
+
+    av_store(stack, ++sp, Nullsv);     /* reserve spot for 1st return arg */
+    Copy(top_env, oldtop, 1, jmp_buf);
+
+    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);
+           }
+           else {
+               perl_callback(SvPVX(tmpsv), sp, G_SCALAR, 0, 0);
+           }
+       }
+       sv_free(tmpsv);
+       sv_free(gv);
+    }
+
+    Copy(oldtop, top_env, 1, jmp_buf);
+}
+