lwall@netlabs.com (Larry Wall) (04/17/91)
Submitted-by: Larry Wall <lwall@netlabs.com>
Posting-number: Volume 18, Issue 34
Archive-name: perl/part16
[There are 36 kits for perl version 4.0.]
#! /bin/sh
# Make a new directory for the perl sources, cd to it, and run kits 1
# thru 36 through sh. When all 36 kits have been run, read README.
echo "This is perl 4.0 kit 16 (of 36). If kit 16 is complete, the line"
echo '"'"End of kit 16 (of 36)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir emacs 2>/dev/null
echo Extracting perl.c
sed >perl.c <<'!STUFFY!FUNK!' -e 's/X//'
Xchar rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:49:05 $\nPatch level: ###\n";
X/*
X * Copyright (c) 1989, Larry Wall
X *
X * You may distribute under the terms of the GNU General Public License
X * as specified in the README file that comes with the perl 3.0 kit.
X *
X * $Log: perl.c,v $
X * Revision 4.0.1.1 91/04/11 17:49:05 lwall
X * patch1: fixed undefined environ problem
X *
X * Revision 4.0 91/03/20 01:37:44 lwall
X * 4.0 baseline.
X *
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X#include "perly.h"
X#ifdef MSDOS
X#include "patchlev.h"
X#else
X#include "patchlevel.h"
X#endif
X
X#ifdef IAMSUID
X#ifndef DOSUID
X#define DOSUID
X#endif
X#endif
X
X#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
X#ifdef DOSUID
X#undef DOSUID
X#endif
X#endif
X
Xstatic char* moreswitches();
Xstatic char* cddir;
Xstatic bool minus_c;
Xstatic char patchlevel[6];
Xstatic char *nrs = "\n";
Xstatic int nrschar = '\n'; /* final char of rs, or 0777 if none */
Xstatic int nrslen = 1;
X
Xmain(argc,argv,env)
Xregister int argc;
Xregister char **argv;
Xregister char **env;
X{
X register STR *str;
X register char *s;
X char *index(), *strcpy(), *getenv();
X bool dosearch = FALSE;
X#ifdef DOSUID
X char *validarg = "";
X#endif
X
X#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
X#ifdef IAMSUID
X#undef IAMSUID
X fatal("suidperl is no longer needed since the kernel can now execute\n\
Xsetuid perl scripts securely.\n");
X#endif
X#endif
X
X origargv = argv;
X origargc = argc;
X origenviron = environ;
X uid = (int)getuid();
X euid = (int)geteuid();
X gid = (int)getgid();
X egid = (int)getegid();
X sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
X#ifdef MSDOS
X /*
X * There is no way we can refer to them from Perl so close them to save
X * space. The other alternative would be to provide STDAUX and STDPRN
X * filehandles.
X */
X (void)fclose(stdaux);
X (void)fclose(stdprn);
X#endif
X if (do_undump) {
X origfilename = savestr(argv[0]);
X do_undump = 0;
X loop_ptr = -1; /* start label stack again */
X goto just_doit;
X }
X (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
X linestr = Str_new(65,80);
X str_nset(linestr,"",0);
X str = str_make("",0); /* first used for -I flags */
X curstash = defstash = hnew(0);
X curstname = str_make("main",4);
X stab_xhash(stabent("_main",TRUE)) = defstash;
X defstash->tbl_name = "main";
X incstab = hadd(aadd(stabent("INC",TRUE)));
X incstab->str_pok |= SP_MULTI;
X for (argc--,argv++; argc > 0; argc--,argv++) {
X if (argv[0][0] != '-' || !argv[0][1])
X break;
X#ifdef DOSUID
X if (*validarg)
X validarg = " PHOOEY ";
X else
X validarg = argv[0];
X#endif
X s = argv[0]+1;
X reswitch:
X switch (*s) {
X case '0':
X case 'a':
X case 'c':
X case 'd':
X case 'D':
X case 'i':
X case 'l':
X case 'n':
X case 'p':
X case 'u':
X case 'U':
X case 'v':
X case 'w':
X if (s = moreswitches(s))
X goto reswitch;
X break;
X
X case 'e':
X#ifdef TAINT
X if (euid != uid || egid != gid)
X fatal("No -e allowed in setuid scripts");
X#endif
X if (!e_fp) {
X e_tmpname = savestr(TMPPATH);
X (void)mktemp(e_tmpname);
X e_fp = fopen(e_tmpname,"w");
X if (!e_fp)
X fatal("Cannot open temporary file");
X }
X if (argv[1]) {
X fputs(argv[1],e_fp);
X argc--,argv++;
X }
X (void)putc('\n', e_fp);
X break;
X case 'I':
X#ifdef TAINT
X if (euid != uid || egid != gid)
X fatal("No -I allowed in setuid scripts");
X#endif
X str_cat(str,"-");
X str_cat(str,s);
X str_cat(str," ");
X if (*++s) {
X (void)apush(stab_array(incstab),str_make(s,0));
X }
X else if (argv[1]) {
X (void)apush(stab_array(incstab),str_make(argv[1],0));
X str_cat(str,argv[1]);
X argc--,argv++;
X str_cat(str," ");
X }
X break;
X case 'P':
X#ifdef TAINT
X if (euid != uid || egid != gid)
X fatal("No -P allowed in setuid scripts");
X#endif
X preprocess = TRUE;
X s++;
X goto reswitch;
X case 's':
X#ifdef TAINT
X if (euid != uid || egid != gid)
X fatal("No -s allowed in setuid scripts");
X#endif
X doswitches = TRUE;
X s++;
X goto reswitch;
X case 'S':
X dosearch = TRUE;
X s++;
X goto reswitch;
X case 'x':
X doextract = TRUE;
X s++;
X if (*s)
X cddir = savestr(s);
X break;
X case '-':
X argc--,argv++;
X goto switch_end;
X case 0:
X break;
X default:
X fatal("Unrecognized switch: -%s",s);
X }
X }
X switch_end:
X if (e_fp) {
X (void)fclose(e_fp);
X argc++,argv--;
X argv[0] = e_tmpname;
X }
X
X#ifdef MSDOS
X#define PERLLIB_SEP ';'
X#else
X#define PERLLIB_SEP ':'
X#endif
X#ifndef TAINT /* Can't allow arbitrary PERLLIB in setuid script */
X {
X char * s2 = getenv("PERLLIB");
X
X if ( s2 ) {
X /* Break at all separators */
X while ( *s2 ) {
X /* First, skip any consecutive separators */
X while ( *s2 == PERLLIB_SEP ) {
X /* Uncomment the next line for PATH semantics */
X /* (void)apush(stab_array(incstab),str_make(".",1)); */
X s2++;
X }
X if ( (s = index(s2,PERLLIB_SEP)) != Nullch ) {
X (void)apush(stab_array(incstab),str_make(s2,(int)(s-s2)));
X s2 = s+1;
X } else {
X (void)apush(stab_array(incstab),str_make(s2,0));
X break;
X }
X }
X }
X }
X#endif /* TAINT */
X
X#ifndef PRIVLIB
X#define PRIVLIB "/usr/local/lib/perl"
X#endif
X (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
X (void)apush(stab_array(incstab),str_make(".",1));
X
X str_set(&str_no,No);
X str_set(&str_yes,Yes);
X
X /* open script */
X
X if (argv[0] == Nullch)
X#ifdef MSDOS
X {
X if ( isatty(fileno(stdin)) )
X moreswitches("v");
X argv[0] = "-";
X }
X#else
X argv[0] = "-";
X#endif
X if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) {
X char *xfound = Nullch, *xfailed = Nullch;
X int len;
X
X bufend = s + strlen(s);
X while (*s) {
X#ifndef MSDOS
X s = cpytill(tokenbuf,s,bufend,':',&len);
X#else
X for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
X tokenbuf[len] = '\0';
X#endif
X if (*s)
X s++;
X#ifndef MSDOS
X if (len && tokenbuf[len-1] != '/')
X#else
X if (len && tokenbuf[len-1] != '\\')
X#endif
X (void)strcat(tokenbuf+len,"/");
X (void)strcat(tokenbuf+len,argv[0]);
X#ifdef DEBUGGING
X if (debug & 1)
X fprintf(stderr,"Looking for %s\n",tokenbuf);
X#endif
X if (stat(tokenbuf,&statbuf) < 0) /* not there? */
X continue;
X if (S_ISREG(statbuf.st_mode)
X && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
X xfound = tokenbuf; /* bingo! */
X break;
X }
X if (!xfailed)
X xfailed = savestr(tokenbuf);
X }
X if (!xfound)
X fatal("Can't execute %s", xfailed ? xfailed : argv[0] );
X if (xfailed)
X Safefree(xfailed);
X argv[0] = savestr(xfound);
X }
X
X fdpid = anew(Nullstab); /* for remembering popen pids by fd */
X pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
X
X origfilename = savestr(argv[0]);
X curcmd->c_filestab = fstab(origfilename);
X if (strEQ(origfilename,"-"))
X argv[0] = "";
X if (preprocess) {
X str_cat(str,"-I");
X str_cat(str,PRIVLIB);
X (void)sprintf(buf, "\
X%ssed %s -e '/^[^#]/b' \
X -e '/^#[ ]*include[ ]/b' \
X -e '/^#[ ]*define[ ]/b' \
X -e '/^#[ ]*if[ ]/b' \
X -e '/^#[ ]*ifdef[ ]/b' \
X -e '/^#[ ]*ifndef[ ]/b' \
X -e '/^#[ ]*else/b' \
X -e '/^#[ ]*endif/b' \
X -e 's/^#.*//' \
X %s | %s -C %s %s",
X#ifdef MSDOS
X "",
X#else
X "/bin/",
X#endif
X (doextract ? "-e '1,/^#/d\n'" : ""),
X argv[0], CPPSTDIN, str_get(str), CPPMINUS);
X#ifdef DEBUGGING
X if (debug & 64) {
X fputs(buf,stderr);
X fputs("\n",stderr);
X }
X#endif
X doextract = FALSE;
X#ifdef IAMSUID /* actually, this is caught earlier */
X if (euid != uid && !euid) /* if running suidperl */
X#ifdef HAS_SETEUID
X (void)seteuid(uid); /* musn't stay setuid root */
X#else
X#ifdef HAS_SETREUID
X (void)setreuid(-1, uid);
X#else
X setuid(uid);
X#endif
X#endif
X#endif /* IAMSUID */
X rsfp = mypopen(buf,"r");
X }
X else if (!*argv[0])
X rsfp = stdin;
X else
X rsfp = fopen(argv[0],"r");
X if (rsfp == Nullfp) {
X#ifdef DOSUID
X#ifndef IAMSUID /* in case script is not readable before setuid */
X if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
X statbuf.st_mode & (S_ISUID|S_ISGID)) {
X (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
X execv(buf, origargv); /* try again */
X fatal("Can't do setuid\n");
X }
X#endif
X#endif
X fatal("Can't open perl script \"%s\": %s\n",
X stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
X }
X str_free(str); /* free -I directories */
X str = Nullstr;
X
X /* do we need to emulate setuid on scripts? */
X
X /* This code is for those BSD systems that have setuid #! scripts disabled
X * in the kernel because of a security problem. Merely defining DOSUID
X * in perl will not fix that problem, but if you have disabled setuid
X * scripts in the kernel, this will attempt to emulate setuid and setgid
X * on scripts that have those now-otherwise-useless bits set. The setuid
X * root version must be called suidperl or sperlN.NNN. If regular perl
X * discovers that it has opened a setuid script, it calls suidperl with
X * the same argv that it had. If suidperl finds that the script it has
X * just opened is NOT setuid root, it sets the effective uid back to the
X * uid. We don't just make perl setuid root because that loses the
X * effective uid we had before invoking perl, if it was different from the
X * uid.
X *
X * DOSUID must be defined in both perl and suidperl, and IAMSUID must
X * be defined in suidperl only. suidperl must be setuid root. The
X * Configure script will set this up for you if you want it.
X *
X * There is also the possibility of have a script which is running
X * set-id due to a C wrapper. We want to do the TAINT checks
X * on these set-id scripts, but don't want to have the overhead of
X * them in normal perl, and can't use suidperl because it will lose
X * the effective uid info, so we have an additional non-setuid root
X * version called taintperl or tperlN.NNN that just does the TAINT checks.
X */
X
X#ifdef DOSUID
X if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
X fatal("Can't stat script \"%s\"",origfilename);
X if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
X int len;
X
X#ifdef IAMSUID
X#ifndef HAS_SETREUID
X /* On this access check to make sure the directories are readable,
X * there is actually a small window that the user could use to make
X * filename point to an accessible directory. So there is a faint
X * chance that someone could execute a setuid script down in a
X * non-accessible directory. I don't know what to do about that.
X * But I don't think it's too important. The manual lies when
X * it says access() is useful in setuid programs.
X */
X if (access(stab_val(curcmd->c_filestab)->str_ptr,1)) /*double check*/
X fatal("Permission denied");
X#else
X /* If we can swap euid and uid, then we can determine access rights
X * with a simple stat of the file, and then compare device and
X * inode to make sure we did stat() on the same file we opened.
X * Then we just have to make sure he or she can execute it.
X */
X {
X struct stat tmpstatbuf;
X
X if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
X fatal("Can't swap uid and euid"); /* really paranoid */
X if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0)
X fatal("Permission denied"); /* testing full pathname here */
X if (tmpstatbuf.st_dev != statbuf.st_dev ||
X tmpstatbuf.st_ino != statbuf.st_ino) {
X (void)fclose(rsfp);
X if (rsfp = mypopen("/bin/mail root","w")) { /* heh, heh */
X fprintf(rsfp,
X"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
X(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
X uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
X statbuf.st_dev, statbuf.st_ino,
X stab_val(curcmd->c_filestab)->str_ptr,
X statbuf.st_uid, statbuf.st_gid);
X (void)mypclose(rsfp);
X }
X fatal("Permission denied\n");
X }
X if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
X fatal("Can't reswap uid and euid");
X if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
X fatal("Permission denied\n");
X }
X#endif /* HAS_SETREUID */
X#endif /* IAMSUID */
X
X if (!S_ISREG(statbuf.st_mode))
X fatal("Permission denied");
X if (statbuf.st_mode & S_IWOTH)
X fatal("Setuid/gid script is writable by world");
X doswitches = FALSE; /* -s is insecure in suid */
X curcmd->c_line++;
X if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
X strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
X fatal("No #! line");
X s = tokenbuf+2;
X if (*s == ' ') s++;
X while (!isspace(*s)) s++;
X if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
X fatal("Not a perl script");
X while (*s == ' ' || *s == '\t') s++;
X /*
X * #! arg must be what we saw above. They can invoke it by
X * mentioning suidperl explicitly, but they may not add any strange
X * arguments beyond what #! says if they do invoke suidperl that way.
X */
X len = strlen(validarg);
X if (strEQ(validarg," PHOOEY ") ||
X strnNE(s,validarg,len) || !isspace(s[len]))
X fatal("Args must match #! line");
X
X#ifndef IAMSUID
X if (euid != uid && (statbuf.st_mode & S_ISUID) &&
X euid == statbuf.st_uid)
X if (!do_undump)
X fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
XFIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
X#endif /* IAMSUID */
X
X if (euid) { /* oops, we're not the setuid root perl */
X (void)fclose(rsfp);
X#ifndef IAMSUID
X (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
X execv(buf, origargv); /* try again */
X#endif
X fatal("Can't do setuid\n");
X }
X
X if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid)
X#ifdef HAS_SETEGID
X (void)setegid(statbuf.st_gid);
X#else
X#ifdef HAS_SETREGID
X (void)setregid((GIDTYPE)-1,statbuf.st_gid);
X#else
X setgid(statbuf.st_gid);
X#endif
X#endif
X if (statbuf.st_mode & S_ISUID) {
X if (statbuf.st_uid != euid)
X#ifdef HAS_SETEUID
X (void)seteuid(statbuf.st_uid); /* all that for this */
X#else
X#ifdef HAS_SETREUID
X (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
X#else
X setuid(statbuf.st_uid);
X#endif
X#endif
X }
X else if (uid) /* oops, mustn't run as root */
X#ifdef HAS_SETEUID
X (void)seteuid((UIDTYPE)uid);
X#else
X#ifdef HAS_SETREUID
X (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
X#else
X setuid((UIDTYPE)uid);
X#endif
X#endif
X uid = (int)getuid();
X euid = (int)geteuid();
X gid = (int)getgid();
X egid = (int)getegid();
X if (!cando(S_IXUSR,TRUE,&statbuf))
X fatal("Permission denied\n"); /* they can't do this */
X }
X#ifdef IAMSUID
X else if (preprocess)
X fatal("-P not allowed for setuid/setgid script\n");
X else
X fatal("Script is not setuid/setgid in suidperl\n");
X#else
X#ifndef TAINT /* we aren't taintperl or suidperl */
X /* script has a wrapper--can't run suidperl or we lose euid */
X else if (euid != uid || egid != gid) {
X (void)fclose(rsfp);
X (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
X execv(buf, origargv); /* try again */
X fatal("Can't run setuid script with taint checks");
X }
X#endif /* TAINT */
X#endif /* IAMSUID */
X#else /* !DOSUID */
X#ifndef TAINT /* we aren't taintperl or suidperl */
X if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
X#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
X fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
X if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
X ||
X (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
X )
X if (!do_undump)
X fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
XFIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
X#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
X /* not set-id, must be wrapped */
X (void)fclose(rsfp);
X (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
X execv(buf, origargv); /* try again */
X fatal("Can't run setuid script with taint checks");
X }
X#endif /* TAINT */
X#endif /* DOSUID */
X
X#if !defined(IAMSUID) && !defined(TAINT)
X
X /* skip forward in input to the real script? */
X
X while (doextract) {
X if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
X fatal("No Perl script found in input\n");
X if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
X ungetc('\n',rsfp); /* to keep line count right */
X doextract = FALSE;
X if (s = instr(s,"perl -")) {
X s += 6;
X while (s = moreswitches(s)) ;
X }
X if (cddir && chdir(cddir) < 0)
X fatal("Can't chdir to %s",cddir);
X }
X }
X#endif /* !defined(IAMSUID) && !defined(TAINT) */
X
X defstab = stabent("_",TRUE);
X
X if (perldb) {
X debstash = hnew(0);
X stab_xhash(stabent("_DB",TRUE)) = debstash;
X curstash = debstash;
X dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
X tmpstab->str_pok |= SP_MULTI;
X dbargs->ary_flags = 0;
X subname = str_make("main",4);
X DBstab = stabent("DB",TRUE);
X DBstab->str_pok |= SP_MULTI;
X DBline = stabent("dbline",TRUE);
X DBline->str_pok |= SP_MULTI;
X DBsub = hadd(tmpstab = stabent("sub",TRUE));
X tmpstab->str_pok |= SP_MULTI;
X DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
X tmpstab->str_pok |= SP_MULTI;
X DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
X tmpstab->str_pok |= SP_MULTI;
X DBsignal = stab_val((tmpstab = stabent("signal",TRUE)));
X tmpstab->str_pok |= SP_MULTI;
X curstash = defstash;
X }
X
X /* init tokener */
X
X bufend = bufptr = str_get(linestr);
X
X savestack = anew(Nullstab); /* for saving non-local values */
X stack = anew(Nullstab); /* for saving non-local values */
X stack->ary_flags = 0; /* not a real array */
X afill(stack,63); afill(stack,-1); /* preextend stack */
X afill(savestack,63); afill(savestack,-1);
X
X /* now parse the script */
X
X error_count = 0;
X if (yyparse() || error_count) {
X if (minus_c)
X fatal("%s had compilation errors.\n", origfilename);
X else {
X fatal("Execution of %s aborted due to compilation errors.\n",
X origfilename);
X }
X }
X
X New(50,loop_stack,128,struct loop);
X#ifdef DEBUGGING
X if (debug) {
X New(51,debname,128,char);
X New(52,debdelim,128,char);
X }
X#endif
X curstash = defstash;
X
X preprocess = FALSE;
X if (e_fp) {
X e_fp = Nullfp;
X (void)UNLINK(e_tmpname);
X }
X
X /* initialize everything that won't change if we undump */
X
X if (sigstab = stabent("SIG",allstabs)) {
X sigstab->str_pok |= SP_MULTI;
X (void)hadd(sigstab);
X }
X
X magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\024\027");
X userinit(); /* in case linked C routines want magical variables */
X
X amperstab = stabent("&",allstabs);
X leftstab = stabent("`",allstabs);
X rightstab = stabent("'",allstabs);
X sawampersand = (amperstab || leftstab || rightstab);
X if (tmpstab = stabent(":",allstabs))
X str_set(STAB_STR(tmpstab),chopset);
X if (tmpstab = stabent("\024",allstabs))
X time(&basetime);
X
X /* these aren't necessarily magical */
X if (tmpstab = stabent(";",allstabs))
X str_set(STAB_STR(tmpstab),"\034");
X if (tmpstab = stabent("]",allstabs)) {
X str = STAB_STR(tmpstab);
X str_set(str,rcsid);
X str->str_u.str_nval = atof(patchlevel);
X str->str_nok = 1;
X }
X str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
X
X stdinstab = stabent("STDIN",TRUE);
X stdinstab->str_pok |= SP_MULTI;
X stab_io(stdinstab) = stio_new();
X stab_io(stdinstab)->ifp = stdin;
X tmpstab = stabent("stdin",TRUE);
X stab_io(tmpstab) = stab_io(stdinstab);
X tmpstab->str_pok |= SP_MULTI;
X
X tmpstab = stabent("STDOUT",TRUE);
X tmpstab->str_pok |= SP_MULTI;
X stab_io(tmpstab) = stio_new();
X stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
X defoutstab = tmpstab;
X tmpstab = stabent("stdout",TRUE);
X stab_io(tmpstab) = stab_io(defoutstab);
X tmpstab->str_pok |= SP_MULTI;
X
X curoutstab = stabent("STDERR",TRUE);
X curoutstab->str_pok |= SP_MULTI;
X stab_io(curoutstab) = stio_new();
X stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
X tmpstab = stabent("stderr",TRUE);
X stab_io(tmpstab) = stab_io(curoutstab);
X tmpstab->str_pok |= SP_MULTI;
X curoutstab = defoutstab; /* switch back to STDOUT */
X
X statname = Str_new(66,0); /* last filename we did stat on */
X
X /* now that script is parsed, we can modify record separator */
X
X rs = nrs;
X rslen = nrslen;
X rschar = nrschar;
X str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
X
X if (do_undump)
X my_unexec();
X
X just_doit: /* come here if running an undumped a.out */
X argc--,argv++; /* skip name of script */
X if (doswitches) {
X for (; argc > 0 && **argv == '-'; argc--,argv++) {
X if (argv[0][1] == '-') {
X argc--,argv++;
X break;
X }
X if (s = index(argv[0], '=')) {
X *s++ = '\0';
X str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
X }
X else
X str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
X }
X }
X#ifdef TAINT
X tainted = 1;
X#endif
X if (tmpstab = stabent("0",allstabs)) {
X str_set(stab_val(tmpstab),origfilename);
X magicname("0", Nullch, 0);
X }
X if (tmpstab = stabent("\020",allstabs))
X str_set(stab_val(tmpstab),origargv[0]);
X if (argvstab = stabent("ARGV",allstabs)) {
X argvstab->str_pok |= SP_MULTI;
X (void)aadd(argvstab);
X aclear(stab_array(argvstab));
X for (; argc > 0; argc--,argv++) {
X (void)apush(stab_array(argvstab),str_make(argv[0],0));
X }
X }
X#ifdef TAINT
X (void) stabent("ENV",TRUE); /* must test PATH and IFS */
X#endif
X if (envstab = stabent("ENV",allstabs)) {
X envstab->str_pok |= SP_MULTI;
X (void)hadd(envstab);
X hclear(stab_hash(envstab), FALSE);
X if (env != environ)
X environ[0] = Nullch;
X for (; *env; env++) {
X if (!(s = index(*env,'=')))
X continue;
X *s++ = '\0';
X str = str_make(s--,0);
X str_magic(str, envstab, 'E', *env, s - *env);
X (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
X *s = '=';
X }
X }
X#ifdef TAINT
X tainted = 0;
X#endif
X if (tmpstab = stabent("$",allstabs))
X str_numset(STAB_STR(tmpstab),(double)getpid());
X
X if (dowarn) {
X stab_check('A','Z');
X stab_check('a','z');
X }
X
X if (setjmp(top_env)) /* sets goto_targ on longjump */
X loop_ptr = -1; /* start label stack again */
X
X#ifdef DEBUGGING
X if (debug & 1024)
X dump_all();
X if (debug)
X fprintf(stderr,"\nEXECUTING...\n\n");
X#endif
X
X if (minus_c) {
X fprintf(stderr,"%s syntax OK\n", origfilename);
X exit(0);
X }
X
X /* do it */
X
X (void) cmd_exec(main_root,G_SCALAR,-1);
X
X if (goto_targ)
X fatal("Can't find label \"%s\"--aborting",goto_targ);
X exit(0);
X /* NOTREACHED */
X}
X
Xvoid
Xmagicalize(list)
Xregister char *list;
X{
X char sym[2];
X
X sym[1] = '\0';
X while (*sym = *list++)
X magicname(sym, Nullch, 0);
X}
X
Xvoid
Xmagicname(sym,name,namlen)
Xchar *sym;
Xchar *name;
Xint namlen;
X{
X register STAB *stab;
X
X if (stab = stabent(sym,allstabs)) {
X stab_flags(stab) = SF_VMAGIC;
X str_magic(stab_val(stab), stab, 0, name, namlen);
X }
X}
X
X/* this routine is in perl.c by virtue of being sort of an alternate main() */
X
Xint
Xdo_eval(str,optype,stash,gimme,arglast)
XSTR *str;
Xint optype;
XHASH *stash;
Xint gimme;
Xint *arglast;
X{
X STR **st = stack->ary_array;
X int retval;
X CMD *myroot = Nullcmd;
X ARRAY *ar;
X int i;
X CMD * VOLATILE oldcurcmd = curcmd;
X VOLATILE int oldtmps_base = tmps_base;
X VOLATILE int oldsave = savestack->ary_fill;
X VOLATILE int oldperldb = perldb;
X SPAT * VOLATILE oldspat = curspat;
X SPAT * VOLATILE oldlspat = lastspat;
X static char *last_eval = Nullch;
X static CMD *last_root = Nullcmd;
X VOLATILE int sp = arglast[0];
X char *specfilename;
X char *tmpfilename;
X int parsing = 1;
X
X tmps_base = tmps_max;
X if (curstash != stash) {
X (void)savehptr(&curstash);
X curstash = stash;
X }
X str_set(stab_val(stabent("@",TRUE)),"");
X if (curcmd->c_line == 0) /* don't debug debugger... */
X perldb = FALSE;
X curcmd = &compiling;
X if (optype == O_EVAL) { /* normal eval */
X curcmd->c_filestab = fstab("(eval)");
X curcmd->c_line = 1;
X str_sset(linestr,str);
X str_cat(linestr,";"); /* be kind to them */
X }
X else {
X if (last_root && !in_eval) {
X Safefree(last_eval);
X last_eval = Nullch;
X cmd_free(last_root);
X last_root = Nullcmd;
X }
X specfilename = str_get(str);
X str_set(linestr,"");
X if (optype == O_REQUIRE && &str_undef !=
X hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
X curcmd = oldcurcmd;
X tmps_base = oldtmps_base;
X st[++sp] = &str_yes;
X perldb = oldperldb;
X return sp;
X }
X tmpfilename = savestr(specfilename);
X if (index("/.", *tmpfilename))
X rsfp = fopen(tmpfilename,"r");
X else {
X ar = stab_array(incstab);
X for (i = 0; i <= ar->ary_fill; i++) {
X (void)sprintf(buf, "%s/%s",
X str_get(afetch(ar,i,TRUE)), specfilename);
X rsfp = fopen(buf,"r");
X if (rsfp) {
X char *s = buf;
X
X if (*s == '.' && s[1] == '/')
X s += 2;
X Safefree(tmpfilename);
X tmpfilename = savestr(s);
X break;
X }
X }
X }
X curcmd->c_filestab = fstab(tmpfilename);
X Safefree(tmpfilename);
X tmpfilename = Nullch;
X if (!rsfp) {
X curcmd = oldcurcmd;
X tmps_base = oldtmps_base;
X if (optype == O_REQUIRE) {
X sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
X if (instr(tokenbuf,".h "))
X strcat(tokenbuf," (change .h to .ph maybe?)");
X if (instr(tokenbuf,".ph "))
X strcat(tokenbuf," (did you run h2ph?)");
X fatal("%s",tokenbuf);
X }
X if (gimme != G_ARRAY)
X st[++sp] = &str_undef;
X perldb = oldperldb;
X return sp;
X }
X curcmd->c_line = 0;
X }
X in_eval++;
X oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
X bufend = bufptr + linestr->str_cur;
X if (++loop_ptr >= loop_max) {
X loop_max += 128;
X Renew(loop_stack, loop_max, struct loop);
X }
X loop_stack[loop_ptr].loop_label = "_EVAL_";
X loop_stack[loop_ptr].loop_sp = sp;
X#ifdef DEBUGGING
X if (debug & 4) {
X deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
X }
X#endif
X eval_root = Nullcmd;
X if (setjmp(loop_stack[loop_ptr].loop_env)) {
X retval = 1;
X }
X else {
X error_count = 0;
X if (rsfp) {
X retval = yyparse();
X retval |= error_count;
X }
X else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){
X retval = 0;
X eval_root = last_root; /* no point in reparsing */
X }
X else if (in_eval == 1) {
X if (last_root) {
X Safefree(last_eval);
X last_eval = Nullch;
X cmd_free(last_root);
X }
X last_root = Nullcmd;
X last_eval = savestr(bufptr);
X retval = yyparse();
X retval |= error_count;
X if (!retval)
X last_root = eval_root;
X if (!last_root) {
X Safefree(last_eval);
X last_eval = Nullch;
X }
X }
X else
X retval = yyparse();
X }
X myroot = eval_root; /* in case cmd_exec does another eval! */
X
X if (retval) {
X st = stack->ary_array;
X sp = arglast[0];
X if (gimme != G_ARRAY)
X st[++sp] = &str_undef;
X if (parsing) {
X#ifndef MANGLEDPARSE
X#ifdef DEBUGGING
X if (debug & 128)
X fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
X#endif
X cmd_free(eval_root);
X#endif
X if (eval_root == last_root)
X last_root = Nullcmd;
X eval_root = myroot = Nullcmd;
X }
X if (rsfp) {
X fclose(rsfp);
X rsfp = 0;
X }
X }
X else {
X parsing = 0;
X sp = cmd_exec(eval_root,gimme,sp);
X st = stack->ary_array;
X for (i = arglast[0] + 1; i <= sp; i++)
X st[i] = str_mortal(st[i]);
X /* if we don't save result, free zaps it */
X if (in_eval != 1 && myroot != last_root)
X cmd_free(myroot);
X }
X
X perldb = oldperldb;
X in_eval--;
X#ifdef DEBUGGING
X if (debug & 4) {
X char *tmps = loop_stack[loop_ptr].loop_label;
X deb("(Popping label #%d %s)\n",loop_ptr,
X tmps ? tmps : "" );
X }
X#endif
X loop_ptr--;
X tmps_base = oldtmps_base;
X curspat = oldspat;
X lastspat = oldlspat;
X if (savestack->ary_fill > oldsave) /* let them use local() */
X restorelist(oldsave);
X
X if (optype != O_EVAL) {
X if (retval) {
X if (optype == O_REQUIRE)
X fatal("%s", str_get(stab_val(stabent("@",TRUE))));
X }
X else {
X curcmd = oldcurcmd;
X if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
X (void)hstore(stab_hash(incstab), specfilename,
X strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
X 0 );
X }
X else if (optype == O_REQUIRE)
X fatal("%s did not return a true value", specfilename);
X }
X }
X curcmd = oldcurcmd;
X return sp;
X}
X
X/* This routine handles any switches that can be given during run */
X
Xstatic char *
Xmoreswitches(s)
Xchar *s;
X{
X int numlen;
X
X reswitch:
X switch (*s) {
X case '0':
X nrschar = scanoct(s, 4, &numlen);
X nrs = nsavestr("\n",1);
X *nrs = nrschar;
X if (nrschar > 0377) {
X nrslen = 0;
X nrs = "";
X }
X else if (!nrschar && numlen >= 2) {
X nrslen = 2;
X nrs = "\n\n";
X nrschar = '\n';
X }
X return s + numlen;
X case 'a':
X minus_a = TRUE;
X s++;
X return s;
X case 'c':
X minus_c = TRUE;
X s++;
X return s;
X case 'd':
X#ifdef TAINT
X if (euid != uid || egid != gid)
X fatal("No -d allowed in setuid scripts");
X#endif
X perldb = TRUE;
X s++;
X return s;
X case 'D':
X#ifdef DEBUGGING
X#ifdef TAINT
X if (euid != uid || egid != gid)
X fatal("No -D allowed in setuid scripts");
X#endif
X debug = atoi(s+1) | 32768;
X#else
X warn("Recompile perl with -DDEBUGGING to use -D switch\n");
X#endif
X for (s++; isdigit(*s); s++) ;
X return s;
X case 'i':
X inplace = savestr(s+1);
X for (s = inplace; *s && !isspace(*s); s++) ;
X *s = '\0';
X break;
X case 'I':
X#ifdef TAINT
X if (euid != uid || egid != gid)
X fatal("No -I allowed in setuid scripts");
X#endif
X if (*++s) {
X (void)apush(stab_array(incstab),str_make(s,0));
X }
X else
X fatal("No space allowed after -I");
X break;
X case 'l':
X minus_l = TRUE;
X s++;
X if (isdigit(*s)) {
X ors = savestr("\n");
X orslen = 1;
X *ors = scanoct(s, 3 + (*s == '0'), &numlen);
X s += numlen;
X }
X else {
X ors = nsavestr(nrs,nrslen);
X orslen = nrslen;
X }
X return s;
X case 'n':
X minus_n = TRUE;
X s++;
X return s;
X case 'p':
X minus_p = TRUE;
X s++;
X return s;
X case 'u':
X do_undump = TRUE;
X s++;
X return s;
X case 'U':
X unsafe = TRUE;
X s++;
X return s;
X case 'v':
X fputs("\nThis is perl, version 4.0\n\n",stdout);
X fputs(rcsid,stdout);
X fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
X#ifdef MSDOS
X fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
X stdout);
X#ifdef OS2
X fputs("OS/2 port Copyright (c) 1990, Raymond Chen, Kai Uwe Rommel\n",
X stdout);
X#endif
X#endif
X fputs("\n\
XPerl may be copied only under the terms of the GNU General Public License,\n\
Xa copy of which can be found with the Perl 4.0 distribution kit.\n",stdout);
X#ifdef MSDOS
X usage(origargv[0]);
X#endif
X exit(0);
X case 'w':
X dowarn = TRUE;
X s++;
X return s;
X case ' ':
X case '\n':
X case '\t':
X break;
X default:
X fatal("Switch meaningless after -x: -%s",s);
X }
X return Nullch;
X}
X
X/* compliments of Tom Christiansen */
X
X/* unexec() can be found in the Gnu emacs distribution */
X
Xmy_unexec()
X{
X#ifdef UNEXEC
X int status;
X extern int etext;
X static char dumpname[BUFSIZ];
X static char perlpath[256];
X
X sprintf (dumpname, "%s.perldump", origfilename);
X sprintf (perlpath, "%s/perl", BIN);
X
X status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
X if (status)
X fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
X exit(status);
X#else
X# ifndef SIGABRT
X# define SIGABRT SIGILL
X# endif
X# ifndef SIGILL
X# define SIGILL 6 /* blech */
X# endif
X kill(getpid(),SIGABRT); /* for use with undump */
X#endif
X}
X
!STUFFY!FUNK!
echo Extracting emacs/perldb.pl
sed >emacs/perldb.pl <<'!STUFFY!FUNK!' -e 's/X//'
Xpackage DB;
X
X# modified Perl debugger, to be run from Emacs in perldb-mode
X# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
X
X$header = '$Header: perldb.pl,v 4.0 91/03/20 01:18:58 lwall Locked $';
X#
X# This file is automatically included if you do perl -d.
X# It's probably not useful to include this yourself.
X#
X# Perl supplies the values for @line and %sub. It effectively inserts
X# a do DB'DB(<linenum>); in front of every place that can
X# have a breakpoint. It also inserts a do 'perldb.pl' before the first line.
X#
X# $Log: perldb.pl,v $
X# Revision 4.0 91/03/20 01:18:58 lwall
X# 4.0 baseline.
X#
X# Revision 3.0.1.6 91/01/11 18:08:58 lwall
X# patch42: @_ couldn't be accessed from debugger
X#
X# Revision 3.0.1.5 90/11/10 01:40:26 lwall
X# patch38: the debugger wouldn't stop correctly or do action routines
X#
X# Revision 3.0.1.4 90/10/15 17:40:38 lwall
X# patch29: added caller
X# patch29: the debugger now understands packages and evals
X# patch29: scripts now run at almost full speed under the debugger
X# patch29: more variables are settable from debugger
X#
X# Revision 3.0.1.3 90/08/09 04:00:58 lwall
X# patch19: debugger now allows continuation lines
X# patch19: debugger can now dump lists of variables
X# patch19: debugger can now add aliases easily from prompt
X#
X# Revision 3.0.1.2 90/03/12 16:39:39 lwall
X# patch13: perl -d didn't format stack traces of *foo right
X# patch13: perl -d wiped out scalar return values of subroutines
X#
X# Revision 3.0.1.1 89/10/26 23:14:02 lwall
X# patch1: RCS expanded an unintended $Header in lib/perldb.pl
X#
X# Revision 3.0 89/10/18 15:19:46 lwall
X# 3.0 baseline
X#
X# Revision 2.0 88/06/05 00:09:45 root
X# Baseline version 2.0.
X#
X#
X
Xopen(IN, "</dev/tty") || open(IN, "<&STDIN"); # so we don't dingle stdin
Xopen(OUT,">/dev/tty") || open(OUT, ">&STDOUT"); # so we don't dongle stdout
Xselect(OUT);
X$| = 1; # for DB'OUT
Xselect(STDOUT);
X$| = 1; # for real STDOUT
X$sub = '';
X
X# Is Perl being run from Emacs?
X$emacs = $main'ARGV[$[] eq '-emacs';
Xshift(@main'ARGV) if $emacs;
X
X$header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
Xprint OUT "\nLoading DB routines from $header\n\nEnter h for help.\n\n";
X
Xsub DB {
X &save;
X ($package, $filename, $line) = caller;
X $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' .
X "package $package;"; # this won't let them modify, alas
X local(*dbline) = "_<$filename";
X $max = $#dbline;
X if (($stop,$action) = split(/\0/,$dbline{$line})) {
X if ($stop eq '1') {
X $signal |= 1;
X }
X else {
X $evalarg = "\$DB'signal |= do {$stop;}"; &eval;
X $dbline{$line} =~ s/;9($|\0)/$1/;
X }
X }
X if ($single || $trace || $signal) {
X if ($emacs) {
X print OUT "\032\032$filename:$line:0\n";
X } else {
X print OUT "$package'" unless $sub =~ /'/;
X print OUT "$sub($filename:$line):\t",$dbline[$line];
X for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
X last if $dbline[$i] =~ /^\s*(}|#|\n)/;
X print OUT "$sub($filename:$i):\t",$dbline[$i];
X }
X }
X }
X $evalarg = $action, &eval if $action;
X if ($single || $signal) {
X $evalarg = $pre, &eval if $pre;
X print OUT $#stack . " levels deep in subroutine calls!\n"
X if $single & 4;
X $start = $line;
X while ((print OUT " DB<", $#hist+1, "> "), $cmd=&gets) {
X $single = 0;
X $signal = 0;
X $cmd eq '' && exit 0;
X chop($cmd);
X $cmd =~ s/\\$// && do {
X print OUT " cont: ";
X $cmd .= &gets;
X redo;
X };
X $cmd =~ /^q$/ && exit 0;
X $cmd =~ /^$/ && ($cmd = $laststep);
X push(@hist,$cmd) if length($cmd) > 1;
X ($i) = split(/\s+/,$cmd);
X eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i};
X $cmd =~ /^h$/ && do {
X print OUT "
XT Stack trace.
Xs Single step.
Xn Next, steps over subroutine calls.
Xr Return from current subroutine.
Xc [line] Continue; optionally inserts a one-time-only breakpoint
X at the specified line.
X<CR> Repeat last n or s.
Xl min+incr List incr+1 lines starting at min.
Xl min-max List lines.
Xl line List line;
Xl List next window.
X- List previous window.
Xw line List window around line.
Xl subname List subroutine.
Xf filename Switch to filename.
X/pattern/ Search forwards for pattern; final / is optional.
X?pattern? Search backwards for pattern.
XL List breakpoints and actions.
XS List subroutine names.
Xt Toggle trace mode.
Xb [line] [condition]
X Set breakpoint; line defaults to the current execution line;
X condition breaks if it evaluates to true, defaults to \'1\'.
Xb subname [condition]
X Set breakpoint at first line of subroutine.
Xd [line] Delete breakpoint.
XD Delete all breakpoints.
Xa [line] command
X Set an action to be done before the line is executed.
X Sequence is: check for breakpoint, print line if necessary,
X do action, prompt user if breakpoint or step, evaluate line.
XA Delete all actions.
XV [pkg [vars]] List some (default all) variables in package (default current).
XX [vars] Same as \"V currentpackage [vars]\".
X< command Define command before prompt.
X| command Define command after prompt.
X! number Redo command (default previous command).
X! -number Redo number\'th to last command.
XH -number Display last number commands (default all).
Xq or ^D Quit.
Xp expr Same as \"print DB'OUT expr\" in current package.
X= [alias value] Define a command alias, or list current aliases.
Xcommand Execute as a perl statement in current package.
X
X";
X next; };
X $cmd =~ /^t$/ && do {
X $trace = !$trace;
X print OUT "Trace = ".($trace?"on":"off")."\n";
X next; };
X $cmd =~ /^S$/ && do {
X foreach $subname (sort(keys %sub)) {
X print OUT $subname,"\n";
X }
X next; };
X $cmd =~ s/^X\b/V $package/;
X $cmd =~ /^V$/ && do {
X $cmd = 'V $package'; };
X $cmd =~ /^V\s*(\S+)\s*(.*)/ && do {
X $packname = $1;
X @vars = split(' ',$2);
X do 'dumpvar.pl' unless defined &main'dumpvar;
X if (defined &main'dumpvar) {
X &main'dumpvar($packname,@vars);
X }
X else {
X print DB'OUT "dumpvar.pl not available.\n";
X }
X next; };
X $cmd =~ /^f\s*(.*)/ && do {
X $file = $1;
X if (!$file) {
X print OUT "The old f command is now the r command.\n";
X print OUT "The new f command switches filenames.\n";
X next;
X }
X if (!defined $_main{'_<' . $file}) {
X if (($try) = grep(m#^_<.*$file#, keys %_main)) {
X $file = substr($try,2);
X print "\n$file:\n";
X }
X }
X if (!defined $_main{'_<' . $file}) {
X print OUT "There's no code here anything matching $file.\n";
X next;
X }
X elsif ($file ne $filename) {
X *dbline = "_<$file";
X $max = $#dbline;
X $filename = $file;
X $start = 1;
X $cmd = "l";
X } };
X $cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do {
X $subname = $1;
X $subname = "main'" . $subname unless $subname =~ /'/;
X $subname = "main" . $subname if substr($subname,0,1) eq "'";
X ($file,$subrange) = split(/:/,$sub{$subname});
X if ($file ne $filename) {
X *dbline = "_<$file";
X $max = $#dbline;
X $filename = $file;
X }
X if ($subrange) {
X if (eval($subrange) < -$window) {
X $subrange =~ s/-.*/+/;
X }
X $cmd = "l $subrange";
X } else {
X print OUT "Subroutine $1 not found.\n";
X next;
X } };
X $cmd =~ /^w\s*(\d*)$/ && do {
X $incr = $window - 1;
X $start = $1 if $1;
X $start -= $preview;
X $cmd = 'l ' . $start . '-' . ($start + $incr); };
X $cmd =~ /^-$/ && do {
X $incr = $window - 1;
X $cmd = 'l ' . ($start-$window*2) . '+'; };
X $cmd =~ /^l$/ && do {
X $incr = $window - 1;
X $cmd = 'l ' . $start . '-' . ($start + $incr); };
X $cmd =~ /^l\s*(\d*)\+(\d*)$/ && do {
X $start = $1 if $1;
X $incr = $2;
X $incr = $window - 1 unless $incr;
X $cmd = 'l ' . $start . '-' . ($start + $incr); };
X $cmd =~ /^l\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
X $end = (!$2) ? $max : ($4 ? $4 : $2);
X $end = $max if $end > $max;
X $i = $2;
X $i = $line if $i eq '.';
X $i = 1 if $i < 1;
X if ($emacs) {
X print OUT "\032\032$filename:$i:0\n";
X $i = $end;
X } else {
X for (; $i <= $end; $i++) {
X print OUT "$i:\t", $dbline[$i];
X last if $signal;
X }
X }
X $start = $i; # remember in case they want more
X $start = $max if $start > $max;
X next; };
X $cmd =~ /^D$/ && do {
X print OUT "Deleting all breakpoints...\n";
X for ($i = 1; $i <= $max ; $i++) {
X if (defined $dbline{$i}) {
X $dbline{$i} =~ s/^[^\0]+//;
X if ($dbline{$i} =~ s/^\0?$//) {
X delete $dbline{$i};
X }
X }
X }
X next; };
X $cmd =~ /^L$/ && do {
X for ($i = 1; $i <= $max; $i++) {
X if (defined $dbline{$i}) {
X print OUT "$i:\t", $dbline[$i];
X ($stop,$action) = split(/\0/, $dbline{$i});
X print OUT " break if (", $stop, ")\n"
X if $stop;
X print OUT " action: ", $action, "\n"
X if $action;
X last if $signal;
X }
X }
X next; };
X $cmd =~ /^b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
X $subname = $1;
X $cond = $2 || '1';
X $subname = "$package'" . $subname unless $subname =~ /'/;
X $subname = "main" . $subname if substr($subname,0,1) eq "'";
X ($filename,$i) = split(/[:-]/, $sub{$subname});
X if ($i) {
X *dbline = "_<$filename";
X ++$i while $dbline[$i] == 0 && $i < $#dbline;
X $dbline{$i} =~ s/^[^\0]*/$cond/;
X } else {
X print OUT "Subroutine $subname not found.\n";
X }
X next; };
X $cmd =~ /^b\s*(\d*)\s*(.*)/ && do {
X $i = ($1?$1:$line);
X $cond = $2 || '1';
X if ($dbline[$i] == 0) {
X print OUT "Line $i not breakable.\n";
X } else {
X $dbline{$i} =~ s/^[^\0]*/$cond/;
X }
X next; };
X $cmd =~ /^d\s*(\d+)?/ && do {
X $i = ($1?$1:$line);
X $dbline{$i} =~ s/^[^\0]*//;
X delete $dbline{$i} if $dbline{$i} eq '';
X next; };
X $cmd =~ /^A$/ && do {
X for ($i = 1; $i <= $max ; $i++) {
X if (defined $dbline{$i}) {
X $dbline{$i} =~ s/\0[^\0]*//;
X delete $dbline{$i} if $dbline{$i} eq '';
X }
X }
X next; };
X $cmd =~ /^<\s*(.*)/ && do {
X $pre = do action($1);
X next; };
X $cmd =~ /^>\s*(.*)/ && do {
X $post = do action($1);
X next; };
X $cmd =~ /^a\s*(\d+)(\s+(.*))?/ && do {
X $i = $1;
X if ($dbline[$i] == 0) {
X print OUT "Line $i may not have an action.\n";
X } else {
X $dbline{$i} =~ s/\0[^\0]*//;
X $dbline{$i} .= "\0" . do action($3);
X }
X next; };
X $cmd =~ /^n$/ && do {
X $single = 2;
X $laststep = $cmd;
X last; };
X $cmd =~ /^s$/ && do {
X $single = 1;
X $laststep = $cmd;
X last; };
X $cmd =~ /^c\s*(\d*)\s*$/ && do {
X $i = $1;
X if ($i) {
X if ($dbline[$i] == 0) {
X print OUT "Line $i not breakable.\n";
X next;
X }
X $dbline{$i} =~ s/(\0|$)/;9$1/; # add one-time-only b.p.
X }
X for ($i=0; $i <= $#stack; ) {
X $stack[$i++] &= ~1;
X }
X last; };
X $cmd =~ /^r$/ && do {
X $stack[$#stack] |= 2;
X last; };
X $cmd =~ /^T$/ && do {
X local($p,$f,$l,$s,$h,$a,@a,@sub);
X for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
X @a = @args;
X for (@a) {
X if (/^StB\000/ && length($_) == length($_main{'_main'})) {
X $_ = sprintf("%s",$_);
X }
X else {
X s/'/\\'/g;
X s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
X s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
X s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
X }
X }
X $w = $w ? '@ = ' : '$ = ';
X $a = $h ? '(' . join(', ', @a) . ')' : '';
X push(@sub, "$w&$s$a from file $f line $l\n");
X last if $signal;
X }
X for ($i=0; $i <= $#sub; $i++) {
X last if $signal;
X print OUT $sub[$i];
X }
X next; };
X $cmd =~ /^\/(.*)$/ && do {
X $inpat = $1;
X $inpat =~ s:([^\\])/$:$1:;
X if ($inpat ne "") {
X eval '$inpat =~ m'."\n$inpat\n";
X if ($@ ne "") {
X print OUT "$@";
X next;
X }
X $pat = $inpat;
X }
X $end = $start;
X eval '
X for (;;) {
X ++$start;
X $start = 1 if ($start > $max);
X last if ($start == $end);
X if ($dbline[$start] =~ m'."\n$pat\n".'i) {
X if ($emacs) {
X print OUT "\032\032$filename:$start:0\n";
X } else {
X print OUT "$start:\t", $dbline[$start], "\n";
X }
X last;
X }
X } ';
X print OUT "/$pat/: not found\n" if ($start == $end);
X next; };
X $cmd =~ /^\?(.*)$/ && do {
X $inpat = $1;
X $inpat =~ s:([^\\])\?$:$1:;
X if ($inpat ne "") {
X eval '$inpat =~ m'."\n$inpat\n";
X if ($@ ne "") {
X print OUT "$@";
X next;
X }
X $pat = $inpat;
X }
X $end = $start;
X eval '
X for (;;) {
X --$start;
X $start = $max if ($start <= 0);
X last if ($start == $end);
X if ($dbline[$start] =~ m'."\n$pat\n".'i) {
X if ($emacs) {
X print OUT "\032\032$filename:$start:0\n";
X } else {
X print OUT "$start:\t", $dbline[$start], "\n";
X }
X last;
X }
X } ';
X print OUT "?$pat?: not found\n" if ($start == $end);
X next; };
X $cmd =~ /^!+\s*(-)?(\d+)?$/ && do {
X pop(@hist) if length($cmd) > 1;
X $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist));
X $cmd = $hist[$i] . "\n";
X print OUT $cmd;
X redo; };
X $cmd =~ /^!(.+)$/ && do {
X $pat = "^$1";
X pop(@hist) if length($cmd) > 1;
X for ($i = $#hist; $i; --$i) {
X last if $hist[$i] =~ $pat;
X }
X if (!$i) {
X print OUT "No such command!\n\n";
X next;
X }
X $cmd = $hist[$i] . "\n";
X print OUT $cmd;
X redo; };
X $cmd =~ /^H\s*(-(\d+))?/ && do {
X $end = $2?($#hist-$2):0;
X $hist = 0 if $hist < 0;
X for ($i=$#hist; $i>$end; $i--) {
X print OUT "$i: ",$hist[$i],"\n"
X unless $hist[$i] =~ /^.?$/;
X };
X next; };
X $cmd =~ s/^p( .*)?$/print DB'OUT$1/;
X $cmd =~ /^=/ && do {
X if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
X $alias{$k}="s~$k~$v~";
X print OUT "$k = $v\n";
X } elsif ($cmd =~ /^=\s*$/) {
X foreach $k (sort keys(%alias)) {
X if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
X print OUT "$k = $v\n";
X } else {
X print OUT "$k\t$alias{$k}\n";
X };
X };
X };
X next; };
X $evalarg = $cmd; &eval;
X print OUT "\n";
X }
X if ($post) {
X $evalarg = $post; &eval;
X }
X }
X ($@, $!, $[, $,, $/, $\) = @saved;
X}
X
Xsub save {
X @saved = ($@, $!, $[, $,, $/, $\);
X $[ = 0; $, = ""; $/ = "\n"; $\ = "";
X}
X
X# The following takes its argument via $evalarg to preserve current @_
X
Xsub eval {
X eval "$usercontext $evalarg; &DB'save";
X print OUT $@;
X}
X
Xsub action {
X local($action) = @_;
X while ($action =~ s/\\$//) {
X print OUT "+ ";
X $action .= &gets;
X }
X $action;
X}
X
Xsub gets {
X local($.);
X <IN>;
X}
X
Xsub catch {
X $signal = 1;
X}
X
Xsub sub {
X push(@stack, $single);
X $single &= 1;
X $single |= 4 if $#stack == $deep;
X if (wantarray) {
X @i = &$sub;
X $single |= pop(@stack);
X @i;
X }
X else {
X $i = &$sub;
X $single |= pop(@stack);
X $i;
X }
X}
X
X$single = 1; # so it stops on first executable statement
X@hist = ('?');
X$SIG{'INT'} = "DB'catch";
X$deep = 100; # warning if stack gets this deep
X$window = 10;
X$preview = 3;
X
X@stack = (0);
X@ARGS = @ARGV;
Xfor (@args) {
X s/'/\\'/g;
X s/(.*)/'$1'/ unless /^-?[\d.]+$/;
X}
X
Xif (-f '.perldb') {
X do './.perldb';
X}
Xelsif (-f "$ENV{'LOGDIR'}/.perldb") {
X do "$ENV{'LOGDIR'}/.perldb";
X}
Xelsif (-f "$ENV{'HOME'}/.perldb") {
X do "$ENV{'HOME'}/.perldb";
X}
X
X1;
!STUFFY!FUNK!
echo Extracting perlsh
sed >perlsh <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl
X
X# Poor man's perl shell.
X
X# Simply type two carriage returns every time you want to evaluate.
X# Note that it must be a complete perl statement--don't type double
X# carriage return in the middle of a loop.
X
X$/ = ''; # set paragraph mode
X$SHlinesep = "\n";
Xwhile ($SHcmd = <>) {
X $/ = $SHlinesep;
X eval $SHcmd; print $@ || "\n";
X $SHlinesep = $/; $/ = '';
X}
!STUFFY!FUNK!
echo " "
echo "End of kit 16 (of 36)"
cat /dev/null >kit16isdone
run=''
config=''
for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36; do
if test -f kit${iskit}isdone; then
run="$run $iskit"
else
todo="$todo $iskit"
fi
done
case $todo in
'')
echo "You have run all your kits. Please read README and then type Configure."
for combo in *:AA; do
if test -f "$combo"; then
realfile=`basename $combo :AA`
cat $realfile:[A-Z][A-Z] >$realfile
rm -rf $realfile:[A-Z][A-Z]
fi
done
rm -rf kit*isdone
chmod 755 Configure
;;
*) echo "You have run$run."
echo "You still need to run$todo."
;;
esac
: Someone might mail this, so...
exit
exit 0 # Just in case...
--
Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM
Sterling Software, IMD UUCP: uunet!sparky!kent
Phone: (402) 291-8300 FAX: (402) 291-4362
Please send comp.sources.misc-related mail to kent@uunet.uu.net.