This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 3.0 patch #22 patch #19, continued
authorLarry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Wed, 8 Aug 1990 17:01:53 +0000 (17:01 +0000)
committerLarry Wall <lwall@jpl-devvax.jpl.nasa.gov>
Wed, 8 Aug 1990 17:01:53 +0000 (17:01 +0000)
See patch #19.

16 files changed:
eval.c
evalargs.xc
form.c
h2ph.SH [new file with mode: 0644]
h2pl/eg/sys/errno.pl [new file with mode: 0644]
h2pl/eg/sys/ioctl.pl [new file with mode: 0644]
h2pl/getioctlsizes [new file with mode: 0644]
handy.h
hash.c
hash.h
lib/dumpvar.pl
lib/flush.pl [new file with mode: 0644]
lib/importenv.pl
makelib.SH
patchlevel.h
usub/man2mus [new file with mode: 0644]

diff --git a/eval.c b/eval.c
index 9978779..42436e4 100644 (file)
--- a/eval.c
+++ b/eval.c
@@ -1,4 +1,4 @@
-/* $Header: eval.c,v 3.0.1.6 90/03/27 15:53:51 lwall Locked $
+/* $Header: eval.c,v 3.0.1.7 90/08/09 03:33:44 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,16 @@
  *    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,7 +60,9 @@
 #include "EXTERN.h"
 #include "perl.h"
 
+#ifndef NSIG
 #include <signal.h>
+#endif
 
 #ifdef I_FCNTL
 #include <fcntl.h>
@@ -282,7 +294,7 @@ register int sp;
        if (when >= 0)
            value = (double)(when % tmplong);
        else
-           value = (double)(tmplong - (-when % tmplong));
+           value = (double)(tmplong - ((-when - 1) % tmplong)) - 1;
 #endif
        goto donumset;
     case O_ADD:
@@ -440,10 +452,19 @@ register int sp;
        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]));
+           value = (double) ~U_L(str_gnum(st[1]));
 #endif
-       goto donumset;
+           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,11 +524,11 @@ register int sp;
        break;
     case O_DBMOPEN:
 #ifdef SOME_DBM
-       if ((arg[1].arg_type & A_MASK) == A_WORD)
-           stab = arg[1].arg_ptr.arg_stab;
+       stab = arg[1].arg_ptr.arg_stab;
+       if (st[3]->str_nok || st[3]->str_pok)
+           anum = (int)str_gnum(st[3]);
        else
-           stab = stabent(str_get(st[1]),TRUE);
-       anum = (int)str_gnum(st[3]);
+           anum = -1;
        value = (double)hdbmopen(stab_hash(stab),str_get(st[2]),anum);
        goto donumset;
 #else
@@ -515,10 +536,7 @@ register int sp;
 #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);
+       stab = arg[1].arg_ptr.arg_stab;
        hdbmclose(stab_hash(stab));
        goto say_yes;
 #else
@@ -539,7 +557,7 @@ register int sp;
            goto say_zero;
        else
            goto say_undef;
-       break;
+       /* break; */
     case O_TRANS:
        value = (double) do_trans(str,arg);
        str = arg->arg_ptr.arg_str;
@@ -582,7 +600,8 @@ register int sp;
                astore(stack,sp + maxarg, Nullstr);
                st = stack->ary_array;
            }
-           Copy(ary->ary_array, &st[sp+1], maxarg, STR*);
+           st += sp;
+           Copy(ary->ary_array, &st[1], maxarg, STR*);
            sp += maxarg;
            goto array_return;
        }
@@ -618,6 +637,8 @@ register int sp;
        }
        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,7 +698,7 @@ register int sp;
            gimme,arglast);
        goto array_return;
     case O_SPLICE:
-       sp = do_splice(stab_array(arg[1].arg_ptr.arg_stab),str,gimme,arglast);
+       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,7 +842,7 @@ register int sp;
            tmps = str_get(st[2]);
        }
        if (!tmps || !*tmps)
-           exit(1);
+           tmps = "Died";
        fatal("%s",tmps);
        goto say_zero;
     case O_PRTF:
@@ -1064,8 +1085,11 @@ register int sp;
            }
 #endif
        }
-       if (loop_ptr < 0)
+       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,6 +1160,10 @@ register int sp;
        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,7 +1345,7 @@ register int sp;
            argtype = arg[2].arg_type & A_MASK;
            argptr = arg[2].arg_ptr;
            sp = arglast[0];
