home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Usenet 1994 January
/
usenetsourcesnewsgroupsinfomagicjanuary1994.iso
/
sources
/
misc
/
volume18
/
perl
/
part31
< prev
next >
Wrap
Internet Message Format
|
1991-04-17
|
51KB
From: lwall@netlabs.com (Larry Wall)
Newsgroups: comp.sources.misc
Subject: v18i049: perl - The perl programming language, Part31/36
Message-ID: <1991Apr17.185846.2891@sparky.IMD.Sterling.COM>
Date: 17 Apr 91 18:58:46 GMT
Approved: kent@sparky.imd.sterling.com
X-Checksum-Snefru: 197883e2 db2142ff 6a702370 8691e194
Submitted-by: Larry Wall <lwall@netlabs.com>
Posting-number: Volume 18, Issue 49
Archive-name: perl/part31
[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 31 (of 36). If kit 31 is complete, the line"
echo '"'"End of kit 31 (of 36)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir h2pl h2pl/eg h2pl/eg/sys lib os2 t t/lib t/op x2p 2>/dev/null
echo Extracting x2p/hash.c
sed >x2p/hash.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: hash.c,v 4.0 91/03/20 01:57:49 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: hash.c,v $
X * Revision 4.0 91/03/20 01:57:49 lwall
X * 4.0 baseline.
X *
X */
X
X#include <stdio.h>
X#include "EXTERN.h"
X#include "handy.h"
X#include "util.h"
X#include "a2p.h"
X
XSTR *
Xhfetch(tb,key)
Xregister HASH *tb;
Xchar *key;
X{
X register char *s;
X register int i;
X register int hash;
X register HENT *entry;
X
X if (!tb)
X return Nullstr;
X for (s=key, i=0, hash = 0;
X /* while */ *s;
X s++, i++, hash *= 5) {
X hash += *s * coeff[i];
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 (strNE(entry->hent_key,key)) /* is this it? */
X continue;
X return entry->hent_val;
X }
X return Nullstr;
X}
X
Xbool
Xhstore(tb,key,val)
Xregister HASH *tb;
Xchar *key;
XSTR *val;
X{
X register char *s;
X register int i;
X register int hash;
X register HENT *entry;
X register HENT **oentry;
X
X if (!tb)
X return FALSE;
X for (s=key, i=0, hash = 0;
X /* while */ *s;
X s++, i++, hash *= 5) {
X hash += *s * coeff[i];
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 (strNE(entry->hent_key,key)) /* is this it? */
X continue;
X /*NOSTRICT*/
X safefree((char*)entry->hent_val);
X entry->hent_val = val;
X return TRUE;
X }
X /*NOSTRICT*/
X entry = (HENT*) safemalloc(sizeof(HENT));
X
X entry->hent_key = savestr(key);
X entry->hent_val = val;
X entry->hent_hash = hash;
X entry->hent_next = *oentry;
X *oentry = entry;
X
X if (i) { /* initial entry? */
X tb->tbl_fill++;
X if ((tb->tbl_fill * 100 / (tb->tbl_max + 1)) > FILLPCT)
X hsplit(tb);
X }
X
X return FALSE;
X}
X
X#ifdef NOTUSED
Xbool
Xhdelete(tb,key)
Xregister HASH *tb;
Xchar *key;
X{
X register char *s;
X register int i;
X register int hash;
X register HENT *entry;
X register HENT **oentry;
X
X if (!tb)
X return FALSE;
X for (s=key, i=0, hash = 0;
X /* while */ *s;
X s++, i++, hash *= 5) {
X hash += *s * coeff[i];
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 = entry->hent_next) {
X if (entry->hent_hash != hash) /* strings can't be equal */
X continue;
X if (strNE(entry->hent_key,key)) /* is this it? */
X continue;
X safefree((char*)entry->hent_val);
X safefree(entry->hent_key);
X *oentry = entry->hent_next;
X safefree((char*)entry);
X if (i)
X tb->tbl_fill--;
X return TRUE;
X }
X return FALSE;
X}
X#endif
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 = (HENT**) saferealloc((char*)tb->tbl_array, newsize * sizeof(HENT*));
X bzero((char*)&a[oldsize], oldsize * sizeof(HENT*)); /* zero second half */
X tb->tbl_max = --newsize;
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()
X{
X register HASH *tb = (HASH*)safemalloc(sizeof(HASH));
X
X tb->tbl_array = (HENT**) safemalloc(8 * sizeof(HENT*));
X tb->tbl_fill = 0;
X tb->tbl_max = 7;
X hiterinit(tb); /* so each() will start off right */
X bzero((char*)tb->tbl_array, 8 * sizeof(HENT*));
X return tb;
X}
X
X#ifdef NOTUSED
Xhshow(tb)
Xregister HASH *tb;
X{
X fprintf(stderr,"%5d %4d (%2d%%)\n",
X tb->tbl_max+1,
X tb->tbl_fill,
X tb->tbl_fill * 100 / (tb->tbl_max+1));
X}
X#endif
X
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
X entry = tb->tbl_eiter;
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)
Xregister HENT *entry;
X{
X return entry->hent_key;
X}
X
XSTR *
Xhiterval(entry)
Xregister HENT *entry;
X{
X return entry->hent_val;
X}
!STUFFY!FUNK!
echo Extracting str.h
sed >str.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $RCSfile: str.h,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:16:12 $
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: str.h,v $
X * Revision 4.0.1.1 91/04/12 09:16:12 lwall
X * patch1: you may now use "die" and "caller" in a signal handler
X *
X * Revision 4.0 91/03/20 01:40:04 lwall
X * 4.0 baseline.
X *
X */
X
Xstruct string {
X char * str_ptr; /* pointer to malloced string */
X STRLEN str_len; /* allocated size */
X union {
X double str_nval; /* numeric value, if any */
X STAB *str_stab; /* magic stab for magic "key" string */
X long str_useful; /* is this search optimization effective? */
X ARG *str_args; /* list of args for interpreted string */
X HASH *str_hash; /* string represents an assoc array (stab?) */
X ARRAY *str_array; /* string represents an array */
X CMD *str_cmd; /* command for this source line */
X } str_u;
X STRLEN str_cur; /* length of str_ptr as a C string */
X STR *str_magic; /* while free, link to next free str */
X /* while in use, ptr to "key" for magic items */
X char str_pok; /* state of str_ptr */
X char str_nok; /* state of str_nval */
X unsigned char str_rare; /* used by search strings */
X unsigned char str_state; /* one of SS_* below */
X /* also used by search strings for backoff */
X#ifdef TAINT
X bool str_tainted; /* 1 if possibly under control of $< */
X#endif
X};
X
Xstruct stab { /* should be identical, except for str_ptr */
X STBP * str_ptr; /* pointer to malloced string */
X STRLEN str_len; /* allocated size */
X union {
X double str_nval; /* numeric value, if any */
X STAB *str_stab; /* magic stab for magic "key" string */
X long str_useful; /* is this search optimization effective? */
X ARG *str_args; /* list of args for interpreted string */
X HASH *str_hash; /* string represents an assoc array (stab?) */
X ARRAY *str_array; /* string represents an array */
X CMD *str_cmd; /* command for this source line */
X } str_u;
X STRLEN str_cur; /* length of str_ptr as a C string */
X STR *str_magic; /* while free, link to next free str */
X /* while in use, ptr to "key" for magic items */
X char str_pok; /* state of str_ptr */
X char str_nok; /* state of str_nval */
X unsigned char str_rare; /* used by search strings */
X unsigned char str_state; /* one of SS_* below */
X /* also used by search strings for backoff */
X#ifdef TAINT
X bool str_tainted; /* 1 if possibly under control of $< */
X#endif
X};
X
X/* some extra info tacked to some lvalue strings */
X
Xstruct lstring {
X struct string lstr;
X STRLEN lstr_offset;
X STRLEN lstr_len;
X};
X
X/* These are the values of str_pok: */
X#define SP_VALID 1 /* str_ptr is valid */
X#define SP_FBM 2 /* string was compiled for fbm search */
X#define SP_STUDIED 4 /* string was studied */
X#define SP_CASEFOLD 8 /* case insensitive fbm search */
X#define SP_INTRP 16 /* string was compiled for interping */
X#define SP_TAIL 32 /* fbm string is tail anchored: /foo$/ */
X#define SP_MULTI 64 /* symbol table entry probably isn't a typo */
X#define SP_TEMP 128 /* string slated to die, so can be plundered */
X
X#define Nullstr Null(STR*)
X
X/* These are the values of str_state: */
X#define SS_NORM 0 /* normal string */
X#define SS_INCR 1 /* normal string, incremented ptr */
X#define SS_SARY 2 /* array on save stack */
X#define SS_SHASH 3 /* associative array on save stack */
X#define SS_SINT 4 /* integer on save stack */
X#define SS_SLONG 5 /* long on save stack */
X#define SS_SSTRP 6 /* STR* on save stack */
X#define SS_SHPTR 7 /* HASH* on save stack */
X#define SS_SNSTAB 8 /* non-stab on save stack */
X#define SS_SCSV 9 /* callsave structure on save stack */
X#define SS_SAPTR 10 /* ARRAY* on save stack */
X#define SS_HASH 253 /* carrying an hash */
X#define SS_ARY 254 /* carrying an array */
X#define SS_FREE 255 /* in free list */
X/* str_state may have any value 0-255 when used to hold fbm pattern, in which */
X/* case it indicates offset to rarest character in screaminstr key */
X
X/* the following macro updates any magic values this str is associated with */
X
X#ifdef TAINT
X#define STABSET(x) \
X (x)->str_tainted |= tainted; \
X if ((x)->str_magic) \
X stabset((x)->str_magic,(x))
X#else
X#define STABSET(x) \
X if ((x)->str_magic) \
X stabset((x)->str_magic,(x))
X#endif
X
X#define STR_SSET(dst,src) if (dst != src) str_sset(dst,src)
X
XEXT STR **tmps_list;
XEXT int tmps_max INIT(-1);
XEXT int tmps_base INIT(-1);
X
Xchar *str_2ptr();
Xdouble str_2num();
XSTR *str_mortal();
XSTR *str_2mortal();
XSTR *str_make();
XSTR *str_nmake();
XSTR *str_smake();
Xint str_cmp();
Xint str_eq();
Xvoid str_magic();
Xvoid str_insert();
XSTRLEN str_len();
!STUFFY!FUNK!
echo Extracting cmd.h
sed >cmd.h <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: cmd.h,v 4.0 91/03/20 01:04:34 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: cmd.h,v $
X * Revision 4.0 91/03/20 01:04:34 lwall
X * 4.0 baseline.
X *
X */
X
X#define C_NULL 0
X#define C_IF 1
X#define C_ELSE 2
X#define C_WHILE 3
X#define C_BLOCK 4
X#define C_EXPR 5
X#define C_NEXT 6
X#define C_ELSIF 7 /* temporary--turns into an IF + ELSE */
X#define C_CSWITCH 8 /* created by switch optimization in block_head() */
X#define C_NSWITCH 9 /* likewise */
X
X#ifdef DEBUGGING
X#ifndef DOINIT
Xextern char *cmdname[];
X#else
Xchar *cmdname[] = {
X "NULL",
X "IF",
X "ELSE",
X "WHILE",
X "BLOCK",
X "EXPR",
X "NEXT",
X "ELSIF",
X "CSWITCH",
X "NSWITCH",
X "10"
X};
X#endif
X#endif /* DEBUGGING */
X
X#define CF_OPTIMIZE 077 /* type of optimization */
X#define CF_FIRSTNEG 0100/* conditional is ($register NE 'string') */
X#define CF_NESURE 0200 /* if short doesn't match we're sure */
X#define CF_EQSURE 0400 /* if short does match we're sure */
X#define CF_COND 01000 /* test c_expr as conditional first, if not null. */
X /* Set for everything except do {} while currently */
X#define CF_LOOP 02000 /* loop on the c_expr conditional (loop modifiers) */
X#define CF_INVERT 04000 /* it's an "unless" or an "until" */
X#define CF_ONCE 010000 /* we've already pushed the label on the stack */
X#define CF_FLIP 020000 /* on a match do flipflop */
X#define CF_TERM 040000 /* value of this cmd might be returned */
X#define CF_DBSUB 0100000 /* this is an inserted cmd for debugging */
X
X#define CFT_FALSE 0 /* c_expr is always false */
X#define CFT_TRUE 1 /* c_expr is always true */
X#define CFT_REG 2 /* c_expr is a simple register */
X#define CFT_ANCHOR 3 /* c_expr is an anchored search /^.../ */
X#define CFT_STROP 4 /* c_expr is a string comparison */
X#define CFT_SCAN 5 /* c_expr is an unanchored search /.../ */
X#define CFT_GETS 6 /* c_expr is <filehandle> */
X#define CFT_EVAL 7 /* c_expr is not optimized, so call eval() */
X#define CFT_UNFLIP 8 /* 2nd half of range not optimized */
X#define CFT_CHOP 9 /* c_expr is a chop on a register */
X#define CFT_ARRAY 10 /* this is a foreach loop */
X#define CFT_INDGETS 11 /* c_expr is <$variable> */
X#define CFT_NUMOP 12 /* c_expr is a numeric comparison */
X#define CFT_CCLASS 13 /* c_expr must start with one of these characters */
X#define CFT_D0 14 /* no special breakpoint at this line */
X#define CFT_D1 15 /* possible special breakpoint at this line */
X
X#ifdef DEBUGGING
X#ifndef DOINIT
Xextern char *cmdopt[];
X#else
Xchar *cmdopt[] = {
X "FALSE",
X "TRUE",
X "REG",
X "ANCHOR",
X "STROP",
X "SCAN",
X "GETS",
X "EVAL",
X "UNFLIP",
X "CHOP",
X "ARRAY",
X "INDGETS",
X "NUMOP",
X "CCLASS",
X "14"
X};
X#endif
X#endif /* DEBUGGING */
X
Xstruct acmd {
X STAB *ac_stab; /* a symbol table entry */
X ARG *ac_expr; /* any associated expression */
X};
X
Xstruct ccmd {
X CMD *cc_true; /* normal code to do on if and while */
X CMD *cc_alt; /* else cmd ptr or continue code */
X};
X
Xstruct scmd {
X CMD **sc_next; /* array of pointers to commands */
X short sc_offset; /* first value - 1 */
X short sc_max; /* last value + 1 */
X};
X
Xstruct cmd {
X CMD *c_next; /* the next command at this level */
X ARG *c_expr; /* conditional expression */
X CMD *c_head; /* head of this command list */
X STR *c_short; /* string to match as shortcut */
X STAB *c_stab; /* a symbol table entry, mostly for fp */
X SPAT *c_spat; /* pattern used by optimization */
X char *c_label; /* label for this construct */
X union ucmd {
X struct acmd acmd; /* normal command */
X struct ccmd ccmd; /* compound command */
X struct scmd scmd; /* switch command */
X } ucmd;
X short c_slen; /* len of c_short, if not null */
X VOLATILE short c_flags; /* optimization flags--see above */
X HASH *c_stash; /* package line was compiled in */
X STAB *c_filestab; /* file the following line # is from */
X line_t c_line; /* line # of this command */
X char c_type; /* what this command does */
X};
X
X#define Nullcmd Null(CMD*)
X#define Nullcsv Null(CSV*)
X
XEXT CMD * VOLATILE main_root INIT(Nullcmd);
XEXT CMD * VOLATILE eval_root INIT(Nullcmd);
X
XEXT CMD compiling;
XEXT CMD * VOLATILE curcmd INIT(&compiling);
XEXT CSV * VOLATILE curcsv INIT(Nullcsv);
X
Xstruct callsave {
X SUBR *sub;
X STAB *stab;
X CSV *curcsv;
X CMD *curcmd;
X ARRAY *savearray;
X ARRAY *argarray;
X long depth;
X int wantarray;
X char hasargs;
X};
X
Xstruct compcmd {
X CMD *comp_true;
X CMD *comp_alt;
X};
X
Xvoid opt_arg();
Xvoid evalstatic();
Xint cmd_exec();
!STUFFY!FUNK!
echo Extracting t/op/s.t
sed >t/op/s.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: s.t,v 4.0 91/03/20 01:54:30 lwall Locked $
X
Xprint "1..51\n";
X
X$x = 'foo';
X$_ = "x";
Xs/x/\$x/;
Xprint "#1\t:$_: eq :\$x:\n";
Xif ($_ eq '$x') {print "ok 1\n";} else {print "not ok 1\n";}
X
X$_ = "x";
Xs/x/$x/;
Xprint "#2\t:$_: eq :foo:\n";
Xif ($_ eq 'foo') {print "ok 2\n";} else {print "not ok 2\n";}
X
X$_ = "x";
Xs/x/\$x $x/;
Xprint "#3\t:$_: eq :\$x foo:\n";
Xif ($_ eq '$x foo') {print "ok 3\n";} else {print "not ok 3\n";}
X
X$b = 'cd';
X($a = 'abcdef') =~ s'(b${b}e)'\n$1';
Xprint "#4\t:$1: eq :bcde:\n";
Xprint "#4\t:$a: eq :a\\n\$1f:\n";
Xif ($1 eq 'bcde' && $a eq 'a\n$1f') {print "ok 4\n";} else {print "not ok 4\n";}
X
X$a = 'abacada';
Xif (($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx')
X {print "ok 5\n";} else {print "not ok 5\n";}
X
Xif (($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx')
X {print "ok 6\n";} else {print "not ok 6 $a\n";}
X
Xif (($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx')
X {print "ok 7\n";} else {print "not ok 7 $a\n";}
X
X$_ = 'ABACADA';
Xif (/a/i && s///gi && $_ eq 'BCD') {print "ok 8\n";} else {print "not ok 8 $_\n";}
X
X$_ = '\\' x 4;
Xif (length($_) == 4) {print "ok 9\n";} else {print "not ok 9\n";}
Xs/\\/\\\\/g;
Xif ($_ eq '\\' x 8) {print "ok 10\n";} else {print "not ok 10 $_\n";}
X
X$_ = '\/' x 4;
Xif (length($_) == 8) {print "ok 11\n";} else {print "not ok 11\n";}
Xs/\//\/\//g;
Xif ($_ eq '\\//' x 4) {print "ok 12\n";} else {print "not ok 12\n";}
Xif (length($_) == 12) {print "ok 13\n";} else {print "not ok 13\n";}
X
X$_ = 'aaaXXXXbbb';
Xs/^a//;
Xprint $_ eq 'aaXXXXbbb' ? "ok 14\n" : "not ok 14\n";
X
X$_ = 'aaaXXXXbbb';
Xs/a//;
Xprint $_ eq 'aaXXXXbbb' ? "ok 15\n" : "not ok 15\n";
X
X$_ = 'aaaXXXXbbb';
Xs/^a/b/;
Xprint $_ eq 'baaXXXXbbb' ? "ok 16\n" : "not ok 16\n";
X
X$_ = 'aaaXXXXbbb';
Xs/a/b/;
Xprint $_ eq 'baaXXXXbbb' ? "ok 17\n" : "not ok 17\n";
X
X$_ = 'aaaXXXXbbb';
Xs/aa//;
Xprint $_ eq 'aXXXXbbb' ? "ok 18\n" : "not ok 18\n";
X
X$_ = 'aaaXXXXbbb';
Xs/aa/b/;
Xprint $_ eq 'baXXXXbbb' ? "ok 19\n" : "not ok 19\n";
X
X$_ = 'aaaXXXXbbb';
Xs/b$//;
Xprint $_ eq 'aaaXXXXbb' ? "ok 20\n" : "not ok 20\n";
X
X$_ = 'aaaXXXXbbb';
Xs/b//;
Xprint $_ eq 'aaaXXXXbb' ? "ok 21\n" : "not ok 21\n";
X
X$_ = 'aaaXXXXbbb';
Xs/bb//;
Xprint $_ eq 'aaaXXXXb' ? "ok 22\n" : "not ok 22\n";
X
X$_ = 'aaaXXXXbbb';
Xs/aX/y/;
Xprint $_ eq 'aayXXXbbb' ? "ok 23\n" : "not ok 23\n";
X
X$_ = 'aaaXXXXbbb';
Xs/Xb/z/;
Xprint $_ eq 'aaaXXXzbb' ? "ok 24\n" : "not ok 24\n";
X
X$_ = 'aaaXXXXbbb';
Xs/aaX.*Xbb//;
Xprint $_ eq 'ab' ? "ok 25\n" : "not ok 25\n";
X
X$_ = 'aaaXXXXbbb';
Xs/bb/x/;
Xprint $_ eq 'aaaXXXXxb' ? "ok 26\n" : "not ok 26\n";
X
X# now for some unoptimized versions of the same.
X
X$_ = 'aaaXXXXbbb';
X$x ne $x || s/^a//;
Xprint $_ eq 'aaXXXXbbb' ? "ok 27\n" : "not ok 27\n";
X
X$_ = 'aaaXXXXbbb';
X$x ne $x || s/a//;
Xprint $_ eq 'aaXXXXbbb' ? "ok 28\n" : "not ok 28\n";
X
X$_ = 'aaaXXXXbbb';
X$x ne $x || s/^a/b/;
Xprint $_ eq 'baaXXXXbbb' ? "ok 29\n" : "not ok 29\n";
X
X$_ = 'aaaXXXXbbb';
X$x ne $x || s/a/b/;
Xprint $_ eq 'baaXXXXbbb' ? "ok 30\n" : "not ok 30\n";
X
X$_ = 'aaaXXXXbbb';
X$x ne $x || s/aa//;
Xprint $_ eq 'aXXXXbbb' ? "ok 31\n" : "not ok 31\n";
X
X$_ = 'aaaXXXXbbb';
X$x ne $x || s/aa/b/;
Xprint $_ eq 'baXXXXbbb' ? "ok 32\n" : "not ok 32\n";
X
X$_ = 'aaaXXXXbbb';
X$x ne $x || s/b$//;
Xprint $_ eq 'aaaXXXXbb' ? "ok 33\n" : "not ok 33\n";
X
X$_ = 'aaaXXXXbbb';
X$x ne $x || s/b//;
Xprint $_ eq 'aaaXXXXbb' ? "ok 34\n" : "not ok 34\n";
X
X$_ = 'aaaXXXXbbb';
X$x ne $x || s/bb//;
Xprint $_ eq 'aaaXXXXb' ? "ok 35\n" : "not ok 35\n";
X
X$_ = 'aaaXXXXbbb';
X$x ne $x || s/aX/y/;
Xprint $_ eq 'aayXXXbbb' ? "ok 36\n" : "not ok 36\n";
X
X$_ = 'aaaXXXXbbb';
X$x ne $x || s/Xb/z/;
Xprint $_ eq 'aaaXXXzbb' ? "ok 37\n" : "not ok 37\n";
X
X$_ = 'aaaXXXXbbb';
X$x ne $x || s/aaX.*Xbb//;
Xprint $_ eq 'ab' ? "ok 38\n" : "not ok 38\n";
X
X$_ = 'aaaXXXXbbb';
X$x ne $x || s/bb/x/;
Xprint $_ eq 'aaaXXXXxb' ? "ok 39\n" : "not ok 39\n";
X
X$_ = 'abc123xyz';
Xs/\d+/$&*2/e; # yields 'abc246xyz'
Xprint $_ eq 'abc246xyz' ? "ok 40\n" : "not ok 40\n";
Xs/\d+/sprintf("%5d",$&)/e; # yields 'abc 246xyz'
Xprint $_ eq 'abc 246xyz' ? "ok 41\n" : "not ok 41\n";
Xs/\w/$& x 2/eg; # yields 'aabbcc 224466xxyyzz'
Xprint $_ eq 'aabbcc 224466xxyyzz' ? "ok 42\n" : "not ok 42\n";
X
X$_ = "aaaaa";
Xprint y/a/b/ == 5 ? "ok 43\n" : "not ok 43\n";
Xprint y/a/b/ == 0 ? "ok 44\n" : "not ok 44\n";
Xprint y/b// == 5 ? "ok 45\n" : "not ok 45\n";
Xprint y/b/c/s == 5 ? "ok 46\n" : "not ok 46\n";
Xprint y/c// == 1 ? "ok 47\n" : "not ok 47\n";
Xprint y/c//d == 1 ? "ok 48\n" : "not ok 48\n";
Xprint $_ eq "" ? "ok 49\n" : "not ok 49\n";
X
X$_ = "Now is the %#*! time for all good men...";
Xprint (($x=(y/a-zA-Z //cd)) == 7 ? "ok 50\n" : "not ok 50\n");
Xprint y/ / /s == 8 ? "ok 51\n" : "not ok 51\n";
X
!STUFFY!FUNK!
echo Extracting t/lib/big.t
sed >t/lib/big.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
Xrequire "../lib/bigint.pl";
X
X$test = 0;
X$| = 1;
Xprint "1..246\n";
Xwhile (<DATA>) {
X chop;
X if (/^&/) {
X $f = $_;
X } else {
X ++$test;
X @args = split(/:/,$_,99);
X $ans = pop(@args);
X $try = "$f('" . join("','", @args) . "');";
X if (($ans1 = eval($try)) eq $ans) {
X print "ok $test\n";
X } else {
X print "not ok $test\n";
X print "# '$try' expected: '$ans' got: '$ans1'\n";
X }
X }
X}
X__END__
X&bnorm
Xabc:NaN
X 1 a:NaN
X1bcd2:NaN
X11111b:NaN
X+1z:NaN
X-1z:NaN
X0:+0
X+0:+0
X+00:+0
X+0 0 0:+0
X000000 0000000 00000:+0
X-0:+0
X-0000:+0
X+1:+1
X+01:+1
X+001:+1
X+00000100000:+100000
X123456789:+123456789
X-1:-1
X-01:-1
X-001:-1
X-123456789:-123456789
X-00000100000:-100000
X&bneg
Xabd:NaN
X+0:+0
X+1:-1
X-1:+1
X+123456789:-123456789
X-123456789:+123456789
X&babs
Xabc:NaN
X+0:+0
X+1:+1
X-1:+1
X+123456789:+123456789
X-123456789:+123456789
X&bcmp
Xabc:abc:
Xabc:+0:
X+0:abc:
X+0:+0:0
X-1:+0:-1
X+0:-1:1
X+1:+0:1
X+0:+1:-1
X-1:+1:-1
X+1:-1:1
X-1:-1:0
X+1:+1:0
X+123:+123:0
X+123:+12:1
X+12:+123:-1
X-123:-123:0
X-123:-12:-1
X-12:-123:1
X+123:+124:-1
X+124:+123:1
X-123:-124:1
X-124:-123:-1
X&badd
Xabc:abc:NaN
Xabc:+0:NaN
X+0:abc:NaN
X+0:+0:+0
X+1:+0:+1
X+0:+1:+1
X+1:+1:+2
X-1:+0:-1
X+0:-1:-1
X-1:-1:-2
X-1:+1:+0
X+1:-1:+0
X+9:+1:+10
X+99:+1:+100
X+999:+1:+1000
X+9999:+1:+10000
X+99999:+1:+100000
X+999999:+1:+1000000
X+9999999:+1:+10000000
X+99999999:+1:+100000000
X+999999999:+1:+1000000000
X+9999999999:+1:+10000000000
X+99999999999:+1:+100000000000
X+10:-1:+9
X+100:-1:+99
X+1000:-1:+999
X+10000:-1:+9999
X+100000:-1:+99999
X+1000000:-1:+999999
X+10000000:-1:+9999999
X+100000000:-1:+99999999
X+1000000000:-1:+999999999
X+10000000000:-1:+9999999999
X+123456789:+987654321:+1111111110
X-123456789:+987654321:+864197532
X-123456789:-987654321:-1111111110
X+123456789:-987654321:-864197532
X&bsub
Xabc:abc:NaN
Xabc:+0:NaN
X+0:abc:NaN
X+0:+0:+0
X+1:+0:+1
X+0:+1:-1
X+1:+1:+0
X-1:+0:-1
X+0:-1:+1
X-1:-1:+0
X-1:+1:-2
X+1:-1:+2
X+9:+1:+8
X+99:+1:+98
X+999:+1:+998
X+9999:+1:+9998
X+99999:+1:+99998
X+999999:+1:+999998
X+9999999:+1:+9999998
X+99999999:+1:+99999998
X+999999999:+1:+999999998
X+9999999999:+1:+9999999998
X+99999999999:+1:+99999999998
X+10:-1:+11
X+100:-1:+101
X+1000:-1:+1001
X+10000:-1:+10001
X+100000:-1:+100001
X+1000000:-1:+1000001
X+10000000:-1:+10000001
X+100000000:-1:+100000001
X+1000000000:-1:+1000000001
X+10000000000:-1:+10000000001
X+123456789:+987654321:-864197532
X-123456789:+987654321:-1111111110
X-123456789:-987654321:+864197532
X+123456789:-987654321:+1111111110
X&bmul
Xabc:abc:NaN
Xabc:+0:NaN
X+0:abc:NaN
X+0:+0:+0
X+0:+1:+0
X+1:+0:+0
X+0:-1:+0
X-1:+0:+0
X+123456789123456789:+0:+0
X+0:+123456789123456789:+0
X-1:-1:+1
X-1:+1:-1
X+1:-1:-1
X+1:+1:+1
X+2:+3:+6
X-2:+3:-6
X+2:-3:-6
X-2:-3:+6
X+111:+111:+12321
X+10101:+10101:+102030201
X+1001001:+1001001:+1002003002001
X+100010001:+100010001:+10002000300020001
X+10000100001:+10000100001:+100002000030000200001
X+11111111111:+9:+99999999999
X+22222222222:+9:+199999999998
X+33333333333:+9:+299999999997
X+44444444444:+9:+399999999996
X+55555555555:+9:+499999999995
X+66666666666:+9:+599999999994
X+77777777777:+9:+699999999993
X+88888888888:+9:+799999999992
X+99999999999:+9:+899999999991
X&bdiv
Xabc:abc:NaN
Xabc:+1:abc:NaN
X+1:abc:NaN
X+0:+0:NaN
X+0:+1:+0
X+1:+0:NaN
X+0:-1:+0
X-1:+0:NaN
X+1:+1:+1
X-1:-1:+1
X+1:-1:-1
X-1:+1:-1
X+1:+2:+0
X+2:+1:+2
X+1000000000:+9:+111111111
X+2000000000:+9:+222222222
X+3000000000:+9:+333333333
X+4000000000:+9:+444444444
X+5000000000:+9:+555555555
X+6000000000:+9:+666666666
X+7000000000:+9:+777777777
X+8000000000:+9:+888888888
X+9000000000:+9:+1000000000
X+35500000:+113:+314159
X+71000000:+226:+314159
X+106500000:+339:+314159
X+1000000000:+3:+333333333
X+10:+5:+2
X+100:+4:+25
X+1000:+8:+125
X+10000:+16:+625
X+999999999999:+9:+111111111111
X+999999999999:+99:+10101010101
X+999999999999:+999:+1001001001
X+999999999999:+9999:+100010001
X+999999999999999:+99999:+10000100001
X&bmod
Xabc:abc:NaN
Xabc:+1:abc:NaN
X+1:abc:NaN
X+0:+0:NaN
X+0:+1:+0
X+1:+0:NaN
X+0:-1:+0
X-1:+0:NaN
X+1:+1:+0
X-1:-1:+0
X+1:-1:+0
X-1:+1:+0
X+1:+2:+1
X+2:+1:+0
X+1000000000:+9:+1
X+2000000000:+9:+2
X+3000000000:+9:+3
X+4000000000:+9:+4
X+5000000000:+9:+5
X+6000000000:+9:+6
X+7000000000:+9:+7
X+8000000000:+9:+8
X+9000000000:+9:+0
X+35500000:+113:+33
X+71000000:+226:+66
X+106500000:+339:+99
X+1000000000:+3:+1
X+10:+5:+0
X+100:+4:+0
X+1000:+8:+0
X+10000:+16:+0
X+999999999999:+9:+0
X+999999999999:+99:+0
X+999999999999:+999:+0
X+999999999999:+9999:+0
X+999999999999999:+99999:+0
X&bgcd
Xabc:abc:NaN
Xabc:+0:NaN
X+0:abc:NaN
X+0:+0:+0
X+0:+1:+1
X+1:+0:+1
X+1:+1:+1
X+2:+3:+1
X+3:+2:+1
X+100:+625:+25
X+4096:+81:+1
!STUFFY!FUNK!
echo Extracting installperl
sed >installperl <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
Xwhile (@ARGV) {
X $nonono = 1 if $ARGV[0] eq '-n';
X $versiononly = 1 if $ARGV[0] eq '-v';
X shift;
X}
X
X@scripts = 'h2ph';
X@manpages = ('perl.man', 'h2ph.man');
X
X$version = sprintf("%5.3f", $]);
X$release = substr($version,0,3);
X$patchlevel = substr($version,3,2);
X
X# Read in the config file.
X
Xopen(CONFIG, "config.sh") || die "You haven't run Configure yet!\n";
Xwhile (<CONFIG>) {
X if (s/^(\w+=)/\$$1/) {
X $accum =~ s/'undef'/undef/g;
X eval $accum;
X $accum = '';
X }
X $accum .= $_;
X}
X
X# Do some quick sanity checks.
X
Xif ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; }
X
X $installbin || die "No installbin directory in config.sh\n";
X-d $installbin || die "$installbin is not a directory\n";
X-w $installbin || die "$installbin is not writable by you\n"
X unless $installbin =~ m#^/afs/#;
X
X-x 'perl' || die "perl isn't executable!\n";
X-x 'taintperl' || die "taintperl isn't executable!\n";
X-x 'suidperl' || die "suidperl isn't executable!\n" if $d_dosuid;
X
X-x 't/TEST' || warn "WARNING: You've never run 'make test'!!!",
X " (Installing anyway.)\n";
X
X# First we install the version-numbered executables.
X
X$ver = sprintf("%5.3f", $]);
X
X&unlink("$installbin/perl$ver");
X&cmd("cp perl $installbin/perl$ver");
X
X&unlink("$installbin/tperl$ver");
X&cmd("cp taintperl $installbin/tperl$ver");
X&chmod(0755, "$installbin/tperl$ver"); # force non-suid for security
X
X&unlink("$installbin/sperl$ver");
Xif ($d_dosuid) {
X &cmd("cp suidperl $installbin/sperl$ver");
X &chmod(04711, "$installbin/sperl$ver");
X}
X
Xexit 0 if $versiononly;
X
X# Make links to ordinary names if installbin directory isn't current directory.
X
X($bdev,$bino) = stat($installbin);
X($ddev,$dino) = stat('.');
X
Xif ($bdev != $ddev || $bino != $dino) {
X &unlink("$installbin/perl", "$installbin/taintperl", "$installbin/suidperl");
X &link("$installbin/perl$ver", "$installbin/perl");
X &link("$installbin/tperl$ver", "$installbin/taintperl");
X &link("$installbin/sperl$ver", "$installbin/suidperl") if $d_dosuid;
X}
X
X# Make some enemies in the name of standardization. :-)
X
X($udev,$uino) = stat("/usr/bin");
X
Xif (-w _ && ($udev != $ddev || $uino != $dino) && !$nonono) {
X unlink "/usr/bin/perl";
X eval 'symlink("$installbin/perl", "/usr/bin/perl")' ||
X eval 'link("$installbin/perl", "/usr/bin/perl")' ||
X &cmd("cp $installbin/perl /usr/bin");
X}
X
X# Install scripts.
X
X&makedir($scriptdir);
X
Xfor (@scripts) {
X &cmd("cp $_ $scriptdir");
X &chmod(0755, "$scriptdir/$_");
X}
X
X# Install library files.
X
X&makedir($installprivlib);
X
X($pdev,$pino) = stat($installprivlib);
X
Xif ($pdev != $ddev || $pino != $dino) {
X &cmd("cd lib && cp *.pl $installprivlib");
X}
X
X# Install man pages.
X
Xif ($mansrc ne '') {
X &makedir($mansrc);
X
X ($mdev,$mino) = stat($mansrc);
X if ($mdev != $ddev || $mino != $dino) {
X for (@manpages) {
X ($new = $_) =~ s/man$/$manext/;
X print STDERR " Installing $mansrc/$new\n";
X next if $nonono;
X open(MI,$_);
X open(MO,">$mansrc/$new");
X print MO ".ds RP Release $release Patchlevel $patchlevel\n";
X while (<MI>) {
X print MO;
X }
X close MI;
X close MO;
X }
X }
X}
X
Xprint STDERR " Installation complete\n";
X
Xexit 0;
X
X###############################################################################
X
Xsub unlink {
X local(@names) = @_;
X
X foreach $name (@names) {
X next unless -e $name;
X print STDERR " unlink $name\n";
X unlink($name) || warn "Couldn't unlink $name: $!\n" unless $nonono;
X }
X}
X
Xsub cmd {
X local($cmd) = @_;
X print STDERR " $cmd\n";
X unless ($nonono) {
X system $cmd;
X warn "Command failed!!!\n" if $?;
X }
X}
X
Xsub link {
X local($from,$to) = @_;
X
X print STDERR " ln $from $to\n";
X link($from,$to) || warn "Couldn't link $from to $to: $!\n" unless $nonono;
X}
X
Xsub chmod {
X local($mode,$name) = @_;
X
X printf STDERR " chmod %o %s\n", $mode, $name;
X chmod($mode,$name) || warn "Couldn't chmod $mode $name: $!\n"
X unless $nonono;
X}
X
Xsub makedir {
X local($dir) = @_;
X unless (-d $dir) {
X local($shortdir) = $dir;
X
X $shortdir =~ s#(.*)/.*#$1#;
X &makedir($shortdir);
X
X print STDERR " mkdir $dir\n";
X mkdir($dir, 0777) || warn "Couldn't create $dir: $!\n" unless $nonono;
X }
X}
!STUFFY!FUNK!
echo Extracting lib/bigrat.pl
sed >lib/bigrat.pl <<'!STUFFY!FUNK!' -e 's/X//'
Xpackage bigrat;
Xrequire "bigint.pl";
X
X# Arbitrary size rational math package
X#
X# Input values to these routines consist of strings of the form
X# m|^\s*[+-]?[\d\s]+(/[\d\s]+)?$|.
X# Examples:
X# "+0/1" canonical zero value
X# "3" canonical value "+3/1"
X# " -123/123 123" canonical value "-1/1001"
X# "123 456/7890" canonical value "+20576/1315"
X# Output values always include a sign and no leading zeros or
X# white space.
X# This package makes use of the bigint package.
X# The string 'NaN' is used to represent the result when input arguments
X# that are not numbers, as well as the result of dividing by zero and
X# the sqrt of a negative number.
X# Extreamly naive algorthims are used.
X#
X# Routines provided are:
X#
X# rneg(RAT) return RAT negation
X# rabs(RAT) return RAT absolute value
X# rcmp(RAT,RAT) return CODE compare numbers (undef,<0,=0,>0)
X# radd(RAT,RAT) return RAT addition
X# rsub(RAT,RAT) return RAT subtraction
X# rmul(RAT,RAT) return RAT multiplication
X# rdiv(RAT,RAT) return RAT division
X# rmod(RAT) return (RAT,RAT) integer and fractional parts
X# rnorm(RAT) return RAT normalization
X# rsqrt(RAT, cycles) return RAT square root
X
X# Convert a number to the canonical string form m|^[+-]\d+/\d+|.
Xsub main'rnorm { #(string) return rat_num
X local($_) = @_;
X s/\s+//g;
X if (m#^([+-]?\d+)(/(\d*[1-9]0*))?$#) {
X &norm($1, $3 ? $3 : '+1');
X } else {
X 'NaN';
X }
X}
X
X# Normalize by reducing to lowest terms
Xsub norm { #(bint, bint) return rat_num
X local($num,$dom) = @_;
X if ($num eq 'NaN') {
X 'NaN';
X } elsif ($dom eq 'NaN') {
X 'NaN';
X } elsif ($dom =~ /^[+-]?0+$/) {
X 'NaN';
X } else {
X local($gcd) = &'bgcd($num,$dom);
X if ($gcd ne '+1') {
X $num = &'bdiv($num,$gcd);
X $dom = &'bdiv($dom,$gcd);
X } else {
X $num = &'bnorm($num);
X $dom = &'bnorm($dom);
X }
X substr($dom,0,1) = '';
X "$num/$dom";
X }
X}
X
X# negation
Xsub main'rneg { #(rat_num) return rat_num
X local($_) = &'rnorm($_[0]);
X tr/-+/+-/ if ($_ ne '+0/1');
X $_;
X}
X
X# absolute value
Xsub main'rabs { #(rat_num) return $rat_num
X local($_) = &'rnorm($_[0]);
X substr($_,0,1) = '+' unless $_ eq 'NaN';
X $_;
X}
X
X# multipication
Xsub main'rmul { #(rat_num, rat_num) return rat_num
X local($xn,$xd) = split('/',&'rnorm($_[0]));
X local($yn,$yd) = split('/',&'rnorm($_[1]));
X &norm(&'bmul($xn,$yn),&'bmul($xd,$yd));
X}
X
X# division
Xsub main'rdiv { #(rat_num, rat_num) return rat_num
X local($xn,$xd) = split('/',&'rnorm($_[0]));
X local($yn,$yd) = split('/',&'rnorm($_[1]));
X &norm(&'bmul($xn,$yd),&'bmul($xd,$yn));
X}
X
X# addition
Xsub main'radd { #(rat_num, rat_num) return rat_num
X local($xn,$xd) = split('/',&'rnorm($_[0]));
X local($yn,$yd) = split('/',&'rnorm($_[1]));
X &norm(&'badd(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
X}
X
X# subtraction
Xsub main'rsub { #(rat_num, rat_num) return rat_num
X local($xn,$xd) = split('/',&'rnorm($_[0]));
X local($yn,$yd) = split('/',&'rnorm($_[1]));
X &norm(&'bsub(&'bmul($xn,$yd),&'bmul($yn,$xd)),&'bmul($xd,$yd));
X}
X
X# comparison
Xsub main'rcmp { #(rat_num, rat_num) return cond_code
X local($xn,$xd) = split('/',&'rnorm($_[0]));
X local($yn,$yd) = split('/',&'rnorm($_[1]));
X &bigint'cmp(&'bmul($xn,$yd),&'bmul($yn,$xd));
X}
X
X# int and frac parts
Xsub main'rmod { #(rat_num) return (rat_num,rat_num)
X local($xn,$xd) = split('/',&'rnorm($_[0]));
X local($i,$f) = &'bdiv($xn,$xd);
X if (wantarray) {
X ("$i/1", "$f/$xd");
X } else {
X "$i/1";
X }
X}
X
X# square root by Newtons method.
X# cycles specifies the number of iterations default: 5
Xsub main'rsqrt { #(fnum_str[, cycles]) return fnum_str
X local($x, $scale) = (&'rnorm($_[0]), $_[1]);
X if ($x eq 'NaN') {
X 'NaN';
X } elsif ($x =~ /^-/) {
X 'NaN';
X } else {
X local($gscale, $guess) = (0, '+1/1');
X $scale = 5 if (!$scale);
X while ($gscale++ < $scale) {
X $guess = &'rmul(&'radd($guess,&'rdiv($x,$guess)),"+1/2");
X }
X "$guess"; # quotes necessary due to perl bug
X }
X}
X
X1;
!STUFFY!FUNK!
echo Extracting h2pl/eg/sys/ioctl.pl
sed >h2pl/eg/sys/ioctl.pl <<'!STUFFY!FUNK!' -e 's/X//'
X$_IOCTL_ = 0x1;
X$TIOCGSIZE = 0x40087468;
X$TIOCSSIZE = 0x80087467;
X$IOCPARM_MASK = 0x7F;
X$IOC_VOID = 0x20000000;
X$IOC_OUT = 0x40000000;
X$IOC_IN = 0x80000000;
X$IOC_INOUT = 0xC0000000;
X$TIOCGETD = 0x40047400;
X$TIOCSETD = 0x80047401;
X$TIOCHPCL = 0x20007402;
X$TIOCMODG = 0x40047403;
X$TIOCMODS = 0x80047404;
X$TIOCM_LE = 0x1;
X$TIOCM_DTR = 0x2;
X$TIOCM_RTS = 0x4;
X$TIOCM_ST = 0x8;
X$TIOCM_SR = 0x10;
X$TIOCM_CTS = 0x20;
X$TIOCM_CAR = 0x40;
X$TIOCM_CD = 0x40;
X$TIOCM_RNG = 0x80;
X$TIOCM_RI = 0x80;
X$TIOCM_DSR = 0x100;
X$TIOCGETP = 0x40067408;
X$TIOCSETP = 0x80067409;
X$TIOCSETN = 0x8006740A;
X$TIOCEXCL = 0x2000740D;
X$TIOCNXCL = 0x2000740E;
X$TIOCFLUSH = 0x80047410;
X$TIOCSETC = 0x80067411;
X$TIOCGETC = 0x40067412;
X$TIOCSET = 0x80047413;
X$TIOCBIS = 0x80047414;
X$TIOCBIC = 0x80047415;
X$TIOCGET = 0x40047416;
X$TANDEM = 0x1;
X$CBREAK = 0x2;
X$LCASE = 0x4;
X$ECHO = 0x8;
X$CRMOD = 0x10;
X$RAW = 0x20;
X$ODDP = 0x40;
X$EVENP = 0x80;
X$ANYP = 0xC0;
X$NLDELAY = 0x300;
X$NL0 = 0x0;
X$NL1 = 0x100;
X$NL2 = 0x200;
X$NL3 = 0x300;
X$TBDELAY = 0xC00;
X$TAB0 = 0x0;
X$TAB1 = 0x400;
X$TAB2 = 0x800;
X$XTABS = 0xC00;
X$CRDELAY = 0x3000;
X$CR0 = 0x0;
X$CR1 = 0x1000;
X$CR2 = 0x2000;
X$CR3 = 0x3000;
X$VTDELAY = 0x4000;
X$FF0 = 0x0;
X$FF1 = 0x4000;
X$BSDELAY = 0x8000;
X$BS0 = 0x0;
X$BS1 = 0x8000;
X$ALLDELAY = 0xFF00;
X$CRTBS = 0x10000;
X$PRTERA = 0x20000;
X$CRTERA = 0x40000;
X$TILDE = 0x80000;
X$MDMBUF = 0x100000;
X$LITOUT = 0x200000;
X$TOSTOP = 0x400000;
X$FLUSHO = 0x800000;
X$NOHANG = 0x1000000;
X$L001000 = 0x2000000;
X$CRTKIL = 0x4000000;
X$L004000 = 0x8000000;
X$CTLECH = 0x10000000;
X$PENDIN = 0x20000000;
X$DECCTQ = 0x40000000;
X$NOFLSH = 0x80000000;
X$TIOCCSET = 0x800E7417;
X$TIOCCGET = 0x400E7418;
X$TIOCLBIS = 0x8004747F;
X$TIOCLBIC = 0x8004747E;
X$TIOCLSET = 0x8004747D;
X$TIOCLGET = 0x4004747C;
X$LCRTBS = 0x1;
X$LPRTERA = 0x2;
X$LCRTERA = 0x4;
X$LTILDE = 0x8;
X$LMDMBUF = 0x10;
X$LLITOUT = 0x20;
X$LTOSTOP = 0x40;
X$LFLUSHO = 0x80;
X$LNOHANG = 0x100;
X$LCRTKIL = 0x400;
X$LCTLECH = 0x1000;
X$LPENDIN = 0x2000;
X$LDECCTQ = 0x4000;
X$LNOFLSH = 0x8000;
X$TIOCSBRK = 0x2000747B;
X$TIOCCBRK = 0x2000747A;
X$TIOCSDTR = 0x20007479;
X$TIOCCDTR = 0x20007478;
X$TIOCGPGRP = 0x40047477;
X$TIOCSPGRP = 0x80047476;
X$TIOCSLTC = 0x80067475;
X$TIOCGLTC = 0x40067474;
X$TIOCOUTQ = 0x40047473;
X$TIOCSTI = 0x80017472;
X$TIOCNOTTY = 0x20007471;
X$TIOCPKT = 0x80047470;
X$TIOCPKT_DATA = 0x0;
X$TIOCPKT_FLUSHREAD = 0x1;
X$TIOCPKT_FLUSHWRITE = 0x2;
X$TIOCPKT_STOP = 0x4;
X$TIOCPKT_START = 0x8;
X$TIOCPKT_NOSTOP = 0x10;
X$TIOCPKT_DOSTOP = 0x20;
X$TIOCSTOP = 0x2000746F;
X$TIOCSTART = 0x2000746E;
X$TIOCREMOTE = 0x20007469;
X$TIOCGWINSZ = 0x40087468;
X$TIOCSWINSZ = 0x80087467;
X$TIOCRESET = 0x20007466;
X$OTTYDISC = 0x0;
X$NETLDISC = 0x1;
X$NTTYDISC = 0x2;
X$FIOCLEX = 0x20006601;
X$FIONCLEX = 0x20006602;
X$FIONREAD = 0x4004667F;
X$FIONBIO = 0x8004667E;
X$FIOASYNC = 0x8004667D;
X$FIOSETOWN = 0x8004667C;
X$FIOGETOWN = 0x4004667B;
X$STPUTTABLE = 0x8004667A;
X$STGETTABLE = 0x80046679;
X$SIOCSHIWAT = 0x80047300;
X$SIOCGHIWAT = 0x40047301;
X$SIOCSLOWAT = 0x80047302;
X$SIOCGLOWAT = 0x40047303;
X$SIOCATMARK = 0x40047307;
X$SIOCSPGRP = 0x80047308;
X$SIOCGPGRP = 0x40047309;
X$SIOCADDRT = 0x8034720A;
X$SIOCDELRT = 0x8034720B;
X$SIOCSIFADDR = 0x8020690C;
X$SIOCGIFADDR = 0xC020690D;
X$SIOCSIFDSTADDR = 0x8020690E;
X$SIOCGIFDSTADDR = 0xC020690F;
X$SIOCSIFFLAGS = 0x80206910;
X$SIOCGIFFLAGS = 0xC0206911;
X$SIOCGIFBRDADDR = 0xC0206912;
X$SIOCSIFBRDADDR = 0x80206913;
X$SIOCGIFCONF = 0xC0086914;
X$SIOCGIFNETMASK = 0xC0206915;
X$SIOCSIFNETMASK = 0x80206916;
X$SIOCGIFMETRIC = 0xC0206917;
X$SIOCSIFMETRIC = 0x80206918;
X$SIOCSARP = 0x8024691E;
X$SIOCGARP = 0xC024691F;
X$SIOCDARP = 0x80246920;
X$PIXCONTINUE = 0x80747000;
X$PIXSTEP = 0x80747001;
X$PIXTERMINATE = 0x20007002;
X$PIGETFLAGS = 0x40747003;
X$PIXINHERIT = 0x80747004;
X$PIXDETACH = 0x20007005;
X$PIXGETSUBCODE = 0xC0747006;
X$PIXRDREGS = 0xC0747007;
X$PIXWRREGS = 0xC0747008;
X$PIXRDVREGS = 0xC0747009;
X$PIXWRVREGS = 0xC074700A;
X$PIXRDVSTATE = 0xC074700B;
X$PIXWRVSTATE = 0xC074700C;
X$PIXRDCREGS = 0xC074700D;
X$PIXWRCREGS = 0xC074700E;
X$PIRDSDRS = 0xC074700F;
X$PIXGETSIGACTION = 0xC0747010;
X$PIGETU = 0xC0747011;
X$PISETRWTID = 0xC0747012;
X$PIXGETTHCOUNT = 0xC0747013;
X$PIXRUN = 0x20007014;
!STUFFY!FUNK!
echo Extracting os2/alarm.c
sed >os2/alarm.c <<'!STUFFY!FUNK!' -e 's/X//'
X/*
X * This software is Copyright 1989 by Jack Hudler.
X *
X * Permission is hereby granted to copy, reproduce, redistribute or otherwise
X * use this software as long as: there is no monetary profit gained
X * specifically from the use or reproduction or this software, it is not
X * sold, rented, traded or otherwise marketed, and this copyright notice is
X * included prominently in any copy made.
X *
X * The author make no claims as to the fitness or correctness of this software
X * for any use whatsoever, and it is provided as is. Any use of this software
X * is at the user's own risk.
X *
X */
X
X/****************************** Module Header ******************************\
X* Module Name: alarm.c
X* Created : 11-08-89
X* Author : Jack Hudler [jack@csccat.lonestar.org]
X* Copyright : 1988 Jack Hudler.
X* Function : Unix like alarm signal simulator.
X\***************************************************************************/
X
X/* Tested using OS2 1.2 with Microsoft C 5.1 and 6.0. */
X
X#define INCL_DOSPROCESS
X#define INCL_DOSSIGNALS
X#define INCL_DOS
X#include <os2.h>
X
X#include <stdlib.h>
X#include <stdio.h>
X#include <signal.h>
X
X#include "alarm.h"
X
X#define ALARM_STACK 4096 /* This maybe over kill, but the page size is 4K */
X
Xstatic PBYTE pbAlarmStack;
Xstatic SEL selAlarmStack;
Xstatic TID tidAlarm;
Xstatic PID pidMain;
Xstatic BOOL bAlarmInit=FALSE;
Xstatic BOOL bAlarmRunning=FALSE;
Xstatic USHORT uTime;
X
Xstatic VOID FAR alarm_thread ( VOID )
X{
X while(1)
X {
X if (bAlarmRunning)
X {
X DosSleep(1000L);
X uTime--;
X if (uTime==0L)
X {
X // send signal to the main process.. I could have put raise() here
X // however that would require the use of the multithreaded library,
X // and it does not contain raise()!
X // I tried it with the standard library, this signaled ok, but a
X // test printf in the signal would not work and even caused SEGV.
X // So I signal the process through OS/2 and then the process
X // signals itself.
X if (bAlarmRunning)
X DosFlagProcess(pidMain,FLGP_PID, PFLG_A,1);
X bAlarmRunning=FALSE;
X }
X }
X else
X DosSleep(500L);
X }
X}
X
Xstatic VOID PASCAL FAR AlarmSignal(USHORT usSigArg,USHORT usSigNum)
X{
X /*
X * this is not executed from the thread. The thread triggers Process
X * flag A which is in the main processes scope, this inturn triggers
X * (via the raise) SIGUSR1 which is defined to SIGALRM.
X */
X raise(SIGUSR1);
X}
X
Xstatic void alarm_init(void)
X{
X PFNSIGHANDLER pfnPrev;
X USHORT pfAction;
X PIDINFO pid;
X
X bAlarmInit = TRUE;
X
X if (!DosAllocSeg( ALARM_STACK, (PSEL) &selAlarmStack, SEG_NONSHARED ))
X {
X OFFSETOF(pbAlarmStack) = ALARM_STACK - 2;
X SELECTOROF(pbAlarmStack) = selAlarmStack;
X /* Create the thread */
X if (DosCreateThread( alarm_thread, &tidAlarm, pbAlarmStack ))
X {
X fprintf(stderr,"Alarm thread failed to start.\n");
X exit(1);
X }
X /* Setup the signal handler for Process Flag A */
X if (DosSetSigHandler(AlarmSignal,&pfnPrev,&pfAction,SIGA_ACCEPT,SIG_PFLG_A))
X {
X fprintf(stderr,"SigHandler Failed to install.\n");
X exit(1);
X }
X /* Save main process ID, we'll need it for triggering the signal */
X DosGetPID(&pid);
X pidMain = pid.pid;
X }
X else
X exit(1);
X}
X
Xunsigned alarm(unsigned sec)
X{
X if (!bAlarmInit) alarm_init();
X
X if (sec)
X {
X uTime = sec;
X bAlarmRunning = TRUE;
X }
X else
X bAlarmRunning = FALSE;
X
X return 0;
X}
X
X#ifdef TESTING
X/* A simple test to see if it works */
XBOOL x;
X
Xvoid timeout(void)
X{
X fprintf(stderr,"ALARM TRIGGERED!!\n");
X DosBeep(1000,500);
X x++;
X}
X
Xvoid main(void)
X{
X (void) signal(SIGALRM, timeout);
X (void) alarm(1L);
X printf("ALARM RUNNING!!\n");
X while(!x);
X}
X#endif
!STUFFY!FUNK!
echo Extracting t/op/array.t
sed >t/op/array.t <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: array.t,v 4.0 91/03/20 01:51:31 lwall Locked $
X
Xprint "1..36\n";
X
X@ary = (1,2,3,4,5);
Xif (join('',@ary) eq '12345') {print "ok 1\n";} else {print "not ok 1\n";}
X
X$tmp = $ary[$#ary]; --$#ary;
Xif ($tmp == 5) {print "ok 2\n";} else {print "not ok 2\n";}
Xif ($#ary == 3) {print "ok 3\n";} else {print "not ok 3\n";}
Xif (join('',@ary) eq '1234') {print "ok 4\n";} else {print "not ok 4\n";}
X
X$[ = 1;
X@ary = (1,2,3,4,5);
Xif (join('',@ary) eq '12345') {print "ok 5\n";} else {print "not ok 5\n";}
X
X$tmp = $ary[$#ary]; --$#ary;
Xif ($tmp == 5) {print "ok 6\n";} else {print "not ok 6\n";}
Xif ($#ary == 4) {print "ok 7\n";} else {print "not ok 7\n";}
Xif (join('',@ary) eq '1234') {print "ok 8\n";} else {print "not ok 8\n";}
X
Xif ($ary[5] eq '') {print "ok 9\n";} else {print "not ok 9\n";}
X
X$#ary += 1; # see if we can recover element 5
Xif ($#ary == 5) {print "ok 10\n";} else {print "not ok 10\n";}
Xif ($ary[5] == 5) {print "ok 11\n";} else {print "not ok 11\n";}
X
X$[ = 0;
X@foo = ();
X$r = join(',', $#foo, @foo);
Xif ($r eq "-1") {print "ok 12\n";} else {print "not ok 12 $r\n";}
X$foo[0] = '0';
X$r = join(',', $#foo, @foo);
Xif ($r eq "0,0") {print "ok 13\n";} else {print "not ok 13 $r\n";}
X$foo[2] = '2';
X$r = join(',', $#foo, @foo);
Xif ($r eq "2,0,,2") {print "ok 14\n";} else {print "not ok 14 $r\n";}
X@bar = ();
X$bar[0] = '0';
X$bar[1] = '1';
X$r = join(',', $#bar, @bar);
Xif ($r eq "1,0,1") {print "ok 15\n";} else {print "not ok 15 $r\n";}
X@bar = ();
X$r = join(',', $#bar, @bar);
Xif ($r eq "-1") {print "ok 16\n";} else {print "not ok 16 $r\n";}
X$bar[0] = '0';
X$r = join(',', $#bar, @bar);
Xif ($r eq "0,0") {print "ok 17\n";} else {print "not ok 17 $r\n";}
X$bar[2] = '2';
X$r = join(',', $#bar, @bar);
Xif ($r eq "2,0,,2") {print "ok 18\n";} else {print "not ok 18 $r\n";}
Xreset 'b';
X@bar = ();
X$bar[0] = '0';
X$r = join(',', $#bar, @bar);
Xif ($r eq "0,0") {print "ok 19\n";} else {print "not ok 19 $r\n";}
X$bar[2] = '2';
X$r = join(',', $#bar, @bar);
Xif ($r eq "2,0,,2") {print "ok 20\n";} else {print "not ok 20 $r\n";}
X
X$foo = 'now is the time';
Xif (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)) {
X if ($F1 eq 'now' && $F2 eq 'is' && $Etc eq 'the time') {
X print "ok 21\n";
X }
X else {
X print "not ok 21\n";
X }
X}
Xelse {
X print "not ok 21\n";
X}
X
X$foo = 'lskjdf';
Xif ($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))) {
X print "not ok 22 $cnt $F1:$F2:$Etc\n";
X}
Xelse {
X print "ok 22\n";
X}
X
X%foo = ('blurfl','dyick','foo','bar','etc.','etc.');
X%bar = %foo;
Xprint $bar{'foo'} eq 'bar' ? "ok 23\n" : "not ok 23\n";
X%bar = ();
Xprint $bar{'foo'} eq '' ? "ok 24\n" : "not ok 24\n";
X(%bar,$a,$b) = (%foo,'how','now');
Xprint $bar{'foo'} eq 'bar' ? "ok 25\n" : "not ok 25\n";
Xprint $bar{'how'} eq 'now' ? "ok 26\n" : "not ok 26\n";
X@bar{keys %foo} = values %foo;
Xprint $bar{'foo'} eq 'bar' ? "ok 27\n" : "not ok 27\n";
Xprint $bar{'how'} eq 'now' ? "ok 28\n" : "not ok 28\n";
X
X@foo = grep(/e/,split(' ','now is the time for all good men to come to'));
Xprint join(' ',@foo) eq 'the time men come' ? "ok 29\n" : "not ok 29\n";
X
X@foo = grep(!/e/,split(' ','now is the time for all good men to come to'));
Xprint join(' ',@foo) eq 'now is for all good to to' ? "ok 30\n" : "not ok 30\n";
X
X$foo = join('',('a','b','c','d','e','f')[0..5]);
Xprint $foo eq 'abcdef' ? "ok 31\n" : "not ok 31\n";
X
X$foo = join('',('a','b','c','d','e','f')[0..1]);
Xprint $foo eq 'ab' ? "ok 32\n" : "not ok 32\n";
X
X$foo = join('',('a','b','c','d','e','f')[6]);
Xprint $foo eq '' ? "ok 33\n" : "not ok 33\n";
X
X@foo = ('a','b','c','d','e','f')[0,2,4];
X@bar = ('a','b','c','d','e','f')[1,3,5];
X$foo = join('',(@foo,@bar)[0..5]);
Xprint $foo eq 'acebdf' ? "ok 34\n" : "not ok 34\n";
X
X$foo = ('a','b','c','d','e','f')[0,2,4];
Xprint $foo eq 'e' ? "ok 35\n" : "not ok 35\n";
X
X$foo = ('a','b','c','d','e','f')[1];
Xprint $foo eq 'b' ? "ok 36\n" : "not ok 36\n";
!STUFFY!FUNK!
echo Extracting lib/timelocal.pl
sed >lib/timelocal.pl <<'!STUFFY!FUNK!' -e 's/X//'
X;# timelocal.pl
X;#
X;# Usage:
X;# $time = timelocal($sec,$min,$hours,$mday,$mon,$year,$junk,$junk,$isdst);
X;# $time = timegm($sec,$min,$hours,$mday,$mon,$year);
X
X;# These routines are quite efficient and yet are always guaranteed to agree
X;# with localtime() and gmtime(). We manage this by caching the start times
X;# of any months we've seen before. If we know the start time of the month,
X;# we can always calculate any time within the month. The start times
X;# themselves are guessed by successive approximation starting at the
X;# current time, since most dates seen in practice are close to the
X;# current date. Unlike algorithms that do a binary search (calling gmtime
X;# once for each bit of the time value, resulting in 32 calls), this algorithm
X;# calls it at most 6 times, and usually only once or twice. If you hit
X;# the month cache, of course, it doesn't call it at all.
X
X;# timelocal is implemented using the same cache. We just assume that we're
X;# translating a GMT time, and then fudge it when we're done for the timezone
X;# and daylight savings arguments. The timezone is determined by examining
X;# the result of localtime(0) when the package is initialized. The daylight
X;# savings offset is currently assumed to be one hour.
X
XCONFIG: {
X package timelocal;
X
X @epoch = localtime(0);
X $tzmin = $epoch[2] * 60 + $epoch[1]; # minutes east of GMT
X if ($tzmin > 0) {
X $tzmin = 24 * 60 - $tzmin; # minutes west of GMT
X $tzmin -= 24 * 60 if $epoch[5] == 70; # account for the date line
X }
X
X $SEC = 1;
X $MIN = 60 * $SEC;
X $HR = 60 * $MIN;
X $DAYS = 24 * $HR;
X}
X
Xsub timegm {
X package timelocal;
X
X $ym = pack(C2, @_[5,4]);
X $cheat = $cheat{$ym} || &cheat;
X $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS;
X}
X
Xsub timelocal {
X package timelocal;
X
X $ym = pack(C2, @_[5,4]);
X $cheat = $cheat{$ym} || &cheat;
X $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS
X + $tzmin * $MIN - 60 * 60 * ($_[8] != 0);
X}
X
Xpackage timelocal;
X
Xsub cheat {
X $year = $_[5];
X $month = $_[4];
X $guess = $^T;
X @g = gmtime($guess);
X while ($diff = $year - $g[5]) {
X $guess += $diff * (364 * $DAYS);
X @g = gmtime($guess);
X }
X while ($diff = $month - $g[4]) {
X $guess += $diff * (28 * $DAYS);
X @g = gmtime($guess);
X }
X $g[3]--;
X $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAYS;
X $cheat{$ym} = $guess;
X}
!STUFFY!FUNK!
echo " "
echo "End of kit 31 (of 36)"
cat /dev/null >kit31isdone
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.
