chiark / gitweb /
new socket id arrangements, working on tun
authorian <ian>
Thu, 26 Dec 2002 12:08:04 +0000 (12:08 +0000)
committerian <ian>
Thu, 26 Dec 2002 12:08:04 +0000 (12:08 +0000)
base/chiark-tcl.h
base/hook.c
base/idtable.c [new file with mode: 0644]
base/tables-examples.tct
base/tcmdifgen
base/troglodyte-Makefile
dgram/dgram.c
hbytes/hbytes.h
hbytes/hook.c
tuntap/tuntap.c [new file with mode: 0644]

index f8f59fd..f7d0110 100644 (file)
@@ -175,10 +175,25 @@ int sockaddr_len(const SockAddr_Value*);
 const struct sockaddr *sockaddr_addr(const SockAddr_Value*);
 void sockaddr_free(const SockAddr_Value*);
 
+/* from idtable.c */
+
+typedef struct {
+  const char *const prefix;
+  int n;
+  void **a;
+} IdDataTable;
+
+extern Tcl_ObjType tabledataid_nearlytype;
+int tabledataid_parse(Tcl_Interp *ip, Tcl_Obj *o, IdDataTable *tab);
+
 /* from dgram.c */
 
-extern Tcl_ObjType dgramsockid_type;
-typedef struct DgramSocket *DgramSockID;
+extern IdDataTable dgram_socks;
+int newfdposixerr(Tcl_Interp *ip, int fd, const char *m);
+
+/* from tuntap.c */
+
+extern IdDataTable tuntap_socks;
 
 /* from hook.c */
 
index a9d0316..b84306a 100644 (file)
@@ -22,6 +22,13 @@ int posixerr(Tcl_Interp *ip, int errnoval, const char *m) {
   return TCL_ERROR;
 }
 