-           st -= sp;
+           st -= sp++;
            goto re_eval;
        }
        str_set(str,"");
@@ -1392,6 +1420,7 @@ register int sp;
            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,11 +1539,15 @@ register int sp;
 #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);
+       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,6 +1771,8 @@ register int sp;
        }
        value = (double)(ary->ary_fill + 1);
        break;
+
+    case O_REQUIRE:
     case O_DOFILE:
     case O_EVAL:
        if (maxarg < 1)
@@ -1803,9 +1838,8 @@ register int sp;
     case O_FTSIZE:
        if (mystat(arg,st[1]) < 0)
            goto say_undef;
-       if (statcache.st_size)
-           goto say_yes;
-       goto say_no;
+       value = (double)statcache.st_size;
+       goto donumset;
 
     case O_FTSOCK:
 #ifdef S_IFSOCK
@@ -2037,10 +2071,7 @@ register int sp;
     case O_ESERVENT:
        value = (double) endservent();
        goto donumset;
-    case O_SSELECT:
-       sp = do_select(gimme,arglast);
-       goto array_return;
-    case O_SOCKETPAIR:
+    case O_SOCKPAIR:
        if ((arg[1].arg_type & A_MASK) == A_WORD)
            stab = arg[1].arg_ptr.arg_stab;
        else
@@ -2089,8 +2120,7 @@ register int sp;
     case O_CONNECT:
     case O_LISTEN:
     case O_ACCEPT:
-    case O_SSELECT:
-    case O_SOCKETPAIR:
+    case O_SOCKPAIR:
     case O_GHBYNAME:
     case O_GHBYADDR:
     case O_GHOSTENT:
@@ -2119,6 +2149,13 @@ register int sp;
       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,8 +2293,9 @@ array_return:
                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]));
+               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 711d9a9..5d4458d 100644 (file)
@@ -2,9 +2,14 @@
  * kit sizes from getting too big.
  */
 
-/* $Header: evalargs.xc,v 3.0.1.5 90/03/27 15:54:42 lwall Locked $
+/* $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
  * 
 #endif
            break;
        case A_STAR:
-           st[++sp] = (STR*)argptr.arg_stab;
+           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));
            fp = mypopen(tmps,"r");
            str_set(str,"");
            if (fp) {
-               while (str_gets(str,fp,str->str_cur) != Nullch)
-                   ;
+               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;
 
-           st[++sp] = str;
+           if (gimme == G_SCALAR)
+               st[++sp] = str;
 #ifdef DEBUGGING
            tmps = "BACK";
 #endif
          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)) {
                        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;
                    }
+                   str = str_static(&str_undef);
                    goto keepgoing;
                }
            }
diff --git a/form.c b/form.c
index ba82433..c4b248a 100644 (file)
--- a/form.c
+++ b/form.c
@@ -1,4 +1,4 @@
-/* $Header: form.c,v 3.0.1.1 90/02/28 17:39:34 lwall Locked $
+/* $Header: form.c,v 3.0.1.2 90/08/09 03:38:40 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,9 @@
  *    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,11 +31,11 @@ register FCMD *fcmd;
     register int items;
     STR *str;
     ARG *parselist();
-    line_t oldline = line;
+    line_t oldline = curcmd->c_line;
     int oldsave = savestack->ary_fill;
 
     str = fcmd->f_unparsed;
-    line = fcmd->f_line;
+    curcmd->c_line = fcmd->f_line;
     fcmd->f_unparsed = Nullstr;
     (void)savehptr(&curstash);
     curstash = str->str_u.str_hash;
@@ -58,7 +61,7 @@ register FCMD *fcmd;
     }
     if (fcmd && fcmd->f_type)
        fatal("Not enough field values");
-    line = oldline;
+    curcmd->c_line = oldline;
     Safefree(arg);
     str_free(str);
 }
@@ -280,6 +283,7 @@ int sp;
            break;
        }
     }
+    CHKLEN(1);
     *d++ = '\0';
 }
 
diff --git a/h2ph.SH b/h2ph.SH
new file mode 100644 (file)
index 0000000..cac5ada
--- /dev/null
+++ b/h2ph.SH
@@ -0,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
diff --git a/h2pl/eg/sys/errno.pl b/h2pl/eg/sys/errno.pl
new file mode 100644 (file)
index 0000000..d9ba3be
--- /dev/null
@@ -0,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;
diff --git a/h2pl/eg/sys/ioctl.pl b/h2pl/eg/sys/ioctl.pl
new file mode 100644 (file)
index 0000000..0b552ca
--- /dev/null
@@ -0,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;
diff --git a/h2pl/getioctlsizes b/h2pl/getioctlsizes
new file mode 100644 (file)
index 0000000..b7d4a0d
--- /dev/null
@@ -0,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";
+} 
diff --git a/handy.h b/handy.h
index a19f684..3eea478 100644 (file)
--- a/handy.h
+++ b/handy.h
@@ -1,4 +1,4 @@
-/* $Header: handy.h,v 3.0.1.1 89/11/17 15:25:55 lwall Locked $
+/* $Header: handy.h,v 3.0.1.2 90/08/09 03:48:28 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,9 @@
  *    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,12 +70,21 @@ typedef unsigned short line_t;
 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)))), \
     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 */
