perl 3.0 patch #22
Larry Wall
lwall at jpl-devvax.JPL.NASA.GOV
Sat Aug 11 07:27:59 AEST 1990
System: perl version 3.0
Patch #: 22
Priority:
Subject: patch #19, continued
Description:
See patch #19.
Fix: From rn, say "| patch -p -N -d DIR", where DIR is your perl source
directory. Outside of rn, say "cd DIR; patch -p -N <thisarticle".
If you don't have the patch program, apply the following by hand,
or get patch (version 2.0, latest patchlevel).
After patching:
*** DO NOTHING--INSTALL ALL PATCHES UP THROUGH #27 FIRST ***
If patch indicates that patchlevel is the wrong version, you may need
to apply one or more previous patches, or the patch may already
have been applied. See the patchlevel.h file to find out what has or
has not been applied. In any event, don't continue with the patch.
If you are missing previous patches they can be obtained from me:
Larry Wall
lwall at jpl-devvax.jpl.nasa.gov
If you send a mail message of the following form it will greatly speed
processing:
Subject: Command
@SH mailpatch PATH perl 3.0 LIST
^ note the c
where PATH is a return path FROM ME TO YOU either in Internet notation,
or in bang notation from some well-known host, and LIST is the number
of one or more patches you need, separated by spaces, commas, and/or
hyphens. Saying 35- says everything from 35 to the end.
You can also get the patches via anonymous FTP from
jpl-devvax.jpl.nasa.gov (128.149.1.143).
Index: patchlevel.h
Prereq: 21
1c1
< #define PATCHLEVEL 21
---
> #define PATCHLEVEL 22
Index: lib/dumpvar.pl
*** lib/dumpvar.pl.old Thu Aug 9 06:00:26 1990
--- lib/dumpvar.pl Thu Aug 9 06:00:27 1990
***************
*** 1,18 ****
package dumpvar;
sub main'dumpvar {
! ($package) = @_;
local(*stab) = eval("*_$package");
while (($key,$val) = each(%stab)) {
{
local(*entry) = $val;
if (defined $entry) {
! print "\$$key = '$entry'\n";
}
if (defined @entry) {
print "\@$key = (\n";
foreach $num ($[ .. $#entry) {
! print " $num\t'",$entry[$num],"'\n";
}
print ")\n";
}
--- 1,25 ----
package dumpvar;
+ # translate control chars to ^X - Randal Schwartz
+ sub unctrl {
+ local($_) = @_;
+ s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
+ $_;
+ }
sub main'dumpvar {
! ($package, at vars) = @_;
local(*stab) = eval("*_$package");
while (($key,$val) = each(%stab)) {
{
+ next if @vars && !grep($key eq $_, at vars);
local(*entry) = $val;
if (defined $entry) {
! print "\$$key = '",&unctrl($entry),"'\n";
}
if (defined @entry) {
print "\@$key = (\n";
foreach $num ($[ .. $#entry) {
! print " $num\t'",&unctrl($entry[$num]),"'\n";
}
print ")\n";
}
***************
*** 19,25 ****
if ($key ne "_$package" && defined %entry) {
print "\%$key = (\n";
foreach $key (sort keys(%entry)) {
! print " $key\t'",$entry{$key},"'\n";
}
print ")\n";
}
--- 26,32 ----
if ($key ne "_$package" && defined %entry) {
print "\%$key = (\n";
foreach $key (sort keys(%entry)) {
! print " $key\t'",&unctrl($entry{$key}),"'\n";
}
print ")\n";
}
Index: h2pl/eg/sys/errno.pl
*** h2pl/eg/sys/errno.pl.old Thu Aug 9 05:59:33 1990
--- h2pl/eg/sys/errno.pl Thu Aug 9 05:59:34 1990
***************
*** 0 ****
--- 1,92 ----
+ $EPERM = 0x1;
+ $ENOENT = 0x2;
+ $ESRCH = 0x3;
+ $EINTR = 0x4;
+ $EIO = 0x5;
+ $ENXIO = 0x6;
+ $E2BIG = 0x7;
+ $ENOEXEC = 0x8;
+ $EBADF = 0x9;
+ $ECHILD = 0xA;
+ $EAGAIN = 0xB;
+ $ENOMEM = 0xC;
+ $EACCES = 0xD;
+ $EFAULT = 0xE;
+ $ENOTBLK = 0xF;
+ $EBUSY = 0x10;
+ $EEXIST = 0x11;
+ $EXDEV = 0x12;
+ $ENODEV = 0x13;
+ $ENOTDIR = 0x14;
+ $EISDIR = 0x15;
+ $EINVAL = 0x16;
+ $ENFILE = 0x17;
+ $EMFILE = 0x18;
+ $ENOTTY = 0x19;
+ $ETXTBSY = 0x1A;
+ $EFBIG = 0x1B;
+ $ENOSPC = 0x1C;
+ $ESPIPE = 0x1D;
+ $EROFS = 0x1E;
+ $EMLINK = 0x1F;
+ $EPIPE = 0x20;
+ $EDOM = 0x21;
+ $ERANGE = 0x22;
+ $EWOULDBLOCK = 0x23;
+ $EINPROGRESS = 0x24;
+ $EALREADY = 0x25;
+ $ENOTSOCK = 0x26;
+ $EDESTADDRREQ = 0x27;
+ $EMSGSIZE = 0x28;
+ $EPROTOTYPE = 0x29;
+ $ENOPROTOOPT = 0x2A;
+ $EPROTONOSUPPORT = 0x2B;
+ $ESOCKTNOSUPPORT = 0x2C;
+ $EOPNOTSUPP = 0x2D;
+ $EPFNOSUPPORT = 0x2E;
+ $EAFNOSUPPORT = 0x2F;
+ $EADDRINUSE = 0x30;
+ $EADDRNOTAVAIL = 0x31;
+ $ENETDOWN = 0x32;
+ $ENETUNREACH = 0x33;
+ $ENETRESET = 0x34;
+ $ECONNABORTED = 0x35;
+ $ECONNRESET = 0x36;
+ $ENOBUFS = 0x37;
+ $EISCONN = 0x38;
+ $ENOTCONN = 0x39;
+ $ESHUTDOWN = 0x3A;
+ $ETOOMANYREFS = 0x3B;
+ $ETIMEDOUT = 0x3C;
+ $ECONNREFUSED = 0x3D;
+ $ELOOP = 0x3E;
+ $ENAMETOOLONG = 0x3F;
+ $EHOSTDOWN = 0x40;
+ $EHOSTUNREACH = 0x41;
+ $ENOTEMPTY = 0x42;
+ $EPROCLIM = 0x43;
+ $EUSERS = 0x44;
+ $EDQUOT = 0x45;
+ $ESTALE = 0x46;
+ $EREMOTE = 0x47;
+ $EDEADLK = 0x48;
+ $ENOLCK = 0x49;
+ $MTH_UNDEF_SQRT = 0x12C;
+ $MTH_OVF_EXP = 0x12D;
+ $MTH_UNDEF_LOG = 0x12E;
+ $MTH_NEG_BASE = 0x12F;
+ $MTH_ZERO_BASE = 0x130;
+ $MTH_OVF_POW = 0x131;
+ $MTH_LRG_SIN = 0x132;
+ $MTH_LRG_COS = 0x133;
+ $MTH_LRG_TAN = 0x134;
+ $MTH_LRG_COT = 0x135;
+ $MTH_OVF_TAN = 0x136;
+ $MTH_OVF_COT = 0x137;
+ $MTH_UNDEF_ASIN = 0x138;
+ $MTH_UNDEF_ACOS = 0x139;
+ $MTH_UNDEF_ATAN2 = 0x13A;
+ $MTH_OVF_SINH = 0x13B;
+ $MTH_OVF_COSH = 0x13C;
+ $MTH_UNDEF_ZLOG = 0x13D;
+ $MTH_UNDEF_ZDIV = 0x13E;
Index: eval.c
Prereq: 3.0.1.6
*** eval.c.old Thu Aug 9 05:58:41 1990
--- eval.c Thu Aug 9 05:58:47 1990
***************
*** 1,4 ****
! /* $Header: eval.c,v 3.0.1.6 90/03/27 15:53:51 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
--- 1,4 ----
! /* $Header: eval.c,v 3.0.1.7 90/08/09 03:33:44 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
***************
*** 6,11 ****
--- 6,21 ----
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: eval.c,v $
+ * Revision 3.0.1.7 90/08/09 03:33:44 lwall
+ * patch19: made ~ do vector operation on strings like &, | and ^
+ * patch19: dbmopen(%name...) didn't work right
+ * patch19: dbmopen(name, 'filename', undef) now refrains from creating
+ * patch19: empty %array now returns 0 in scalar context
+ * patch19: die with no arguments no longer exits unconditionally
+ * patch19: return outside a subroutine now returns a reasonable message
+ * patch19: rename done with unlink()/link()/unlink() now checks for clobbering
+ * patch19: -s now returns size of file
+ *
* Revision 3.0.1.6 90/03/27 15:53:51 lwall
* patch16: MSDOS support
* patch16: support for machines that can't cast negative floats to unsigned ints
***************
*** 50,56 ****
--- 60,68 ----
#include "EXTERN.h"
#include "perl.h"
+ #ifndef NSIG
#include <signal.h>
+ #endif
#ifdef I_FCNTL
#include <fcntl.h>
***************
*** 282,288 ****
if (when >= 0)
value = (double)(when % tmplong);
else
! value = (double)(tmplong - (-when % tmplong));
#endif
goto donumset;
case O_ADD:
--- 294,300 ----
if (when >= 0)
value = (double)(when % tmplong);
else
! value = (double)(tmplong - ((-when - 1) % tmplong)) - 1;
#endif
goto donumset;
case O_ADD:
***************
*** 440,449 ****
value = (double) !str_true(st[1]);
goto donumset;
case O_COMPLEMENT:
#ifndef lint
! value = (double) ~U_L(str_gnum(st[1]));
#endif
! goto donumset;
case O_SELECT:
tmps = stab_name(defoutstab);
if (maxarg > 0) {
--- 452,470 ----
value = (double) !str_true(st[1]);
goto donumset;
case O_COMPLEMENT:
+ if (!sawvec || st[1]->str_nok) {
#ifndef lint
! value = (double) ~U_L(str_gnum(st[1]));
#endif
! goto donumset;
! }
! else {
! STR_SSET(str,st[1]);
! tmps = str_get(str);
! for (anum = str->str_cur; anum; anum--)
! *tmps = ~*tmps;
! }
! break;
case O_SELECT:
tmps = stab_name(defoutstab);
if (maxarg > 0) {
***************
*** 503,513 ****
break;
case O_DBMOPEN:
#ifdef SOME_DBM
! if ((arg[1].arg_type & A_MASK) == A_WORD)
! stab = arg[1].arg_ptr.arg_stab;
else
! stab = stabent(str_get(st[1]),TRUE);
! anum = (int)str_gnum(st[3]);
value = (double)hdbmopen(stab_hash(stab),str_get(st[2]),anum);
goto donumset;
#else
--- 524,534 ----
break;
case O_DBMOPEN:
#ifdef SOME_DBM
! stab = arg[1].arg_ptr.arg_stab;
! if (st[3]->str_nok || st[3]->str_pok)
! anum = (int)str_gnum(st[3]);
else
! anum = -1;
value = (double)hdbmopen(stab_hash(stab),str_get(st[2]),anum);
goto donumset;
#else
***************
*** 515,524 ****
#endif
case O_DBMCLOSE:
#ifdef SOME_DBM
! if ((arg[1].arg_type & A_MASK) == A_WORD)
! stab = arg[1].arg_ptr.arg_stab;
! else
! stab = stabent(str_get(st[1]),TRUE);
hdbmclose(stab_hash(stab));
goto say_yes;
#else
--- 536,542 ----
#endif
case O_DBMCLOSE:
#ifdef SOME_DBM
! stab = arg[1].arg_ptr.arg_stab;
hdbmclose(stab_hash(stab));
goto say_yes;
#else
***************
*** 539,545 ****
goto say_zero;
else
goto say_undef;
! break;
case O_TRANS:
value = (double) do_trans(str,arg);
str = arg->arg_ptr.arg_str;
--- 557,563 ----
goto say_zero;
else
goto say_undef;
! /* break; */
case O_TRANS:
value = (double) do_trans(str,arg);
str = arg->arg_ptr.arg_str;
***************
*** 582,588 ****
astore(stack,sp + maxarg, Nullstr);
st = stack->ary_array;
}
! Copy(ary->ary_array, &st[sp+1], maxarg, STR*);
sp += maxarg;
goto array_return;
}
--- 600,607 ----
astore(stack,sp + maxarg, Nullstr);
st = stack->ary_array;
}
! st += sp;
! Copy(ary->ary_array, &st[1], maxarg, STR*);
sp += maxarg;
goto array_return;
}
***************
*** 618,623 ****
--- 637,644 ----
}
else {
tmpstab = arg[1].arg_ptr.arg_stab;
+ if (!stab_hash(tmpstab)->tbl_fill)
+ goto say_zero;
sprintf(buf,"%d/%d",stab_hash(tmpstab)->tbl_fill,
stab_hash(tmpstab)->tbl_max+1);
str_set(str,buf);
***************
*** 677,683 ****
gimme,arglast);
goto array_return;
case O_SPLICE:
! sp = do_splice(stab_array(arg[1].arg_ptr.arg_stab),str,gimme,arglast);
goto array_return;
case O_PUSH:
if (arglast[2] - arglast[1] != 1)
--- 698,704 ----
gimme,arglast);
goto array_return;
case O_SPLICE:
! sp = do_splice(stab_array(arg[1].arg_ptr.arg_stab),gimme,arglast);
goto array_return;
case O_PUSH:
if (arglast[2] - arglast[1] != 1)
***************
*** 821,827 ****
tmps = str_get(st[2]);
}
if (!tmps || !*tmps)
! exit(1);
fatal("%s",tmps);
goto say_zero;
case O_PRTF:
--- 842,848 ----
tmps = str_get(st[2]);
}
if (!tmps || !*tmps)
! tmps = "Died";
fatal("%s",tmps);
goto say_zero;
case O_PRTF:
***************
*** 1064,1071 ****
}
#endif
}
! if (loop_ptr < 0)
fatal("Bad label: %s", maxarg > 0 ? tmps : "<null>");
if (!lastretstr && optype == O_LAST && lastsize) {
st -= arglast[0];
st += lastspbase + 1;
--- 1085,1095 ----
}
#endif
}
! if (loop_ptr < 0) {
! if (tmps && strEQ(tmps, "_SUB_"))
! fatal("Can't return outside a subroutine");
fatal("Bad label: %s", maxarg > 0 ? tmps : "<null>");
+ }
if (!lastretstr && optype == O_LAST && lastsize) {
st -= arglast[0];
st += lastspbase + 1;
***************
*** 1136,1141 ****
--- 1160,1169 ----
sp = do_time(str,gmtime(&when),
gimme,arglast);
goto array_return;
+ case O_TRUNCATE:
+ sp = do_truncate(str,arg,
+ gimme,arglast);
+ goto array_return;
case O_LSTAT:
case O_STAT:
sp = do_stat(str,arg,
***************
*** 1317,1323 ****
argtype = arg[2].arg_type & A_MASK;
argptr = arg[2].arg_ptr;
sp = arglast[0];
! st -= sp;
goto re_eval;
}
str_set(str,"");
--- 1345,1351 ----
argtype = arg[2].arg_type & A_MASK;
argptr = arg[2].arg_ptr;
sp = arglast[0];
! st -= sp++;
goto re_eval;
}
str_set(str,"");
***************
*** 1392,1397 ****
--- 1420,1426 ----
else {
value = (double)((unsigned int)argflags & 0xffff);
}
+ do_execfree(); /* free any memory child malloced on vfork */
goto donumset;
}
if ((arg[1].arg_type & A_MASK) == A_STAB)
***************
*** 1510,1520 ****
#ifdef RENAME
value = (double)(rename(tmps,tmps2) >= 0);
#else
! if (euid || stat(tmps2,&statbuf) < 0 ||
! (statbuf.st_mode & S_IFMT) != S_IFDIR )
! (void)UNLINK(tmps2); /* avoid unlinking a directory */
! if (!(anum = link(tmps,tmps2)))
! anum = UNLINK(tmps);
value = (double)(anum >= 0);
#endif
goto donumset;
--- 1539,1553 ----
#ifdef RENAME
value = (double)(rename(tmps,tmps2) >= 0);
#else
! if (same_dirent(tmps2, tmps) /* can always rename to same name */
! anum = 1;
! else {
! if (euid || stat(tmps2,&statbuf) < 0 ||
! (statbuf.st_mode & S_IFMT) != S_IFDIR )
! (void)UNLINK(tmps2);
! if (!(anum = link(tmps,tmps2)))
! anum = UNLINK(tmps);
! }
value = (double)(anum >= 0);
#endif
goto donumset;
***************
*** 1738,1743 ****
--- 1771,1778 ----
}
value = (double)(ary->ary_fill + 1);
break;
+
+ case O_REQUIRE:
case O_DOFILE:
case O_EVAL:
if (maxarg < 1)
***************
*** 1803,1811 ****
case O_FTSIZE:
if (mystat(arg,st[1]) < 0)
goto say_undef;
! if (statcache.st_size)
! goto say_yes;
! goto say_no;
case O_FTSOCK:
#ifdef S_IFSOCK
--- 1838,1845 ----
case O_FTSIZE:
if (mystat(arg,st[1]) < 0)
goto say_undef;
! value = (double)statcache.st_size;
! goto donumset;
case O_FTSOCK:
#ifdef S_IFSOCK
***************
*** 2037,2046 ****
case O_ESERVENT:
value = (double) endservent();
goto donumset;
! case O_SSELECT:
! sp = do_select(gimme,arglast);
! goto array_return;
! case O_SOCKETPAIR:
if ((arg[1].arg_type & A_MASK) == A_WORD)
stab = arg[1].arg_ptr.arg_stab;
else
--- 2071,2077 ----
case O_ESERVENT:
value = (double) endservent();
goto donumset;
! case O_SOCKPAIR:
if ((arg[1].arg_type & A_MASK) == A_WORD)
stab = arg[1].arg_ptr.arg_stab;
else
***************
*** 2089,2096 ****
case O_CONNECT:
case O_LISTEN:
case O_ACCEPT:
! case O_SSELECT:
! case O_SOCKETPAIR:
case O_GHBYNAME:
case O_GHBYADDR:
case O_GHOSTENT:
--- 2120,2126 ----
case O_CONNECT:
case O_LISTEN:
case O_ACCEPT:
! case O_SOCKPAIR:
case O_GHBYNAME:
case O_GHBYADDR:
case O_GHOSTENT:
***************
*** 2119,2124 ****
--- 2149,2161 ----
badsock:
fatal("Unsupported socket function");
#endif /* SOCKET */
+ case O_SSELECT:
+ #ifdef SELECT
+ sp = do_select(gimme,arglast);
+ goto array_return;
+ #else
+ fatal("select not implemented");
+ #endif
case O_FILENO:
if (maxarg < 1)
goto say_undef;
***************
*** 2256,2263 ****
deb("%s RETURNS (\"%s\")\n",opname[optype],str_get(st[1]));
break;
default:
! deb("%s RETURNS %d ARGS (\"%s\",%s\"%s\"\n",opname[optype],anum,
! str_get(st[1]),anum==2?"":"...,",str_get(st[anum]));
break;
}
}
--- 2293,2301 ----
deb("%s RETURNS (\"%s\")\n",opname[optype],str_get(st[1]));
break;
default:
! tmps = str_get(st[1]);
! deb("%s RETURNS %d ARGS (\"%s\",%s\"%s\")\n",opname[optype],
! anum,tmps,anum==2?"":"...,",str_get(st[anum]));
break;
}
}
Index: evalargs.xc
Prereq: 3.0.1.5
*** evalargs.xc.old Thu Aug 9 05:59:00 1990
--- evalargs.xc Thu Aug 9 05:59:02 1990
***************
*** 2,10 ****
* kit sizes from getting too big.
*/
! /* $Header: evalargs.xc,v 3.0.1.5 90/03/27 15:54:42 lwall Locked $
*
* $Log: evalargs.xc,v $
* Revision 3.0.1.5 90/03/27 15:54:42 lwall
* patch16: MSDOS support
*
--- 2,15 ----
* kit sizes from getting too big.
*/
! /* $Header: evalargs.xc,v 3.0.1.6 90/08/09 03:37:15 lwall Locked $
*
* $Log: evalargs.xc,v $
+ * Revision 3.0.1.6 90/08/09 03:37:15 lwall
+ * patch19: passing *name to subroutine now forces filehandle and array creation
+ * patch19: `command` in array context now returns array of lines
+ * patch19: <handle> input is a little more efficient
+ *
* Revision 3.0.1.5 90/03/27 15:54:42 lwall
* patch16: MSDOS support
*
***************
*** 98,104 ****
#endif
break;
case A_STAR:
! st[++sp] = (STR*)argptr.arg_stab;
#ifdef DEBUGGING
if (debug & 8) {
(void)sprintf(buf,"STAR *%s",stab_name(argptr.arg_stab));
--- 103,116 ----
#endif
break;
case A_STAR:
! stab = argptr.arg_stab;
! st[++sp] = (STR*)stab;
! if (!stab_xarray(stab))
! aadd(stab);
! if (!stab_xhash(stab))
! hadd(stab);
! if (!stab_io(stab))
! stab_io(stab) = stio_new();
#ifdef DEBUGGING
if (debug & 8) {
(void)sprintf(buf,"STAR *%s",stab_name(argptr.arg_stab));
***************
*** 221,234 ****
fp = mypopen(tmps,"r");
str_set(str,"");
if (fp) {
! while (str_gets(str,fp,str->str_cur) != Nullch)
! ;
statusvalue = mypclose(fp);
}
else
statusvalue = -1;
! st[++sp] = str;
#ifdef DEBUGGING
tmps = "BACK";
#endif
--- 233,262 ----
fp = mypopen(tmps,"r");
str_set(str,"");
if (fp) {
! if (gimme == G_SCALAR) {
! while (str_gets(str,fp,str->str_cur) != Nullch)
! ;
! }
! else {
! for (;;) {
! if (++sp > stack->ary_max) {
! astore(stack, sp, Nullstr);
! st = stack->ary_array;
! }
! st[sp] = str_static(&str_undef);
! if (str_gets(st[sp],fp,0) == Nullch) {
! sp--;
! break;
! }
! }
! }
statusvalue = mypclose(fp);
}
else
statusvalue = -1;
! if (gimme == G_SCALAR)
! st[++sp] = str;
#ifdef DEBUGGING
tmps = "BACK";
#endif
***************
*** 268,273 ****
--- 296,303 ----
do_read:
if (anum > 1) /* assign to scalar */
gimme = G_SCALAR; /* force context to scalar */
+ if (gimme == G_ARRAY)
+ str = str_static(&str_undef);
++sp;
fp = Nullfp;
if (stab_io(last_in_stab)) {
***************
*** 362,372 ****
goto keepgoing; /* unmatched wildcard? */
}
if (gimme == G_ARRAY) {
- st[sp] = str_static(st[sp]);
if (++sp > stack->ary_max) {
astore(stack, sp, Nullstr);
st = stack->ary_array;
}
goto keepgoing;
}
}
--- 392,402 ----
goto keepgoing; /* unmatched wildcard? */
}
if (gimme == G_ARRAY) {
if (++sp > stack->ary_max) {
astore(stack, sp, Nullstr);
st = stack->ary_array;
}
+ str = str_static(&str_undef);
goto keepgoing;
}
}
Index: lib/flush.pl
*** lib/flush.pl.old Thu Aug 9 06:00:30 1990
--- lib/flush.pl Thu Aug 9 06:00:32 1990
***************
*** 0 ****
--- 1,22 ----
+ ;# Usage: &flush(FILEHANDLE)
+ ;# flushes the named filehandle
+
+ ;# Usage: &printflush(FILEHANDLE, "prompt: ")
+ ;# prints arguments and flushes filehandle
+
+ sub flush {
+ local($old) = select(shift);
+ $| = 1;
+ print "";
+ $| = 0;
+ select($old);
+ }
+
+ sub printflush {
+ local($old) = select(shift);
+ $| = 1;
+ print @_;
+ $| = 0;
+ select($old);
+ }
+
Index: form.c
Prereq: 3.0.1.1
*** form.c.old Thu Aug 9 05:59:07 1990
--- form.c Thu Aug 9 05:59:08 1990
***************
*** 1,4 ****
! /* $Header: form.c,v 3.0.1.1 90/02/28 17:39:34 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
--- 1,4 ----
! /* $Header: form.c,v 3.0.1.2 90/08/09 03:38:40 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
***************
*** 6,11 ****
--- 6,14 ----
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: form.c,v $
+ * Revision 3.0.1.2 90/08/09 03:38:40 lwall
+ * patch19: did preliminary work toward debugging packages and evals
+ *
* Revision 3.0.1.1 90/02/28 17:39:34 lwall
* patch9: ... in format threw off subsequent field
*
***************
*** 28,38 ****
register int items;
STR *str;
ARG *parselist();
! line_t oldline = line;
int oldsave = savestack->ary_fill;
str = fcmd->f_unparsed;
! line = fcmd->f_line;
fcmd->f_unparsed = Nullstr;
(void)savehptr(&curstash);
curstash = str->str_u.str_hash;
--- 31,41 ----
register int items;
STR *str;
ARG *parselist();
! line_t oldline = curcmd->c_line;
int oldsave = savestack->ary_fill;
str = fcmd->f_unparsed;
! curcmd->c_line = fcmd->f_line;
fcmd->f_unparsed = Nullstr;
(void)savehptr(&curstash);
curstash = str->str_u.str_hash;
***************
*** 58,64 ****
}
if (fcmd && fcmd->f_type)
fatal("Not enough field values");
! line = oldline;
Safefree(arg);
str_free(str);
}
--- 61,67 ----
}
if (fcmd && fcmd->f_type)
fatal("Not enough field values");
! curcmd->c_line = oldline;
Safefree(arg);
str_free(str);
}
***************
*** 280,285 ****
--- 283,289 ----
break;
}
}
+ CHKLEN(1);
*d++ = '\0';
}
Index: h2pl/getioctlsizes
*** h2pl/getioctlsizes.old Thu Aug 9 05:59:44 1990
--- h2pl/getioctlsizes Thu Aug 9 05:59:45 1990
***************
*** 0 ****
--- 1,13 ----
+ #!/usr/bin/perl
+
+ open (IOCTLS,'/usr/include/sys/ioctl.h') || die "ioctl open failed";
+
+ while (<IOCTLS>) {
+ if (/^\s*#\s*define\s+\w+\s+_IO(R|W|WR)\(\w+,\s*\w+,\s*([^)]+)/) {
+ $need{$2}++;
+ }
+ }
+
+ foreach $key ( sort keys %need ) {
+ print $key,"\n";
+ }
Index: h2ph.SH
*** h2ph.SH.old Thu Aug 9 05:59:12 1990
--- h2ph.SH Thu Aug 9 05:59:13 1990
***************
*** 0 ****
--- 1,247 ----
+ case $CONFIG in
+ '')
+ if test ! -f config.sh; then
+ ln ../config.sh . || \
+ ln ../../config.sh . || \
+ ln ../../../config.sh . || \
+ (echo "Can't find config.sh."; exit 1)
+ fi
+ . config.sh
+ ;;
+ esac
+ : This forces SH files to create target in same directory as SH file.
+ : This is so that make depend always knows where to find SH derivatives.
+ case "$0" in
+ */*) cd `expr X$0 : 'X\(.*\)/'` ;;
+ esac
+ echo "Extracting h2ph (with variable substitutions)"
+ : This section of the file will have variable substitutions done on it.
+ : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
+ : Protect any dollar signs and backticks that you do not want interpreted
+ : by putting a backslash in front. You may delete these comments.
+ $spitshell >h2ph <<!GROK!THIS!
+ #!$bin/perl
+ 'di';
+ 'ig00';
+
+ \$perlincl = '$privlib';
+ !GROK!THIS!
+
+ : In the following dollars and backticks do not need the extra backslash.
+ $spitshell >>h2ph <<'!NO!SUBS!'
+
+ chdir '/usr/include' || die "Can't cd /usr/include";
+
+ %isatype = ('char',1,'short',1,'int',1,'long',1);
+
+ foreach $file (@ARGV) {
+ ($outfile = $file) =~ s/\.h$/.ph/;
+ print "$file -> $outfile\n";
+ if ($file =~ m|^(.*)/|) {
+ $dir = $1;
+ if (!-d "$perlincl/$dir") {
+ mkdir("$perlincl/$dir",0777);
+ }
+ }
+ open(IN,"$file") || ((warn "Can't open $file: $!\n"),next);
+ open(OUT,">$perlincl/$outfile") || die "Can't create $outfile: $!\n";
+ while (<IN>) {
+ chop;
+ while (/\\$/) {
+ chop;
+ $_ .= <IN>;
+ chop;
+ }
+ if (s:/\*:\200:g) {
+ s:\*/:\201:g;
+ s/\200[^\201]*\201//g; # delete single line comments
+ if (s/\200.*//) { # begin multi-line comment?
+ $_ .= '/*';
+ $_ .= <IN>;
+ redo;
+ }
+ }
+ if (s/^#\s*//) {
+ if (s/^define\s+(\w+)//) {
+ $name = $1;
+ $new = '';
+ s/\s+$//;
+ if (s/^\(([\w,\s]*)\)//) {
+ $args = $1;
+ if ($args ne '') {
+ foreach $arg (split(/,\s*/,$args)) {
+ $curargs{$arg} = 1;
+ }
+ $args =~ s/\b(\w)/\$$1/g;
+ $args = "local($args) = \@_;\n$t ";
+ }
+ s/^\s+//;
+ do expr();
+ $new =~ s/(["\\])/\\$1/g;
+ if ($t ne '') {
+ $new =~ s/(['\\])/\\$1/g;
+ print OUT $t,
+ "eval 'sub $name {\n$t ${args}eval \"$new\";\n$t}';\n";
+ }
+ else {
+ print OUT "sub $name {\n ${args}eval \"$new\";\n}\n";
+ }
+ %curargs = ();
+ }
+ else {
+ s/^\s+//;
+ do expr();
+ $new = 1 if $new eq '';
+ if ($t ne '') {
+ $new =~ s/(['\\])/\\$1/g;
+ print OUT $t,"eval 'sub $name {",$new,";}';\n";
+ }
+ else {
+ print OUT $t,"sub $name {",$new,";}\n";
+ }
+ }
+ }
+ elsif (/^include <(.*)>/) {
+ print OUT $t,"do '$1' || die \"Can't include $1: \$!\";\n";
+ }
+ elsif (/^ifdef\s+(\w+)/) {
+ print OUT $t,"if (defined &$1) {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ }
+ elsif (/^ifndef\s+(\w+)/) {
+ print OUT $t,"if (!defined &$1) {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ }
+ elsif (s/^if\s+//) {
+ $new = '';
+ do expr();
+ print OUT $t,"if ($new) {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ }
+ elsif (s/^elif\s+//) {
+ $new = '';
+ do expr();
+ $tab -= 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT $t,"}\n${t}elsif ($new) {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ }
+ elsif (/^else/) {
+ $tab -= 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT $t,"}\n${t}else {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ }
+ elsif (/^endif/) {
+ $tab -= 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT $t,"}\n";
+ }
+ }
+ }
+ print OUT "1;\n";
+ }
+
+ sub expr {
+ while ($_ ne '') {
+ s/^(\s+)// && do {$new .= ' '; next;};
+ s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;};
+ s/^(\d+)// && do {$new .= $1; next;};
+ s/^("(\\"|[^"])*")// && do {$new .= $1; next;};
+ s/^'((\\"|[^"])*)'// && do {
+ if ($curargs{$1}) {
+ $new .= "ord('\$$1')";
+ }
+ else {
+ $new .= "ord('$1')";
+ }
+ next;
+ };
+ s/^(struct\s+\w+)// && do {$new .= "'$1'"; next;};
+ s/^sizeof\s*\(([^)]+)\)/{$1}/ && do {
+ $new .= '$sizeof';
+ next;
+ };
+ s/^([_a-zA-Z]\w*)// && do {
+ $id = $1;
+ if ($curargs{$id}) {
+ $new .= '$' . $id;
+ }
+ elsif ($id eq 'defined') {
+ $new .= 'defined';
+ }
+ elsif (/^\(/) {
+ s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/; # cheat
+ $new .= " &$id";
+ }
+ elsif ($isatype{$id}) {
+ $new .= "'$id'";
+ }
+ else {
+ $new .= ' &' . $id;
+ }
+ next;
+ };
+ s/^(.)// && do {$new .= $1; next;};
+ }
+ }
+ ##############################################################################
+
+ # These next few lines are legal in both Perl and nroff.
+
+ .00; # finish .ig
+
+ 'di \" finish diversion--previous line must be blank
+ .nr nl 0-1 \" fake up transition to first page again
+ .nr % 0 \" start at page 1
+ '; __END__ ############# From here on it's a standard manual page ############
+ .TH H2PH 1 "August 8, 1990"
+ .AT 3
+ .SH NAME
+ h2ph \- convert .h C header files to .ph Perl header files
+ .SH SYNOPSIS
+ .B h2ph [headerfiles]
+ .SH DESCRIPTION
+ .I h2ph
+ converts any C header files specified to the corresponding Perl header file
+ format.
+ It is most easily run while in /usr/include:
+ .nf
+
+ cd /usr/include; h2ph * sys/*
+
+ .fi
+ .SH ENVIRONMENT
+ No environment variables are used.
+ .SH FILES
+ /usr/include/*.h
+ .br
+ /usr/include/sys/*.h
+ .br
+ etc.
+ .SH AUTHOR
+ Larry Wall
+ .SH "SEE ALSO"
+ perl(1)
+ .SH DIAGNOSTICS
+ The usual warnings if it can't read or write the files involved.
+ .SH BUGS
+ Doesn't construct the %sizeof array for you.
+ .PP
+ It doesn't handle all C constructs, but it does attempt to isolate
+ definitions inside evals so that you can get at the definitions
+ that it can translate.
+ .PP
+ It's only intended as a rough tool.
+ You may need to dicker with the files produced.
+ .ex
+ !NO!SUBS!
+ chmod 755 h2ph
+ $eunicefix h2ph
+ rm -f h2ph.man
+ ln h2ph h2ph.man
Index: handy.h
Prereq: 3.0.1.1
*** handy.h.old Thu Aug 9 06:00:04 1990
--- handy.h Thu Aug 9 06:00:05 1990
***************
*** 1,4 ****
! /* $Header: handy.h,v 3.0.1.1 89/11/17 15:25:55 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
--- 1,4 ----
! /* $Header: handy.h,v 3.0.1.2 90/08/09 03:48:28 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
***************
*** 6,11 ****
--- 6,14 ----
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: handy.h,v $
+ * Revision 3.0.1.2 90/08/09 03:48:28 lwall
+ * patch19: various MSDOS and OS/2 patches folded in
+ *
* Revision 3.0.1.1 89/11/17 15:25:55 lwall
* patch5: some machines already define TRUE and FALSE
*
***************
*** 67,72 ****
--- 70,76 ----
char *safemalloc();
char *saferealloc();
void safefree();
+ #ifndef MSDOS
#define New(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t))))
#define Newc(x,v,n,t,c) (v = (c*)safemalloc((MEM_SIZE)((n) * sizeof(t))))
#define Newz(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))), \
***************
*** 73,78 ****
--- 77,90 ----
bzero((char*)(v), (n) * sizeof(t))
#define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
#define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
+ #else
+ #define New(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t))))
+ #define Newc(x,v,n,t,c) (v = (c*)safemalloc(((unsigned long)(n) * sizeof(t))))
+ #define Newz(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t)))), \
+ bzero((char*)(v), (n) * sizeof(t))
+ #define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t))))
+ #define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t))))
+ #endif /* MSDOS */
#define Safefree(d) safefree((char*)d)
#define Str_new(x,len) str_new(len)
#else /* LEAKTEST */
Index: hash.c
Prereq: 3.0.1.3
*** hash.c.old Thu Aug 9 06:00:10 1990
--- hash.c Thu Aug 9 06:00:11 1990
***************
*** 1,4 ****
! /* $Header: hash.c,v 3.0.1.3 90/03/27 15:59:09 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
--- 1,4 ----
! /* $Header: hash.c,v 3.0.1.4 90/08/09 03:50:22 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
***************
*** 6,11 ****
--- 6,14 ----
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: hash.c,v $
+ * Revision 3.0.1.4 90/08/09 03:50:22 lwall
+ * patch19: dbmopen(name, 'filename', undef) now refrains from creating
+ *
* Revision 3.0.1.3 90/03/27 15:59:09 lwall
* patch16: @dbmvalues{'foo','bar'} could use the same cache entry for both values
*
***************
*** 23,28 ****
--- 26,41 ----
#include "EXTERN.h"
#include "perl.h"
+ static char coeff[] = {
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
+ 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1};
+
STR *
hfetch(tb,key,klen,lval)
register HASH *tb;
***************
*** 502,520 ****
if (tb->tbl_dbm) /* never really closed it */
return TRUE;
#endif
! if (tb->tbl_dbm)
hdbmclose(tb);
hclear(tb);
#ifdef NDBM
! tb->tbl_dbm = dbm_open(fname, O_RDWR|O_CREAT, mode);
! if (!tb->tbl_dbm) /* oops, just try reading it */
! tb->tbl_dbm = dbm_open(fname, O_RDONLY, mode);
#else
if (dbmrefcnt++)
fatal("Old dbm can only open one database");
sprintf(buf,"%s.dir",fname);
if (stat(buf, &statbuf) < 0) {
! if (close(creat(buf,mode)) < 0)
return FALSE;
sprintf(buf,"%s.pag",fname);
if (close(creat(buf,mode)) < 0)
--- 515,536 ----
if (tb->tbl_dbm) /* never really closed it */
return TRUE;
#endif
! if (tb->tbl_dbm) {
hdbmclose(tb);
+ tb->tbl_dbm = 0;
+ }
hclear(tb);
#ifdef NDBM
! if (mode >= 0)
! tb->tbl_dbm = dbm_open(fname, O_RDWR|O_CREAT, mode);
! if (!tb->tbl_dbm)
! tb->tbl_dbm = dbm_open(fname, O_RDWR, mode);
#else
if (dbmrefcnt++)
fatal("Old dbm can only open one database");
sprintf(buf,"%s.dir",fname);
if (stat(buf, &statbuf) < 0) {
! if (mode < 0 || close(creat(buf,mode)) < 0)
return FALSE;
sprintf(buf,"%s.pag",fname);
if (close(creat(buf,mode)) < 0)
Index: hash.h
Prereq: 3.0
*** hash.h.old Thu Aug 9 06:00:16 1990
--- hash.h Thu Aug 9 06:00:17 1990
***************
*** 1,4 ****
! /* $Header: hash.h,v 3.0 89/10/18 15:18:39 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
--- 1,4 ----
! /* $Header: hash.h,v 3.0.1.1 90/08/09 03:51:34 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
***************
*** 6,11 ****
--- 6,14 ----
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: hash.h,v $
+ * Revision 3.0.1.1 90/08/09 03:51:34 lwall
+ * patch19: various MSDOS and OS/2 patches folded in
+ *
* Revision 3.0 89/10/18 15:18:39 lwall
* 3.0 baseline
*
***************
*** 15,34 ****
#define DBM_CACHE_MAX 63 /* cache 64 entries for dbm file */
/* (resident array acts as a write-thru cache)*/
! #define COEFFSIZE (16 * 8) /* size of array below */
! #ifdef DOINIT
! char coeff[] = {
! 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
! 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
! 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
! 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
! 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
! 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
! 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
! 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1};
! #else
! extern char coeff[];
! #endif
typedef struct hentry HENT;
--- 18,24 ----
#define DBM_CACHE_MAX 63 /* cache 64 entries for dbm file */
/* (resident array acts as a write-thru cache)*/
! #define COEFFSIZE (16 * 8) /* size of coeff array */
typedef struct hentry HENT;
Index: lib/importenv.pl
Prereq: 3.0
*** lib/importenv.pl.old Thu Aug 9 06:00:37 1990
--- lib/importenv.pl Thu Aug 9 06:00:38 1990
***************
*** 1,8 ****
! ;# $Header: importenv.pl,v 3.0 89/10/18 15:19:39 lwall Locked $
;# This file, when interpreted, pulls the environment into normal variables.
;# Usage:
! ;# do 'importenv.pl';
;# or
;# #include <importenv.pl>
--- 1,8 ----
! ;# $Header: importenv.pl,v 3.0.1.1 90/08/09 03:56:38 lwall Locked $
;# This file, when interpreted, pulls the environment into normal variables.
;# Usage:
! ;# require 'importenv.pl';
;# or
;# #include <importenv.pl>
Index: h2pl/eg/sys/ioctl.pl
*** h2pl/eg/sys/ioctl.pl.old Thu Aug 9 05:59:36 1990
--- h2pl/eg/sys/ioctl.pl Thu Aug 9 05:59:38 1990
***************
*** 0 ****
--- 1,186 ----
+ $_IOCTL_ = 0x1;
+ $TIOCGSIZE = 0x40087468;
+ $TIOCSSIZE = 0x80087467;
+ $IOCPARM_MASK = 0x7F;
+ $IOC_VOID = 0x20000000;
+ $IOC_OUT = 0x40000000;
+ $IOC_IN = 0x80000000;
+ $IOC_INOUT = 0xC0000000;
+ $TIOCGETD = 0x40047400;
+ $TIOCSETD = 0x80047401;
+ $TIOCHPCL = 0x20007402;
+ $TIOCMODG = 0x40047403;
+ $TIOCMODS = 0x80047404;
+ $TIOCM_LE = 0x1;
+ $TIOCM_DTR = 0x2;
+ $TIOCM_RTS = 0x4;
+ $TIOCM_ST = 0x8;
+ $TIOCM_SR = 0x10;
+ $TIOCM_CTS = 0x20;
+ $TIOCM_CAR = 0x40;
+ $TIOCM_CD = 0x40;
+ $TIOCM_RNG = 0x80;
+ $TIOCM_RI = 0x80;
+ $TIOCM_DSR = 0x100;
+ $TIOCGETP = 0x40067408;
+ $TIOCSETP = 0x80067409;
+ $TIOCSETN = 0x8006740A;
+ $TIOCEXCL = 0x2000740D;
+ $TIOCNXCL = 0x2000740E;
+ $TIOCFLUSH = 0x80047410;
+ $TIOCSETC = 0x80067411;
+ $TIOCGETC = 0x40067412;
+ $TIOCSET = 0x80047413;
+ $TIOCBIS = 0x80047414;
+ $TIOCBIC = 0x80047415;
+ $TIOCGET = 0x40047416;
+ $TANDEM = 0x1;
+ $CBREAK = 0x2;
+ $LCASE = 0x4;
+ $ECHO = 0x8;
+ $CRMOD = 0x10;
+ $RAW = 0x20;
+ $ODDP = 0x40;
+ $EVENP = 0x80;
+ $ANYP = 0xC0;
+ $NLDELAY = 0x300;
+ $NL0 = 0x0;
+ $NL1 = 0x100;
+ $NL2 = 0x200;
+ $NL3 = 0x300;
+ $TBDELAY = 0xC00;
+ $TAB0 = 0x0;
+ $TAB1 = 0x400;
+ $TAB2 = 0x800;
+ $XTABS = 0xC00;
+ $CRDELAY = 0x3000;
+ $CR0 = 0x0;
+ $CR1 = 0x1000;
+ $CR2 = 0x2000;
+ $CR3 = 0x3000;
+ $VTDELAY = 0x4000;
+ $FF0 = 0x0;
+ $FF1 = 0x4000;
+ $BSDELAY = 0x8000;
+ $BS0 = 0x0;
+ $BS1 = 0x8000;
+ $ALLDELAY = 0xFF00;
+ $CRTBS = 0x10000;
+ $PRTERA = 0x20000;
+ $CRTERA = 0x40000;
+ $TILDE = 0x80000;
+ $MDMBUF = 0x100000;
+ $LITOUT = 0x200000;
+ $TOSTOP = 0x400000;
+ $FLUSHO = 0x800000;
+ $NOHANG = 0x1000000;
+ $L001000 = 0x2000000;
+ $CRTKIL = 0x4000000;
+ $L004000 = 0x8000000;
+ $CTLECH = 0x10000000;
+ $PENDIN = 0x20000000;
+ $DECCTQ = 0x40000000;
+ $NOFLSH = 0x80000000;
+ $TIOCCSET = 0x800E7417;
+ $TIOCCGET = 0x400E7418;
+ $TIOCLBIS = 0x8004747F;
+ $TIOCLBIC = 0x8004747E;
+ $TIOCLSET = 0x8004747D;
+ $TIOCLGET = 0x4004747C;
+ $LCRTBS = 0x1;
+ $LPRTERA = 0x2;
+ $LCRTERA = 0x4;
+ $LTILDE = 0x8;
+ $LMDMBUF = 0x10;
+ $LLITOUT = 0x20;
+ $LTOSTOP = 0x40;
+ $LFLUSHO = 0x80;
+ $LNOHANG = 0x100;
+ $LCRTKIL = 0x400;
+ $LCTLECH = 0x1000;
+ $LPENDIN = 0x2000;
+ $LDECCTQ = 0x4000;
+ $LNOFLSH = 0x8000;
+ $TIOCSBRK = 0x2000747B;
+ $TIOCCBRK = 0x2000747A;
+ $TIOCSDTR = 0x20007479;
+ $TIOCCDTR = 0x20007478;
+ $TIOCGPGRP = 0x40047477;
+ $TIOCSPGRP = 0x80047476;
+ $TIOCSLTC = 0x80067475;
+ $TIOCGLTC = 0x40067474;
+ $TIOCOUTQ = 0x40047473;
+ $TIOCSTI = 0x80017472;
+ $TIOCNOTTY = 0x20007471;
+ $TIOCPKT = 0x80047470;
+ $TIOCPKT_DATA = 0x0;
+ $TIOCPKT_FLUSHREAD = 0x1;
+ $TIOCPKT_FLUSHWRITE = 0x2;
+ $TIOCPKT_STOP = 0x4;
+ $TIOCPKT_START = 0x8;
+ $TIOCPKT_NOSTOP = 0x10;
+ $TIOCPKT_DOSTOP = 0x20;
+ $TIOCSTOP = 0x2000746F;
+ $TIOCSTART = 0x2000746E;
+ $TIOCREMOTE = 0x20007469;
+ $TIOCGWINSZ = 0x40087468;
+ $TIOCSWINSZ = 0x80087467;
+ $TIOCRESET = 0x20007466;
+ $OTTYDISC = 0x0;
+ $NETLDISC = 0x1;
+ $NTTYDISC = 0x2;
+ $FIOCLEX = 0x20006601;
+ $FIONCLEX = 0x20006602;
+ $FIONREAD = 0x4004667F;
+ $FIONBIO = 0x8004667E;
+ $FIOASYNC = 0x8004667D;
+ $FIOSETOWN = 0x8004667C;
+ $FIOGETOWN = 0x4004667B;
+ $STPUTTABLE = 0x8004667A;
+ $STGETTABLE = 0x80046679;
+ $SIOCSHIWAT = 0x80047300;
+ $SIOCGHIWAT = 0x40047301;
+ $SIOCSLOWAT = 0x80047302;
+ $SIOCGLOWAT = 0x40047303;
+ $SIOCATMARK = 0x40047307;
+ $SIOCSPGRP = 0x80047308;
+ $SIOCGPGRP = 0x40047309;
+ $SIOCADDRT = 0x8034720A;
+ $SIOCDELRT = 0x8034720B;
+ $SIOCSIFADDR = 0x8020690C;
+ $SIOCGIFADDR = 0xC020690D;
+ $SIOCSIFDSTADDR = 0x8020690E;
+ $SIOCGIFDSTADDR = 0xC020690F;
+ $SIOCSIFFLAGS = 0x80206910;
+ $SIOCGIFFLAGS = 0xC0206911;
+ $SIOCGIFBRDADDR = 0xC0206912;
+ $SIOCSIFBRDADDR = 0x80206913;
+ $SIOCGIFCONF = 0xC0086914;
+ $SIOCGIFNETMASK = 0xC0206915;
+ $SIOCSIFNETMASK = 0x80206916;
+ $SIOCGIFMETRIC = 0xC0206917;
+ $SIOCSIFMETRIC = 0x80206918;
+ $SIOCSARP = 0x8024691E;
+ $SIOCGARP = 0xC024691F;
+ $SIOCDARP = 0x80246920;
+ $PIXCONTINUE = 0x80747000;
+ $PIXSTEP = 0x80747001;
+ $PIXTERMINATE = 0x20007002;
+ $PIGETFLAGS = 0x40747003;
+ $PIXINHERIT = 0x80747004;
+ $PIXDETACH = 0x20007005;
+ $PIXGETSUBCODE = 0xC0747006;
+ $PIXRDREGS = 0xC0747007;
+ $PIXWRREGS = 0xC0747008;
+ $PIXRDVREGS = 0xC0747009;
+ $PIXWRVREGS = 0xC074700A;
+ $PIXRDVSTATE = 0xC074700B;
+ $PIXWRVSTATE = 0xC074700C;
+ $PIXRDCREGS = 0xC074700D;
+ $PIXWRCREGS = 0xC074700E;
+ $PIRDSDRS = 0xC074700F;
+ $PIXGETSIGACTION = 0xC0747010;
+ $PIGETU = 0xC0747011;
+ $PISETRWTID = 0xC0747012;
+ $PIXGETTHCOUNT = 0xC0747013;
+ $PIXRUN = 0x20007014;
Index: makelib.SH
*** makelib.SH.old Thu Aug 9 06:01:27 1990
--- makelib.SH Thu Aug 9 06:01:28 1990
***************
*** 1,192 ****
! case $CONFIG in
! '')
! if test ! -f config.sh; then
! ln ../config.sh . || \
! ln ../../config.sh . || \
! ln ../../../config.sh . || \
! (echo "Can't find config.sh."; exit 1)
! fi
! . config.sh
! ;;
! esac
! : This forces SH files to create target in same directory as SH file.
! : This is so that make depend always knows where to find SH derivatives.
! case "$0" in
! */*) cd `expr X$0 : 'X\(.*\)/'` ;;
! esac
! echo "Extracting makelib (with variable substitutions)"
! : This section of the file will have variable substitutions done on it.
! : Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
! : Protect any dollar signs and backticks that you do not want interpreted
! : by putting a backslash in front. You may delete these comments.
! $spitshell >makelib <<!GROK!THIS!
! #!/usr/bin/perl
!
! \$perlincl = '$privlib';
! !GROK!THIS!
!
! : In the following dollars and backticks do not need the extra backslash.
! $spitshell >>makelib <<'!NO!SUBS!'
!
! chdir '/usr/include' || die "Can't cd /usr/include";
!
! %isatype = ('char',1,'short',1,'int',1,'long',1);
!
! foreach $file (@ARGV) {
! print $file,"\n";
! if ($file =~ m|^(.*)/|) {
! $dir = $1;
! if (!-d "$perlincl/$dir") {
! mkdir("$perlincl/$dir",0777);
! }
! }
! open(IN,"$file") || ((warn "Can't open $file: $!\n"),next);
! open(OUT,">$perlincl/$file") || die "Can't create $file: $!\n";
! while (<IN>) {
! chop;
! while (/\\$/) {
! chop;
! $_ .= <IN>;
! chop;
! }
! if (s:/\*:\200:g) {
! s:\*/:\201:g;
! s/\200[^\201]*\201//g; # delete single line comments
! if (s/\200.*//) { # begin multi-line comment?
! $_ .= '/*';
! $_ .= <IN>;
! redo;
! }
! }
! if (s/^#\s*//) {
! if (s/^define\s+(\w+)//) {
! $name = $1;
! $new = '';
! s/\s+$//;
! if (s/^\(([\w,\s]*)\)//) {
! $args = $1;
! if ($args ne '') {
! foreach $arg (split(/,\s*/,$args)) {
! $curargs{$arg} = 1;
! }
! $args =~ s/\b(\w)/\$$1/g;
! $args = "local($args) = \@_;\n$t ";
! }
! s/^\s+//;
! do expr();
! $new =~ s/(["\\])/\\$1/g;
! if ($t ne '') {
! $new =~ s/(['\\])/\\$1/g;
! print OUT $t,
! "eval 'sub $name {\n$t ${args}eval \"$new\";\n$t}';\n";
! }
! else {
! print OUT "sub $name {\n ${args}eval \"$new\";\n}\n";
! }
! %curargs = ();
! }
! else {
! s/^\s+//;
! do expr();
! $new = 1 if $new eq '';
! if ($t ne '') {
! $new =~ s/(['\\])/\\$1/g;
! print OUT $t,"eval 'sub $name {",$new,";}';\n";
! }
! else {
! print OUT $t,"sub $name {",$new,";}\n";
! }
! }
! }
! elsif (/^include <(.*)>/) {
! print OUT $t,"do '$1' || die \"Can't include $1: \$!\";\n";
! }
! elsif (/^ifdef\s+(\w+)/) {
! print OUT $t,"if (defined &$1) {\n";
! $tab += 4;
! $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
! }
! elsif (/^ifndef\s+(\w+)/) {
! print OUT $t,"if (!defined &$1) {\n";
! $tab += 4;
! $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
! }
! elsif (s/^if\s+//) {
! $new = '';
! do expr();
! print OUT $t,"if ($new) {\n";
! $tab += 4;
! $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
! }
! elsif (s/^elif\s+//) {
! $new = '';
! do expr();
! $tab -= 4;
! $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
! print OUT $t,"}\n${t}elsif ($new) {\n";
! $tab += 4;
! $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
! }
! elsif (/^else/) {
! $tab -= 4;
! $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
! print OUT $t,"}\n${t}else {\n";
! $tab += 4;
! $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
! }
! elsif (/^endif/) {
! $tab -= 4;
! $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
! print OUT $t,"}\n";
! }
! }
! }
! print OUT "1;\n";
! }
!
! sub expr {
! while ($_ ne '') {
! s/^(\s+)// && do {$new .= ' '; next;};
! s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;};
! s/^(\d+)// && do {$new .= $1; next;};
! s/^("(\\"|[^"])*")// && do {$new .= $1; next;};
! s/^'((\\"|[^"])*)'// && do {
! if ($curargs{$1}) {
! $new .= "ord('\$$1')";
! }
! else {
! $new .= "ord('$1')";
! }
! next;
! };
! s/^(struct\s+\w+)// && do {$new .= "'$1'"; next;};
! s/^sizeof\s*\(([^)]+)\)/{$1}/ && do {
! $new .= '$sizeof';
! next;
! };
! s/^([_a-zA-Z]\w*)// && do {
! $id = $1;
! if ($curargs{$id}) {
! $new .= '$' . $id;
! }
! elsif ($id eq 'defined') {
! $new .= 'defined';
! }
! elsif (/^\(/) {
! s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/; # cheat
! $new .= "&$id";
! }
! elsif ($isatype{$id}) {
! $new .= "'$id'";
! }
! else {
! $new .= '&' . $id;
! }
! next;
! };
! s/^(.)// && do {$new .= $1; next;};
! }
! }
! !NO!SUBS!
! chmod 755 makelib
! $eunicefix makelib
--- 1,2 ----
! echo "makelib.SH has been renamed to h2ph.SH"
! rm makelib
Index: usub/man2mus
*** usub/man2mus.old Thu Aug 9 06:01:52 1990
--- usub/man2mus Thu Aug 9 06:01:53 1990
***************
*** 0 ****
--- 1,66 ----
+ #!/usr/bin/perl
+ while (<>) {
+ if (/^\.SH SYNOPSIS/) {
+ $spec = '';
+ for ($_ = <>; $_ && !/^\.SH/; $_ = <>) {
+ s/^\.[IRB][IRB]\s*//;
+ s/^\.[IRB]\s+//;
+ next if /^\./;
+ s/\\f\w//g;
+ s/\\&//g;
+ s/^\s+//;
+ next if /^$/;
+ next if /^#/;
+ $spec .= $_;
+ }
+ $_ = $spec;
+ 0 while s/\(([^),;]*)\s*,\s*([^);]*)\)/($1|$2)/g;
+ s/\(\*([^,;]*)\)\(\)/(*)()$1/g;
+ s/(\w+)\[\]/*$1/g;
+
+ s/\n/ /g;
+ s/\s+/ /g;
+ s/(\w+) \(([^*])/$1($2/g;
+ s/^ //;
+ s/ ?; ?/\n/g;
+ s/\) /)\n/g;
+ s/ \* / \*/g;
+ s/\* / \*/g;
+
+ $* = 1;
+ 0 while s/^((struct )?\w+ )([^\n,]*), ?(.*)/$1$3\n$1$4/g;
+ $* = 0;
+ s/\|/,/g;
+
+ @cases = ();
+ for (reverse split(/\n/,$_)) {
+ if (/\)$/) {
+ ($type,$name,$args) = split(/(\w+)\(/);
+ $type =~ s/ $//;
+ if ($type =~ /^(\w+) =/) {
+ $type = $type{$1} if $type{$1};
+ }
+ $type = 'int' if $type eq '';
+ @args = grep(/./, split(/[,)]/,$args));
+ $case = "CASE $type $name\n";
+ foreach $arg (@args) {
+ $type = $type{$arg} || "int";
+ $type =~ s/ //g;
+ $type .= "\t" if length($type) < 8;
+ if ($type =~ /\*/) {
+ $case .= "IO $type $arg\n";
+ }
+ else {
+ $case .= "I $type $arg\n";
+ }
+ }
+ $case .= "END\n\n";
+ unshift(@cases, $case);
+ }
+ else {
+ $type{$name} = $type if ($type,$name) = /(.*\W)(\w+)$/;
+ }
+ }
+ print @cases;
+ }
+ }
*** End of Patch 22 ***
More information about the Comp.sources.bugs
mailing list