new socket id arrangements, working on tun

[chiark-tcl.git] / base / idtable.c

diff --git a/base/idtable.c b/base/idtable.c
new file mode 100644 (file)
index 0000000..c2f3aaa
--- /dev/null
+++ b/base/idtable.c
@@ -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
+};