+int newfdposixerr(Tcl_Interp *ip, int fd, const char *m) {
+  int e;
+  e= errno;
+  close(fd);
+  return posixerr(ip,e,m);
+}
+
 void objfreeir(Tcl_Obj *o) {
   if (o->typePtr && o->typePtr->freeIntRepProc)
     o->typePtr->freeIntRepProc(o);
@@ -361,6 +368,12 @@ int do_toplevel_dgram_socket(ClientData cd, Tcl_Interp *ip,
   return subcmd->func(0,ip,objc,objv);
 }
 
+int do_toplevel_tuntap_socket(ClientData cd, Tcl_Interp *ip,
+                            const TunSocket_SubCommand *subcmd,
+                            int objc, Tcl_Obj *const *objv) {
+  return subcmd->func(0,ip,objc,objv);
+}
+
 int do_toplevel_ulong(ClientData cd, Tcl_Interp *ip,
                      const ULong_SubCommand *subcmd,
                      int objc, Tcl_Obj *const *objv) {
@@ -400,7 +413,7 @@ int Hbytes_Init(Tcl_Interp *ip) {
   Tcl_RegisterObjType(&enum_nearlytype);
   Tcl_RegisterObjType(&enum1_nearlytype);
   Tcl_RegisterObjType(&sockaddr_type);
-  Tcl_RegisterObjType(&dgramsockid_type);
+  Tcl_RegisterObjType(&tabledataid_nearlytype);
   Tcl_RegisterObjType(&ulong_type);
 
   for (cmd=toplevel_commands;
diff --git a/base/idtable.c b/base/idtable.c
new file mode 100644 (file)
index 0000000..c2f3aaa
--- /dev/null
@@ -0,0 +1,126 @@
+/*
+ */
+/*
+ * dgram-socket create <local>                        => <sockid>
+ * dgram-socket close <sockid>
+ * dgram-socket transmit <sockid> <data> <remote>
+ * dgram-socket on-receive <sockid> [<script>]
+ *    calls, effectively,  eval <script> [list <data> <remote-addr> <socket>]
+ *    if script not supplied, cancel
+ */
+
+#include "tables.h"
+#include "hbytes.h"
+
+/* Arg parsing */
+
+static void setobjdataid(Tcl_Obj *o, int ix, IdDataTable *tab) {
+  unsigned long *ulp;
+  
+  ulp= TALLOC(sizeof(unsigned long));
+  *ulp= ix;
+  o->internalRep.twoPtrValue.ptr1= tab;
+  o->internalRep.twoPtrValue.ptr2= ulp;
+  o->typePtr= &tabledataid_nearlytype;
+}
+
+int tabledataid_parse(Tcl_Interp *ip, Tcl_Obj *o, IdDataTable *tab) {
+  int l;
+  unsigned long ul;
+  char *ep, *str;
+
+  if (o->typePtr == &tabledataid_nearlytype &&
+      o->internalRep.twoPtrValue.ptr1 == tab) return TCL_OK;
+
+  l= strlen(tab->prefix);
+  str= Tcl_GetStringFromObj(o,0);
+  if (memcmp(str,tab->prefix,l))
+    return staticerr(ip,"bad id (wrong prefix)",0);
+  errno=0; ul=strtoul(str+l,&ep,10);
+  if (errno || *ep) return staticerr(ip,"bad id number",0);
+  if (ul > INT_MAX) return staticerr(ip,"out of range id number",0);
+
+  objfreeir(o);
+  setobjdataid(o,ul,tab);
+  return TCL_OK;
+}
+
+int pat_iddata(Tcl_Interp *ip, Tcl_Obj *o, void **rv, IdDataTable *tab) {
+  int rc, ix;
+  void *r;
+  
+  rc= tabledataid_parse(ip,o,tab);
+  if (rc) return rc;
+
+  ix= *(unsigned long*)o->internalRep.twoPtrValue.ptr2;
+  if (ix >= tab->n || !(r= tab->a[ix]))
+    return staticerr(ip,"id not in use",0);
+
+  assert(*(int*)r == ix);
+
+  *rv= r;
+  return TCL_OK;
+}
+
+Tcl_Obj *ret_iddata(Tcl_Interp *ip, void *val, IdDataTable *tab) {
+  /* Command procedure implementation may set val->ix,
+   * ie *(int*)val, to -1, to mean it's a new struct.  Otherwise
+   * it had better be an old one !
+   */
+  Tcl_Obj *o;
+  int ix;
+
+  ix= *(int*)val;
+  if (ix==-1) {
+    for (ix=0; ix<tab->n && tab->a[ix]; ix++);
+    if (ix>=tab->n) {
+      tab->n += 2;
+      tab->n *= 2;
+      tab->a= (void*)Tcl_Realloc((void*)tab->a, tab->n*sizeof(*tab->a));
+      while (ix<tab->n) tab->a[ix++]=0;
+      ix--;
+    }
+    tab->a[ix]= val;
+    *(int*)val= ix;
+  } else {
+    assert(val == tab->a[ix]);
+  }
+
+  o= Tcl_NewObj();
+  setobjdataid(o,ix,tab);
+  Tcl_InvalidateStringRep(o);
+  return o;
+}
+
+static int tabledataid_nt_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
+  abort();
+}
+
+static void tabledataid_nt_free(Tcl_Obj *o) {
+  TFREE(o->internalRep.twoPtrValue.ptr2);
+  o->internalRep.twoPtrValue.ptr2= 0;
+}
+
+static void tabledataid_nt_dup(Tcl_Obj *src, Tcl_Obj *dup) {
+  setobjdataid(dup,*(unsigned long*)src->internalRep.twoPtrValue.ptr2,
+              src->internalRep.twoPtrValue.ptr1);
+}
+
+static void tabledataid_nt_ustr(Tcl_Obj *o) {
+  char buf[75];
+  const char *prefix;
+
+  prefix= o->internalRep.twoPtrValue.ptr2;
+  snprintf(buf,sizeof(buf), "%lu",
+          *(unsigned long*)o->internalRep.twoPtrValue.ptr2);
+  obj_updatestr_vstringls(o,
+                         prefix, strlen(prefix),
+                         buf, strlen(buf),
+                         (char*)0);
+}
+
+Tcl_ObjType tabledataid_ntype = {
+  "tabledataid",
+  tabledataid_nt_free, tabledataid_nt_dup,
+  tabledataid_nt_ustr, tabledataid_nt_sfa
+};
index 2e1e573..82700dc 100644 (file)
@@ -8,9 +8,10 @@ Fini hbv                       fini_hbv(ip, rc, &@);
 Type sockaddr:                 SockAddr_Value @
 Init sockaddr                  sockaddr_clear(&@);
 
-Type sockid:                   DgramSockID @
+Type iddata(IdDataTable *tab): void *@
 Type ulong:                    uint32_t @
 Type long:                     long @
+Type string:                   const char *@
 
 H-Include      "hbytes.h"
 
@@ -21,6 +22,9 @@ Table toplevel TopLevel_Command
        dgram-socket
                subcmd  enum(DgramSocket_SubCommand,"dgram-socket subcommand")
                ...     obj
+       tuntap-socket
+               subcmd  enum(TunSocket_SubCommand,"tuntap-socket subcommand")
+               ...     obj
        ulong
                subcmd  enum(ULong_SubCommand,"ulong subcommand")
                ...     obj
@@ -168,15 +172,34 @@ Table padmethodinfo PadMethodInfo
 Table dgram_socket DgramSocket_SubCommand
        create
                local   sockaddr
-               =>      sockid
+               =>      iddata(&dgram_socks)
        close
-               sock    sockid
+               sock    iddata(&dgram_socks)
        transmit
-               sock    sockid
+               sock    iddata(&dgram_socks)
                data    hb
                remote  sockaddr
        on-receive
-               sock    sockid
+               sock    iddata(&dgram_socks)
+               ?script obj
+
+Table tuntap_socket TunSocket_SubCommand
+       create-ptp
+               local   sockaddr
+               peer    sockaddr
+               mtu     long
+               ?ifname string
+               =>      iddata(&tuntap_socks)
+       close
+               sock    iddata(&tuntap_socks)
+       ifname
+               sock    iddata(&tuntap_socks)
+               =>      string
+       receive
+               sock    iddata(&tuntap_socks)
+               data    hb
+       on-transmit
+               sock    iddata(&tuntap_socks)
                ?script obj
 
 Table blockcipherop BlockCipherOp
index 1456770..5cd076e 100755 (executable)
@@ -77,27 +77,17 @@ sub parse ($$) {
        } elsif (@i==2 && m/^(\??)([a-z]\w*)\s*(\S.*)/
                 && defined $c_entry) {
            ($opt, $var, $type) = ($1,$2,$3);
-           if ($type =~ m/^\w+$/) {
-               $xtypeargs='';
-           } elsif ($type =~ m/^(\w+)\((.+)\)$/) {
-               $type= $1;
-               $xtypeargs= $2;
-           }
+           ($type, $xtypeargs) = split_type_args($type);
            push @{ $tables{$c_table}{$c_entry}{A} },
                { N => $var, T => $type, A => $xtypeargs, O => ($opt eq '?') };
        } elsif (@i==2 && m/^\=\>\s*(\S.*)$/ && defined $c_entry) {
-           $tables{$c_table}{$c_entry}{R}= $1;
+           ($type, $xtypeargs) = split_type_args($1);
+           $tables{$c_table}{$c_entry}{R}= $type;
+           $tables{$c_table}{$c_entry}{X}= $xtypeargs;
        } elsif (@i==0 && m/^Type\s+([^\:]+)\:\s+(\S.*)$/) {
            ($typename,$ctype)= ($1,$2);
            $ctype .= ' @' unless $ctype =~ m/\@/;
-           if ($typename =~ m/^\w+$/) {
-               $xtypeargs='';
-           } elsif ($typename =~ m/^(\w+)\((.+)\)$/) {
-               $typename=$1;
-               $xtypeargs=$2;
-           } else {
-               badsyntax($wh,$.,"bad type name/args");
-           }
+           ($typename,$xtypeargs) = split_type_args($typename);
            $types{$typename}= { C => $ctype, X => $xtypeargs };
        } elsif (@i==0 && s/^Init\s+(\w+)\s+(\S.*)//) {
            $type_init{$1}= $2;
@@ -125,7 +115,9 @@ foreach $t (sort keys %types) {
     $decl .= ");\n";
     o('h',160, $decl);
 
-    $decl= "Tcl_Obj *ret_$t(Tcl_Interp *ip, ".subst_in_decl('val',$c).");\n";
+    $decl= "Tcl_Obj *ret_$t(Tcl_Interp *ip, ".subst_in_decl('val',$c);
+    $decl .= ", $xta" if length $xta;
+    $decl .= ");\n";
     o('h',170, $decl);
 }
 
@@ -170,8 +162,9 @@ foreach $c_table (sort keys %tables) {
            $n= $arg->{N};
            $t= $arg->{T};
            $a= $arg->{A};
-           push @do_al, make_decl($n, $t, $arg->{A});
-           $pa_vars .= make_decl_init("a_$n", $t, $a, \$pa_init);
+           push @do_al, make_decl($n, $t, $arg->{A},
+                                  "table $c_table entry $c_entry arg $n");
+           $pa_vars .= make_decl_init("a_$n", $t, $a, \$pa_init, "pa_vars");
            if ($arg->{O}) {
                $pa_hint .= " ?$n?";
                if ($any_mand) {
@@ -223,10 +216,14 @@ foreach $c_table (sort keys %tables) {
        }
        if (exists $r_entry->{R}) {
            $t= $r_entry->{R};
-           push @do_al, make_decl("*result", $t);
-           $pa_vars .= make_decl_init("result", $t, '', \$pa_init);
+           $xta= $r_entry->{X};
+           push @do_al, make_decl("*result", $t, "do_al result");
+           $pa_vars .= make_decl_init("result", $t, $xta, \$pa_init,
+                                      "pa_vars result");
            push @do_aa, "&result";
-           $pa_rslt .= "  Tcl_SetObjResult(ip, ret_$t(ip, result));\n";
+           $pa_rslt .= "  Tcl_SetObjResult(ip, ret_$t(ip, result";
+           $pa_rslt .= ", $xta" if length $xta;
+           $pa_rslt .= "));\n";
        }
        $pa_body .= "\n";
        $pa_body .= "  rc= do_${c_table}_${c_entry_c}(";
@@ -330,10 +327,24 @@ sub o ($$) {
     $o{$wh}{sprintf "%010d", $pr} .= $s;
 }
 
-sub make_decl_init ($$$$) {
-    my ($n, $t, $a, $initcode) = @_;
+sub split_type_args ($) {
+    my ($type) = @_;
+    my ($xtypeargs);
+    if ($type =~ m/^\w+$/) {
+       $xtypeargs='';
+    } elsif ($type =~ m/^(\w+)\((.+)\)$/) {
+       $type= $1;
+       $xtypeargs= $2;
+    } else {
+       badsyntax($wh,$.,"bad type name/args \`$type'\n");
+    }
+    return ($type,$xtypeargs);
+}
+
+sub make_decl_init ($$$$$) {
+    my ($n, $t, $a, $initcode, $why) = @_;
     my ($o,$init);
-    $o= make_decl($n,$t,$a);
+    $o= make_decl($n,$t,$a,"$why _init");
     if (exists $type_init{$t}) {
        $init= $type_init{$t};
        $$initcode .= "  ".subst_in("$n", $init)."\n"
@@ -344,14 +355,14 @@ sub make_decl_init ($$$$) {
     return "  ".$o.";\n";
 }
 
-sub make_decl ($$$) {
-    my ($n, $t, $ta) = @_;
+sub make_decl ($$$$) {
+    my ($n, $t, $ta, $why) = @_;
     my ($type);
     if ($t eq 'enum') {
-       $ta =~ m/\,/ or die "invalid enum type \`$t'\n";
+       $ta =~ m/\,/ or die "invalid enum type \`$t' ($why)\n";
        $c= "const $` *@";
     } else { 
-       defined $types{$t} or die "unknown type $t\n";
+       defined $types{$t} or die "unknown type $t ($why)\n";
        $c= $types{$t}{C};
     }
     return subst_in_decl($n,$c);
index d84d43e..8a19442 100644 (file)
@@ -1,6 +1,7 @@
 OBJS=          tables.o \
                hbytes.o \
                enum.o \
+               idtable.o \
                ulongs.o \
                sockaddr.o \
                dgram.o \
index e541a3a..8148792 100644 (file)
 #include "hbytes.h"
 
 typedef struct DgramSocket {
-  int ix, fd, script_llength;
+  int ix; /* first ! */
+  int fd, script_llength;
   Tcl_Interp *ip;
   Tcl_Obj *script;
   void *addr_buf, *msg_buf;
   int addr_buflen, msg_buflen;
 } DgramSocket;
 
-static int n_socks;
-static DgramSocket **socks;
-
-static int sockfail(Tcl_Interp *ip, int fd, const char *m) {
-  int e;
-  e= errno;
-  close(fd);
-  return posixerr(ip,e,m);
-}
+IdDataTable dgram_socks= { "dgramsock" };
 
 int do_dgram_socket_create(ClientData cd, Tcl_Interp *ip,
-                         SockAddr_Value local, DgramSockID *sock_r) {
-  int fd, al, r, sockix;
+                          SockAddr_Value local, void **sock_r) {
+  int fd, al, r;
   DgramSocket *sock;
   const struct sockaddr *sa;
 
-  for (sockix=0; sockix<n_socks && socks[sockix]; sockix++);
-  if (sockix>=n_socks) {
-    n_socks += 2;
-    n_socks *= 2;
-    socks= (void*)Tcl_Realloc((void*)socks, n_socks*sizeof(*socks));
-    while (sockix<n_socks) socks[sockix++]=0;
-    sockix--;
-  }
-
   sa= sockaddr_addr(&local);
   al= sockaddr_len(&local);
 
   fd= socket(sa->sa_family, SOCK_DGRAM, 0);
   if (fd<0) return posixerr(ip,errno,"socket");
-  r= bind(fd, sa, al);  if (r) return sockfail(ip,fd,"bind");
-  r= setnonblock(fd, 1);  if (r) return sockfail(ip,fd,"setnonblock");
+  r= bind(fd, sa, al);  if (r) return newfdposixerr(ip,fd,"bind");
+  r= setnonblock(fd, 1);  if (r) return newfdposixerr(ip,fd,"setnonblock");
 
-  socks[sockix]= sock= TALLOC(sizeof(DgramSocket));
+  sock= TALLOC(sizeof(DgramSocket));
+  sock->ix= -1;
   sock->fd= fd;
-  sock->ix= sockix;
   sock->script= 0;
   sock->addr_buflen= al+1;
   sock->addr_buf= TALLOC(sock->addr_buflen);
@@ -67,8 +51,9 @@ int do_dgram_socket_create(ClientData cd, Tcl_Interp *ip,
 }
 
 int do_dgram_socket_transmit(ClientData cd, Tcl_Interp *ip,
-                            DgramSocket *sock, HBytes_Value data,
+                            void *sock_v, HBytes_Value data,
                             SockAddr_Value remote) {
+  DgramSocket *sock= sock_v;
   int l, r;
 
   r= sendto(sock->fd,
@@ -139,7 +124,7 @@ static void recv_call(ClientData sock_cd, int mask) {
 
   args[0]= ret_hb(ip, message_val);  hbytes_empty(&message_val);
   args[1]= ret_sockaddr(ip, peer_val);  sockaddr_clear(&peer_val);
-  args[2]= ret_sockid(ip, sock);
+  args[2]= ret_iddata(ip, sock, &dgram_socks);
   for (i=0; i<3; i++) Tcl_IncrRefCount(args[i]);
 
   invoke= Tcl_DuplicateObj(sock->script);
@@ -159,7 +144,8 @@ x_rc:
 }
 
 int do_dgram_socket_on_receive(ClientData cd, Tcl_Interp *ip,
-                              DgramSocket *sock, Tcl_Obj *script) {
+                              void *sock_v, Tcl_Obj *script) {
+  DgramSocket *sock= sock_v;
   int rc;
   
   if (script) {
@@ -177,7 +163,8 @@ int do_dgram_socket_on_receive(ClientData cd, Tcl_Interp *ip,
   return TCL_OK;
 }
 
-int do_dgram_socket_close(ClientData cd, Tcl_Interp *ip, DgramSocket *sock) {
+int do_dgram_socket_close(ClientData cd, Tcl_Interp *ip, void *sock_v) {
+  DgramSocket *sock= sock_v;
   int sockix;
   cancel(sock);
   close(sock->fd); /* nothing useful to be done with errors */
@@ -185,73 +172,6 @@ int do_dgram_socket_close(ClientData cd, Tcl_Interp *ip, DgramSocket *sock) {
   TFREE(sock->addr_buf);
   TFREE(sock->msg_buf);
   TFREE(sock);
-  socks[sockix]= 0;
-  return TCL_OK;
-}
-
-/* Arg parsing */
-
-int pat_sockid(Tcl_Interp *ip, Tcl_Obj *o, DgramSocket **val) {
-  int rc, sockix;
-  DgramSocket *sock;
-  
-  rc= Tcl_ConvertToType(ip,o,&dgramsockid_type);
-  if (rc) return rc;
-
-  sockix= o->internalRep.longValue;
-  if (sockix >= n_socks || !(sock= socks[sockix]))
-    return staticerr(ip,"dgram socket not open",0);
-
-  assert(socks[sockix]->ix == sockix);
-
-  *val= sock;
-  return TCL_OK;
-}
-
-Tcl_Obj *ret_sockid(Tcl_Interp *ip, DgramSocket *val) {
-  Tcl_Obj *o;
-
-  o= Tcl_NewObj();
-  Tcl_InvalidateStringRep(o);
-  o->internalRep.longValue= val->ix;
-  o->typePtr= &dgramsockid_type;
-  return o;
-}
-
-static void sockid_t_free(Tcl_Obj *o) { }
-
-static void sockid_t_dup(Tcl_Obj *src, Tcl_Obj *dup) {
-  dup->internalRep= src->internalRep;
-  dup->typePtr= &dgramsockid_type;
-}
-
-static void sockid_t_ustr(Tcl_Obj *o) {
-  char buf[75];
-
-  snprintf(buf,sizeof(buf), "%d", (int)o->internalRep.longValue);
-  obj_updatestr_vstringls(o,
-                         "dgramsock",9,
-                         buf, strlen(buf),
-                         (char*)0);
-}
-
-static int sockid_t_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
-  unsigned long ul;
-  char *ep, *str;
-  
-  str= Tcl_GetStringFromObj(o,0);
-  if (memcmp(str,"dgramsock",9)) return staticerr(ip,"bad dgram socket id",0);
-  errno=0; ul=strtoul(str+9,&ep,10);
-  if (errno || *ep) return staticerr(ip,"bad dgram socket id number",0);
-  if (ul > INT_MAX) return staticerr(ip,"out of range dgram socket id",0);
-
-  objfreeir(o);
-  o->internalRep.longValue= ul;
-  o->typePtr= &dgramsockid_type;
+  dgram_socks.a[sockix]= 0;
   return TCL_OK;
 }
-
-Tcl_ObjType dgramsockid_type = {
-  "dgramsockid",
-  sockid_t_free, sockid_t_dup, sockid_t_ustr, sockid_t_sfa
-};
index f8f59fd..f7d0110 100644 (file)
@@ -175,10 +175,25 @@ int sockaddr_len(const SockAddr_Value*);
 const struct sockaddr *sockaddr_addr(const SockAddr_Value*);
 void sockaddr_free(const SockAddr_Value*);
 
+/* from idtable.c */
+
+typedef struct {
+  const char *const prefix;
+  int n;
+  void **a;
+} IdDataTable;
+
+extern Tcl_ObjType tabledataid_nearlytype;
+int tabledataid_parse(Tcl_Interp *ip, Tcl_Obj *o, IdDataTable *tab);
+
 /* from dgram.c */
 
-extern Tcl_ObjType dgramsockid_type;
-typedef struct DgramSocket *DgramSockID;
+extern IdDataTable dgram_socks;
+int newfdposixerr(Tcl_Interp *ip, int fd, const char *m);
+
+/* from tuntap.c */
+
+extern IdDataTable tuntap_socks;
 
 /* from hook.c */
 
index a9d0316..b84306a 100644 (file)
@@ -22,6 +22,13 @@ int posixerr(Tcl_Interp *ip, int errnoval, const char *m) {
   return TCL_ERROR;
 }
 
+int newfdposixerr(Tcl_Interp *ip, int fd, const char *m) {
+  int e;
+  e= errno;
+  close(fd);
+  return posixerr(ip,e,m);
+}
+
 void objfreeir(Tcl_Obj *o) {
   if (o->typePtr && o->typePtr->freeIntRepProc)
     o->typePtr->freeIntRepProc(o);
@@ -361,6 +368,12 @@ int do_toplevel_dgram_socket(ClientData cd, Tcl_Interp *ip,
   return subcmd->func(0,ip,objc,objv);
 }
 
+int do_toplevel_tuntap_socket(ClientData cd, Tcl_Interp *ip,
+                            const TunSocket_SubCommand *subcmd,
+                            int objc, Tcl_Obj *const *objv) {
+  return subcmd->func(0,ip,objc,objv);
+}
+
 int do_toplevel_ulong(ClientData cd, Tcl_Interp *ip,
                      const ULong_SubCommand *subcmd,
                      int objc, Tcl_Obj *const *objv) {
@@ -400,7 +413,7 @@ int Hbytes_Init(Tcl_Interp *ip) {
   Tcl_RegisterObjType(&enum_nearlytype);
   Tcl_RegisterObjType(&enum1_nearlytype);
   Tcl_RegisterObjType(&sockaddr_type);
-  Tcl_RegisterObjType(&dgramsockid_type);
+  Tcl_RegisterObjType(&tabledataid_nearlytype);
   Tcl_RegisterObjType(&ulong_type);
 
   for (cmd=toplevel_commands;
diff --git a/tuntap/tuntap.c b/tuntap/tuntap.c
new file mode 100644 (file)
index 0000000..a4d9f9a
--- /dev/null
@@ -0,0 +1,276 @@
+/*
+ */
+/*
+ * tuntap-socket create-ptp <local-addr> <peer-addr> <mtu> [<ifname>]
+ *               => <sockid>
+ * tuntap-socket close <sockid>
+ * tuntap-socket ifname <sockid>
+ * tuntap-socket receive <sockid> <data>
+ * tuntap-socket on-transmit <sockid> [<script>]
+ *    calls, effectively,  eval <script> [list <data> <socket>]
+ *    if script not supplied, cancel
+ */
+
+#include "tables.h"
+#include "hbytes.h"
+
+typedef struct TunSocket {
+  int ix, fd, script_llength;
+  Tcl_Interp *ip;
+  Tcl_Obj *script;
+  void msg_buf;
+  int mtu;
+  char *ifname;
+} TuntapSocket;
+
+IdDataTable tuntap_socks= { "tuntap" };
+
+static int sockfail(Tcl_Interp *ip, int fd, const char *m) {
+  int e;
+  e= errno;
+  close(fd);
+  return posixerr(ip,e,m);
+}
+
+int do_tuntap_socket_create_ptp(ClientData cd, Tcl_Interp *ip,
+                               SockAddr_Value local, SockAddr_Value peer,
+                               long mtu, const char *ifname,
+                               void **sock_r) {
+  int fd, local_al, peer_al, r;
+  struct ifreq ifr;
+  DgramSocket *sock;
+  const struct sockaddr *local_sa, *peer_sa;
+
+  local_sa= sockaddr_addr(&local);
+  local_al= sockaddr_len(&local);
+
+  peer_sa= sockaddr_addr(&peer);
+  peer_al= sockaddr_len(&peer);
+
+  if (local_sa != AF_INET || local_al != sizeof(struct in_addr) ||
+      peer_sa != AF_INET || peer_al != sizeof(struct in_addr))
+    return staticerr(ip,"tuntap not IPv4");
+
+  memset(&ifr,0,sizeof(ifr));
+  ifr.ifr_flags= IFF_TUN | IFF_NO_PI;
+  
+  if (ifname) {
+    if (strlen(ifname) > IFNAMSIZ-1)
+      return staticerr(ip,"tun interface name too long");
+    strcpy(ifr.ifr_name, ifname);
+  }
+
+  fd= open("/dev/net/tun", O_RDWR);
+  if (fd<0) return posixerr(ip,errno,"open /dev/net/tun");
+
+  r= ioctl(fd, TUNSETIFF, (void*)&ifr);
+  if (r) return posixerr(ip,errno,"ioctl TUNSETIFF");
+
+  
+
+  r= 
+  r= bind(fd, sa, al);  if (r) return sockfail(ip,fd,"bind");
+  r= setnonblock(fd, 1);  if (r) return sockfail(ip,fd,"setnonblock");
+
+  sock= TALLOC(sizeof(DgramSocket));
+  sock->ix= -1;
+  sock->fd= fd;
+  sock->script= 0;
+  sock->addr_buflen= al+1;
+  sock->addr_buf= TALLOC(sock->addr_buflen);
+  sock->msg_buflen= 0;
+  sock->msg_buf= 0;
+
+  *sock_r= sock;
+  return TCL_OK;
+}
+
+int do_tuntap_socket_transmit(ClientData cd, Tcl_Interp *ip,
+                            TuntapSocket *sock, HBytes_Value data,
+                            SockAddr_Value remote) {
+  int l, r;
+
+  r= sendto(sock->fd,
+           hbytes_data(&data), l=hbytes_len(&data),
+           0,
+           sockaddr_addr(&remote), sockaddr_len(&remote));
+  if (r==-1) return posixerr(ip,errno,"sendto");
+  else if (r!=l) return staticerr(ip,"sendto gave wrong answer",0);
+  return TCL_OK;
+}
+
+static void cancel(TuntapSocket *sock) {
+  if (sock->script) {
+    Tcl_DeleteFileHandler(sock->fd);
+    Tcl_DecrRefCount(sock->script);
+    sock->script= 0;
+  }
+}
+
+static void recv_call(ClientData sock_cd, int mask) {
+  TuntapSocket *sock= (void*)sock_cd;
+  Tcl_Interp *ip= sock->ip;
+  int sz, rc, i, peek;
+  HBytes_Value message_val;
+  SockAddr_Value peer_val;
+  Tcl_Obj *args[3], *invoke;
+  struct msghdr mh;
+  struct iovec iov;
+
+  hbytes_empty(&message_val);
+  sockaddr_clear(&peer_val);
+  invoke=0; for (i=0; i<3; i++) args[i]=0;
+
+  mh.msg_iov= &iov;
+  mh.msg_iovlen= 1;
+  mh.msg_control= 0;
+  mh.msg_controllen= 0;
+  mh.msg_flags= 0;
+
+  peek= MSG_PEEK;
+  
+  for (;;) {
+    mh.msg_name= sock->addr_buf;
+    mh.msg_namelen= sock->addr_buflen;
+
+    iov.iov_base= sock->msg_buf;
+    iov.iov_len= sock->msg_buflen;
+
+    sz= recvmsg(sock->fd, &mh, peek);
+    if (sz==-1) { rc=0; goto x_rc; }
+
+    assert(mh.msg_namelen < sock->addr_buflen);
+
+    if (!(mh.msg_flags & MSG_TRUNC)) {
+      if (!peek) break;
+      peek= 0;
+      continue;
+    }
+
+    TFREE(sock->msg_buf);
+    sock->msg_buflen *= 2;
+    sock->msg_buflen += 100;
+    sock->msg_buf= TALLOC(sock->msg_buflen);
+  }
+
+  hbytes_array(&message_val, iov.iov_base, sz);
+  sockaddr_create(&peer_val, mh.msg_name, mh.msg_namelen);
+
+  args[0]= ret_hb(ip, message_val);  hbytes_empty(&message_val);
+  args[1]= ret_sockaddr(ip, peer_val);  sockaddr_clear(&peer_val);
+  args[2]= ret_sockid(ip, sock);
+  for (i=0; i<3; i++) Tcl_IncrRefCount(args[i]);
+
+  invoke= Tcl_DuplicateObj(sock->script);
+  Tcl_IncrRefCount(invoke);
+
+  rc= Tcl_ListObjReplace(ip,invoke,sock->script_llength,0,3,args);
+  for (i=0; i<3; i++) { Tcl_DecrRefCount(args[i]); args[i]= 0; }
+  if (rc) goto x_rc;
+
+  rc= Tcl_EvalObjEx(ip,invoke,TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT);
+
+x_rc:
+  if (invoke) Tcl_DecrRefCount(invoke);
+
+  if (rc)
+    Tcl_BackgroundError(ip);
+}
+
+int do_tuntap_socket_on_receive(ClientData cd, Tcl_Interp *ip,
+                              TuntapSocket *sock, Tcl_Obj *script) {
+  int rc;
+  
+  if (script) {
+    rc= Tcl_ListObjLength(ip, script, &sock->script_llength);
+    if (rc) return rc;
+  }
+  
+  cancel(sock);
+  if (script) {
+    Tcl_IncrRefCount(script);
+    sock->script= script;
+    sock->ip= ip;
+  }
+  Tcl_CreateFileHandler(sock->fd, TCL_READABLE, recv_call, sock);
+  return TCL_OK;
+}
+
+int do_tuntap_socket_close(ClientData cd, Tcl_Interp *ip, TuntapSocket *sock) {
+  int sockix;
+  cancel(sock);
+  close(sock->fd); /* nothing useful to be done with errors */
+  sockix= sock->ix;
+  TFREE(sock->addr_buf);
+  TFREE(sock->msg_buf);
+  TFREE(sock);
+  socks[sockix]= 0;
+  return TCL_OK;
+}
+
+/* Arg parsing */
+
+int pat_sockid(Tcl_Interp *ip, Tcl_Obj *o, TuntapSocket **val) {
+  int rc, sockix;
+  TuntapSocket *sock;
+  
+  rc= Tcl_ConvertToType(ip,o,&tuntapsockid_type);
+  if (rc) return rc;
+
+  sockix= o->internalRep.longValue;
+  if (sockix >= n_socks || !(sock= socks[sockix]))
+    return staticerr(ip,"tuntap socket not open",0);
+
+  assert(socks[sockix]->ix == sockix);
+
+  *val= sock;
+  return TCL_OK;
+}
+
+Tcl_Obj *ret_sockid(Tcl_Interp *ip, TuntapSocket *val) {
+  Tcl_Obj *o;
+
+  o= Tcl_NewObj();
+  Tcl_InvalidateStringRep(o);
+  o->internalRep.longValue= val->ix;
+  o->typePtr= &tuntapsockid_type;
+  return o;
+}
+
+static void sockid_t_free(Tcl_Obj *o) { }
+
+static void sockid_t_dup(Tcl_Obj *src, Tcl_Obj *dup) {
+  dup->internalRep= src->internalRep;
+  dup->typePtr= &tuntapsockid_type;
+}
+
+static void sockid_t_ustr(Tcl_Obj *o) {
+  char buf[75];
+
+  snprintf(buf,sizeof(buf), "%d", (int)o->internalRep.longValue);
+  obj_updatestr_vstringls(o,
+                         "tuntapsock",9,
+                         buf, strlen(buf),
+                         (char*)0);
+}
+
+static int sockid_t_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
+  unsigned long ul;
+  char *ep, *str;
+  
+  str= Tcl_GetStringFromObj(o,0);
+  if (memcmp(str,"tuntapsock",9)) return staticerr(ip,"bad tuntap socket id",0);
+  errno=0; ul=strtoul(str+9,&ep,10);
+  if (errno || *ep) return staticerr(ip,"bad tuntap socket id number",0);
+  if (ul > INT_MAX) return staticerr(ip,"out of range tuntap socket id",0);
+
+  objfreeir(o);
+  o->internalRep.longValue= ul;
+  o->typePtr= &tuntapsockid_type;
+  return TCL_OK;
+}
+
+Tcl_ObjType tuntapsockid_type = {
+  "tuntapsockid",
+  sockid_t_free, sockid_t_dup, sockid_t_ustr, sockid_t_sfa
+};