diff --git a/hash.c b/hash.c
index e0b00ea..ffeaf1d 100644 (file)
--- a/hash.c
+++ b/hash.c
@@ -1,4 +1,4 @@
-/* $Header: hash.c,v 3.0.1.3 90/03/27 15:59:09 lwall Locked $
+/* $Header: hash.c,v 3.0.1.4 90/08/09 03:50:22 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,9 @@
  *    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
  * 
 #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,19 +515,22 @@ int mode;
     if (tb->tbl_dbm)   /* never really closed it */
        return TRUE;
 #endif
-    if (tb->tbl_dbm)
+    if (tb->tbl_dbm) {
        hdbmclose(tb);
+       tb->tbl_dbm = 0;
+    }
     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);
+    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 (close(creat(buf,mode)) < 0)
+       if (mode < 0 || close(creat(buf,mode)) < 0)
            return FALSE;
        sprintf(buf,"%s.pag",fname);
        if (close(creat(buf,mode)) < 0)
diff --git a/hash.h b/hash.h
index d13f2b7..430fcfe 100644 (file)
--- a/hash.h
+++ b/hash.h
@@ -1,4 +1,4 @@
-/* $Header: hash.h,v 3.0 89/10/18 15:18:39 lwall Locked $
+/* $Header: hash.h,v 3.0.1.1 90/08/09 03:51:34 lwall Locked $
  *
  *    Copyright (c) 1989, Larry Wall
  *
@@ -6,6 +6,9 @@
  *    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
  * 
 #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
+#define COEFFSIZE (16 * 8)     /* size of coeff array */
 
 typedef struct hentry HENT;
 
index b8cff89..b3fb02b 100644 (file)
@@ -1,25 +1,32 @@
 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) = @_;
+    ($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 = '$entry'\n";
+               print "\$$key = '",&unctrl($entry),"'\n";
            }
            if (defined @entry) {
                print "\@$key = (\n";
                foreach $num ($[ .. $#entry) {
-                   print "  $num\t'",$entry[$num],"'\n";
+                   print "  $num\t'",&unctrl($entry[$num]),"'\n";
                }
                print ")\n";
            }
            if ($key ne "_$package" && defined %entry) {
                print "\%$key = (\n";
                foreach $key (sort keys(%entry)) {
-                   print "  $key\t'",$entry{$key},"'\n";
+                   print "  $key\t'",&unctrl($entry{$key}),"'\n";
                }
                print ")\n";
            }
diff --git a/lib/flush.pl b/lib/flush.pl
new file mode 100644 (file)
index 0000000..1d22819
--- /dev/null
@@ -0,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 c321a20..db3128b 100644 (file)
@@ -1,8 +1,8 @@
-;# $Header: importenv.pl,v 3.0 89/10/18 15:19:39 lwall Locked $
+;# $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:
-;#     do 'importenv.pl';
+;#     require 'importenv.pl';
 ;# or
 ;#     #include <importenv.pl>
 
index 6cc9783..e74ba8d 100644 (file)
@@ -1,192 +1,2 @@
-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
+echo "makelib.SH has been renamed to h2ph.SH"
+rm makelib
index 49ea5df..7c3da2c 100644 (file)
@@ -1 +1 @@
-#define PATCHLEVEL 21
+#define PATCHLEVEL 22
diff --git a/usub/man2mus b/usub/man2mus
new file mode 100644 (file)
index 0000000..a304678
--- /dev/null
@@ -0,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;
+    }
+}