Xref: utzoo comp.sources.bugs:2473 comp.lang.perl:2030 Path: utzoo!utgpu!news-server.csri.toronto.edu!cs.utexas.edu!wuarchive!zaphod.mps.ohio-state.edu!usc!elroy.jpl.nasa.gov!jpl-devvax!lwall From: lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) Newsgroups: comp.sources.bugs,comp.lang.perl Subject: perl 3.0 patch #22 Summary: This is an official patch for perl 3.0. Please apply it. Message-ID: <9100@jpl-devvax.JPL.NASA.GOV> Date: 10 Aug 90 21:27:59 GMT Organization: Jet Propulsion Laboratory, Pasadena, CA Lines: 1849 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 #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,@vars) = @_; local(*stab) = eval("*_$package"); while (($key,$val) = each(%stab)) { { + next if @vars && !grep($key eq $_,@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 + #endif #ifdef I_FCNTL #include *************** *** 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 : ""); 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 : ""); + } 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: 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 () { + 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 <>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 () { + chop; + while (/\\$/) { + chop; + $_ .= ; + chop; + } + if (s:/\*:\200:g) { + s:\*/:\201:g; + s/\200[^\201]*\201//g; # delete single line comments + if (s/\200.*//) { # begin multi-line comment? + $_ .= '/*'; + $_ .= ; + 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 --- 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 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 <>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 () { ! chop; ! while (/\\$/) { ! chop; ! $_ .= ; ! chop; ! } ! if (s:/\*:\200:g) { ! s:\*/:\201:g; ! s/\200[^\201]*\201//g; # delete single line comments ! if (s/\200.*//) { # begin multi-line comment? ! $_ .= '/*'; ! $_ .= ; ! 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 ***