perl 3.0 beta kit [17/23]
Larry Wall
lwall at jato.Jpl.Nasa.Gov
Mon Sep 4 05:00:13 AEST 1989
#! /bin/sh
# Make a new directory for the perl sources, cd to it, and run kits 1
# thru 23 through sh. When all 23 kits have been run, read README.
echo "This is perl 3.0 kit 17 (of 23). If kit 17 is complete, the line"
echo '"'"End of kit 17 (of 23)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir eg lib x2p 2>/dev/null
echo Extracting hash.c
sed >hash.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: hash.c,v 2.0 88/06/05 00:09:06 root Exp $
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: hash.c,v $
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X#include <errno.h>
X
Xextern int errno;
X
XSTR *
Xhfetch(tb,key,klen,lval)
Xregister HASH *tb;
Xchar *key;
Xint klen;
Xint lval;
X{
X register char *s;
X register int i;
X register int hash;
X register HENT *entry;
X register int maxi;
X STR *str;
X#ifdef SOME_DBM
X datum dkey,dcontent;
X#endif
X
X if (!tb)
X return Nullstr;
X
X /* The hash function we use on symbols has to be equal to the first
X * character when taken modulo 128, so that str_reset() can be implemented
X * efficiently. We throw in the second character and the last character
X * (times 128) so that long chains of identifiers starting with the
X * same letter don't have to be strEQ'ed within hfetch(), since it
X * compares hash values before trying strEQ().
X */
X if (!tb->tbl_coeffsize)
X hash = *key + 128 * key[1] + 128 * key[klen-1]; /* assuming klen > 0 */
X else { /* use normal coefficients */
X if (klen < tb->tbl_coeffsize)
X maxi = klen;
X else
X maxi = tb->tbl_coeffsize;
X for (s=key, i=0, hash = 0;
X i < maxi;
X s++, i++, hash *= 5) {
X hash += *s * coeff[i];
X }
X }
X
X entry = tb->tbl_array[hash & tb->tbl_max];
X for (; entry; entry = entry->hent_next) {
X if (entry->hent_hash != hash) /* strings can't be equal */
X continue;
X if (entry->hent_klen != klen)
X continue;
X if (bcmp(entry->hent_key,key,klen)) /* is this it? */
X continue;
X return entry->hent_val;
X }
X#ifdef SOME_DBM
X if (tb->tbl_dbm) {
X dkey.dptr = key;
X dkey.dsize = klen;
X dcontent = dbm_fetch(tb->tbl_dbm,dkey);
X if (dcontent.dptr) { /* found one */
X str = str_new(dcontent.dsize);
X str_nset(str,dcontent.dptr,dcontent.dsize);
X hstore(tb,key,klen,str,hash); /* cache it */
X return str;
X }
X }
X#endif
X if (lval) { /* gonna assign to this, so it better be there */
X str = str_new(0);
X hstore(tb,key,klen,str,hash);
X return str;
X }
X return Nullstr;
X}
X
Xbool
Xhstore(tb,key,klen,val,hash)
Xregister HASH *tb;
Xchar *key;
Xint klen;
XSTR *val;
Xregister int hash;
X{
X register char *s;
X register int i;
X register HENT *entry;
X register HENT **oentry;
X register int maxi;
X
X if (!tb)
X return FALSE;
X
X if (hash)
X ;
X else if (!tb->tbl_coeffsize)
X hash = *key + 128 * key[1] + 128 * key[klen-1];
X else { /* use normal coefficients */
X if (klen < tb->tbl_coeffsize)
X maxi = klen;
X else
X maxi = tb->tbl_coeffsize;
X for (s=key, i=0, hash = 0;
X i < maxi;
X s++, i++, hash *= 5) {
X hash += *s * coeff[i];
X }
X }
X
X oentry = &(tb->tbl_array[hash & tb->tbl_max]);
X i = 1;
X
X for (entry = *oentry; entry; i=0, entry = entry->hent_next) {
X if (entry->hent_hash != hash) /* strings can't be equal */
X continue;
X if (entry->hent_klen != klen)
X continue;
X if (bcmp(entry->hent_key,key,klen)) /* is this it? */
X continue;
X Safefree(entry->hent_val);
X entry->hent_val = val;
X return TRUE;
X }
X New(501,entry, 1, HENT);
X
X entry->hent_klen = klen;
X entry->hent_key = nsavestr(key,klen);
X entry->hent_val = val;
X entry->hent_hash = hash;
X entry->hent_next = *oentry;
X *oentry = entry;
X
X /* hdbmstore not necessary here because it's called from stabset() */
X
X if (i) { /* initial entry? */
X tb->tbl_fill++;
X#ifdef SOME_DBM
X if (tb->tbl_dbm && tb->tbl_max >= DBM_CACHE_MAX)
X return FALSE;
X#endif
X if (tb->tbl_fill > tb->tbl_dosplit)
X hsplit(tb);
X }
X#ifdef SOME_DBM
X else if (tb->tbl_dbm) { /* is this just a cache for dbm file? */
X entry = tb->tbl_array[hash & tb->tbl_max];
X oentry = &entry->hent_next;
X entry = *oentry;
X while (entry) { /* trim chain down to 1 entry */
X *oentry = entry->hent_next;
X hentfree(entry); /* no doubt they'll want this next. */
X entry = *oentry;
X }
X }
X#endif
X
X return FALSE;
X}
X
XSTR *
Xhdelete(tb,key,klen)
Xregister HASH *tb;
Xchar *key;
Xint klen;
X{
X register char *s;
X register int i;
X register int hash;
X register HENT *entry;
X register HENT **oentry;
X STR *str;
X int maxi;
X#ifdef SOME_DBM
X datum dkey;
X#endif
X
X if (!tb)
X return Nullstr;
X if (!tb->tbl_coeffsize)
X hash = *key + 128 * key[1] + 128 * key[klen-1];
X else { /* use normal coefficients */
X if (klen < tb->tbl_coeffsize)
X maxi = klen;
X else
X maxi = tb->tbl_coeffsize;
X for (s=key, i=0, hash = 0;
X i < maxi;
X s++, i++, hash *= 5) {
X hash += *s * coeff[i];
X }
X }
X
X oentry = &(tb->tbl_array[hash & tb->tbl_max]);
X entry = *oentry;
X i = 1;
X for (; entry; i=0, oentry = &entry->hent_next, entry = *oentry) {
X if (entry->hent_hash != hash) /* strings can't be equal */
X continue;
X if (entry->hent_klen != klen)
X continue;
X if (bcmp(entry->hent_key,key,klen)) /* is this it? */
X continue;
X *oentry = entry->hent_next;
X str = str_static(entry->hent_val);
X hentfree(entry);
X if (i)
X tb->tbl_fill--;
X#ifdef SOME_DBM
X do_dbm_delete:
X if (tb->tbl_dbm) {
X dkey.dptr = key;
X dkey.dsize = klen;
X dbm_delete(tb->tbl_dbm,dkey);
X }
X#endif
X return str;
X }
X#ifdef SOME_DBM
X str = Nullstr;
X goto do_dbm_delete;
X#else
X return Nullstr;
X#endif
X}
X
Xhsplit(tb)
XHASH *tb;
X{
X int oldsize = tb->tbl_max + 1;
X register int newsize = oldsize * 2;
X register int i;
X register HENT **a;
X register HENT **b;
X register HENT *entry;
X register HENT **oentry;
X
X a = tb->tbl_array;
X Renew(a, newsize, HENT*);
X Zero(&a[oldsize], oldsize, HENT*); /* zero 2nd half*/
X tb->tbl_max = --newsize;
X tb->tbl_dosplit = tb->tbl_max * FILLPCT / 100;
X tb->tbl_array = a;
X
X for (i=0; i<oldsize; i++,a++) {
X if (!*a) /* non-existent */
X continue;
X b = a+oldsize;
X for (oentry = a, entry = *a; entry; entry = *oentry) {
X if ((entry->hent_hash & newsize) != i) {
X *oentry = entry->hent_next;
X entry->hent_next = *b;
X if (!*b)
X tb->tbl_fill++;
X *b = entry;
X continue;
X }
X else
X oentry = &entry->hent_next;
X }
X if (!*a) /* everything moved */
X tb->tbl_fill--;
X }
X}
X
XHASH *
Xhnew(lookat)
Xunsigned int lookat;
X{
X register HASH *tb;
X
X Newz(502,tb, 1, HASH);
X if (lookat) {
X tb->tbl_coeffsize = lookat;
X tb->tbl_max = 7; /* it's a normal associative array */
X tb->tbl_dosplit = tb->tbl_max * FILLPCT / 100;
X }
X else {
X tb->tbl_max = 127; /* it's a symbol table */
X tb->tbl_dosplit = 128; /* so never split */
X }
X Newz(503,tb->tbl_array, tb->tbl_max + 1, HENT*);
X tb->tbl_fill = 0;
X#ifdef SOME_DBM
X tb->tbl_dbm = 0;
X#endif
X (void)hiterinit(tb); /* so each() will start off right */
X return tb;
X}
X
Xvoid
Xhentfree(hent)
Xregister HENT *hent;
X{
X if (!hent)
X return;
X str_free(hent->hent_val);
X Safefree(hent->hent_key);
X Safefree(hent);
X}
X
Xvoid
Xhclear(tb)
Xregister HASH *tb;
X{
X register HENT *hent;
X register HENT *ohent = Null(HENT*);
X
X if (!tb)
X return;
X (void)hiterinit(tb);
X while (hent = hiternext(tb)) { /* concise but not very efficient */
X hentfree(ohent);
X ohent = hent;
X }
X hentfree(ohent);
X tb->tbl_fill = 0;
X#ifndef lint
X (void)bzero((char*)tb->tbl_array, (tb->tbl_max + 1) * sizeof(HENT*));
X#endif
X}
X
Xvoid
Xhfree(tb)
Xregister HASH *tb;
X{
X register HENT *hent;
X register HENT *ohent = Null(HENT*);
X
X if (!tb)
X return;
X (void)hiterinit(tb);
X while (hent = hiternext(tb)) {
X hentfree(ohent);
X ohent = hent;
X }
X hentfree(ohent);
X Safefree(tb->tbl_array);
X Safefree(tb);
X}
X
Xint
Xhiterinit(tb)
Xregister HASH *tb;
X{
X tb->tbl_riter = -1;
X tb->tbl_eiter = Null(HENT*);
X return tb->tbl_fill;
X}
X
XHENT *
Xhiternext(tb)
Xregister HASH *tb;
X{
X register HENT *entry;
X#ifdef SOME_DBM
X datum key;
X#endif
X
X entry = tb->tbl_eiter;
X#ifdef SOME_DBM
X if (tb->tbl_dbm) {
X if (entry) {
X#ifdef NDBM
X key = dbm_nextkey(tb->tbl_dbm);
X#else
X key.dptr = entry->hent_key;
X key.dsize = entry->hent_klen;
X key = nextkey(key);
X#endif
X }
X else {
X Newz(504,entry, 1, HENT);
X tb->tbl_eiter = entry;
X key = dbm_firstkey(tb->tbl_dbm);
X }
X entry->hent_key = key.dptr;
X entry->hent_klen = key.dsize;
X if (!key.dptr) {
X if (entry->hent_val)
X str_free(entry->hent_val);
X Safefree(entry);
X tb->tbl_eiter = Null(HENT*);
X return Null(HENT*);
X }
X return entry;
X }
X#endif
X do {
X if (entry)
X entry = entry->hent_next;
X if (!entry) {
X tb->tbl_riter++;
X if (tb->tbl_riter > tb->tbl_max) {
X tb->tbl_riter = -1;
X break;
X }
X entry = tb->tbl_array[tb->tbl_riter];
X }
X } while (!entry);
X
X tb->tbl_eiter = entry;
X return entry;
X}
X
Xchar *
Xhiterkey(entry,retlen)
Xregister HENT *entry;
Xint *retlen;
X{
X *retlen = entry->hent_klen;
X return entry->hent_key;
X}
X
XSTR *
Xhiterval(tb,entry)
Xregister HASH *tb;
Xregister HENT *entry;
X{
X#ifdef SOME_DBM
X datum key, content;
X
X if (tb->tbl_dbm) {
X key.dptr = entry->hent_key;
X key.dsize = entry->hent_klen;
X content = dbm_fetch(tb->tbl_dbm,key);
X if (!entry->hent_val)
X entry->hent_val = str_new(0);
X str_nset(entry->hent_val,content.dptr,content.dsize);
X }
X#endif
X return entry->hent_val;
X}
X
X#ifdef SOME_DBM
X#if defined(FCNTL) && ! defined(O_CREAT)
X#include <fcntl.h>
X#endif
X
X#ifndef O_RDONLY
X#define O_RDONLY 0
X#endif
X#ifndef O_RDWR
X#define O_RDWR 2
X#endif
X#ifndef O_CREAT
X#define O_CREAT 01000
X#endif
X
X#ifndef NDBM
Xstatic int dbmrefcnt = 0;
X#endif
X
Xbool
Xhdbmopen(tb,fname,mode)
Xregister HASH *tb;
Xchar *fname;
Xint mode;
X{
X if (!tb)
X return FALSE;
X#ifndef NDBM
X if (tb->tbl_dbm) /* never really closed it */
X return TRUE;
X#endif
X if (tb->tbl_dbm)
X hdbmclose(tb);
X hclear(tb);
X#ifdef NDBM
X tb->tbl_dbm = dbm_open(fname, O_RDWR|O_CREAT, mode);
X if (!tb->tbl_dbm) /* oops, just try reading it */
X tb->tbl_dbm = dbm_open(fname, O_RDONLY, mode);
X#else
X if (dbmrefcnt++)
X fatal("Old dbm can only open one database");
X sprintf(buf,"%s.dir",fname);
X if (stat(buf) < 0) {
X if (creat(buf,mode) < 0)
X return FALSE;
X sprintf(buf,"%s.pag",fname);
X if (creat(buf,mode) < 0)
X return FALSE;
X }
X tb->tbl_dbm = dbminit(fname) >= 0;
X#endif
X return tb->tbl_dbm != 0;
X}
X
Xvoid
Xhdbmclose(tb)
Xregister HASH *tb;
X{
X if (tb && tb->tbl_dbm) {
X#ifdef NDBM
X dbm_close(tb->tbl_dbm);
X tb->tbl_dbm = 0;
X#else
X /* dbmrefcnt--; */ /* doesn't work, rats */
X#endif
X }
X else if (dowarn)
X warn("Close on unopened dbm file");
X}
X
Xbool
Xhdbmstore(tb,key,klen,str)
Xregister HASH *tb;
Xchar *key;
Xint klen;
Xregister STR *str;
X{
X datum dkey, dcontent;
X int error;
X
X if (!tb || !tb->tbl_dbm)
X return FALSE;
X dkey.dptr = key;
X dkey.dsize = klen;
X dcontent.dptr = str_get(str);
X dcontent.dsize = str->str_cur;
X error = dbm_store(tb->tbl_dbm, dkey, dcontent, DBM_REPLACE);
X if (error) {
X if (errno == EPERM)
X fatal("No write permission to dbm file");
X warn("dbm store returned %d, errno %d, key \"%s\"",error,errno,key);
X#ifdef NDBM
X dbm_clearerr(tb->tbl_dbm);
X#endif
X }
X return !error;
X}
X#endif /* SOME_DBM */
!STUFFY!FUNK!
echo Extracting lib/perldb.pl
sed >lib/perldb.pl <<'!STUFFY!FUNK!' -e 's/X//'
Xpackage DB;
X
X$header = '$Header: perldb,v 2.0 88/06/05 00:09:45 root Exp $';
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,v $
X# Revision 2.0 88/06/05 00:09:45 root
X# Baseline version 2.0.
X#
X#
X
X$| = 1;
X$header =~ s/\$Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
Xprint "\nLoading DB from $header\n\n";
X
Xsub DB {
X local($. ,$@, $!, $[, $,, $/, $\);
X $[ = 0; $, = ""; $/ = "\n"; $\ = "";
X ($line) = @_;
X if ($stop[$line]) {
X if ($stop eq '1') {
X $signal |= 1;
X }
X else {
X package main;
X $DB'signal |= eval $DB'stop[$DB'line]; print DB'OUT $@;
X $DB'stop[$DB'line] =~ s/;9$//;
X }
X }
X if ($single || $trace || $signal) {
X print OUT "$sub($line):\t",$line[$line];
X for ($i = $line + 1; $i <= $max && $line[$i] == 0; ++$i) {
X last if $line[$i] =~ /^\s*(}|#|\n)/;
X print OUT "$sub($i):\t",$line[$i];
X }
X }
X if ($action[$line]) {
X package main;
X eval $DB'action[$DB'line]; print DB'OUT $@;
X }
X if ($single || $signal) {
X if ($pre) {
X package main;
X eval $DB'pre; print DB'OUT $@;
X }
X print $#stack . " levels deep in subroutine calls!\n"
X if $single & 4;
X $start = $line;
X while ((print OUT " DB<", $#hist+1, "> "), $cmd=<IN>) {
X $single = 0;
X $signal = 0;
X $cmd eq '' && exit 0;
X chop($cmd);
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.
Xf Finish 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.
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 evaluate 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 package List all variables and values in package (default main).
X< command Define command before prompt.
X> command Define command after prompt.
X! number Redo command (default previous command).
X! -number Redo numberth to last command.
XH -number Display last number commands (default all).
Xq or ^D Quit.
Xp expr Same as \"package main; print DB'OUT expr\".
Xcommand Execute as a perl statement.
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 if ($subname =~ /^main'(.*)/) {
X print $1,"\n";
X }
X else {
X print $subname,"\n";
X }
X }
X next; };
X $cmd =~ /^V$/ && do {
X $cmd = 'V main'; };
X $cmd =~ /^V\s*(['A-Za-z_]['\w]*)$/ && do {
X $packname = $1;
X do 'dumpvar.pl' unless defined &main'dumpvar;
X if (defined &main'dumpvar) {
X &main'dumpvar($packname);
X }
X else {
X print DB'OUT "dumpvar.pl not available.\n";
X }
X next; };
X $cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do {
X $subname = $1;
X $subname = "main'" . $subname unless $subname =~ /'/;
X $subrange = $sub{$subname};
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 for (; $i <= $end; $i++) {
X print OUT "$i:\t", $line[$i];
X last if $signal;
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 $stop[$i] = 0;
X }
X next; };
X $cmd =~ /^L$/ && do {
X for ($i = 1; $i <= $max; $i++) {
X if ($stop[$i] || $action[$i]) {
X print "$i:\t", $line[$i];
X print " break if (", $stop[$i], ")\n"
X if $stop[$i];
X print " action: ", $action[$i], "\n"
X if $action[$i];
X last if $signal;
X }
X }
X next; };
X $cmd =~ /^b\s*(['A-Za-z_]['A-Za-z_\d]*)\s*(.*)/ && do {
X $subname = $1;
X $subname = "main'" . $subname unless $subname =~ /'/;
X $i = $sub{$subname} + 0;
X if ($i) {
X ++$i while $line[$i] == 0 && $i < $#line;
X $stop[$i] = $2 ? $2 : 1;
X } else {
X print OUT "Subroutine $1 not found.\n";
X }
X next; };
X $cmd =~ /^b\s*(\d*)\s*(.*)/ && do {
X $i = ($1?$1:$line);
X if ($line[$i] == 0) {
X print OUT "Line $i not breakable.\n";
X } else {
X $stop[$i] = $2 ? $2 : 1;
X }
X next; };
X $cmd =~ /^d\s*(\d+)?/ && do {
X $i = ($1?$1:$line);
X $stop[$i] = '';
X next; };
X $cmd =~ /^A$/ && do {
X for ($i = 1; $i <= $max ; $i++) {
X $action[$i] = '';
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 ($line[$i] == 0) {
X print OUT "Line $i may not have an action.\n";
X } else {
X $action[$i] = 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 ($line[$i] == 0) {
X print "Line $i not breakable.\n";
X next;
X }
X $stop[$i] .= ";9"; # add one-time-only b.p.
X }
X for ($i=0; $i <= $#stack; ) {
X $stack[$i++] &= ~1;
X }
X last; };
X $cmd =~ /^f$/ && do {
X $stack[$#stack] |= 2;
X last; };
X $cmd =~ /^T$/ && do {
X for ($i=0; $i <= $#sub; ) {
X print $sub[$i++], "\n";
X last if $signal;
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 ($line[$start] =~ m'."\n$pat\n".'i) {
X print "$start:\t", $line[$start], "\n";
X last;
X }
X } ';
X print "/$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 ($line[$start] =~ m'."\n$pat\n".'i) {
X print "$start:\t", $line[$start], "\n";
X last;
X }
X } ';
X print "?$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 /;
X {
X package main;
X eval $DB'cmd;
X }
X print OUT $@,"\n";
X }
X if ($post) {
X package main;
X eval $DB'post; print DB'OUT $@;
X }
X }
X}
X
Xsub action {
X local($action) = @_;
X while ($action =~ s/\\\\$//) {
X print OUT "+ ";
X $action .= <IN>;
X }
X $action;
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 local(@args) = @_;
X for (@args) {
X s/'/\\'/g;
X s/(.*)/'$1'/ unless /^-?[\d.]+$/;
X }
X push(@sub, $sub . '(' . join(', ', @args) . ") from $line" );
X $i = do $sub(@_);
X pop(@sub);
X $single = pop(@stack);
X $i;
X}
X
X$single = 1; # so it stops on first executable statement
Xopen(IN,"/dev/tty"); # so we don't dingle stdin
Xopen(OUT,">/dev/tty"); # so we don't dongle stdout
Xselect(OUT);
X$| = 1;
Xselect(STDOUT);
X$max = $#line;
X at hist = ('?');
X$SIG{'INT'} = "DB'catch";
X$deep = 100; # warning if stack gets this deep
X$window = 10;
X$preview = 3;
X
X at stack = (0);
X at args = @ARGV;
Xfor (@args) {
X s/'/\\'/g;
X s/(.*)/'$1'/ unless /^-?[\d.]+$/;
X}
Xpush(@sub, 'main(' . join(', ', @args) . ")" );
X$sub = 'main';
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 x2p/a2p.y
sed >x2p/a2p.y <<'!STUFFY!FUNK!' -e 's/X//'
X%{
X/* $Header: a2p.y,v 2.0.1.3 88/08/05 01:30:15 root Exp $
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: a2p.y,v $
X * Revision 2.0.1.3 88/08/05 01:30:15 root
X * patch13: a2p was treating strings and numbers as variables
X *
X * Revision 2.0.1.2 88/08/03 22:49:27 root
X * patch11: in a2p, newlines weren't allowed following comma
X *
X * Revision 2.0.1.1 88/07/11 23:20:14 root
X * patch2: changes to support translation of 1985 awk
X *
X * Revision 2.0 88/06/05 00:15:38 root
X * Baseline version 2.0.
X *
X */
X
X#include "INTERN.h"
X#include "a2p.h"
X
Xint root;
Xint begins = Nullop;
Xint ends = Nullop;
X
X%}
X%token BEGIN END
X%token REGEX
X%token SEMINEW NEWLINE COMMENT
X%token FUN1 FUNN GRGR
X%token PRINT PRINTF SPRINTF SPLIT
X%token IF ELSE WHILE FOR IN
X%token EXIT NEXT BREAK CONTINUE RET
X%token GETLINE DO SUB GSUB MATCH
X%token FUNCTION USERFUN DELETE
X
X%right ASGNOP
X%right '?' ':'
X%left OROR
X%left ANDAND
X%left IN
X%left NUMBER VAR SUBSTR INDEX
X%left MATCHOP
X%left RELOP '<' '>'
X%left OR
X%left STRING
X%left '+' '-'
X%left '*' '/' '%'
X%right UMINUS
X%left NOT
X%right '^'
X%left INCR DECR
X%left FIELD VFIELD
X
X%%
X
Xprogram : junk hunks
X { root = oper4(OPROG,$1,begins,$2,ends); }
X ;
X
Xbegin : BEGIN '{' maybe states '}' junk
X { begins = oper4(OJUNK,begins,$3,$4,$6); in_begin = FALSE;
X $$ = Nullop; }
X ;
X
Xend : END '{' maybe states '}'
X { ends = oper3(OJUNK,ends,$3,$4); $$ = Nullop; }
X | end NEWLINE
X { $$ = $1; }
X ;
X
Xhunks : hunks hunk junk
X { $$ = oper3(OHUNKS,$1,$2,$3); }
X | /* NULL */
X { $$ = Nullop; }
X ;
X
Xhunk : patpat
X { $$ = oper1(OHUNK,$1); need_entire = TRUE; }
X | patpat '{' maybe states '}'
X { $$ = oper2(OHUNK,$1,oper2(OJUNK,$3,$4)); }
X | FUNCTION USERFUN '(' arg_list ')' maybe '{' maybe states '}'
X { fixfargs($2,$4,0); $$ = oper5(OUSERDEF,$2,$4,$6,$8,$9); }
X | '{' maybe states '}'
X { $$ = oper2(OHUNK,Nullop,oper2(OJUNK,$2,$3)); }
X | begin
X | end
X ;
X
Xarg_list: expr_list
X { $$ = rememberargs($$); }
X ;
X
Xpatpat : pat
X { $$ = oper1(OPAT,$1); }
X | pat ',' pat
X { $$ = oper2(ORANGE,$1,$3); }
X ;
X
Xpat : match
X | rel
X | compound_pat
X ;
X
Xcompound_pat
X : '(' compound_pat ')'
X { $$ = oper1(OPPAREN,$2); }
X | pat ANDAND maybe pat
X { $$ = oper3(OPANDAND,$1,$3,$4); }
X | pat OROR maybe pat
X { $$ = oper3(OPOROR,$1,$3,$4); }
X | NOT pat
X { $$ = oper1(OPNOT,$2); }
X ;
X
Xcond : expr
X | match
X | rel
X | compound_cond
X ;
X
Xcompound_cond
X : '(' compound_cond ')'
X { $$ = oper1(OCPAREN,$2); }
X | cond ANDAND maybe cond
X { $$ = oper3(OCANDAND,$1,$3,$4); }
X | cond OROR maybe cond
X { $$ = oper3(OCOROR,$1,$3,$4); }
X | NOT cond
X { $$ = oper1(OCNOT,$2); }
X ;
X
Xrel : expr RELOP expr
X { $$ = oper3(ORELOP,$2,$1,$3); }
X | expr '>' expr
X { $$ = oper3(ORELOP,string(">",1),$1,$3); }
X | expr '<' expr
X { $$ = oper3(ORELOP,string("<",1),$1,$3); }
X | '(' rel ')'
X { $$ = oper1(ORPAREN,$2); }
X ;
X
Xmatch : expr MATCHOP expr
X { $$ = oper3(OMATCHOP,$2,$1,$3); }
X | expr MATCHOP REGEX
X { $$ = oper3(OMATCHOP,$2,$1,oper1(OREGEX,$3)); }
X | REGEX %prec MATCHOP
X { $$ = oper1(OREGEX,$1); }
X | '(' match ')'
X { $$ = oper1(OMPAREN,$2); }
X ;
X
Xexpr : term
X { $$ = $1; }
X | expr term
X { $$ = oper2(OCONCAT,$1,$2); }
X | variable ASGNOP expr
X { $$ = oper3(OASSIGN,$2,$1,$3);
X if ((ops[$1].ival & 255) == OFLD)
X lval_field = TRUE;
X if ((ops[$1].ival & 255) == OVFLD)
X lval_field = TRUE;
X }
X ;
X
Xterm : variable
X { $$ = $1; }
X | NUMBER
X { $$ = oper1(ONUM,$1); }
X | STRING
X { $$ = oper1(OSTR,$1); }
X | term '+' term
X { $$ = oper2(OADD,$1,$3); }
X | term '-' term
X { $$ = oper2(OSUBTRACT,$1,$3); }
X | term '*' term
X { $$ = oper2(OMULT,$1,$3); }
X | term '/' term
X { $$ = oper2(ODIV,$1,$3); }
X | term '%' term
X { $$ = oper2(OMOD,$1,$3); }
X | term '^' term
X { $$ = oper2(OPOW,$1,$3); }
X | term IN VAR
X { $$ = oper2(ODEFINED,aryrefarg($3),$1); }
X | term '?' term ':' term
X { $$ = oper2(OCOND,$1,$3,$5); }
X | variable INCR
X { $$ = oper1(OPOSTINCR,$1); }
X | variable DECR
X { $$ = oper1(OPOSTDECR,$1); }
X | INCR variable
X { $$ = oper1(OPREINCR,$2); }
X | DECR variable
X { $$ = oper1(OPREDECR,$2); }
X | '-' term %prec UMINUS
X { $$ = oper1(OUMINUS,$2); }
X | '+' term %prec UMINUS
X { $$ = oper1(OUPLUS,$2); }
X | '(' expr ')'
X { $$ = oper1(OPAREN,$2); }
X | GETLINE
X { $$ = oper0(OGETLINE); }
X | GETLINE VAR
X { $$ = oper1(OGETLINE,$2); }
X | GETLINE '<' expr
X { $$ = oper3(OGETLINE,Nullop,string("<",1),$3);
X if (ops[$3].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
X | GETLINE VAR '<' expr
X { $$ = oper3(OGETLINE,$2,string("<",1),$4);
X if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
X | term 'p' GETLINE
X { $$ = oper3(OGETLINE,Nullop,string("|",1),$1);
X if (ops[$1].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
X | term 'p' GETLINE VAR
X { $$ = oper3(OGETLINE,$4,string("|",1),$1);
X if (ops[$1].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
X | FUN1
X { $$ = oper0($1); need_entire = do_chop = TRUE; }
X | FUN1 '(' ')'
X { $$ = oper1($1,Nullop); need_entire = do_chop = TRUE; }
X | FUN1 '(' expr ')'
X { $$ = oper1($1,$3); }
X | FUNN '(' expr_list ')'
X { $$ = oper1($1,$3); }
X | USERFUN '(' expr_list ')'
X { $$ = oper2(OUSERFUN,$1,$3); }
X | SPRINTF expr_list
X { $$ = oper1(OSPRINTF,$2); }
X | SUBSTR '(' expr ',' expr ',' expr ')'
X { $$ = oper3(OSUBSTR,$3,$5,$7); }
X | SUBSTR '(' expr ',' expr ')'
X { $$ = oper2(OSUBSTR,$3,$5); }
X | SPLIT '(' expr ',' VAR ',' expr ')'
X { $$ = oper3(OSPLIT,$3,aryrefarg(numary($5)),$7); }
X | SPLIT '(' expr ',' VAR ')'
X { $$ = oper2(OSPLIT,$3,aryrefarg(numary($5))); }
X | INDEX '(' expr ',' expr ')'
X { $$ = oper2(OINDEX,$3,$5); }
X | MATCH '(' expr ',' REGEX ')'
X { $$ = oper2(OMATCH,$3,oper1(OREGEX,$5)); }
X | MATCH '(' expr ',' expr ')'
X { $$ = oper2(OMATCH,$3,$5); }
X | SUB '(' expr ',' expr ')'
X { $$ = oper2(OSUB,$3,$5); }
X | SUB '(' REGEX ',' expr ')'
X { $$ = oper2(OSUB,oper1(OREGEX,$3),$5); }
X | GSUB '(' expr ',' expr ')'
X { $$ = oper2(OGSUB,$3,$5); }
X | GSUB '(' REGEX ',' expr ')'
X { $$ = oper2(OGSUB,oper1(OREGEX,$3),$5); }
X | SUB '(' expr ',' expr ',' expr ')'
X { $$ = oper3(OSUB,$3,$5,$7); }
X | SUB '(' REGEX ',' expr ',' expr ')'
X { $$ = oper3(OSUB,oper1(OREGEX,$3),$5,$7); }
X | GSUB '(' expr ',' expr ',' expr ')'
X { $$ = oper3(OGSUB,$3,$5,$7); }
X | GSUB '(' REGEX ',' expr ',' expr ')'
X { $$ = oper3(OGSUB,oper1(OREGEX,$3),$5,$7); }
X ;
X
Xvariable: VAR
X { $$ = oper1(OVAR,$1); }
X | VAR '[' expr_list ']'
X { $$ = oper2(OVAR,aryrefarg($1),$3); }
X | FIELD
X { $$ = oper1(OFLD,$1); }
X | VFIELD term
X { $$ = oper1(OVFLD,$2); }
X ;
X
Xexpr_list
X : expr
X | clist
X | /* NULL */
X { $$ = Nullop; }
X ;
X
Xclist : expr ',' maybe expr
X { $$ = oper3(OCOMMA,$1,$3,$4); }
X | clist ',' maybe expr
X { $$ = oper3(OCOMMA,$1,$3,$4); }
X | '(' clist ')' /* these parens are invisible */
X { $$ = $2; }
X ;
X
Xjunk : junk hunksep
X { $$ = oper2(OJUNK,$1,$2); }
X | /* NULL */
X { $$ = Nullop; }
X ;
X
Xhunksep : ';'
X { $$ = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); }
X | SEMINEW
X { $$ = oper2(OJUNK,oper0(OSEMICOLON),oper0(ONEWLINE)); }
X | NEWLINE
X { $$ = oper0(ONEWLINE); }
X | COMMENT
X { $$ = oper1(OCOMMENT,$1); }
X ;
X
Xmaybe : maybe nlstuff
X { $$ = oper2(OJUNK,$1,$2); }
X | /* NULL */
X { $$ = Nullop; }
X ;
X
Xnlstuff : NEWLINE
X { $$ = oper0(ONEWLINE); }
X | COMMENT
X { $$ = oper1(OCOMMENT,$1); }
X ;
X
Xseparator
X : ';' maybe
X { $$ = oper2(OJUNK,oper0(OSEMICOLON),$2); }
X | SEMINEW maybe
X { $$ = oper2(OJUNK,oper0(OSNEWLINE),$2); }
X | NEWLINE maybe
X { $$ = oper2(OJUNK,oper0(OSNEWLINE),$2); }
X | COMMENT maybe
X { $$ = oper2(OJUNK,oper1(OSCOMMENT,$1),$2); }
X ;
X
Xstates : states statement
X { $$ = oper2(OSTATES,$1,$2); }
X | /* NULL */
X { $$ = Nullop; }
X ;
X
Xstatement
X : simple separator maybe
X { $$ = oper2(OJUNK,oper2(OSTATE,$1,$2),$3); }
X | ';' maybe
X { $$ = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSEMICOLON),$2)); }
X | SEMINEW maybe
X { $$ = oper2(OSTATE,Nullop,oper2(OJUNK,oper0(OSNEWLINE),$2)); }
X | compound
X ;
X
Xsimpnull: simple
X | /* NULL */
X { $$ = Nullop; }
X ;
X
Xsimple
X : expr
X | PRINT expr_list redir expr
X { $$ = oper3(OPRINT,$2,$3,$4);
X do_opens = TRUE;
X saw_ORS = saw_OFS = TRUE;
X if (!$2) need_entire = TRUE;
X if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
X | PRINT expr_list
X { $$ = oper1(OPRINT,$2);
X if (!$2) need_entire = TRUE;
X saw_ORS = saw_OFS = TRUE;
X }
X | PRINTF expr_list redir expr
X { $$ = oper3(OPRINTF,$2,$3,$4);
X do_opens = TRUE;
X if (!$2) need_entire = TRUE;
X if (ops[$4].ival != OSTR + (1<<8)) do_fancy_opens = TRUE; }
X | PRINTF expr_list
X { $$ = oper1(OPRINTF,$2);
X if (!$2) need_entire = TRUE;
X }
X | BREAK
X { $$ = oper0(OBREAK); }
X | NEXT
X { $$ = oper0(ONEXT); }
X | EXIT
X { $$ = oper0(OEXIT); }
X | EXIT expr
X { $$ = oper1(OEXIT,$2); }
X | CONTINUE
X { $$ = oper0(OCONTINUE); }
X | RET
X { $$ = oper0(ORETURN); }
X | RET expr
X { $$ = oper1(ORETURN,$2); }
X | DELETE VAR '[' expr ']'
X { $$ = oper2(ODELETE,aryrefarg($2),$4); }
X ;
X
Xredir : '>' %prec FIELD
X { $$ = oper1(OREDIR,$1); }
X | GRGR
X { $$ = oper1(OREDIR,string(">>",2)); }
X | '|'
X { $$ = oper1(OREDIR,string("|",1)); }
X ;
X
Xcompound
X : IF '(' cond ')' maybe statement
X { $$ = oper2(OIF,$3,bl($6,$5)); }
X | IF '(' cond ')' maybe statement ELSE maybe statement
X { $$ = oper3(OIF,$3,bl($6,$5),bl($9,$8)); }
X | WHILE '(' cond ')' maybe statement
X { $$ = oper2(OWHILE,$3,bl($6,$5)); }
X | DO maybe statement WHILE '(' cond ')'
X { $$ = oper2(ODO,bl($3,$2),$6); }
X | FOR '(' simpnull ';' cond ';' simpnull ')' maybe statement
X { $$ = oper4(OFOR,$3,$5,$7,bl($10,$9)); }
X | FOR '(' simpnull ';' ';' simpnull ')' maybe statement
X { $$ = oper4(OFOR,$3,string("",0),$6,bl($9,$8)); }
X | FOR '(' expr ')' maybe statement
X { $$ = oper2(OFORIN,$3,bl($6,$5)); }
X | '{' maybe states '}' maybe
X { $$ = oper3(OBLOCK,oper2(OJUNK,$2,$3),Nullop,$5); }
X ;
X
X%%
X#include "a2py.c"
!STUFFY!FUNK!
echo Extracting perl.h
sed >perl.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: perl.h,v 2.0.1.5 88/11/18 23:58:38 lwall Locked $
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.h,v $
X */
X
X#ifndef lint
X#define DEBUGGING
X#endif
X
X#define VOIDUSED 1
X#include "config.h"
X
X#ifdef IAMSUID
X# ifndef TAINT
X# define TAINT
X# endif
X#endif
X
X#ifdef MEMCPY
Xextern char *memcpy(), *memset();
X#define bcopy(s1,s2,l) memcpy(s2,s1,l)
X#define bcmp(s1,s2,l) memcmp(s1,s2,l)
X#define bzero(s,l) memset(s,0,l)
X#endif
X
X#include <stdio.h>
X#include <ctype.h>
X#include <setjmp.h>
X#include <sys/param.h> /* if this needs types.h we're still wrong */
X
X#ifndef _TYPES_ /* If types.h defines this it's easy. */
X#ifndef major /* Does everyone's types.h define this? */
X#include <sys/types.h>
X#endif
X#endif
X
X#include <sys/stat.h>
X
X#ifdef TMINSYS
X#include <sys/time.h>
X#else
X#ifdef I_SYSTIME
X#include <sys/time.h>
X#else
X#include <time.h>
X#endif
X#endif
X
X#include <sys/times.h>
X
X#ifdef IOCTL
X#ifndef _IOCTL_
X#include <sys/ioctl.h>
X#endif
X#endif
X
X#ifdef NDBM
X#include <ndbm.h>
X#define SOME_DBM
X#else
X#ifdef ODBM
X#include <dbm.h>
X#define SOME_DBM
X#define dbm_fetch(db,dkey) fetch(dkey)
X#define dbm_delete(db,dkey) delete(dkey)
X#define dbm_store(db,dkey,dcontent,flags) store(dkey,dcontent)
X#define dbm_close(db) dbmclose()
X#define dbm_firstkey(db) firstkey()
X#endif /* ODBM */
X#endif /* NDBM */
X#ifdef SOME_DBM
XEXT char *dbmkey;
XEXT int dbmlen;
X#endif
X
X#if INTSIZE == 2
X#define htoni htons
X#define ntohi ntohs
X#else
X#define htoni htonl
X#define ntohi ntohl
X#endif
X
Xtypedef struct arg ARG;
Xtypedef struct cmd CMD;
Xtypedef struct formcmd FCMD;
Xtypedef struct scanpat SPAT;
Xtypedef struct stio STIO;
Xtypedef struct sub SUBR;
Xtypedef struct string STR;
Xtypedef struct atbl ARRAY;
Xtypedef struct htbl HASH;
Xtypedef struct regexp REGEXP;
Xtypedef struct stabptrs STBP;
Xtypedef struct stab STAB;
X
X#include "handy.h"
X#include "regexp.h"
X#include "str.h"
X#include "util.h"
X#include "form.h"
X#include "stab.h"
X#include "spat.h"
X#include "arg.h"
X#include "cmd.h"
X#include "array.h"
X#include "hash.h"
X
X#if defined(iAPX286) || defined(M_I286) || defined(I80286)
X# define I286
X#endif
X
X#ifdef CHARSPRINTF
X char *sprintf();
X#else
X int sprintf();
X#endif
X
XEXT char *Yes INIT("1");
XEXT char *No INIT("");
X
X/* "gimme" values */
X#define G_SCALAR 0
X#define G_ARRAY 1
X
X#define str_true(str) (Str = (str), \
X (Str->str_pok ? \
X ((*Str->str_ptr > '0' || \
X Str->str_cur > 1 || \
X (Str->str_cur && *Str->str_ptr != '0')) ? 1 : 0) \
X : \
X (Str->str_nok ? (Str->str_u.str_nval != 0.0) : 0 ) ))
X
X#ifdef DEBUGGING
X#define str_peek(str) (Str = (str), (Str->str_pok ? Str->str_ptr : (Str->str_nok ? (sprintf(tokenbuf,"num(%g)",Str->str_u.str_nval),(char*)tokenbuf) : "" )))
X#endif
X
X#ifdef CRIPPLED_CC
Xchar *str_get();
X#else
X#ifdef TAINT
X#define str_get(str) (Str = (str), tainted |= Str->str_tainted, \
X (Str->str_pok ? Str->str_ptr : str_2ptr(Str)))
X#else
X#define str_get(str) (Str = (str), (Str->str_pok ? Str->str_ptr : str_2ptr(Str)))
X#endif /* TAINT */
X#endif /* CRIPPLED_CC */
X
X#ifdef TAINT
X#define str_gnum(str) (Str = (str), tainted |= Str->str_tainted, \
X (Str->str_nok ? Str->str_u.str_nval : str_2num(Str)))
X#else
X#define str_gnum(str) (Str = (str), (Str->str_nok ? Str->str_u.str_nval : str_2num(Str)))
X#endif
XEXT STR *Str;
X
X#define GROWSTR(pp,lp,len) if (*(lp) < (len)) growstr(pp,lp,len)
X
X#define STR_GROW(str,len) if ((str)->str_len < (len)) str_grow(str,len)
X
X#ifndef BYTEORDER
X#define BYTEORDER 01234
X#endif
X
X#ifndef HTONL
X#if BYTEORDER != 04321
X#define HTONS
X#define HTONL
X#define NTOHS
X#define NTOHL
X#define MYSWAP
X#define htons my_swap
X#define htonl my_htonl
X#define ntohs my_swap
X#define ntohl my_ntohl
X#endif
X#else
X#if BYTEORDER == 04321
X#undef HTONS
X#undef HTONL
X#undef NTOHS
X#undef NTOHL
X#endif
X#endif
X
XCMD *add_label();
XCMD *block_head();
XCMD *append_line();
XCMD *make_acmd();
XCMD *make_ccmd();
XCMD *make_icmd();
XCMD *invert();
XCMD *addcond();
XCMD *addloop();
XCMD *wopt();
XCMD *over();
X
XSTAB *stabent();
XSTAB *genstab();
X
XARG *stab2arg();
XARG *op_new();
XARG *make_op();
XARG *make_match();
XARG *make_split();
XARG *rcatmaybe();
XARG *listish();
XARG *maybelistish();
XARG *localize();
XARG *fixeval();
XARG *jmaybe();
XARG *l();
XARG *fixl();
XARG *mod_match();
XARG *make_list();
XARG *cmd_to_arg();
XARG *addflags();
XARG *hide_ary();
XARG *cval_to_arg();
X
XSTR *str_new();
XSTR *stab_str();
X
Xint do_each();
Xint do_subr();
Xint do_match();
Xint do_unpack();
Xint eval(); /* this evaluates expressions */
Xint do_eval(); /* this evaluates eval operator */
Xint do_assign();
X
XSUBR *make_sub();
X
XFCMD *load_format();
X
Xchar *scanpat();
Xchar *scansubst();
Xchar *scantrans();
Xchar *scanstr();
Xchar *scanreg();
Xchar *str_append_till();
Xchar *str_gets();
Xchar *str_grow();
X
Xbool do_open();
Xbool do_close();
Xbool do_print();
Xbool do_aprint();
Xbool do_exec();
Xbool do_aexec();
X
Xint do_subst();
Xint cando();
Xint ingroup();
X
Xvoid str_replace();
Xvoid str_inc();
Xvoid str_dec();
Xvoid str_free();
Xvoid stab_clear();
Xvoid do_join();
Xvoid do_sprintf();
Xvoid do_accept();
Xvoid do_vecset();
Xvoid savelist();
Xvoid saveitem();
Xvoid saveint();
Xvoid savelong();
Xvoid savesptr();
Xvoid savehptr();
Xvoid restorelist();
XHASH *savehash();
XARRAY *saveary();
X
XEXT line_t line INIT(0);
XEXT line_t subline INIT(0);
XEXT STR *subname INIT(Nullstr);
XEXT int arybase INIT(0);
X
Xstruct outrec {
X line_t o_lines;
X char *o_str;
X int o_len;
X};
X
XEXT struct outrec outrec;
XEXT struct outrec toprec;
X
XEXT STAB *stdinstab INIT(Nullstab);
XEXT STAB *last_in_stab INIT(Nullstab);
XEXT STAB *defstab INIT(Nullstab);
XEXT STAB *argvstab INIT(Nullstab);
XEXT STAB *envstab INIT(Nullstab);
XEXT STAB *sigstab INIT(Nullstab);
XEXT STAB *defoutstab INIT(Nullstab);
XEXT STAB *curoutstab INIT(Nullstab);
XEXT STAB *argvoutstab INIT(Nullstab);
XEXT STAB *incstab INIT(Nullstab);
XEXT STAB *leftstab INIT(Nullstab);
XEXT STAB *amperstab INIT(Nullstab);
XEXT STAB *rightstab INIT(Nullstab);
XEXT STAB *DBstab INIT(Nullstab);
XEXT STAB *DBsub INIT(Nullstab);
X
XEXT HASH *defstash; /* main symbol table */
XEXT HASH *curstash; /* symbol table for current package */
XEXT HASH *debstash; /* symbol table for perldb package */
X
XEXT STR *curstname; /* name of current package */
X
XEXT STR *freestrroot INIT(Nullstr);
XEXT STR *lastretstr INIT(Nullstr);
XEXT STR *DBsingle INIT(Nullstr);
X
XEXT int lastspbase;
XEXT int lastsize;
X
XEXT char *filename;
XEXT char *origfilename;
XEXT FILE *rsfp;
XEXT char buf[1024];
XEXT char *bufptr;
XEXT char *oldbufptr;
XEXT char *oldoldbufptr;
XEXT char *bufend;
X
XEXT STR *linestr INIT(Nullstr);
X
XEXT char record_separator INIT('\n');
XEXT int rslen INIT(1);
XEXT char *ofs INIT(Nullch);
XEXT int ofslen INIT(0);
XEXT char *ors INIT(Nullch);
XEXT int orslen INIT(0);
XEXT char *ofmt INIT(Nullch);
XEXT char *inplace INIT(Nullch);
XEXT char *nointrp INIT("");
X
XEXT bool preprocess INIT(FALSE);
XEXT bool minus_n INIT(FALSE);
XEXT bool minus_p INIT(FALSE);
XEXT bool minus_a INIT(FALSE);
XEXT bool doswitches INIT(FALSE);
XEXT bool dowarn INIT(FALSE);
XEXT bool allstabs INIT(FALSE); /* init all customary symbols in symbol table?*/
XEXT bool sawampersand INIT(FALSE); /* must save all match strings */
XEXT bool sawstudy INIT(FALSE); /* do fbminstr on all strings */
XEXT bool sawi INIT(FALSE); /* study must assume case insensitive */
XEXT bool sawvec INIT(FALSE);
X
XEXT int csh INIT(0); /* 1 if /bin/csh is there, -1 if not */
X
X#ifdef TAINT
XEXT bool tainted INIT(FALSE); /* using variables controlled by $< */
X#endif
X
X#define TMPPATH "/tmp/perl-eXXXXXX"
XEXT char *e_tmpname;
XEXT FILE *e_fp INIT(Nullfp);
X
XEXT char tokenbuf[256];
XEXT int expectterm INIT(TRUE); /* how to interpret ambiguous tokens */
XEXT int in_eval INIT(FALSE); /* trap fatal errors? */
XEXT int multiline INIT(0); /* $*--do strings hold >1 line? */
XEXT int forkprocess; /* so do_open |- can return proc# */
XEXT int do_undump INIT(0); /* -u or dump seen? */
XEXT int error_count INIT(0); /* how many errors so far, max 10 */
XEXT int multi_start INIT(0); /* 1st line of multi-line string */
XEXT int multi_end INIT(0); /* last line of multi-line string */
XEXT int multi_open INIT(0); /* delimiter of said string */
XEXT int multi_close INIT(0); /* delimiter of said string */
X
XFILE *popen();
X/* char *str_get(); */
XSTR *interp();
Xvoid free_arg();
XSTIO *stio_new();
X
XEXT struct stat statbuf;
XEXT struct stat statcache;
XSTAB *statstab INIT(Nullstab);
XSTR *statname;
XEXT struct tms timesbuf;
XEXT int uid;
XEXT int euid;
XUIDTYPE getuid();
XUIDTYPE geteuid();
XGIDTYPE getgid();
XGIDTYPE getegid();
XEXT int unsafe;
X
X#ifdef DEBUGGING
XEXT int debug INIT(0);
XEXT int dlevel INIT(0);
XEXT char debname[128];
XEXT char debdelim[128];
X#define YYDEBUG 1
Xextern int yydebug;
X#endif
XEXT int perldb INIT(0);
X
XEXT line_t cmdline INIT(NOLINE);
X
XEXT STR str_undef;
XEXT STR str_no;
XEXT STR str_yes;
X
X/* runtime control stuff */
X
XEXT struct loop {
X char *loop_label; /* what the loop was called, if anything */
X int loop_sp; /* stack pointer to copy stuff down to */
X jmp_buf loop_env;
X} loop_stack[128];
X
XEXT int loop_ptr INIT(-1);
X
XEXT jmp_buf top_env;
XEXT jmp_buf eval_env;
X
XEXT char *goto_targ INIT(Nullch); /* cmd_exec gets strange when set */
X
XEXT ARRAY *stack; /* THE STACK */
X
XEXT ARRAY *savestack; /* to save non-local values on */
X
XEXT ARRAY *tosave; /* strings to save on recursive subroutine */
X
XEXT ARRAY *lineary; /* lines of script for debugger */
X
XEXT ARRAY *pidstatary; /* keep pids and statuses by fd for mypopen */
X
Xdouble atof();
Xlong time();
Xstruct tm *gmtime(), *localtime();
Xchar *mktemp();
Xchar *index(), *rindex();
Xchar *strcpy(), *strcat();
X
X#ifdef EUNICE
X#define UNLINK unlnk
Xint unlnk();
X#else
X#define UNLINK unlink
X#endif
!STUFFY!FUNK!
echo Extracting x2p/util.c
sed >x2p/util.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: util.c,v 2.0 88/06/05 00:16:07 root Exp $
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: util.c,v $
X * Revision 2.0 88/06/05 00:16:07 root
X * Baseline version 2.0.
X *
X */
X
X#include <stdio.h>
X
X#include "handy.h"
X#include "EXTERN.h"
X#include "a2p.h"
X#include "INTERN.h"
X#include "util.h"
X
X#define FLUSH
X#define MEM_SIZE unsigned int
X
Xstatic char nomem[] = "Out of memory!\n";
X
X/* paranoid version of malloc */
X
Xstatic int an = 0;
X
Xchar *
Xsafemalloc(size)
XMEM_SIZE size;
X{
X char *ptr;
X char *malloc();
X
X ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
X#ifdef DEBUGGING
X if (debug & 128)
X fprintf(stderr,"0x%x: (%05d) malloc %d bytes\n",ptr,an++,size);
X#endif
X if (ptr != Nullch)
X return ptr;
X else {
X fputs(nomem,stdout) FLUSH;
X exit(1);
X }
X /*NOTREACHED*/
X}
X
X/* paranoid version of realloc */
X
Xchar *
Xsaferealloc(where,size)
Xchar *where;
XMEM_SIZE size;
X{
X char *ptr;
X char *realloc();
X
X ptr = realloc(where,size?size:1); /* realloc(0) is NASTY on our system */
X#ifdef DEBUGGING
X if (debug & 128) {
X fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++);
X fprintf(stderr,"0x%x: (%05d) realloc %d bytes\n",ptr,an++,size);
X }
X#endif
X if (ptr != Nullch)
X return ptr;
X else {
X fputs(nomem,stdout) FLUSH;
X exit(1);
X }
X /*NOTREACHED*/
X}
X
X/* safe version of free */
X
Xsafefree(where)
Xchar *where;
X{
X#ifdef DEBUGGING
X if (debug & 128)
X fprintf(stderr,"0x%x: (%05d) free\n",where,an++);
X#endif
X free(where);
X}
X
X/* safe version of string copy */
X
Xchar *
Xsafecpy(to,from,len)
Xchar *to;
Xregister char *from;
Xregister int len;
X{
X register char *dest = to;
X
X if (from != Nullch)
X for (len--; len && (*dest++ = *from++); len--) ;
X *dest = '\0';
X return to;
X}
X
X#ifdef undef
X/* safe version of string concatenate, with \n deletion and space padding */
X
Xchar *
Xsafecat(to,from,len)
Xchar *to;
Xregister char *from;
Xregister int len;
X{
X register char *dest = to;
X
X len--; /* leave room for null */
X if (*dest) {
X while (len && *dest++) len--;
X if (len) {
X len--;
X *(dest-1) = ' ';
X }
X }
X if (from != Nullch)
X while (len && (*dest++ = *from++)) len--;
X if (len)
X dest--;
X if (*(dest-1) == '\n')
X dest--;
X *dest = '\0';
X return to;
X}
X#endif
X
X/* copy a string up to some (non-backslashed) delimiter, if any */
X
Xchar *
Xcpytill(to,from,delim)
Xregister char *to, *from;
Xregister int delim;
X{
X for (; *from; from++,to++) {
X if (*from == '\\') {
X if (from[1] == delim)
X from++;
X else if (from[1] == '\\')
X *to++ = *from++;
X }
X else if (*from == delim)
X break;
X *to = *from;
X }
X *to = '\0';
X return from;
X}
X
X
Xchar *
Xcpy2(to,from,delim)
Xregister char *to, *from;
Xregister int delim;
X{
X for (; *from; from++,to++) {
X if (*from == '\\')
X *to++ = *from++;
X else if (*from == '$')
X *to++ = '\\';
X else if (*from == delim)
X break;
X *to = *from;
X }
X *to = '\0';
X return from;
X}
X
X/* return ptr to little string in big string, NULL if not found */
X
Xchar *
Xinstr(big, little)
Xchar *big, *little;
X
X{
X register char *t, *s, *x;
X
X for (t = big; *t; t++) {
X for (x=t,s=little; *s; x++,s++) {
X if (!*x)
X return Nullch;
X if (*s != *x)
X break;
X }
X if (!*s)
X return t;
X }
X return Nullch;
X}
X
X/* copy a string to a safe spot */
X
Xchar *
Xsavestr(str)
Xchar *str;
X{
X register char *newaddr = safemalloc((MEM_SIZE)(strlen(str)+1));
X
X (void)strcpy(newaddr,str);
X return newaddr;
X}
X
X/* grow a static string to at least a certain length */
X
Xvoid
Xgrowstr(strptr,curlen,newlen)
Xchar **strptr;
Xint *curlen;
Xint newlen;
X{
X if (newlen > *curlen) { /* need more room? */
X if (*curlen)
X *strptr = saferealloc(*strptr,(MEM_SIZE)newlen);
X else
X *strptr = safemalloc((MEM_SIZE)newlen);
X *curlen = newlen;
X }
X}
X
X/*VARARGS1*/
Xfatal(pat,a1,a2,a3,a4)
Xchar *pat;
X{
X fprintf(stderr,pat,a1,a2,a3,a4);
X exit(1);
X}
X
Xstatic bool firstsetenv = TRUE;
Xextern char **environ;
X
Xvoid
Xsetenv(nam,val)
Xchar *nam, *val;
X{
X register int i=envix(nam); /* where does it go? */
X
X if (!environ[i]) { /* does not exist yet */
X if (firstsetenv) { /* need we copy environment? */
X int j;
X#ifndef lint
X char **tmpenv = (char**) /* point our wand at memory */
X safemalloc((i+2) * sizeof(char*));
X#else
X char **tmpenv = Null(char **);
X#endif /* lint */
X
X firstsetenv = FALSE;
X for (j=0; j<i; j++) /* copy environment */
X tmpenv[j] = environ[j];
X environ = tmpenv; /* tell exec where it is now */
X }
X#ifndef lint
X else
X environ = (char**) saferealloc((char*) environ,
X (i+2) * sizeof(char*));
X /* just expand it a bit */
X#endif /* lint */
X environ[i+1] = Nullch; /* make sure it's null terminated */
X }
X environ[i] = safemalloc(strlen(nam) + strlen(val) + 2);
X /* this may or may not be in */
X /* the old environ structure */
X sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
X}
X
Xint
Xenvix(nam)
Xchar *nam;
X{
X register int i, len = strlen(nam);
X
X for (i = 0; environ[i]; i++) {
X if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
X break; /* strnEQ must come first to avoid */
X } /* potential SEGV's */
X return i;
X}
!STUFFY!FUNK!
echo Extracting eg/rmfrom
sed >eg/rmfrom <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl -n
X
X# $Header: rmfrom,v 2.0 88/06/05 00:16:57 root Exp $
X
X# A handy (but dangerous) script to put after a find ... -print.
X
Xchop; unlink;
!STUFFY!FUNK!
echo ""
echo "End of kit 17 (of 23)"
cat /dev/null >kit17isdone
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; 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."
chmod 755 Configure
;;
*) echo "You have run$run."
echo "You still need to run$todo."
;;
esac
: Someone might mail this, so...
exit
More information about the Alt.sources
mailing list