Usenet 1994 October/usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso/misc/volume18/perl/part31

Internet Message Format | 1991-04-17 | 49.5 KB

From: [e-mail] (Larry Wall)
Newsgroups: comp.sources.misc
Subject: v18i049:  perl - The perl programming language, Part31/36
Message-ID: <[e-mail]>
Date: 17 Apr 91 18:58:46 GMT
Approved: [e-mail]
X-Checksum-Snefru: 197883e2 db2142ff 6a702370 8691e194

Submitted-by: Larry Wall <[e-mail]>
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:[phone]
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:[phone]
X&babs
Xabc:NaN
X+0:+0
X+1:+1
X-1:+1
X+123456789:[phone]
X-123456789:[phone]
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:[phone]
X+99999999:+1:[phone]
X+999999999:+1:[phone]
X+9999999999:+1:[phone]
X+99999999999:+1:[phone]
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:[phone]
X+1000000000:-1:[phone]
X+10000000000:-1:[phone]
X+123456789:[phone]:[phone]
X-123456789:[phone]:[phone]
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:[phone]
X+999999999:+1:[phone]
X+9999999999:+1:[phone]
X+99999999999:+1:[phone]
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:[phone]
X+100000000:-1:[phone]
X+1000000000:-1:[phone]
X+10000000000:-1:[phone]
X+123456789:[phone]:-864197532
X-123456789:[phone]:-1111111110
X-123456789:-987654321:[phone]
X+123456789:-987654321:[phone]
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:[phone]
X+1001001:+1001001:[phone]
X+100010001:[phone]:+10002000300020001
X+10000100001:[phone]:+100002000030000200001
X+11111111111:+9:[phone]
X+22222222222:+9:[phone]
X+33333333333:+9:[phone]
X+44444444444:+9:[phone]
X+55555555555:+9:[phone]
X+66666666666:+9:[phone]
X+77777777777:+9:[phone]
X+88888888888:+9:[phone]
X+99999999999:+9:[phone]
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:[phone]
X+2000000000:+9:[phone]
X+3000000000:+9:[phone]
X+4000000000:+9:[phone]
X+5000000000:+9:[phone]
X+6000000000:+9:[phone]
X+7000000000:+9:[phone]
X+8000000000:+9:[phone]
X+9000000000:+9:[phone]
X+35500000:+113:+314159
X+71000000:+226:+314159
X+106500000:+339:+314159
X+1000000000:+3:[phone]
X+10:+5:+2
X+100:+4:+25
X+1000:+8:+125
X+10000:+16:+625
X+999999999999:+9:[phone]
X+999999999999:+99:[phone]
X+999999999999:+999:[phone]
X+999999999999:+9999:[phone]
X+999999999999999:+99999:[phone]
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  [[e-mail]]
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: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].