* Non-maintainer upload.
* Build against the default Tcl version instead of deprecated 8.4
(closes: #725248).
# imported from the archive
--- /dev/null
+
+SUBDIRS= base adns hbytes cdb crypto dgram tuntap
+
+default: all
+
+clean all:
+ set -e; for d in $(SUBDIRS); do $(MAKE) -C $$d $@; done
+
+# To find undefined symbols when implementing, for example:
+#
+# liberator:chiark-tcl> LD_LIBRARY_PATH=:adns:base:cdb:crypto:dgram:hbytes:tuntap tclsh8.3
+# % load chiark_tcl_tuntap-1.so
+# couldn't load file "chiark_tcl_tuntap-1.so": tuntap/chiark_tcl_tuntap-1.so: undefined symbol: cht_tunsocket_entries
+# %
--- /dev/null
+BASE_DIR = ../base
+EXTBASE = adns
+CFILES = adns
+LDLIBS += -ladns
+
+include ../base/extension.make
+
--- /dev/null
+/*
+ * adns lookup TYPE DOMAIN [QUERY-OPTIONS] => [list RDATA]
+ * if no or dontknow, throws an exception, with errorCode one of
+ * ADNS permfail 300 nxdomain {No such domain}
+ * ADNS permfail 301 nodata {No such data}
+ * ADNS tempfail ERROR-CODE ERROR-NAME ERROR-STRING
+ * where
+ * ERROR-CODE is the numerical adns status value
+ * ERROR-NAME is the symbolic adns status value (in lowercase)
+ * ERROR-STRING is the result of adns_strstatus
+ *
+ * adns synch TYPE DOMAIN [QUERY-OPTIONS] => RESULTS
+ * RESULTS is [list ok|permfail|tempfail
+ * ERROR-CODE ERROR-NAME ERROR-STRING \
+ * OWNER CNAME \
+ * [list RDATA ...]]
+ * OWNER is the RR owner
+ * CNAME is the empty string or the canonical name if we went
+ * via a CNAME
+ *
+ * adns asynch ON-YES ON-NO ON-DONTKNOW XARGS \
+ * TYPE DOMAIN \
+ * [QUERY-OPTIONS...] => QUERY-ID
+ * calls, later,
+ * [concat ON-YES|ON-NO|ON-DONTKNOW XARGS RESULTS]
+ * adns asynch-cancel QUERY-ID
+ *
+ * QUERY-OPTIONS are zero or more of
+ * -resolver RESOLVER (see adns new-resolver)
+ * default is to use a default resolver
+ * -search
+ * -usevc
+ * -quoteok-query
+ * -quoteok-anshost
+ * -quotefail-cname
+ * -cname-loose
+ * -cname-forbid
+ * -reverse
+ * -reverse-any ZONE-A-LIKE
+ *
+ * adns new-resolver [RES-OPTIONS...] => RESOLVER
+ * options:
+ * -errfile stdout|stderr (stderr is the default)
+ * -noerrprint
+ * -errcallback CALLBACK results in eval CALLBACK [list MESSAGE]
+ * -noenv|-debug|-logpid
+ * -checkc-entex
+ * -checkc-freq
+ * -config CONFIG-STRING
+ *
+ * adns set-default-resolver RESOLVER
+ * cancels any outstanding queries from a previous anonymous
+ * default resolver
+ *
+ * adns destroy-resolver RESOLVER
+ * cancels outstanding queries
+ *
+ */
+/* ---8<--- end of documentation comment --8<-- */
+
+/*
+ * adns.c - adns binding for Tcl
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#define _GNU_SOURCE
+
+#include <stdio.h>
+
+#include <adns.h>
+
+#include "chiark_tcl_adns.h"
+
+/*---------- important types and forward declarations ----------*/
+
+typedef struct Query Query;
+typedef struct Resolver Resolver;
+typedef struct OptionInfo OptionInfo;
+
+static void asynch_sethandlers(Resolver *res);
+static void asynch_cancelhandlers(Resolver *res);
+static void asynch_perturbed(Resolver *res);
+
+static void asynch_query_dispose(Tcl_Interp *interp, Query *query);
+
+#define ASSOC_DEFAULTRES "adns-defaultresolver"
+
+/*---------- common resolver/query option processing ----------*/
+
+typedef struct {
+ /* this struct type is used to hold both resolver and query options */
+ /* common to resolver and query: */
+ unsigned long aflags;
+ unsigned long sflags;
+ /* resolver: */
+ FILE *errfile;
+ Tcl_Obj *errcallback;
+ const char *config_string;
+ /* query: */
+ Resolver *resolver;
+ const char *reverseany;
+} OptionParse;
+
+struct OptionInfo {
+ const char *name;
+ int (*fn)(Tcl_Interp *ip, const OptionInfo *oi, Tcl_Obj *arg,
+ OptionParse *op);
+ int takesarg;
+ unsigned long flags_add, flags_remove;
+};
+
+enum {
+ oisf_reverse= 0x0002
+};
+
+static int oiufn_f(const OptionInfo *oi, unsigned long *flags) {
+ *flags &= ~oi->flags_remove;
+ *flags |= oi->flags_add;
+ return TCL_OK;
+}
+static int oifn_fa(Tcl_Interp *ip, const OptionInfo *oi, Tcl_Obj *arg,
+ OptionParse *op) { return oiufn_f(oi,&op->aflags); }
+static int oifn_fs(Tcl_Interp *ip, const OptionInfo *oi, Tcl_Obj *arg,
+ OptionParse *op) { return oiufn_f(oi,&op->sflags); }
+
+static int oifn_reverse_any(Tcl_Interp *ip, const OptionInfo *oi,
+ Tcl_Obj *arg, OptionParse *op) {
+ return cht_pat_string(ip,arg,&op->reverseany);
+}
+
+#define OIFA1(t,f,r) { "-" #f, oifn_fa, 0, adns_##t##_##f, r }
+#define OIFA2(t,f,g) { "-" #f "-" #g, oifn_fa, 0, adns_##t##_##f##_##g, 0 }
+#define OIFS(f) { "-" #f, oifn_fs, 0, oisf_##f, 0 }
+#define OICA(o) { "-" #o, oifn_##o, 1 }
+
+static void optparse_blank(OptionParse *op) {
+ memset(op,0,sizeof(*op));
+ op->errfile= stderr;
+ op->errcallback= 0;
+ op->config_string= 0;
+}
+
+static int parse_options(Tcl_Interp *ip, int objc, Tcl_Obj *const *objv,
+ const OptionInfo opttable[], OptionParse *op) {
+ const OptionInfo *oi;
+ const void *oi_v;
+ Tcl_Obj *arg;
+ int rc;
+
+ objc--; objv++;
+ for (;;) {
+ if (!objc--) break;
+ rc= cht_pat_enum(ip, *objv++, &oi_v, opttable, sizeof(OptionInfo),
+ "query or resolver option");
+ if (rc) return rc;
+ oi= oi_v;
+
+ if (oi->takesarg) {
+ if (!objc--) {
+ cht_setstringresult(ip,"missing value for option");
+ return TCL_ERROR;
+ }
+ arg= *objv++;
+ } else {
+ arg= 0;
+ }
+ rc= oi->fn(ip,oi,arg,op);
+ if (rc) return rc;
+ }
+ return TCL_OK;
+}
+
+/*---------- resolver management ----------*/
+
+struct Resolver {
+ int ix; /* first! */
+ Tcl_Interp *interp;
+ adns_state ads;
+ Tcl_TimerToken timertoken;
+ int maxfd;
+ fd_set handling[3];
+ ScriptToInvoke errcallback;
+ Tcl_Obj *errstring_accum;
+};
+
+struct Query {
+ int ix; /* first! */
+ Resolver *res;
+ adns_query aqu;
+ ScriptToInvoke on_yes, on_no, on_fail;
+ Tcl_Obj *xargs;
+};
+
+/* The default resolver is recorded using Tcl_SetAssocData with key
+ * ASSOC_DEFAULTRES to record the Resolver*. If it was explicitly
+ * created with `adns new-resolver' then ix will be >=0, and the
+ * resolver will be destroyed - leaving no default - when explicitly
+ * requested. If it was implicitly created (by starting a query when
+ * there is no default) then ix will be -1. */
+
+static int oifn_errfile(Tcl_Interp *ip, const OptionInfo *oi,
+ Tcl_Obj *arg, OptionParse *op) {
+ int rc;
+ const char *str;
+
+ rc= cht_pat_string(ip,arg,&str); if (rc) return rc;
+ if (!strcmp(str,"stderr")) op->errfile= stderr;
+ else if (!strcmp(str,"stdout")) op->errfile= stdout;
+ else return cht_staticerr(ip,"-errfile argument must be stderr or stdout",0);
+
+ op->aflags &= ~adns_if_noerrprint;
+ op->errcallback= 0;
+ return TCL_OK;
+}
+
+static int oifn_errcallback(Tcl_Interp *ip, const OptionInfo *oi,
+ Tcl_Obj *arg, OptionParse *op) {
+ op->errcallback= arg;
+ op->aflags &= ~adns_if_noerrprint;
+ op->errfile= 0;
+ return TCL_OK;
+}
+
+static int oifn_config(Tcl_Interp *ip, const OptionInfo *oi,
+ Tcl_Obj *arg, OptionParse *op) {
+ return cht_pat_string(ip,arg,&op->config_string);
+}
+
+static const OptionInfo resolver_optioninfos[]= {
+ OIFA1(if,noenv, 0),
+ OIFA1(if,debug, adns_if_noerrprint),
+ OIFA1(if,logpid, adns_if_noerrprint),
+ OIFA1(if,noerrprint, adns_if_debug),
+ OIFA2(if,checkc,entex),
+ OIFA2(if,checkc,freq),
+ OICA(errfile),
+ OICA(errcallback),
+ OICA(config),
+ { 0 }
+};
+
+static void adnslogfn_flushmessage(Resolver *res) {
+ cht_scriptinv_invoke(&res->errcallback, 1, &res->errstring_accum);
+ Tcl_SetObjLength(res->errstring_accum, 0);
+}
+
+static void adnslogfn_callback(adns_state ads, void *logfndata,
+ const char *fmt, va_list al) {
+ Resolver *res= logfndata;
+ int l, newline;
+ char *str;
+
+ l= vasprintf(&str,fmt,al);
+ if (l<0) {
+ cht_posixerr(res->interp,errno,"construct adns log callback string");
+ Tcl_BackgroundError(res->interp);
+ }
+
+ if (l==0) { free(str); return; }
+ if ((newline= l>0 && str[l-1]=='\n')) l--;
+
+ if (!res->errstring_accum) {
+ res->errstring_accum= Tcl_NewStringObj(str,l);
+ Tcl_IncrRefCount(res->errstring_accum);
+ } else {
+ Tcl_AppendToObj(res->errstring_accum,str,l);
+ }
+ free(str);
+
+ if (newline)
+ adnslogfn_flushmessage(res);
+}
+
+static Resolver *default_resolver(Tcl_Interp *ip) {
+ return Tcl_GetAssocData(ip,ASSOC_DEFAULTRES,0);
+}
+
+static void destroy_resolver(Tcl_Interp *ip, Resolver *res) {
+ void *query_v;
+ Query *query;
+ int logstring_len;
+ char *rstr;
+ adns_query aqu;
+
+ if (res == default_resolver(ip))
+ Tcl_DeleteAssocData(ip,ASSOC_DEFAULTRES);
+
+ if (res->errstring_accum) {
+ rstr= Tcl_GetStringFromObj(res->errstring_accum, &logstring_len);
+ assert(rstr);
+ if (logstring_len)
+ adnslogfn_flushmessage(res);
+ }
+
+ if (res->ads) {
+ /* although adns would throw these away for us, we need to
+ * destroy our own data too and only adns has a list of them */
+ for (;;) {
+ adns_forallqueries_begin(res->ads);
+ aqu= adns_forallqueries_next(res->ads, &query_v);
+ if (!aqu) break;
+ query= query_v;
+ assert(query->aqu == aqu);
+ query->aqu= 0; /* avoid disrupting the adns query list */
+ asynch_query_dispose(ip, query_v);
+ }
+ adns_finish(res->ads);
+ res->ads= 0;
+ }
+ asynch_cancelhandlers(res);
+ cht_scriptinv_cancel(&res->errcallback);
+ Tcl_EventuallyFree(res, Tcl_Free);
+}
+
+static void destroy_resolver_idtabcb(Tcl_Interp *ip, void *resolver_v) {
+ destroy_resolver(ip,resolver_v);
+}
+static void destroy_resolver_defcb(ClientData resolver_v, Tcl_Interp *ip) {
+ destroy_resolver(ip,resolver_v);
+}
+
+int cht_do_adns_destroy_resolver(ClientData cd, Tcl_Interp *ip, void *res_v) {
+ cht_tabledataid_disposing(ip,res_v,&cht_adnstcl_resolvers);
+ destroy_resolver(ip,res_v);
+ return TCL_OK;
+}
+
+static int create_resolver(Tcl_Interp *ip, const OptionParse *op,
+ Resolver **res_r) {
+ Resolver *res=0;
+ int rc, i, ec;
+
+ res= TALLOC(sizeof(*res)); assert(res);
+ res->ix= -1;
+ res->interp= ip;
+ res->ads= 0;
+ res->timertoken= 0;
+ res->maxfd= 0;
+ for (i=0; i<3; i++) FD_ZERO(&res->handling[i]);
+ cht_scriptinv_init(&res->errcallback);
+ res->errstring_accum= 0;
+
+ if (op->errcallback)
+ cht_scriptinv_set(&res->errcallback, ip, op->errcallback, 0);
+
+ ec= adns_init_logfn(&res->ads,
+ op->aflags | adns_if_noautosys,
+ op->config_string,
+ op->errcallback ? adnslogfn_callback : 0,
+ op->errcallback ? (void*)res : (void*)op->errfile);
+ if (ec) { rc= cht_posixerr(ip,ec,"create adns resolver"); goto x_rc; }
+
+ *res_r= res;
+ return TCL_OK;
+
+ x_rc:
+ if (res) {
+ if (res->ads) adns_finish(res->ads);
+ TFREE(res);
+ }
+ return rc;
+}
+
+int cht_do_adns_new_resolver(ClientData cd, Tcl_Interp *ip,
+ int objc, Tcl_Obj *const *objv,
+ void **result) {
+ OptionParse op;
+ Resolver *res=0;
+ int rc;
+
+ optparse_blank(&op);
+ rc= parse_options(ip,objc,objv,resolver_optioninfos,&op);
+ if (rc) return rc;
+
+ if (op.aflags & adns_if_noerrprint) {
+ op.errfile= 0;
+ op.errcallback= 0;
+ }
+
+ rc= create_resolver(ip, &op, &res);
+ if (rc) return rc;
+
+ *result= res;
+ return TCL_OK;
+}
+
+int cht_do_adns_set_default_resolver(ClientData cd, Tcl_Interp *ip, void *res_v) {
+ Resolver *res= res_v;
+ Tcl_DeleteAssocData(ip,ASSOC_DEFAULTRES);
+ Tcl_SetAssocData(ip, ASSOC_DEFAULTRES, 0, res);
+ return TCL_OK;
+}
+
+const IdDataSpec cht_adnstcl_resolvers= {
+ "adns-res", "adns-resolvers-table", destroy_resolver_idtabcb
+};
+
+/*---------- query, query option and answers - common stuff ----------*/
+
+#define RRTYPE_EXACTLY(t) { #t, adns_r_##t }
+#define RRTYPE_RAW(t) { #t, adns_r_##t##_raw }
+#define RRTYPE_PLUS(t) { #t "+", adns_r_##t }
+#define RRTYPE_MINUS(t) { #t "-", adns_r_##t##_raw }
+
+const AdnsTclRRTypeInfo cht_adnstclrrtypeinfo_entries[]= {
+ RRTYPE_EXACTLY(a),
+ RRTYPE_EXACTLY(cname),
+ RRTYPE_EXACTLY(hinfo),
+ RRTYPE_EXACTLY(addr),
+
+ RRTYPE_RAW(ns),
+ RRTYPE_RAW(mx),
+ RRTYPE_EXACTLY(txt),
+
+ RRTYPE_EXACTLY(soa),
+ RRTYPE_EXACTLY(ptr),
+ RRTYPE_EXACTLY(rp),
+
+ RRTYPE_MINUS(soa),
+ RRTYPE_MINUS(ptr),
+ RRTYPE_MINUS(rp),
+ { 0 }
+};
+
+static int oifn_resolver(Tcl_Interp *ip, const OptionInfo *oi,
+ Tcl_Obj *arg, OptionParse *op) {
+ void *val_v;
+ int rc;
+
+ rc= cht_pat_iddata(ip,arg,&val_v,&cht_adnstcl_resolvers);
+ if (rc) return rc;
+ op->resolver= val_v;
+ return TCL_OK;
+}
+
+static const OptionInfo query_optioninfos[]= {
+ OIFA1(qf,search,0),
+ OIFA1(qf,usevc,0),
+ OIFA2(qf,quoteok,query),
+ OIFA2(qf,quoteok,anshost),
+ OIFA2(qf,quotefail,cname),
+ OIFA2(qf,cname,loose),
+ OIFA2(qf,cname,forbid),
+ OICA(resolver),
+ OIFS(reverse),
+ { "-reverse-any", oifn_reverse_any, 1 },
+ { 0 }
+};
+
+static int query_submit(Tcl_Interp *ip,
+ const AdnsTclRRTypeInfo *type, const char *domain,
+ int queryopts_objc, Tcl_Obj *const *queryopts_objv,
+ adns_query *aqu_r, void *context, Resolver **res_r) {
+ struct sockaddr sa;
+ static const int aftry[]= { AF_INET, AF_INET6 };
+ OptionParse op;
+ OptionParse res_op;
+ int rc, r, ec;
+ adns_state ads;
+
+ op.aflags= adns_qf_owner;
+ op.sflags= 0;
+ op.resolver= 0;
+ op.reverseany= 0;
+ rc= parse_options(ip, queryopts_objc,queryopts_objv, query_optioninfos,&op);
+ if (rc) return rc;
+
+ if (!op.resolver) {
+ op.resolver= default_resolver(ip);
+ if (!op.resolver) {
+ optparse_blank(&res_op);
+ rc= create_resolver(ip, &res_op, &op.resolver);
+ if (rc) return rc;
+
+ Tcl_SetAssocData(ip, ASSOC_DEFAULTRES,
+ destroy_resolver_defcb, op.resolver);
+ }
+ }
+
+ *res_r= op.resolver;
+
+ if (op.reverseany || (op.sflags & oisf_reverse)) {
+ const int *af;
+ for (af=aftry; af < af + sizeof(af)/sizeof(*af); af++) {
+ memset(&sa,0,sizeof(sa));
+ sa.sa_family= *af;
+ r= inet_pton(*af,domain,&sa);
+ if (!r) goto af_found;
+ }
+ return cht_staticerr(ip,"invalid address for adns reverse submit",
+ "ADNS REVERSE INVALID");
+ af_found:;
+ }
+
+ ads= op.resolver->ads;
+
+ if (op.reverseany) {
+ ec= adns_submit_reverse_any(ads, &sa, op.reverseany,
+ type->number, op.aflags, context, aqu_r);
+ } else if (op.sflags & oisf_reverse) {
+ ec= adns_submit_reverse(ads, &sa,
+ type->number, op.aflags, context, aqu_r);
+ } else {
+ ec= adns_submit(ads, domain,
+ type->number, op.aflags, context, aqu_r);
+ }
+ if (ec)
+ return cht_posixerr(ip,ec,"submit adns query");
+
+ return TCL_OK;
+}
+
+#define RESULTSTATUS_LLEN 4
+#define RESULTLIST_LLEN 7
+
+static void make_resultstatus(Tcl_Interp *ip, adns_status status,
+ Tcl_Obj *results[RESULTSTATUS_LLEN]) {
+ results[0]= cht_ret_string(ip, adns_errtypeabbrev(status));
+ results[1]= cht_ret_int(ip, status);
+ results[2]= cht_ret_string(ip, adns_errabbrev(status));
+ results[3]= cht_ret_string(ip, adns_strerror(status));
+ assert(RESULTSTATUS_LLEN==4);
+}
+
+static Tcl_Obj *make_resultrdata(Tcl_Interp *ip, adns_answer *answer) {
+ Tcl_Obj **rdata, *rl;
+ int i, rrsz;
+ adns_status st;
+ char *datap, *rdatastring;
+
+ rdata= TALLOC(sizeof(*rdata) * answer->nrrs);
+ for (i=0, datap=answer->rrs.untyped;
+ i<answer->nrrs;
+ i++, datap += rrsz) {
+ st= adns_rr_info(answer->type, 0,0, &rrsz, datap, &rdatastring);
+ assert(!st);
+ rdata[i]= cht_ret_string(ip, rdatastring);
+ free(rdatastring);
+ }
+ rl= Tcl_NewListObj(answer->nrrs, rdata);
+ TFREE(rdata);
+ return rl;
+}
+
+static void make_resultlist(Tcl_Interp *ip, adns_answer *answer,
+ Tcl_Obj *results[RESULTLIST_LLEN]) {
+
+ make_resultstatus(ip, answer->status, results);
+ assert(RESULTSTATUS_LLEN==4);
+ results[4]= cht_ret_string(ip, answer->owner);
+ results[5]= cht_ret_string(ip, answer->cname ? answer->cname : "");
+ results[6]= make_resultrdata(ip, answer);
+ assert(RESULTLIST_LLEN==7);
+}
+
+/*---------- synchronous query handling ----------*/
+
+static int synch(Tcl_Interp *ip, const AdnsTclRRTypeInfo *rrtype,
+ const char *domain,
+ int objc, Tcl_Obj *const *objv, adns_answer **answer_r) {
+ adns_query aqu;
+ Resolver *res;
+ int rc, ec;
+
+ rc= query_submit(ip,rrtype,domain,objc,objv,&aqu,0,&res);
+ if (rc) return rc;
+
+ ec= adns_wait(res->ads,&aqu,answer_r,0);
+ assert(!ec);
+
+ asynch_perturbed(res);
+ return TCL_OK;
+}
+
+int cht_do_adns_lookup(ClientData cd, Tcl_Interp *ip,
+ const AdnsTclRRTypeInfo *rrtype,
+ const char *domain,
+ int objc, Tcl_Obj *const *objv,
+ Tcl_Obj **result) {
+ int rc;
+ adns_answer *answer;
+
+ rc= synch(ip,rrtype,domain,objc,objv,&answer); if (rc) return rc;
+
+ if (answer->status) {
+ Tcl_Obj *problem[RESULTSTATUS_LLEN];
+ make_resultstatus(ip, answer->status, problem);
+ *result= Tcl_NewListObj(RESULTSTATUS_LLEN, problem);
+ } else {
+ *result= make_resultrdata(ip, answer);
+ }
+ free(answer);
+ return TCL_OK;
+}
+
+int cht_do_adns_synch(ClientData cd, Tcl_Interp *ip,
+ const AdnsTclRRTypeInfo *rrtype,
+ const char *domain,
+ int objc, Tcl_Obj *const *objv,
+ Tcl_Obj **result) {
+ int rc;
+ adns_answer *answer;
+ Tcl_Obj *results[RESULTLIST_LLEN];
+
+ rc= synch(ip,rrtype,domain,objc,objv,&answer); if (rc) return rc;
+ make_resultlist(ip,answer,results);
+ free(answer);
+ *result= Tcl_NewListObj(RESULTLIST_LLEN, results);
+ return TCL_OK;
+}
+
+/*---------- asynchronous query handling ----------*/
+
+static void asynch_check_now(Resolver *res);
+
+static void asynch_timerhandler(void *res_v) {
+ Resolver *res= res_v;
+ res->timertoken= 0;
+ adns_processtimeouts(res->ads,0);
+ asynch_check_now(res);
+}
+
+static void asynch_filehandler(void *res_v, int mask) {
+ Resolver *res= res_v;
+ int ec;
+
+ ec= adns_processany(res->ads);
+ if (ec) adns_globalsystemfailure(res->ads);
+ asynch_check_now(res);
+}
+
+static void asynch_sethandlers_generic(Resolver *res,
+ int shutdown /*from _cancelhandlers*/,
+ int immediate /*from _perturbed*/) {
+ fd_set want[3];
+ int maxfd;
+ struct timeval tv_buf, *timeout;
+ int i, fd;
+
+ timeout= 0;
+ maxfd= 0;
+ for (i=0; i<3; i++) FD_ZERO(&want[i]);
+
+ if (!shutdown)
+ adns_beforeselect(res->ads,&maxfd,&want[0],&want[1],&want[2],
+ &timeout,&tv_buf,0);
+
+ for (fd= 0; fd < maxfd || fd < res->maxfd; fd++)
+ for (i=0; i<3; i++)
+ if (!!FD_ISSET(fd, &res->handling[i])
+ != !!FD_ISSET(fd, &want[i])) {
+ int mask=0;
+ if (FD_ISSET(fd, &want[0])) mask |= TCL_READABLE;
+ if (FD_ISSET(fd, &want[1])) mask |= TCL_WRITABLE;
+ if (FD_ISSET(fd, &want[2])) mask |= TCL_EXCEPTION;
+ if (mask) {
+ Tcl_CreateFileHandler(fd,mask,asynch_filehandler,res);
+ FD_SET(fd, &res->handling[i]);
+ } else {
+ Tcl_DeleteFileHandler(fd);
+ FD_CLR(fd, &res->handling[i]);
+ }
+ }
+ res->maxfd= maxfd;
+
+ Tcl_DeleteTimerHandler(res->timertoken);
+
+ if (immediate) {
+ res->timertoken= Tcl_CreateTimerHandler(0,asynch_timerhandler,res);
+ } else if (timeout) {
+ int milliseconds;
+
+ if (timeout->tv_sec >= INT_MAX/1000 - 1)
+ milliseconds= INT_MAX;
+ else
+ milliseconds= timeout->tv_sec * 1000 +
+ (timeout->tv_usec + 999) / 1000;
+
+ res->timertoken=
+ Tcl_CreateTimerHandler(milliseconds,asynch_timerhandler,res);
+ }
+}
+
+static void asynch_sethandlers(Resolver *res) {
+ asynch_sethandlers_generic(res,0,0);
+}
+static void asynch_cancelhandlers(Resolver *res) {
+ asynch_sethandlers_generic(res,1,0);
+}
+static void asynch_perturbed(Resolver *res) {
+ asynch_sethandlers_generic(res,0,1);
+}
+
+static void asynch_check_now(Resolver *res) {
+ Tcl_Interp *interp= res->interp;
+ adns_query aqu;
+ adns_answer *answer;
+ void *query_v;
+ Query *query;
+ ScriptToInvoke *si;
+ int ec;
+ Tcl_Obj *results[RESULTLIST_LLEN];
+
+ Tcl_Preserve(res);
+
+ for (;;) {
+ if (!res->ads) { /* oh, it has been destroyed! */
+ Tcl_Release(res);
+ return;
+ }
+
+ aqu= 0;
+ ec= adns_check(res->ads, &aqu, &answer, &query_v);
+ if (ec==ESRCH || ec==EAGAIN) break;
+ assert(!ec);
+ query= query_v;
+
+ query->aqu= 0;
+ cht_tabledataid_disposing(interp, query, &cht_adnstcl_queries);
+
+ si= (!answer->status ? &query->on_yes
+ : answer->status > adns_s_max_tempfail ? &query->on_no
+ : &query->on_fail);
+
+ make_resultlist(interp, answer, results);
+ free(answer);
+ cht_scriptinv_invoke(si, RESULTLIST_LLEN, results);
+ asynch_query_dispose(interp, query);
+ }
+
+ asynch_sethandlers(res);
+
+ Tcl_Release(res);
+}
+
+int cht_do_adns_asynch(ClientData cd, Tcl_Interp *ip,
+ Tcl_Obj *on_yes, Tcl_Obj *on_no,
+ Tcl_Obj *on_fail, Tcl_Obj *xargs,
+ const AdnsTclRRTypeInfo *rrtype, const char *domain,
+ int objc, Tcl_Obj *const *objv, void **result) {
+ Query *query;
+ int rc;
+ Resolver *res= 0;
+
+ query= TALLOC(sizeof(*query));
+ query->ix= -1;
+ query->aqu= 0;
+ cht_scriptinv_init(&query->on_yes);
+ cht_scriptinv_init(&query->on_no);
+ cht_scriptinv_init(&query->on_fail);
+ query->xargs= 0;
+
+ rc= query_submit(ip,rrtype,domain,objc,objv,&query->aqu,query,&query->res);
+ if (rc) goto x_rc;
+
+ res= query->res;
+
+ rc= cht_scriptinv_set(&query->on_yes, ip,on_yes, xargs); if (rc) goto x_rc;
+ rc= cht_scriptinv_set(&query->on_no, ip,on_no, xargs); if (rc) goto x_rc;
+ rc= cht_scriptinv_set(&query->on_fail,ip,on_fail,xargs); if (rc) goto x_rc;
+ query->xargs= xargs;
+ Tcl_IncrRefCount(xargs);
+ *result= query;
+ query= 0; /* do not dispose */
+ rc= TCL_OK;
+
+ x_rc:
+ if (query) asynch_query_dispose(ip, query);
+ if (res) asynch_perturbed(res);
+ return rc;
+}
+
+int cht_do_adns_asynch_cancel(ClientData cd, Tcl_Interp *ip, void *query_v) {
+ Query *query= query_v;
+ Resolver *res= query->res;
+ asynch_query_dispose(ip, query);
+ asynch_perturbed(res);
+ return TCL_OK;
+}
+
+static void asynch_query_dispose(Tcl_Interp *interp, Query *query) {
+ cht_tabledataid_disposing(interp, query, &cht_adnstcl_queries);
+ cht_scriptinv_cancel(&query->on_yes);
+ cht_scriptinv_cancel(&query->on_no);
+ cht_scriptinv_cancel(&query->on_fail);
+ if (query->xargs) Tcl_DecrRefCount(query->xargs);
+ if (query->aqu) adns_cancel(query->aqu);
+ TFREE(query);
+}
+
+static void destroy_query_idtabcb(Tcl_Interp *interp, void *query_v) {
+ asynch_query_dispose(interp, query_v);
+}
+
+const IdDataSpec cht_adnstcl_queries= {
+ "adns", "adns-query-table", destroy_query_idtabcb
+};
+
+/*---------- main hooks for tcl ----------*/
+
+CHT_INIT(adns, {}, CHTI_COMMANDS(cht_adnstoplevel_entries))
--- /dev/null
+# adns binding for Tcl
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+Type adnsresults: adns_answer *@
+Init adnsresults @=0;
+Fini adnsresults free(@);
+
+Table *adnstoplevel TopLevel_Command
+ adns
+ dispatch(Adns/_SubCommand, "adns subcommand")
+
+Table adns Adns_SubCommand
+ lookup
+ rrtype enum(AdnsTclRRTypeInfo/, "rrtype")
+ domain string
+ ... obj
+ => obj
+ synch
+ rrtype enum(AdnsTclRRTypeInfo/, "rrtype")
+ domain string
+ ... obj
+ => obj
+ asynch
+ on_yes obj
+ on_no obj
+ on_fail obj
+ xargs obj
+ rrtype enum(AdnsTclRRTypeInfo/, "rrtype")
+ domain string
+ ... obj
+ => iddata(&cht_adnstcl_queries)
+ asynch-cancel
+ query iddata(&cht_adnstcl_queries)
+ new-resolver
+ ... obj
+ => iddata(&cht_adnstcl_resolvers)
+ set-default-resolver
+ res iddata(&cht_adnstcl_resolvers)
+ destroy-resolver
+ res iddata(&cht_adnstcl_resolvers)
+
--- /dev/null
+/*
+ * adns binding for Tcl
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#ifndef ADNSTCL_H
+#define ADNSTCL_H
+
+#include "chiark-tcl.h"
+
+typedef struct {
+ const char *name;
+ adns_rrtype number;
+} AdnsTclRRTypeInfo;
+
+extern const IdDataSpec cht_adnstcl_queries, cht_adnstcl_resolvers;
+
+#include "adns+tcmdif.h"
+
+#endif /*ADNSTCL_H*/
--- /dev/null
+# base code for various Tcl extensions
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+default: all
+
+CFILES = enum hook idtable parse scriptinv tcmdiflib
+BASE_DIR = .
+
+AUTO_HDRS += base+tcmdif.h
+
+include common.make
+
+SHLIB = $(BASE_SHLIB)
+
+base+tcmdif.h: $(BASE_TCT) $(TCMDIFGEN)
+ $(TCMDIFGEN) -wh -o$@ $<
+
+include shlib.make
+include final.make
--- /dev/null
+# base code for various Tcl extensions
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+Type iddata(const IdDataSpec *idds): void *@
+Type ulong: uint32_t @
+Type long: long @
+Type string: const char *@
+Type constv(Tcl_ObjType*): Tcl_Obj *@
+
+Type charfrom(const char *opts, const char *what): int
+
+NoEntryDefine TopLevel_Command
--- /dev/null
+/*
+ * base code for various Tcl extensions
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+
+#include <string.h>
+#include <errno.h>
+
+#include "chiark-tcl.h"
+#include "base+tcmdif.h"
--- /dev/null
+/*
+ * base code for various Tcl extensions
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#ifndef CHIARK_TCL_H
+#define CHIARK_TCL_H
+
+#include <assert.h>
+#include <stdlib.h>
+#include <errno.h>
+#include <unistd.h>
+#include <fcntl.h>
+#include <limits.h>
+#include <sys/socket.h>
+#include <sys/uio.h>
+#include <sys/un.h>
+#include <arpa/inet.h>
+
+#ifndef _TCL /* if someone already included some tcl.h, use that */
+#include <tcl.h>
+#endif /*_TCL*/
+
+#include <adns.h>
+
+typedef unsigned char Byte;
+
+/* for assisting tcmdifgen and tcmdiflib.c */
+
+typedef struct TopLevel_Command TopLevel_Command;
+
+struct TopLevel_Command {
+ const char *name;
+ Tcl_ObjCmdProc *func;
+};
+
+void cht_setstringresult(Tcl_Interp*, const char*);
+int cht_pat_enum(Tcl_Interp*, Tcl_Obj*, const void**,
+ const void*, size_t, const char *what);
+
+/* from scriptinv.c */
+
+typedef struct { /* opaque; comments are for scriptinv.c impl'n only */
+ /* states: Cancelled Set */
+ Tcl_Interp *ipq; /* 0 valid, non-0, useable */
+ Tcl_Obj *script; /* 0 valid, non-0 */
+ Tcl_Obj *xargs; /* 0 valid, may be 0 */
+ int llen; /* undefined llength of script + xargs */
+} ScriptToInvoke;
+
+void cht_scriptinv_init(ScriptToInvoke *si); /* undefined -> Cancelled */
+int cht_scriptinv_set(ScriptToInvoke *si, Tcl_Interp *ip,
+ Tcl_Obj *newscript, Tcl_Obj *xargs);
+ /* Cancelled/Set -> Set (newscript!=0, ok) / Cancelled (otherwise) */
+void cht_scriptinv_cancel(ScriptToInvoke *si);
+ /* Cancelled/Set -> Cancelled. No separate free function - just cancel. */
+#define cht_scriptinv_interp(si) ((si)->ipq)
+ /* int cht_scriptinv_interp(ScriptToInvoke *si); returns 0 if Cancelled */
+
+int cht_scriptinv_invoke_fg(ScriptToInvoke *si, int argc,
+ Tcl_Obj *const *argv);
+ /* is a no-op if Cancelled rather than Set */
+ /* if script fails, returns that error */
+
+void cht_scriptinv_invoke(ScriptToInvoke *si, int argc, Tcl_Obj *const *argv);
+ /* if script fails, reports it with Tcl_BackgroundError */
+
+/* from idtable.c */
+
+typedef struct {
+ const char *valprefix, *assockey;
+ void (*destroyitem)(Tcl_Interp *ip, void *val);
+} IdDataSpec;
+
+/* The stored struct must start with a single int, conventionally
+ * named `ix'. When the struct is returned for the first time ix must
+ * be -1; on subsequent occasions it must be >=0. ix will be -1 iff
+ * the struct is registered by the iddatatable machinery. */
+
+extern Tcl_ObjType cht_tabledataid_nearlytype;
+int cht_tabledataid_parse(Tcl_Interp *ip, Tcl_Obj *o, const IdDataSpec *idds);
+void cht_tabledataid_disposing(Tcl_Interp *ip, void *val, const IdDataSpec *idds);
+ /* call this when you destroy the struct, to remove its name;
+ * _disposing is idempotent */
+
+/* from hook.c */
+
+int cht_staticerr(Tcl_Interp *ip, const char *m, const char *ec);
+int cht_posixerr(Tcl_Interp *ip, int errnoval, const char *m);
+int cht_newfdposixerr(Tcl_Interp *ip, int fd, const char *m);
+void cht_objfreeir(Tcl_Obj *o);
+int cht_get_urandom(Tcl_Interp *ip, Byte *buffer, int l);
+
+void cht_obj_updatestr_vstringls(Tcl_Obj *o, ...);
+ /* const char*, size_t, const char*, size_t, ..., (const char*)0 */
+void cht_obj_updatestr_string_len(Tcl_Obj *o, const char *str, int l);
+void cht_obj_updatestr_string(Tcl_Obj *o, const char *str);
+
+void cht_prepare__basic(Tcl_Interp *ip);
+void cht_setup__commands(Tcl_Interp *ip, const TopLevel_Command *cmds);
+ /* ... for use by CHT_INIT and CHTI_... macros only */
+
+/* from parse.c */
+
+typedef struct {
+ Tcl_Obj *obj, *var;
+ int copied;
+} Something_Var;
+
+void cht_init_somethingv(Something_Var *sth);
+void cht_fini_somethingv(Tcl_Interp *ip, int rc, Something_Var *sth);
+int cht_pat_somethingv(Tcl_Interp *ip, Tcl_Obj *var,
+ Something_Var *sth, Tcl_ObjType *type);
+
+/* from enum.c */
+
+extern Tcl_ObjType cht_enum_nearlytype;
+extern Tcl_ObjType cht_enum1_nearlytype;
+
+const void *cht_enum_lookup_cached_func(Tcl_Interp *ip, Tcl_Obj *o,
+ const void *firstentry, size_t entrysize,
+ const char *what);
+#define enum_lookup_cached(ip,o,table,what) \
+ (cht_enum_lookup_cached_func((ip),(o), \
+ &(table)[0],sizeof((table)[0]), \
+ (what)))
+ /* table should be a pointer to an array of structs of size
+ * entrysize, the first member of which should be a const char*.
+ * The table should finish with a null const char *.
+ * On error, 0 is returned and the ip->result will have been
+ * set to the error message.
+ */
+
+int cht_enum1_lookup_cached_func(Tcl_Interp *ip, Tcl_Obj *o,
+ const char *opts, const char *what);
+ /* -1 => error */
+
+/* useful macros */
+
+#define TALLOC(s) ((void*)Tcl_Alloc((s)))
+#define TFREE(f) (Tcl_Free((void*)(f)))
+#define TREALLOC(p,l) ((void*)Tcl_Realloc((void*)(p),(l)))
+
+/* macros for Chiark_tcl_FOOBAR_Init et al */
+
+ /*
+ * use these macros like this:
+ * CHT_INIT(<extbase>,
+ * <preparations>,
+ * <results>)
+ * where
+ *
+ * <extbase> is the short name eg `hbytes'
+ * and should correspond to EXTBASE from the Makefile.
+ *
+ * <results> are the initialisations which cause new commands
+ * etc. to appear in the Tcl namespace. Eg, CHTI_COMMANDS,
+ * These initialisations are called only when a Tcl `load'
+ * command loads this extension.
+ *
+ * <preparations> are the initialisations that we need but which
+ * do not interfere with the Tcl namespaces. For example,
+ * OBJECT types we used (CHTI_TYPE), and other chiark_tcl
+ * extensions (CHTI_OTHER). These initialisations are called
+ * both as a result of Tcl `load' (before the <results>
+ * initialisations) and also when another extension declares a
+ * dependency on this one with CHTI_OTHER.
+ *
+ * Both <results> and <preparations> are whitespace-separated
+ * lists of calls to CHTI_... macros. If the list is to be empty,
+ * write `{ }' instead to prevent an empty macro argument. The
+ * preparations and results currently supported are:
+ *
+ * CHTI_COMMANDS(cht_<somethingtoplevel>_entries)
+ * where the .tct file contains
+ * Table *<somethingtoplevel> TopLevel_Command
+ *
+ * CHTI_OTHER(<extbase-of-underlying-extension>)
+ * which does the <preparations> of that extension
+ * (if they have not already been done).
+ *
+ * CHTI_TYPE(cht_<something>_type)
+ * where extern Tcl_ObjType cht_<something>_type;
+ * Note that CHTI_TYPE should only be called by the
+ * extension which actually implements the type. Other
+ * extensions which need it should use CHTI_OTHER to bring
+ * in the implementing extension.
+ */
+
+#define CHT_INIT(e, preparations, results) \
+ extern void cht_prepare_##e(Tcl_Interp *ip); \
+ void cht_prepare_##e(Tcl_Interp *ip) { \
+ static int prepared; \
+ if (prepared) return; \
+ cht_prepare__basic(ip); \
+ { preparations } \
+ prepared= 1; \
+ } \
+ extern int Chiark_tcl_##e##_Init(Tcl_Interp *ip); /*called by load(3tcl)*/ \
+ int Chiark_tcl_##e##_Init(Tcl_Interp *ip) { \
+ static int initd; \
+ if (initd) return TCL_OK; \
+ cht_prepare_##e(ip); \
+ { results } \
+ initd= 1; \
+ return TCL_OK; \
+ }
+
+#define CHTI_OTHER(e) \
+ { extern void cht_prepare_##e(Tcl_Interp *ip); cht_prepare_##e(ip); }
+
+#define CHTI_TYPE(ot) { Tcl_RegisterObjType(&(ot)); }
+
+#define CHTI_COMMANDS(cl) { cht_setup__commands(ip,cl); }
+
+#endif /*CHIARK_TCL_H*/
--- /dev/null
+# base code for various Tcl extensions
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+VERSION ?= 1
+FAMILY ?= chiark_tcl
+TCL_VERSION ?= 8.4
+TCL_INCLUDEDIR ?= /usr/include/tcl$(TCL_VERSION)
+
+OPTIMISE ?= -O2
+TCL_MEM_DEBUG ?= -DTCL_MEM_DEBUG
+
+TCMDIFGEN ?= $(BASE_DIR)/tcmdifgen
+BASE_TCT ?= $(BASE_DIR)/base.tct
+BASE_SHLIB ?= lib$(FAMILY)-$(VERSION)
+
+CFLAGS += -g -Wall -Wmissing-prototypes -Wstrict-prototypes -Werror \
+ $(OPTIMISE)
+
+ifeq ($(shell $(CC) -Wno-pointer-sign -E -x c /dev/null >/dev/null || echo x),)
+CFLAGS += -Wno-pointer-sign
+endif
+
+ifeq ($(shell $(CC) -fno-strict-aliasing -E -x c /dev/null >/dev/null || echo x),)
+CFLAGS += -fno-strict-aliasing
+endif
+
+CPPFLAGS += -I$(TCL_INCLUDEDIR) -I$(BASE_DIR)
+CPPFLAGS += $(TCL_MEM_DEBUG)
+
+AUTOS += $(AUTO_SRCS) $(AUTO_HDRS)
+
+default: all
+
--- /dev/null
+/*
+ * base code for various Tcl extensions
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include "chiark-tcl-base.h"
+
+static void enum_nt_dup(Tcl_Obj *src, Tcl_Obj *dup) {
+ dup->internalRep= src->internalRep;
+ dup->typePtr= src->typePtr;
+}
+
+static void enum_nt_ustr(Tcl_Obj *o) {
+ abort();
+}
+
+static int enum_nt_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
+ abort();
+}
+
+Tcl_ObjType cht_enum_nearlytype = {
+ "enum-nearly",
+ 0, enum_nt_dup, enum_nt_ustr, enum_nt_sfa
+};
+
+Tcl_ObjType cht_enum1_nearlytype = {
+ "enum1-nearly",
+ 0, enum_nt_dup, enum_nt_ustr, enum_nt_sfa
+};
+
+static void report_bad(Tcl_Interp *ip, const char *what, const char *supplied,
+ const void *first, size_t each,
+ int (*isvalid)(const void *entry),
+ void (*appres)(Tcl_Interp *ip, const void *entry)) {
+ int count, i;
+ const Byte *entry;
+
+ for (entry=first; isvalid(entry); entry+=each);
+ count= (entry - (const Byte*)first) / each;
+
+ Tcl_ResetResult(ip);
+ Tcl_AppendResult(ip, "bad ",what," \"",supplied,"\": must be",(char*)0);
+
+ for (i=0, entry=first; i<count; i++, entry+=each) {
+ Tcl_AppendResult(ip,
+ (char*)(i==0 ? " " :
+ i+1==count ? ", or " :
+ ", "),
+ (char*)0);
+ appres(ip,entry);
+ }
+}
+
+static const char *enum_str(const void *p) { return *(const char*const*)p; }
+static int isvalid_enum(const void *p) { return !!enum_str(p); }
+static void appres_enum(Tcl_Interp *ip, const void *p) {
+ Tcl_AppendResult(ip, enum_str(p), (char*)0);
+}
+
+const void *cht_enum_lookup_cached_func(Tcl_Interp *ip, Tcl_Obj *o,
+ const void *firstentry, size_t entrysize,
+ const char *what) {
+ const char *supplied, *found;
+ const char *ep;
+
+ if (o->typePtr == &cht_enum_nearlytype &&
+ o->internalRep.twoPtrValue.ptr1 == firstentry)
+ return o->internalRep.twoPtrValue.ptr2;
+
+ supplied= Tcl_GetStringFromObj(o,0); assert(supplied);
+ for (ep= firstentry;
+ (found= *(const char*const*)ep) && strcmp(supplied,found);
+ ep += entrysize);
+
+ if (found) {
+ cht_objfreeir(o);
+ o->typePtr= &cht_enum_nearlytype;
+ o->internalRep.twoPtrValue.ptr1= (void*)firstentry;
+ o->internalRep.twoPtrValue.ptr2= (void*)ep;
+ return ep;
+ }
+
+ report_bad(ip,what,supplied, firstentry,entrysize, isvalid_enum,appres_enum);
+ return 0;
+}
+
+static int isvalid_enum1(const void *p) { return !!*(const char*)p; }
+static void appres_enum1(Tcl_Interp *ip, const void *p) {
+ char buf[2];
+ buf[0]= *(const char*)p;
+ buf[1]= 0;
+ Tcl_AppendResult(ip, buf, (char*)0);
+}
+
+int cht_enum1_lookup_cached_func(Tcl_Interp *ip, Tcl_Obj *o,
+ const char *opts, const char *what) {
+ const char *supplied, *fp;
+
+ if (o->typePtr != &cht_enum1_nearlytype ||
+ o->internalRep.twoPtrValue.ptr1 != opts) {
+
+ supplied= Tcl_GetStringFromObj(o,0); assert(supplied);
+
+ if (!(strlen(supplied) == 1 &&
+ (fp= strchr(opts, supplied[0])))) {
+ report_bad(ip,what,supplied, opts,1, isvalid_enum1,appres_enum1);
+ return -1;
+ }
+
+ cht_objfreeir(o);
+ o->typePtr= &cht_enum1_nearlytype;
+ o->internalRep.twoPtrValue.ptr1= (void*)opts;
+ o->internalRep.twoPtrValue.ptr2= (void*)fp;
+ }
+ return (const char*)o->internalRep.twoPtrValue.ptr2 - opts;
+}
--- /dev/null
+# base code for various Tcl extensions
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+
+EXTPREFIX ?= $(FAMILY)_
+EXTENSION ?= $(EXTPREFIX)$(EXTBASE)
+SHLIB ?= $(EXTENSION)-$(VERSION)
+TABLE ?= $(EXTBASE)
+
+AUTO_HDRS += $(TABLE)+tcmdif.h
+AUTO_SRCS += $(TABLE)+tcmdif.c
+CFILES += $(TABLE)+tcmdif
+
+CPPFLAGS += $(foreach o, $(OTHER_EXTS), -I../$(dir $o))
+LDLIBS += $(foreach o, $(OTHER_EXTS), ../$(dir $o)$(EXTPREFIX)$(notdir $o)-$(VERSION).so)
+
+LDLIBS += $(BASE_DIR)/$(BASE_SHLIB).so
+
+include $(BASE_DIR)/common.make
+include $(BASE_DIR)/shlib.make
+
+TCMDIFARGS ?= -p$(FAMILY)_$(EXTBASE) -o$@ $(BASE_TCT) $(OTHER_TCTS) $<
+
+%+tcmdif.c: %.tct $(BASE_TCT) $(OTHER_TCTS) $(TCMDIFGEN)
+ $(TCMDIFGEN) -wc $(TCMDIFARGS)
+
+%+tcmdif.h: %.tct $(BASE_TCT) $(OTHER_TCTS) $(TCMDIFGEN)
+ $(TCMDIFGEN) -wh $(TCMDIFARGS)
+
+include $(BASE_DIR)/final.make
--- /dev/null
+# base code for various Tcl extensions
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+all: $(TARGETS) $(AUTOS)
+
+$(OBJS_CFILES): $(AUTO_HDRS)
+
+%.o: %.c
+ $(CC) $(CFLAGS) $(CPPFLAGS) -MMD -o $@ -c $<
+
+clean:
+ rm -f $(AUTOS) *~ ./#*# *.d *+tcmdif.*
+ rm -f *.o *.so $(CLEANS)
+
+-include $(patsubst %.o,%.d, $(OBJS))
+
--- /dev/null
+/*
+ * base code for various Tcl extensions
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include "chiark-tcl-base.h"
+
+int cht_staticerr(Tcl_Interp *ip, const char *m, const char *ec) {
+ Tcl_SetResult(ip, (char*)m, TCL_STATIC);
+ if (ec) Tcl_SetObjErrorCode(ip, Tcl_NewStringObj(ec,-1));
+ return TCL_ERROR;
+}
+
+int cht_posixerr(Tcl_Interp *ip, int errnoval, const char *m) {
+ const char *em;
+
+ Tcl_ResetResult(ip);
+ errno= errnoval;
+ em= Tcl_PosixError(ip);
+ Tcl_AppendResult(ip, m, ": ", em, (char*)0);
+ return TCL_ERROR;
+}
+
+int cht_newfdposixerr(Tcl_Interp *ip, int fd, const char *m) {
+ int e;
+ e= errno;
+ close(fd);
+ return cht_posixerr(ip,e,m);
+}
+
+void cht_objfreeir(Tcl_Obj *o) {
+ if (o->typePtr && o->typePtr->freeIntRepProc)
+ o->typePtr->freeIntRepProc(o);
+ o->typePtr= 0;
+}
+
+void cht_obj_updatestr_vstringls(Tcl_Obj *o, ...) {
+ va_list al;
+ char *p;
+ const char *part;
+ int l;
+ size_t pl;
+
+ va_start(al,o);
+ for (l=0; (part= va_arg(al, const char*)); ) {
+ pl= va_arg(al, size_t);
+ assert(pl <= INT_MAX/2 - l);
+ l += pl;
+ }
+ va_end(al);
+
+ o->length= l;
+ o->bytes= TALLOC(l+1);
+
+ va_start(al,o);
+ for (p= o->bytes; (part= va_arg(al, const char*)); p += pl) {
+ pl= va_arg(al, size_t);
+ memcpy(p, part, pl);
+ }
+ va_end(al);
+
+ *p= 0;
+}
+
+void cht_obj_updatestr_string(Tcl_Obj *o, const char *str) {
+ cht_obj_updatestr_vstringls(o, str, strlen(str), (char*)0);
+}
+
+#define URANDOM "/dev/urandom"
+
+int cht_get_urandom(Tcl_Interp *ip, Byte *buffer, int l) {
+ static FILE *urandom;
+
+ int r;
+
+ if (!urandom) {
+ urandom= fopen(URANDOM,"rb");
+ if (!urandom) return cht_posixerr(ip,errno,"open " URANDOM);
+ }
+ r= fread(buffer,1,l,urandom);
+ if (r==l) return 0;
+
+ if (ferror(urandom)) {
+ r = cht_posixerr(ip,errno,"read " URANDOM);
+ } else {
+ assert(feof(urandom));
+ r = cht_staticerr(ip, URANDOM " gave eof!", 0);
+ }
+ fclose(urandom); urandom=0;
+ return r;
+}
+
+void cht_prepare__basic(Tcl_Interp *ip) {
+ static int prepared;
+
+ if (prepared) return;
+ Tcl_RegisterObjType(&cht_tabledataid_nearlytype);
+ Tcl_RegisterObjType(&cht_enum_nearlytype);
+ Tcl_RegisterObjType(&cht_enum1_nearlytype);
+ prepared= 1;
+}
+
+void cht_setup__commands(Tcl_Interp *ip, const TopLevel_Command *cmds) {
+ const TopLevel_Command *cmd;
+
+ for (cmd= cmds;
+ cmd->name;
+ cmd++)
+ Tcl_CreateObjCommand(ip, (char*)cmd->name, cmd->func, 0,0);
+}
--- /dev/null
+/*
+ * base code for various Tcl extensions
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include "chiark-tcl-base.h"
+
+/* Arg parsing */
+
+typedef struct {
+ const IdDataSpec *idds;
+ int n;
+ void **a;
+} IdDataAssocData;
+
+typedef struct {
+ Tcl_Interp *interp;
+ IdDataAssocData *assoc;
+ int ix;
+} IdDataValue;
+
+static void assoc_del(ClientData assoc_cd, Tcl_Interp *ip) {
+ IdDataAssocData *assoc;
+ int ix;
+ void **p, *v;
+
+ assoc= assoc_cd;
+ for (ix=0, p=assoc->a; ix<assoc->n; ix++, p++) {
+ v= *p;
+ if (!v) continue;
+ assert(*(int*)v == ix);
+ *(int*)v= -1;
+ assoc->idds->destroyitem(ip,v);
+ *p= 0;
+ }
+ TFREE(assoc->a);
+ TFREE(assoc);
+}
+
+static void setobjdataid(Tcl_Interp *interp, Tcl_Obj *o,
+ int ix, const IdDataSpec *idds) {
+ IdDataValue *dv;
+ IdDataAssocData *assoc;
+
+ assoc= Tcl_GetAssocData(interp, (char*)idds->assockey, 0);
+ if (!assoc) {
+ assoc= TALLOC(sizeof(*assoc));
+ assoc->idds= idds;
+ assoc->n= 0;
+ assoc->a= 0;
+ Tcl_SetAssocData(interp, (char*)idds->assockey, assoc_del, assoc);
+ }
+
+ dv= TALLOC(sizeof(*dv));
+ dv->interp= interp;
+ dv->assoc= assoc;
+ dv->ix= ix;
+
+ o->typePtr= &cht_tabledataid_nearlytype;
+ o->internalRep.otherValuePtr= dv;
+}
+
+int cht_tabledataid_parse(Tcl_Interp *ip, Tcl_Obj *o, const IdDataSpec *idds) {
+ int l;
+ unsigned long ul;
+ IdDataValue *dv;
+ char *ep, *str;
+
+ if (o->typePtr != &cht_tabledataid_nearlytype) goto convert;
+
+ dv= o->internalRep.otherValuePtr;
+ if (dv->interp != ip) goto convert;
+ if (dv->assoc->idds != idds) goto convert;
+
+ return TCL_OK;
+
+convert:
+ l= strlen(idds->valprefix);
+ str= Tcl_GetStringFromObj(o,0);
+ if (memcmp(str,idds->valprefix,l))
+ return cht_staticerr(ip,"bad id (wrong prefix)",0);
+
+ errno=0; ul=strtoul(str+l,&ep,10);
+ if (errno || *ep) return cht_staticerr(ip,"bad id number",0);
+ if (ul > INT_MAX) return cht_staticerr(ip,"out of range id number",0);
+
+ cht_objfreeir(o);
+ setobjdataid(ip,o,ul,idds);
+ return TCL_OK;
+}
+
+int cht_pat_iddata(Tcl_Interp *ip, Tcl_Obj *o, void **rv, const IdDataSpec *idds) {
+ int rc, ix;
+ IdDataValue *dv;
+ IdDataAssocData *assoc;
+ void *r;
+
+ rc= cht_tabledataid_parse(ip,o,idds);
+ if (rc) return rc;
+
+ dv= o->internalRep.otherValuePtr;
+ ix= dv->ix;
+ assoc= dv->assoc;
+
+ if (ix >= assoc->n || !(r= assoc->a[ix]))
+ return cht_staticerr(ip,"id not in use",0);
+
+ assert(*(int*)r == ix);
+
+ *rv= r;
+ return TCL_OK;
+}
+
+Tcl_Obj *cht_ret_iddata(Tcl_Interp *ip, void *val, const IdDataSpec *idds) {
+ /* 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;
+ IdDataValue *dv;
+ IdDataAssocData *assoc;
+ int ix;
+
+ o= Tcl_NewObj();
+ setobjdataid(ip,o,0,idds);
+ dv= o->internalRep.otherValuePtr;
+ assoc= dv->assoc;
+
+ ix= *(int*)val;
+ if (ix==-1) {
+ for (ix=0; ix<assoc->n && assoc->a[ix]; ix++);
+ if (ix>=assoc->n) {
+ assert(assoc->n < INT_MAX/4);
+ assoc->n += 2;
+ assoc->n *= 2;
+ assoc->a= TREALLOC(assoc->a, assoc->n*sizeof(*assoc->a));
+ while (ix<assoc->n) assoc->a[ix++]=0;
+ ix--;
+ }
+ assoc->a[ix]= val;
+ *(int*)val= ix;
+ } else {
+ assert(val == assoc->a[ix]);
+ }
+ dv->ix= ix;
+ Tcl_InvalidateStringRep(o);
+ return o;
+}
+
+void cht_tabledataid_disposing(Tcl_Interp *ip, void *val, const IdDataSpec *idds) {
+ IdDataAssocData *assoc;
+ int ix;
+
+ ix= *(int*)val;
+ if (ix==-1) return;
+
+ assoc= Tcl_GetAssocData(ip, (char*)idds->assockey, 0);
+ assert(assoc->a[ix] == val);
+ assoc->a[ix]= 0;
+ *(int*)val= -1;
+}
+
+static int tabledataid_nt_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
+ abort();
+}
+
+static void tabledataid_nt_free(Tcl_Obj *o) {
+ TFREE(o->internalRep.otherValuePtr);
+ o->internalRep.otherValuePtr= 0;
+}
+
+static void tabledataid_nt_dup(Tcl_Obj *src, Tcl_Obj *dup) {
+ IdDataValue *sv, *dv;
+
+ sv= src->internalRep.otherValuePtr;
+ dv= TALLOC(sizeof(*dv));
+ *dv= *sv;
+ dup->typePtr= &cht_tabledataid_nearlytype;
+ dup->internalRep.otherValuePtr= dv;
+}
+
+static void tabledataid_nt_ustr(Tcl_Obj *o) {
+ const IdDataValue *dv;
+ const IdDataAssocData *assoc;
+ const IdDataSpec *idds;
+ char buf[75];
+
+ dv= o->internalRep.otherValuePtr;
+ assoc= dv->assoc;
+ idds= assoc->idds;
+
+ snprintf(buf,sizeof(buf), "%d", dv->ix);
+ cht_obj_updatestr_vstringls(o,
+ idds->valprefix, strlen(idds->valprefix),
+ buf, strlen(buf),
+ (char*)0);
+}
+
+Tcl_ObjType cht_tabledataid_nearlytype = {
+ "tabledataid",
+ tabledataid_nt_free, tabledataid_nt_dup,
+ tabledataid_nt_ustr, tabledataid_nt_sfa
+};
--- /dev/null
+/*
+ * base code for various Tcl extensions
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include "chiark-tcl-base.h"
+
+int cht_pat_charfrom(Tcl_Interp *ip, Tcl_Obj *obj, int *val,
+ const char *opts, const char *what) {
+ *val= cht_enum1_lookup_cached_func(ip,obj,opts,what);
+ if (*val==-1) return TCL_ERROR;
+ return TCL_OK;
+}
+
+int cht_pat_int(Tcl_Interp *ip, Tcl_Obj *obj, int *val) {
+ return Tcl_GetIntFromObj(ip, obj, val);
+}
+
+int cht_pat_long(Tcl_Interp *ip, Tcl_Obj *obj, long *val) {
+ return Tcl_GetLongFromObj(ip, obj, val);
+}
+
+int cht_pat_string(Tcl_Interp *ip, Tcl_Obj *obj, const char **val) {
+ *val= Tcl_GetString(obj);
+ return TCL_OK;
+}
+
+int cht_pat_constv(Tcl_Interp *ip, Tcl_Obj *var,
+ Tcl_Obj **val_r, Tcl_ObjType *type) {
+ int rc;
+ Tcl_Obj *val;
+
+ val= Tcl_ObjGetVar2(ip,var,0,TCL_LEAVE_ERR_MSG);
+ if (!val) return TCL_ERROR;
+
+ if (type) {
+ rc= Tcl_ConvertToType(ip,val,type);
+ if (rc) return rc;
+ }
+
+ *val_r= val;
+ return TCL_OK;
+}
+
+void cht_init_somethingv(Something_Var *sth) {
+ sth->obj=0; sth->var=0; sth->copied=0;
+}
+
+int cht_pat_somethingv(Tcl_Interp *ip, Tcl_Obj *var,
+ Something_Var *sth, Tcl_ObjType *type) {
+ int rc;
+ Tcl_Obj *val;
+
+ sth->var= var;
+
+ val= Tcl_ObjGetVar2(ip,var,0,TCL_LEAVE_ERR_MSG);
+ if (!val) return TCL_ERROR;
+
+ rc= Tcl_ConvertToType(ip,val,type);
+ if (rc) return rc;
+
+ if (Tcl_IsShared(val)) {
+ val= Tcl_DuplicateObj(val);
+ sth->copied= 1;
+ }
+ Tcl_InvalidateStringRep(val);
+ sth->obj= val;
+
+ return TCL_OK;
+}
+
+void cht_fini_somethingv(Tcl_Interp *ip, int rc, Something_Var *sth) {
+ Tcl_Obj *ro;
+
+ if (!rc) {
+ assert(sth->obj);
+ ro= Tcl_ObjSetVar2(ip,sth->var,0,sth->obj,TCL_LEAVE_ERR_MSG);
+ if (!ro) rc= TCL_ERROR;
+ }
+ if (rc && sth->copied)
+ Tcl_DecrRefCount(sth->obj);
+}
+
+Tcl_Obj *cht_ret_long(Tcl_Interp *ip, long val) {
+ return Tcl_NewLongObj(val);
+}
+
+Tcl_Obj *cht_ret_string(Tcl_Interp *ip, const char *val) {
+ return Tcl_NewStringObj(val,-1);
+}
--- /dev/null
+/*
+ * base code for various Tcl extensions
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include "chiark-tcl-base.h"
+
+void cht_scriptinv_init(ScriptToInvoke *si) {
+ si->ipq= 0;
+ si->script= 0;
+ si->xargs= 0;
+}
+
+void cht_scriptinv_cancel(ScriptToInvoke *si) {
+ if (si->script) { Tcl_DecrRefCount(si->script); si->script= 0; }
+ if (si->xargs) { Tcl_DecrRefCount(si->xargs); si->xargs= 0; }
+ si->ipq= 0;
+}
+
+int cht_scriptinv_set(ScriptToInvoke *si, Tcl_Interp *ip,
+ Tcl_Obj *newscript, Tcl_Obj *xargs) {
+ int rc, xlength;
+
+ cht_scriptinv_cancel(si);
+ if (!newscript) return 0;
+
+ rc= Tcl_ListObjLength(ip, newscript, &si->llen); if (rc) return rc;
+ Tcl_IncrRefCount(newscript);
+
+ if (xargs) {
+ rc= Tcl_ListObjLength(ip, xargs, &xlength); if (rc) return rc;
+ Tcl_IncrRefCount(xargs);
+ assert(si->llen < INT_MAX/2 && xlength < INT_MAX/2);
+ si->llen += xlength;
+ }
+
+ si->script= newscript;
+ si->xargs= xargs;
+ si->ipq= ip;
+ return 0;
+}
+
+int cht_scriptinv_invoke_fg(ScriptToInvoke *si, int argc,
+ Tcl_Obj *const *argv) {
+ Tcl_Obj *invoke=0;
+ int i, rc;
+
+ if (!si->ipq) return TCL_OK;
+
+ for (i=0; i<argc; i++) Tcl_IncrRefCount(argv[i]);
+
+ invoke= Tcl_DuplicateObj(si->script);
+ Tcl_IncrRefCount(invoke);
+
+ if (si->xargs) {
+ rc= Tcl_ListObjAppendList(si->ipq, invoke, si->xargs);
+ if (rc) goto x_rc;
+ }
+
+ rc= Tcl_ListObjReplace(si->ipq, invoke,si->llen,0, argc,argv);
+ if (rc) goto x_rc;
+
+ rc= Tcl_EvalObjEx(si->ipq, invoke, TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT);
+ if (rc) goto x_rc;
+
+ rc= 0;
+
+x_rc:
+ for (i=0; i<argc; i++) Tcl_DecrRefCount(argv[i]);
+ if (invoke) Tcl_DecrRefCount(invoke);
+ return rc;
+}
+
+void cht_scriptinv_invoke(ScriptToInvoke *si, int argc, Tcl_Obj *const *argv) {
+ int rc;
+ rc= cht_scriptinv_invoke_fg(si, argc, argv);
+ if (rc) Tcl_BackgroundError(si->ipq);
+}
--- /dev/null
+# base code for various Tcl extensions
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+
+OBJS_CFILES += $(addsuffix .o, $(CFILES))
+OBJS += $(OBJS_CFILES)
+CFLAGS += -fPIC
+
+TARGETS += $(SHLIB).so
+SHLIB_LDFLAGS ?= $(LDFLAGS) -o $@ -shared -Xlinker -soname=$@
+
+$(SHLIB).so: $(OBJS)
+ $(CC) $(CFLAGS) $(SHLIB_LDFLAGS) $(OBJS) $(LDLIBS)
--- /dev/null
+#!/usr/bin/perl
+
+# code generator to help with writing Tcl extensions
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+# Input format is line-based, ws-significant, offside rule (some kind
+# of, anyway).
+#
+# Type TYPE: C-TYPE-DECLARATOR
+# Defines TYPE as a type (for arguments and return values)
+# which corresponds to the C type specified. C-TYPE-DECLARATOR
+# must contain one `@' where the identifier would go.
+# The type may contain allocated memory, etc., in which case
+# `Init' and `Fini' must be used.
+#
+# TYPE may be either TYPENAME or TYPENAME(ARGS) - in this case,
+# ARGS should be C argument declarations as for in a function
+# prototype, of extra arguments for the application-supplied
+# parser/returner functions. Each time a TYPE is used elsewhere,
+# the ARGS should be the actual arguments to pass, and will be
+# textually copied into the calls to the parser/returner
+# functions.
+#
+# `Type' causes declarations in the .h file of these functions:
+# int cht_pat_TYPENAME(Tcl_Interp*, Tcl_Obj *obj, C-TYPE *val, ARGS);
+# Tcl_Obj *cht_ret_TYPENAME(Tcl_Interp*, C-TYPE val, ARGS);
+#
+# cht_pat_... must attempt to parse obj into the appropriate type.
+# val will already have been initialised with `Init' statements if
+# relevant. Whether cht_pat_... fails or succeeds it may allocate
+# memory into the object and must leave the object valid (for
+# `Fini').
+#
+# cht_ret_... must convert the value back to a new Tcl_Obj. It may
+# not fail.
+#
+# Init TYPENAME C-STATEMENTS
+# Provides some statements which are used to initialise a variable
+# of type TYPENAME. C-STATEMENTS should contain one or more `@',
+# which will be replaced by the actual variable name. The
+# variable will have been declared with the C declarator specified
+# with `Type'. C-STATEMENTS may not fail or longjmp, and they may
+# not allocate memory or other resources. If no `Init' is
+# supplied then there is no invariant (so no `Fini' may be
+# supplied either, and the type is `flat' - no memory, external
+# refs, etc.)
+#
+# Fini TYPENAME C-STATEMENTS
+# Provides some statements (like `Init') which are used to free a
+# variable of type TYPENAME. The variable will already have been
+# initialised with the `Init' statements, and may have been
+# modified since by application per-type or per-command code. Its
+# invariant will be satisfied before C-STATEMENTS. Afterwards the
+# invariant may or may not be satisfied, but it may not have any
+# memory or other resources allocated. C-STATEMENTS may not fail
+# or longjmp.
+#
+# H-Include C-INCLUDE-SPECIFIER
+# Arranges for generated .h files to #include the specified
+# file. C-INCLUDE-SPECIFIER should include the <..> or "..".
+#
+# Table [*]TABLENAME C-ENTRY-TYPE
+# Starts a table of commands or subcommands. The generated .h
+# will contain a definition of C-ENTRY-TYPE containing
+# const char *name;
+# Tcl_ObjCmdProc *func;
+# and the generated .c will contain
+# const C-ENTRY-TYPE C-ARRAY-NAME[];
+# where C-ARRAY-NAME is TABLENAME, with `_entries' appended
+# and `cht_' prepended. The entries are indented one level (one
+# or more spaces) and look like this:
+# ENTRYNAME [ C-EXTRA-ENTRY-VALUES ]
+# FORMALARGNAME TYPE
+# ...
+# [ => RESULT-TYPE ]
+# This will cause the declaration of
+# int cht_do_TABLENAME_ENTRYNAME(ClientData cd, Tcl_Interp *ip,
+# FORMAL-ARGUMENTS, RESULT-C-TYPE*);
+# which is the procedure which the application must supply to
+# implement the function. If the `=> RESULT-TYPE' is omitted, so
+# is the result argument to the function. Each argument to the
+# function is of the C type corresponding to the specified type.
+# TYPE may be `...', in which case the C function will be passed
+# two args (int objc, Tcl_Obj *const *objv) for the remaining
+# arguments.
+#
+# The cht_do_... function should not eat any memory associated with
+# the arguments. The result buffer (if any) will be initialised
+# using the `Init' and should on success contain the relevant
+# result. On failure it should leave the result unmodified (or at
+# least, not in need of freeing).
+#
+# As an alternative, the arguments can be replaced with just
+# dispatch(TYPE-ARGS-FOR-ENUM)
+# which is a shorthand for
+# subcmd enum(TYPE-ARGS-FOR-ENUM)
+# args ...
+# and also generates and uses a standard dispatch function.
+#
+# There will be an entry in C-ARRAY-NAME for every table entry.
+# The name will be ENTRYNAME, and the func will be a function
+# suitable for use as a Tcl command procedure, which parses the
+# arguments, processes the command, and sets any result, as
+# applicable.
+#
+# `*' should be used if the table name is not useful for error
+# messages. It suppresses `TABLENAME ' from the front of the
+# autogenerated argument parsing error strings.
+#
+# EntryExtra C-ENTRY-TYPE
+# Introduces a section of additional C code which will be inserted
+# into the definition of C-ENTRY-TYPE by `Table'. The C
+# code, which follows on several indented lines, should be
+# structure member definitions.
+#
+# When EntryExtra is used, in the corresponding Table, each
+# ENTRYNAME should be followed on the same line by whitespace and
+# EXTRA-VALUES; the EXTRA-VALUES are used as initialisers for the
+# additional structure elements.
+#
+# NoEntryDefine C-ENTRY-TYPE
+# Prevents the definition of C-ENTRY-TYPE by Table.
+# The C type must be defined elsewhere.
+#
+# Also expected are these functions:
+# void cht_setstringresult(Tcl_Interp*, const char*);
+# sets the Tcl result from the supplied string
+# int cht_pat_enum(Tcl_Interp*, Tcl_Obj*, const void **c_e_t_array,
+# const void *c_e_t_return, size_t c_e_t_sz, const char *what);
+# scans a table of C-ENTRY-TYPEs looking for the
+# string matching the string supplied by the script
+# (as a Tcl_Obj). On error sets the result, using
+# what (a noun phrase describing the type of thing).
+# Assumes (unportably!) that the name and func members
+# are in the same places no matter what the rest of
+# the struct contains.
+# and the two predefined types `int' (C `int') and `obj' (Tcl_Obj*,
+# unmodified.) The corresponding definitions are in tcmdiflib.c.
+
+use IO;
+use Data::Dumper;
+
+parse('builtins','DATA');
+
+while (@ARGV) {
+ $_= shift @ARGV;
+ if (m/^\-p([-_0-9a-z]+)$/) {
+ $prefix= $1;
+ $prefix =~ y/-/_/;
+ } elsif (m/^\-w(c|h)$/) {
+ $write= $1;
+ } elsif (m/^\-o(.+)$/) {
+ $output= $1;
+ } elsif (m/^\-/) {
+ die "unknown option $_\n";
+ } else {
+ if (!defined $prefix) { $prefix= $_; $prefix =~ s/\.[^.]+$//; }
+ $x= new IO::File $_,'r' or die "$_: $!\n";
+ parse($_,$x);
+ }
+}
+
+die "must say -w<something>\n" if !defined $write;
+
+sub zilch () {
+ undef $c_table;
+ undef $c_entryextra;
+ undef $c_of;
+}
+
+sub enumargs ($) {
+ my ($a) = @_;
+ $a =~ m:/(.*),: or die "invalid enum type \`$a'\n";
+ my ($a_tab, $ee_type, $estr) = ($`,$1,$');
+ if ($ee_type !~ m/^[^_]/) {
+ $ee_type= $a_tab.$ee_type;
+ $a_tab= lc($a_tab).'_entries';
+ }
+ return ($a_tab, $ee_type, $estr);
+}
+
+sub parse ($$) {
+ my ($wh,$f) = @_;
+ while (defined($_= $f->getline)) {
+ chomp; s/\s+$//;
+ next if m/^\s*\#/;
+ next if !m/\S/;
+ while (s/\t/ ' 'x(8 - (length $`) % 8) /e) { }
+
+ s/^\s*//;
+ $this_indent= length $&;
+ while (@i && $this_indent < $i[0]) {
+ shift @i;
+ }
+ if ($this_indent && (!@i || $this_indent > $i[0])) {
+ unshift @i, $this_indent;
+ }
+
+ if (@i==0 && m/^Table\s+(\*?)(\w+)\s+(\w+)$/) {
+ zilch();
+ $c_table= $2;
+ $table_x{$c_table}{T}= $1;
+ $table_x{$c_table}{C}= $3;
+ $entrytype_x{$3}= '' unless exists $entrytype_x{$3};
+ } elsif (@i==0 && m/^Untabled$/) {
+ zilch();
+ $c_table= '';
+ } elsif (@i==0 && m/^(C|H)\-Include\s+(\S.*)$/) {
+ o(lc $1, 30, "#include $2\n");
+ } elsif (@i==0 && m/^EntryExtra\s+(\w+)$/) {
+ zilch();
+ $c_entryextra= $1;
+ } elsif (@i==0 && m/^NoEntryDefine\s+(\w+)$/) {
+ zilch();
+ $entrytype_x{$1}= " ";
+ } elsif (@i>=1 && defined $c_entryextra) {
+ $entrytype_x{$c_entryextra} .= " $_\n";
+ } elsif (@i==1 && m/^[a-z].*$/ && defined $c_table) {
+ if (m/^[-_0-9A-Za-z]+$/) {
+ $c_entry= $_;
+ } elsif (m/^([-_0-9A-Za-z]+)\s+(\S.*)$/) {
+ $c_entry= $1;
+ $tables{$c_table}{$c_entry}{I} .= ", $2";
+ } else {
+ badsyntax($wh,$.,"bad entry");
+ }
+ $tables{$c_table}{$c_entry}{A} = [ ];
+ } elsif (@i==2 && m/^\.\.\.\s+(\w+)$/ && defined $c_entry) {
+ $tables{$c_table}{$c_entry}{V}= $1;
+ } elsif (@i==2 && m:^dispatch\(((.*)/(.*)\,.*)\)$: && defined $c_entry) {
+ my $enumargs= $1;
+ my $subcmdtype= $2.$3;
+ $tables{$c_table}{$c_entry}{D}= $subcmdtype;
+ $tables{$c_table}{$c_entry}{V}= 'obj';
+ push @{ $tables{$c_table}{$c_entry}{A} },
+ { N => 'subcmd', T => 'enum', A => $enumargs, O => '' };
+ } elsif (@i==2 && m/^(\??)([a-z]\w*)\s*(\S.*)/
+ && defined $c_entry) {
+ ($opt, $var, $type) = ($1,$2,$3);
+ ($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) {
+ ($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/\@/;
+ ($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;
+ } elsif (@i==0 && s/^Fini\s+(\w+)\s+(\S.*)//) {
+ $type_fini{$1}= $2;
+ } else {
+ badsyntax($wh,$., sprintf
+ "bad directive (indent level %d)", scalar @i);
+ }
+ }
+ $f->error and die $!;
+ $f->close;
+}
+
+#print Dumper(\%tables),"\n";
+#print Dumper(\%types),"\n";
+
+foreach $t (sort keys %types) {
+ $type= $types{$t};
+ $c= $type->{C};
+ $xta= $type->{X};
+ $decl= "int cht_pat_$t(Tcl_Interp *ip, Tcl_Obj *obj, ";
+ $decl .= subst_in_decl('*val', $c, "type $t");
+ $decl .= ", $xta", if length $xta;
+ $decl .= ");\n";
+ o('h',160, $decl);
+
+ $decl= "Tcl_Obj *cht_ret_$t(Tcl_Interp *ip, ".subst_in_decl('val',$c);
+ $decl .= ", $xta" if length $xta;
+ $decl .= ");\n";
+ o('h',170, $decl);
+}
+
+foreach $c_entrytype (sort keys %entrytype_x) {
+ next if $entrytype_x{$c_entrytype} =~ m/^\s$/;
+ o('h', 20, "typedef struct $c_entrytype $c_entrytype;\n");
+ o('h', 100,
+ "struct $c_entrytype {\n".
+ " const char *name;\n".
+ " Tcl_ObjCmdProc *func;\n".
+ $entrytype_x{$c_entrytype}.
+ "};\n\n");
+}
+
+foreach $c_table (sort keys %tables) {
+ $r_table= $tables{$c_table};
+ $x_table= $table_x{$c_table};
+ $op_tab= '';
+
+ foreach $c_entry (sort keys %$r_table) {
+ $c_entry_c= $c_entry; $c_entry_c =~ y/-/_/;
+ $r_entry= $r_table->{$c_entry};
+ $pa_decl= "int pa_${c_table}_${c_entry_c}(ClientData cd,".
+ " Tcl_Interp *ip, int objc, Tcl_Obj *const *objv)";
+ $pa_func= "cht_do_${c_table}_${c_entry_c}";
+ if (exists $r_entry->{D}) {
+ $pa_func= "cht_dispatch_$r_entry->{D}";
+ }
+ $do_decl= "int $pa_func(";
+ @do_al= ('ClientData cd', 'Tcl_Interp *ip');
+ @do_aa= qw(cd ip);
+ $pa_init= '';
+ $pa_argc= " objc--; objv++;\n";
+ $pa_vars= " int rc;\n";
+ $pa_body= '';
+ $pa_rslt= '';
+ $pa_free= '';
+ $pa_fini= '';
+ $any_mand= 0;
+ $any_optl= 0;
+ $any_eerr= 0;
+ $any_eargc= 0;
+ $pa_hint= '';
+ $pa_hint .= "$c_table " if length $c_table &&
+ !length $table_x{$c_table}{T};
+ $pa_hint.= $c_entry;
+ foreach $arg (@{ $r_entry->{A} }) {
+ $n= $arg->{N};
+ $t= $arg->{T};
+ $a= $arg->{A};
+ 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) {
+ $any_mand= 0;
+ $any_eerr= 1;
+ }
+ $pa_body .= " if (!objc--) goto end_optional;\n";
+ $any_optl= 1;
+ } else {
+ $pa_hint .= " $n";
+ $pa_body .= " if (!objc--) goto wrong_count_args;\n";
+ $any_mand++;
+ $any_eargc= 1;
+ die if $any_optl;
+ }
+ $paarg= "&a_$n";
+ $pafin= '';
+ if ($t eq 'enum') {
+ $pa_vars .= " const void *v_$n= 0;\n";
+ $paarg= "&v_$n";
+ $pafin= "\n a_$n= v_$n; ";
+ ($a_tab, $ee_type, $estr) = enumargs($a);
+ $a = "cht_$a_tab, sizeof($ee_type), $estr";
+ o('h', 210, "extern const $ee_type cht_$a_tab".'[]'.";\n");
+ }
+ if (exists $type_fini{$t}) {
+ $pa_fini .= ' '.subst_in("a_$n", $type_fini{$t})."\n";
+ }
+ $pa_body .= " rc= cht_pat_$t(ip, *objv++, $paarg";
+ $pa_body .= ", ".$a if length $a;
+ $pa_body .= ");$pafin if (rc) goto rc_err;\n";
+ push @do_aa, "a_$n";
+ }
+ if (exists $r_entry->{V}) {
+ $pa_hint .= " ...";
+ $va= $r_entry->{V};
+ push @do_al, subst_in_decl("${va}c", 'int @');
+ push @do_al, subst_in_decl("${va}v", 'Tcl_Obj *const *@');
+ push @do_aa, "objc+1", "objv-1";
+ } else {
+ if (!$any_optl) {
+ $pa_body .= " if (objc) goto wrong_count_args;\n";
+ $any_eargc= 1;
+ }
+ }
+ if ($any_optl) {
+ $pa_body .= "end_optional:\n";
+ }
+ if (exists $r_entry->{R}) {
+ $t= $r_entry->{R};
+ $xta= $r_entry->{X};
+ push @do_al, make_decl("*result", $t, "cht_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, cht_ret_$t(ip, result";
+ $pa_rslt .= ", $xta" if length $xta;
+ $pa_rslt .= "));\n";
+ }
+ $pa_body .= "\n";
+ $pa_body .= " rc= $pa_func(";
+ $pa_body .= join ', ', @do_aa;
+ $pa_body .= ");\n";
+ $pa_body .= " if (rc) goto rc_err;\n";
+
+ $pa_rslt .= " rc= TCL_OK;\n\n";
+ $pa_rslt .= "rc_err:\n";
+
+ $pa_fini .= " return rc;\n";
+ if ($any_eargc) {
+ $pa_fini .= "\nwrong_count_args:\n";
+ $pa_fini .= " e=\"wrong # args: should be \\\"$pa_hint\\\"\";\n";
+ $pa_fini .= " goto e_err;";
+ $any_eerr= 1;
+ }
+ if ($any_eerr) {
+ $pa_vars .= " const char *e;\n";
+ $pa_fini .= "\n";
+ $pa_fini .= "e_err:\n";
+ $pa_fini .= " cht_setstringresult(ip,e);\n";
+ $pa_fini .= " rc= TCL_ERROR; goto rc_err;\n";
+ }
+ $pa_vars .= "\n";
+ $pa_init .= "\n" if length $pa_init;
+ $pa_fini .= "}\n\n";
+
+ if (length $c_table) {
+ $static= 'static ';
+ } else {
+ $static= '';
+ o('h',90, "$pa_decl;\n");
+ }
+ o('c',100,
+ $static.$pa_decl." {\n".
+ $pa_vars.
+ $pa_init.
+ $pa_argc.
+ $pa_body.
+ $pa_rslt.
+ $pa_free.
+ $pa_fini);
+ $do_decl .= join ', ', @do_al;
+ $do_decl .= ")";
+
+ if (exists $r_entry->{D}) {
+ my $subcmdtype= $r_entry->{D};
+ if (!exists $dispatch_done{$subcmdtype}) {
+ my $di_body='';
+ $di_body .= "static $do_decl {\n";
+ $di_body .= " return subcmd->func(0,ip,objc,objv);\n";
+ $di_body .= "}\n";
+ o('c',50, $di_body) or die $!;
+ }
+ } else {
+ o('h',100, $do_decl.";\n") or die $!;
+ }
+
+ $op_tab .= sprintf(" { %-20s %-40s%s },\n",
+ "\"$c_entry\",",
+ "pa_${c_table}_${c_entry_c}",
+ $r_entry->{I});
+ }
+ if (length $c_table) {
+ $decl= "const $x_table->{C} cht_${c_table}_entries[]";
+ o('h', 500, "extern $decl;\n");
+ o('c', 100,
+ "$decl = {\n".
+ $op_tab.
+ " { 0 }\n".
+ "};\n\n");
+ }
+}
+
+o(c, 0, "#include \"$prefix.h\"\n");
+
+o(h, 0,
+ "#ifndef INCLUDED_\U${prefix}_H\n".
+ "#define INCLUDED_\U${prefix}_H\n\n");
+
+o(h, 999,
+ "#endif /*INCLUDED_\U${prefix}_H*/\n");
+
+if (defined $output) {
+ $oh= new IO::File "$output.tmp", 'w' or die "$output.tmp: $!\n";
+} else {
+ $oh= 'STDOUT';
+}
+
+print $oh "/* AUTOGENERATED - DO NOT EDIT */\n" or die $!;
+foreach $pr (sort keys %{ $o{$write} }) {
+ print $oh "\n" or die $!;
+ print $oh $o{$write}{$pr} or die $!;
+}
+
+die if $oh->error;
+die $! unless $oh->close;
+
+if (defined $output) {
+ rename "$output.tmp", $output or die $!;
+}
+
+sub o ($$) {
+ my ($wh,$pr,$s) = @_;
+ $o{$wh}{sprintf "%010d", $pr} .= $s;
+}
+
+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,"$why _init");
+ if (exists $type_init{$t}) {
+ $init= $type_init{$t};
+ $$initcode .= " ".subst_in("$n", $init)."\n"
+ if length $init;
+ } else {
+ $o .= ' =0';
+ }
+ return " ".$o.";\n";
+}
+
+sub make_decl ($$$$) {
+ my ($n, $t, $ta, $why) = @_;
+ my ($type);
+ if ($t eq 'enum') {
+ ($a_tab, $ee_type, $estr) = enumargs($ta);
+ $c= "const $ee_type* @";
+ } else {
+ defined $types{$t} or die "unknown type $t ($why)\n";
+ $c= $types{$t}{C};
+ }
+ return subst_in_decl($n,$c);
+}
+
+sub subst_in_decl ($$$) {
+ my ($val, $pat, $why) = @_;
+ local ($_) = subst_in($val, $pat, $why);
+ s/ *(\**) *$/$1/;
+ return $_;
+}
+
+sub subst_in ($$$) {
+ my ($val, $pat, $why) = @_;
+ $pat =~ m/\@/ or die "$pat for $val in $why ?";
+ $pat =~ s/\@/$val/g;
+ return $pat;
+}
+
+sub badsyntax ($$$) {
+ die "$_[0]:$_[1]: $_[2]\n";
+}
+
+__DATA__
+Type int: int
+Type obj: Tcl_Obj *@
--- /dev/null
+/*
+ * base code for various Tcl extensions
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include "chiark-tcl-base.h"
+
+int cht_pat_enum(Tcl_Interp *ip, Tcl_Obj *obj, const void **val,
+ const void *opts, size_t sz, const char *what) {
+ *val= cht_enum_lookup_cached_func(ip,obj,opts,sz,what);
+ if (!*val) return TCL_ERROR;
+ return TCL_OK;
+}
+
+int cht_pat_obj(Tcl_Interp *ip, Tcl_Obj *obj, Tcl_Obj **val) {
+ *val= obj;
+ return TCL_OK;
+}
+
+Tcl_Obj *cht_ret_int(Tcl_Interp *ip, int val) {
+ return Tcl_NewIntObj(val);
+}
+
+Tcl_Obj *cht_ret_obj(Tcl_Interp *ip, Tcl_Obj *val) {
+ return val;
+}
+
+void cht_setstringresult(Tcl_Interp *ip, const char *m) {
+ Tcl_ResetResult(ip);
+ Tcl_AppendResult(ip, m, (char*)0);
+}
--- /dev/null
+# cdb, cdb-wr - Tcl bindings for tinycdb and a journalling write extension
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+BASE_DIR = ../base
+EXTBASE = cdb
+CFILES = readonly writeable lookup
+OTHER_TCTS = ../hbytes/hbytes-base.tct
+OTHER_EXTS += hbytes/hbytes
+LDLIBS += -lcdb
+
+include ../base/extension.make
+
+# eg, for testing:
+# liberator:cdb> LD_LIBRARY_PATH=../base:../hbytes:. tclsh8.3
+# % load chiark_tcl_cdb.so
+# % cdb
+# wrong # args: should be "cdb subcmd ..."
+# % cdb open
+# wrong # args: should be "cdb open path"
+# %
+# liberator:cdb>
--- /dev/null
+# cdb, cdb-wr - Tcl bindings for tinycdb and a journalling write extension
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+Table *cdbtoplevel TopLevel_Command
+ cdb
+ dispatch(Cdb/_SubCommand, "cdb subcommand")
+ cdb-wr
+ dispatch(Cdbwr/_SubCommand, "cdb-wr subcommand")
+
+Table cdb Cdb_SubCommand
+ open
+ path string
+ => iddata(&cdbtcl_databases)
+ lookup
+ db iddata(&cdbtcl_databases)
+ key obj
+ ?def obj
+ => obj
+ lookup-hb
+ db iddata(&cdbtcl_databases)
+ key hb
+ ?def obj
+ => obj
+ close
+ db iddata(&cdbtcl_databases)
+
+Table cdbwr Cdbwr_SubCommand
+ create-empty 0
+ pathb string
+ # files:
+ # <pathb>.main
+ # <pathb>.lock
+ # <pathb>.cdb
+ # <pathb>.jrn
+ # <pathb>.tmp (might be new .main or new .cdb)
+ # invariants:
+ # .lock is an empty file
+ # which is locked with fcntl by open
+ # .main is a cdb native text file
+ # and always exists
+ # .cdb is a cdb database containing data
+ # equivalent to and at least as recent as .main
+ # (maybe not identical, because .cdb may
+ # have been updated with data from .jrn but
+ # .main not yet); if .jrn does not exist then
+ # they are identical)
+ # .cdb may not exist; in which case it is to
+ # be treated as if it existed and was empty
+ # but this is maximally early (so main must
+ # exist and be empty since .main is never
+ # newer than .cdb)
+ # if .jrn exists, it is a cdb native
+ # text file _without the trailing newline_;
+ # its contents override values from .main or .cdb
+ # if .main.tmp or .cdb.tmp exists it is irrelevant
+ # zero length values mean record is deleted (in .jrn only;
+ # forbidden elsewhere)
+ # while db is open:
+ # .lock is locked
+ # .jrn and open hash table contain same info
+ open 0
+ pathb string
+ on_info obj
+ ?on_lexminval obj
+ # on_lexminval present and not empty list: provides a
+ # script which returns the current lexminval. In
+ # this case, occasionally,
+ # on_lexminval will be called and then entries whose
+ # value is lexically strictly less than lexminval
+ # will be deleted automatically. The comparison
+ # is bytewise on the UTF-8 representations.
+ => iddata(&cdbtcl_rwdatabases)
+ open-okjunk RWSCF_OKJUNK
+ pathb string
+ on_info obj
+ ?on_lexminval obj
+ => iddata(&cdbtcl_rwdatabases)
+ # on_info <event> <xinfo>...:
+ # on_info open-clean <statistics-info-string>
+ # on_info open-dirty-start <statistics-info-string>
+ # on_info open-dirty-junk <problem-info-string> \
+ # <problem-error-code-list>
+ # on_info open-dirty-done <statistics-info-string>
+ # on_info compact-start <statistics-info-string>
+ # on_info compact-done <statistics-info-string>
+ # on_info close <statistics-info-string>
+ lookup 0
+ db iddata(&cdbtcl_rwdatabases)
+ key string
+ ?def obj
+ => obj
+ lookup-hb 0
+ db iddata(&cdbtcl_rwdatabases)
+ key string
+ ?def obj
+ => obj
+ delete 0
+ db iddata(&cdbtcl_rwdatabases)
+ key string
+ update 0
+ db iddata(&cdbtcl_rwdatabases)
+ key string
+ value obj
+ update-hb 0
+ db iddata(&cdbtcl_rwdatabases)
+ key string
+ value hb
+ compact-force 0
+ db iddata(&cdbtcl_rwdatabases)
+ compact-check 0
+ db iddata(&cdbtcl_rwdatabases)
+ compact-auto 0
+ # this is the default
+ db iddata(&cdbtcl_rwdatabases)
+ compact-explicit 0
+ db iddata(&cdbtcl_rwdatabases)
+ close 0
+ db iddata(&cdbtcl_rwdatabases)
+
+EntryExtra Cdbwr_SubCommand
+ unsigned flags;
--- /dev/null
+/*
+ * cdb, cdb-wr - Tcl bindings for tinycdb and a journalling write extension
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#ifndef CHIARK_TCL_CDB_H
+#define CHIARK_TCL_CDB_H
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <unistd.h>
+
+#include <ctype.h>
+#include <stdio.h>
+
+#include <cdb.h>
+
+#include "hbytes.h"
+#include "cdb+tcmdif.h"
+
+#define RWSCF_OKJUNK 002
+
+extern const IdDataSpec cdbtcl_databases, cdbtcl_rwdatabases;
+
+/*---------- from lookup.c ----------*/
+
+int cht_cdb_donesomelookup(Tcl_Interp *ip, void *db_v,
+ Tcl_Obj *def, Tcl_Obj **result,
+ const Byte *data, int dlen,
+ int (*storeanswer)(Tcl_Interp *ip, Tcl_Obj **result,
+ const Byte *data, int len));
+int cht_cdb_storeanswer_string(Tcl_Interp *ip, Tcl_Obj **result,
+ const Byte *data, int len);
+int cht_cdb_storeanswer_hb(Tcl_Interp *ip, Tcl_Obj **result,
+ const Byte *data, int len);
+int cht_cdb_lookup_cdb(Tcl_Interp *ip, struct cdb *cdb,
+ const Byte *key, int klen,
+ const Byte **data_r, int *dlen_r);
+
+/*---------- macros ----------*/
+
+#define PE(m) do{ \
+ rc= cht_posixerr(ip, errno, "failed to " m); goto x_rc; \
+ }while(0)
+
+#endif /*CHIARK_TCL_CDB_H*/
--- /dev/null
+/*
+ * cdb, cdb-wr - Tcl bindings for tinycdb and a journalling write extension
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include "chiark_tcl_cdb.h"
+
+int cht_cdb_donesomelookup(Tcl_Interp *ip, void *db_v,
+ Tcl_Obj *def, Tcl_Obj **result,
+ const Byte *data, int dlen,
+ int (*storeanswer)(Tcl_Interp *ip, Tcl_Obj **result,
+ const Byte *data, int len)) {
+ if (dlen>0) return storeanswer(ip, result, data, dlen);
+ if (def) { *result= def; return TCL_OK; }
+ return cht_staticerr(ip, "cdbwr lookup key not found", "CDB NOTFOUND");
+}
+
+int cht_cdb_storeanswer_string(Tcl_Interp *ip, Tcl_Obj **result,
+ const Byte *data, int len) {
+ *result= Tcl_NewStringObj(data, len);
+ if (!*result) return cht_staticerr(ip, "Tcl_NewStringObj failed for"
+ " lookup (utf-8 encoding problem?)", "CDB BADSTRING");
+ return TCL_OK;
+}
+
+int cht_cdb_storeanswer_hb(Tcl_Interp *ip, Tcl_Obj **result,
+ const Byte *data, int len) {
+ HBytes_Value val;
+ cht_hb_array(&val, data, len);
+ *result= cht_ret_hb(ip, val);
+ return TCL_OK;
+}
+
+int cht_cdb_lookup_cdb(Tcl_Interp *ip, struct cdb *cdb,
+ const Byte *key, int klen,
+ const Byte **data_r, int *len_r) {
+ int r;
+
+ r= cdb_find(cdb, key, klen);
+ if (!r) { *data_r= 0; *len_r= -1; return TCL_OK; }
+ if (r<0) return cht_posixerr(ip, errno, "cdb_find failed");
+ assert(r==1);
+ *len_r= cdb_datalen(cdb);
+ assert(*len_r > 0);
+ *data_r= cdb_getdata(cdb);
+ if (!*data_r) return cht_posixerr(ip, errno, "cdb_getdata failed");
+ return TCL_OK;
+}
+
+CHT_INIT(cdb,
+ CHTI_OTHER(hbytes),
+ CHTI_COMMANDS(cht_cdbtoplevel_entries))
--- /dev/null
+/*
+ * cdb, cdb-wr - Tcl bindings for tinycdb and a journalling write extension
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include "chiark_tcl_cdb.h"
+
+typedef struct Ro {
+ int ix, fd;
+ struct cdb cdb;
+} Ro;
+
+static void ro_close(Ro *ro) {
+ cdb_free(&ro->cdb);
+ close(ro->fd);
+}
+
+static void destroy_cdb_idtabcb(Tcl_Interp *ip, void *ro_v) {
+ ro_close(ro_v);
+ TFREE(ro_v);
+}
+
+const IdDataSpec cdbtcl_databases= {
+ "cdb-db", "cdb-opendatabases-table", destroy_cdb_idtabcb
+};
+
+int cht_do_cdb_open(ClientData cd, Tcl_Interp *ip,
+ const char *path, void **result) {
+ Ro *ro;
+ int rc, r;
+
+ ro= TALLOC(sizeof(*ro));
+ ro->ix= -1;
+ ro->fd= open(path, O_RDONLY);
+ if (ro->fd<0) PE("open database file");
+ r= cdb_init(&ro->cdb, ro->fd);
+ if (r) PE("initialise cdb");
+ *result= ro;
+ return TCL_OK;
+
+ x_rc:
+ if (ro->fd >= 0) close(ro->fd);
+ return rc;
+}
+
+int cht_do_cdb_close(ClientData cd, Tcl_Interp *ip, void *ro_v) {
+ ro_close(ro_v);
+ cht_tabledataid_disposing(ip, ro_v, &cdbtcl_databases);
+ TFREE(ro_v);
+ return TCL_OK;
+}
+
+int cht_do_cdb_lookup(ClientData cd, Tcl_Interp *ip, void *ro_v,
+ Tcl_Obj *keyo, Tcl_Obj *def, Tcl_Obj **result) {
+ Ro *ro= ro_v;
+ const Byte *key;
+ const Byte *data;
+ int r, dlen, klen;
+
+ key= Tcl_GetStringFromObj(keyo, &klen); assert(key);
+
+ r= cht_cdb_lookup_cdb(ip, &ro->cdb, key, klen, &data, &dlen);
+ if (r) return r;
+
+ return cht_cdb_donesomelookup(ip, ro_v, def, result, data, dlen,
+ cht_cdb_storeanswer_string);
+}
+
+int cht_do_cdb_lookup_hb(ClientData cd, Tcl_Interp *ip, void *ro_v,
+ HBytes_Value key, Tcl_Obj *def, Tcl_Obj **result) {
+ Ro *ro= ro_v;
+ const Byte *data;
+ int r, dlen;
+
+ r= cht_cdb_lookup_cdb(ip, &ro->cdb,
+ cht_hb_data(&key), cht_hb_len(&key),
+ &data, &dlen);
+ if (r) return r;
+
+ return cht_cdb_donesomelookup(ip, ro_v, def, result, data, dlen,
+ cht_cdb_storeanswer_hb);
+}
--- /dev/null
+/*
+ * cdb, cdb-wr - Tcl bindings for tinycdb and a journalling write extension
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include "chiark_tcl_cdb.h"
+
+#define KEYLEN_MAX (INT_MAX/2)
+
+#define ftello ftell
+#define fseeko fseek
+
+/*---------- Forward declarations ----------*/
+
+struct ht_forall_ctx;
+
+/*---------- Useful routines ----------*/
+
+static void maybe_close(int fd) {
+ if (fd>=0) close(fd);
+}
+
+/*==================== Subsystems and subtypes ====================*/
+
+/*---------- Pathbuf ----------*/
+
+typedef struct Pathbuf {
+ char *buf, *sfx;
+} Pathbuf;
+
+#define MAX_SUFFIX 5
+
+static void pathbuf_init(Pathbuf *pb, const char *pathb) {
+ size_t l= strlen(pathb);
+ assert(l < INT_MAX);
+ pb->buf= TALLOC(l + MAX_SUFFIX + 1);
+ memcpy(pb->buf, pathb, l);
+ pb->sfx= pb->buf + l;
+}
+static const char *pathbuf_sfx(Pathbuf *pb, const char *suffix) {
+ assert(strlen(suffix) <= MAX_SUFFIX);
+ strcpy(pb->sfx, suffix);
+ return pb->buf;
+}
+static void pathbuf_free(Pathbuf *pb) {
+ TFREE(pb->buf);
+ pb->buf= 0;
+}
+
+/*---------- Our hash table ----------*/
+
+typedef struct HashTable {
+ Tcl_HashTable t;
+ Byte padding[128]; /* allow for expansion by Tcl, urgh */
+ Byte confound[16];
+} HashTable;
+
+typedef struct HashValue {
+ int len;
+ Byte data[1];
+} HashValue;
+
+static HashValue *htv_prep(int len) {
+ HashValue *hd;
+ hd= TALLOC((hd->data - (Byte*)hd) + len);
+ hd->len= len;
+ return hd;
+}
+static Byte *htv_fillptr(HashValue *hd) {
+ return hd->data;
+}
+
+static void ht_setup(HashTable *ht) {
+ Tcl_InitHashTable(&ht->t, TCL_STRING_KEYS);
+}
+static void ht_update(HashTable *ht, const char *key, HashValue *val_eat) {
+ Tcl_HashEntry *he;
+ int new;
+
+ he= Tcl_CreateHashEntry(&ht->t, (char*)key, &new);
+ if (!new) TFREE(Tcl_GetHashValue(he));
+ Tcl_SetHashValue(he, val_eat);
+ /* eats the value since the data structure owns the memory */
+}
+static void ht_maybeupdate(HashTable *ht, const char *key,
+ HashValue *val_eat) {
+ /* like ht_update except does not overwrite existing values */
+ Tcl_HashEntry *he;
+ int new;
+
+ he= Tcl_CreateHashEntry(&ht->t, (char*)key, &new);
+ if (!new) { TFREE(val_eat); return; }
+ Tcl_SetHashValue(he, val_eat);
+}
+
+static const HashValue *ht_lookup(HashTable *ht, const char *key) {
+ Tcl_HashEntry *he;
+
+ he= Tcl_FindHashEntry(&ht->t, key);
+ if (!he) return 0;
+
+ return Tcl_GetHashValue(he);
+}
+
+static int ht_forall(HashTable *ht,
+ int (*fn)(const char *key, HashValue *val,
+ struct ht_forall_ctx *ctx),
+ struct ht_forall_ctx *ctx) {
+ /* Returns first positive value returned by any call to fn, or 0. */
+ Tcl_HashSearch sp;
+ Tcl_HashEntry *he;
+ const char *key;
+ HashValue *val;
+ int r;
+
+ for (he= Tcl_FirstHashEntry(&ht->t, &sp);
+ he;
+ he= Tcl_NextHashEntry(&sp)) {
+ val= Tcl_GetHashValue(he);
+ if (!val->len) continue;
+
+ key= Tcl_GetHashKey(&ht->t, he);
+
+ r= fn(key, val, ctx);
+ if (r) return r;
+ }
+ return 0;
+}
+
+static void ht_destroy(HashTable *ht) {
+ Tcl_HashSearch sp;
+ Tcl_HashEntry *he;
+
+ for (he= Tcl_FirstHashEntry(&ht->t, &sp);
+ he;
+ he= Tcl_NextHashEntry(&sp)) {
+ /* ht_forall skips empty (deleted) entries so is no good for this */
+ TFREE(Tcl_GetHashValue(he));
+ }
+ Tcl_DeleteHashTable(&ht->t);
+}
+
+/*==================== Existential ====================*/
+
+/*---------- Rw data structure ----------*/
+
+typedef struct Rw {
+ int ix, autocompact;
+ int cdb_fd, lock_fd;
+ struct cdb cdb; /* valid iff cdb_fd >= 0 */
+ FILE *logfile; /* may be 0; if so, is broken */
+ HashTable logincore;
+ Pathbuf pbsome, pbother;
+ off_t mainsz;
+ ScriptToInvoke on_info, on_lexminval;
+} Rw;
+
+static void rw_cdb_close(Tcl_Interp *ip, Rw *rw) {
+ if (rw->cdb_fd >= 0) cdb_free(&rw->cdb);
+ maybe_close(rw->cdb_fd);
+}
+
+static int rw_close(Tcl_Interp *ip, Rw *rw) {
+ int rc, r;
+
+ rc= TCL_OK;
+ ht_destroy(&rw->logincore);
+ rw_cdb_close(ip,rw);
+ maybe_close(rw->lock_fd);
+
+ if (rw->logfile) {
+ r= fclose(rw->logfile);
+ if (r && ip) { rc= cht_posixerr(ip, errno, "probable data loss! failed to"
+ " fclose logfile during untidy close"); }
+ }
+
+ pathbuf_free(&rw->pbsome); pathbuf_free(&rw->pbother);
+ return rc;
+}
+
+static void destroy_cdbrw_idtabcb(Tcl_Interp *ip, void *rw_v) {
+ rw_close(0,rw_v);
+ TFREE(rw_v);
+}
+const IdDataSpec cdbtcl_rwdatabases= {
+ "cdb-rwdb", "cdb-openrwdatabases-table", destroy_cdbrw_idtabcb
+};
+
+/*---------- File handling ----------*/
+
+static int acquire_lock(Tcl_Interp *ip, Pathbuf *pb, int *lockfd_r) {
+ /* *lockfd_r must be -1 on entry. If may be set to >=0 even
+ * on error, and must be closed by the caller. */
+ mode_t um, lockmode;
+ struct flock fl;
+ int r;
+
+ um= umask(~(mode_t)0);
+ umask(um);
+
+ lockmode= 0666 & ~((um & 0444)>>1);
+ /* Remove r where umask would remove w;
+ * eg umask intending 0664 here gives 0660 */
+
+ *lockfd_r= open(pathbuf_sfx(pb,".lock"), O_RDWR|O_CREAT, lockmode);
+ if (*lockfd_r < 0)
+ return cht_posixerr(ip, errno, "could not open/create lockfile");
+
+ fl.l_type= F_WRLCK;
+ fl.l_whence= SEEK_SET;
+ fl.l_start= 0;
+ fl.l_len= 0;
+ fl.l_pid= getpid();
+
+ r= fcntl(*lockfd_r, F_SETLK, &fl);
+ if (r == -1) {
+ if (errno == EACCES || errno == EAGAIN)
+ return cht_staticerr(ip, "lock held by another process", "CDB LOCKED");
+ else return cht_posixerr(ip, errno, "unexpected error from fcntl while"
+ " acquiring lock");
+ }
+
+ return TCL_OK;
+}
+
+/*---------- Log reading and writing ----------*/
+
+static int readlognum(FILE *f, int delim, int *num_r) {
+ int c;
+ char numbuf[20], *p, *ep;
+ unsigned long ul;
+
+ p= numbuf;
+ for (;;) {
+ c= getc(f); if (c==EOF) return -2;
+ if (c == delim) break;
+ if (!isdigit((unsigned char)c)) return -2;
+ *p++= c;
+ if (p == numbuf+sizeof(numbuf)) return -2;
+ }
+ if (p == numbuf) return -2;
+ *p= 0;
+
+ errno=0; ul= strtoul(numbuf, &ep, 10);
+ if (*ep || errno || ul >= KEYLEN_MAX) return -2;
+ *num_r= ul;
+ return 0;
+}
+
+static int readstorelogrecord(FILE *f, HashTable *ht,
+ int (*omitfn)(const HashValue*,
+ struct ht_forall_ctx *ctx),
+ struct ht_forall_ctx *ctx,
+ void (*updatefn)(HashTable*, const char*,
+ HashValue*)) {
+ /* returns:
+ * 0 for OK
+ * -1 eof
+ * -2 corrupt or error
+ * -3 got newline indicating end
+ * >0 value from omitfn
+ */
+ int keylen, vallen;
+ char *key;
+ HashValue *val;
+ int c, rc, r;
+
+ c= getc(f);
+ if (c==EOF) { return feof(f) ? -1 : -2; }
+ if (c=='\n') return -3;
+ if (c!='+') return -2;
+
+ rc= readlognum(f, ',', &keylen); if (rc) return rc;
+ rc= readlognum(f, ':', &vallen); if (rc) return rc;
+
+ key= TALLOC(keylen+1);
+ val= htv_prep(vallen);
+
+ r= fread(key, 1,keylen, f);
+ if (r!=keylen) goto x2_free_keyval;
+ if (memchr(key,0,keylen)) goto x2_free_keyval;
+ key[keylen]= 0;
+
+ c= getc(f); if (c!='-') goto x2_free_keyval;
+ c= getc(f); if (c!='>') goto x2_free_keyval;
+
+ r= fread(htv_fillptr(val), 1,vallen, f);
+ if (r!=vallen) goto x2_free_keyval;
+
+ c= getc(f); if (c!='\n') goto x2_free_keyval;
+
+ rc= omitfn ? omitfn(val, ctx) : TCL_OK;
+ if (rc) { assert(rc>0); TFREE(val); }
+ else updatefn(ht, key, val);
+
+ TFREE(key);
+ return rc;
+
+ x2_free_keyval:
+ TFREE(val);
+ TFREE(key);
+ return -2;
+}
+
+static int writerecord(FILE *f, const char *key, const HashValue *val) {
+ int r;
+
+ r= fprintf(f, "+%d,%d:%s->", (int)strlen(key), val->len, key);
+ if (r<0) return -1;
+
+ r= fwrite(val->data, 1, val->len, f);
+ if (r != val->len) return -1;
+
+ r= putc('\n', f);
+ if (r==EOF) return -1;
+
+ return 0;
+}
+
+/*---------- Creating ----------*/
+
+int cht_do_cdbwr_create_empty(ClientData cd, Tcl_Interp *ip,
+ const char *pathb) {
+ static const char *const toremoves[]= { ".cdb", ".jrn", ".tmp", 0 };
+
+ Pathbuf pb, pbmain;
+ int lock_fd=-1, rc, r;
+ FILE *f= 0;
+ const char *const *toremove;
+ struct stat stab;
+
+ pathbuf_init(&pb, pathb);
+ pathbuf_init(&pbmain, pathb);
+
+ rc= acquire_lock(ip, &pb, &lock_fd); if (rc) goto x_rc;
+
+ r= lstat(pathbuf_sfx(&pbmain, ".main"), &stab);
+ if (!r) { rc= cht_staticerr(ip, "database already exists during creation",
+ "CDB ALREADY-EXISTS"); goto x_rc; }
+ if (errno != ENOENT) PE("check for existing database .main during creation");
+
+ for (toremove=toremoves; *toremove; toremove++) {
+ r= remove(pathbuf_sfx(&pb, *toremove));
+ if (r && errno != ENOENT)
+ PE("delete possible spurious file during creation");
+ }
+
+ f= fopen(pathbuf_sfx(&pb, ".tmp"), "w");
+ if (!f) PE("create new database .tmp");
+ r= putc('\n', f); if (r==EOF) PE("write sentinel to new database .tmp");
+ r= fclose(f); f=0; if (r) PE("close new database .tmp during creation");
+
+ r= rename(pb.buf, pbmain.buf);
+ if (r) PE("install new database .tmp as .main (finalising creation)");
+
+ rc= TCL_OK;
+
+ x_rc:
+ if (f) fclose(f);
+ maybe_close(lock_fd);
+ pathbuf_free(&pb);
+ pathbuf_free(&pbmain);
+ return rc;
+}
+
+/*---------- Info callbacks ----------*/
+
+static int infocbv3(Tcl_Interp *ip, Rw *rw, const char *arg1,
+ const char *arg2fmt, const char *arg3, va_list al) {
+ Tcl_Obj *aa[3];
+ int na;
+ char buf[200];
+ vsnprintf(buf, sizeof(buf), arg2fmt, al);
+
+ na= 0;
+ aa[na++]= cht_ret_string(ip, arg1);
+ aa[na++]= cht_ret_string(ip, buf);
+ if (arg3) aa[na++]= cht_ret_string(ip, arg3);
+
+ return cht_scriptinv_invoke_fg(&rw->on_info, na, aa);
+}
+
+static int infocb3(Tcl_Interp *ip, Rw *rw, const char *arg1,
+ const char *arg2fmt, const char *arg3, ...) {
+ int rc;
+ va_list al;
+ va_start(al, arg3);
+ rc= infocbv3(ip,rw,arg1,arg2fmt,arg3,al);
+ va_end(al);
+ return rc;
+}
+
+static int infocb(Tcl_Interp *ip, Rw *rw, const char *arg1,
+ const char *arg2fmt, ...) {
+ int rc;
+ va_list al;
+ va_start(al, arg2fmt);
+ rc= infocbv3(ip,rw,arg1,arg2fmt,0,al);
+ va_end(al);
+ return rc;
+}
+
+/*---------- Opening ----------*/
+
+static int cdbinit(Tcl_Interp *ip, Rw *rw) {
+ /* On entry, cdb_fd >=0 but cdb is _undefined_
+ * On exit, either cdb_fd<0 or cdb is initialised */
+ int r, rc;
+
+ r= cdb_init(&rw->cdb, rw->cdb_fd);
+ if (r) {
+ rc= cht_posixerr(ip, errno, "failed to initialise cdb reader");
+ close(rw->cdb_fd); rw->cdb_fd= -1; return rc;
+ }
+ return TCL_OK;
+}
+
+int cht_do_cdbwr_open(ClientData cd, Tcl_Interp *ip, const char *pathb,
+ Tcl_Obj *on_info, Tcl_Obj *on_lexminval,
+ void **result) {
+ const Cdbwr_SubCommand *subcmd= cd;
+ int r, rc, mainfd=-1;
+ Rw *rw;
+ struct stat stab;
+ off_t logrecstart, logjunkpos;
+
+ rw= TALLOC(sizeof(*rw));
+ rw->ix= -1;
+ ht_setup(&rw->logincore);
+ cht_scriptinv_init(&rw->on_info);
+ cht_scriptinv_init(&rw->on_lexminval);
+ rw->cdb_fd= rw->lock_fd= -1; rw->logfile= 0;
+ pathbuf_init(&rw->pbsome, pathb);
+ pathbuf_init(&rw->pbother, pathb);
+ rw->autocompact= 1;
+
+ rc= cht_scriptinv_set(&rw->on_info, ip, on_info, 0);
+ if (rc) goto x_rc;
+
+ rc= cht_scriptinv_set(&rw->on_lexminval, ip, on_lexminval, 0);
+ if (rc) goto x_rc;
+
+ mainfd= open(pathbuf_sfx(&rw->pbsome,".main"), O_RDONLY);
+ if (mainfd<0) PE("open existing database file .main");
+ rc= acquire_lock(ip, &rw->pbsome, &rw->lock_fd); if (rc) goto x_rc;
+
+ r= fstat(mainfd, &stab); if (r) PE("fstat .main");
+ rw->mainsz= stab.st_size;
+
+ rw->cdb_fd= open(pathbuf_sfx(&rw->pbsome,".cdb"), O_RDONLY);
+ if (rw->cdb_fd >=0) {
+ rc= cdbinit(ip, rw); if (rc) goto x_rc;
+ } else if (errno == ENOENT) {
+ if (rw->mainsz > 1) {
+ rc= cht_staticerr(ip, ".cdb does not exist but .main is >1byte -"
+ " .cdb must have been accidentally deleted!",
+ "CDB CDBMISSING");
+ goto x_rc;
+ }
+ /* fine */
+ } else {
+ PE("open .cdb");
+ }
+
+ rw->logfile= fopen(pathbuf_sfx(&rw->pbsome,".jrn"), "r+");
+ if (!rw->logfile) {
+ if (errno != ENOENT) PE("failed to open .jrn during open");
+ rw->logfile= fopen(rw->pbsome.buf, "w");
+ if (!rw->logfile) PE("create .jrn during (clean) open");
+ } else { /* rw->logfile */
+ r= fstat(fileno(rw->logfile), &stab);
+ if (r==-1) PE("fstat .jrn during open");
+ rc= infocb(ip, rw, "open-dirty-start", "log=%luby",
+ (unsigned long)stab.st_size);
+ if (rc) goto x_rc;
+
+ for (;;) {
+ logrecstart= ftello(rw->logfile);
+ if (logrecstart < 0) PE("ftello .jrn during (dirty) open");
+ r= readstorelogrecord(rw->logfile, &rw->logincore, 0,0, ht_update);
+ if (ferror(rw->logfile)) {
+ rc= cht_posixerr(ip, errno, "error reading .jrn during (dirty) open");
+ goto x_rc;
+ }
+ if (r==-1) {
+ break;
+ } else if (r==-2 || r==-3) {
+ char buf[100];
+ logjunkpos= ftello(rw->logfile);
+ if(logjunkpos<0) PE("ftello .jrn during report of junk in dirty open");
+
+ snprintf(buf,sizeof(buf), "CDB SYNTAX LOG %lu %lu",
+ (unsigned long)logjunkpos, (unsigned long)logrecstart);
+
+ if (!(subcmd->flags & RWSCF_OKJUNK)) {
+ Tcl_SetObjErrorCode(ip, Tcl_NewStringObj(buf,-1));
+ snprintf(buf,sizeof(buf),"%lu",(unsigned long)logjunkpos);
+ Tcl_ResetResult(ip);
+ Tcl_AppendResult(ip, "syntax error (junk) in .jrn during"
+ " (dirty) open, at file position ", buf, (char*)0);
+ rc= TCL_ERROR;
+ goto x_rc;
+ }
+ rc= infocb3(ip, rw, "open-dirty-junk", "errorfpos=%luby", buf,
+ (unsigned long)logjunkpos);
+ if (rc) goto x_rc;
+
+ r= fseeko(rw->logfile, logrecstart, SEEK_SET);
+ if (r) PE("failed to fseeko .jrn before junk during dirty open");
+
+ r= ftruncate(fileno(rw->logfile), logrecstart);
+ if (r) PE("ftruncate .jrn to chop junk during dirty open");
+ } else {
+ assert(!r);
+ }
+ }
+ }
+ /* now log is positioned for appending and everything is read */
+
+ *result= rw;
+ maybe_close(mainfd);
+ return TCL_OK;
+
+ x_rc:
+ rw_close(0,rw);
+ TFREE(rw);
+ maybe_close(mainfd);
+ return rc;
+}
+
+int cht_do_cdbwr_open_okjunk(ClientData cd, Tcl_Interp *ip, const char *pathb,
+ Tcl_Obj *on_info, Tcl_Obj *on_lexminval,
+ void **result) {
+ return cht_do_cdbwr_open(cd,ip,pathb,on_info,on_lexminval,result);
+}
+
+/*==================== COMPACTION ====================*/
+
+struct ht_forall_ctx {
+ struct cdb_make cdbm;
+ FILE *mainfile;
+ long *reccount;
+ int lexminvall;
+ const char *lexminval; /* may be invalid if lexminvall <= 0 */
+};
+
+/*---------- helper functions ----------*/
+
+static int expiredp(const HashValue *val, struct ht_forall_ctx *a) {
+ int r, l;
+ if (!val->len || a->lexminvall<=0) return 0;
+ l= val->len < a->lexminvall ? val->len : a->lexminvall;
+ r= memcmp(val->data, a->lexminval, l);
+ if (r>0) return 0;
+ if (r<0) return 1;
+ return val->len < a->lexminvall;
+}
+
+static int delete_ifexpired(const char *key, HashValue *val,
+ struct ht_forall_ctx *a) {
+ if (!expiredp(val, a)) return 0;
+ val->len= 0;
+ /* we don't actually need to realloc it to free the memory because
+ * this will shortly all be deleted as part of the compaction */
+ return 0;
+}
+
+static int addto_cdb(const char *key, HashValue *val,
+ struct ht_forall_ctx *a) {
+ return cdb_make_add(&a->cdbm, key, strlen(key), val->data, val->len);
+}
+
+static int addto_main(const char *key, HashValue *val,
+ struct ht_forall_ctx *a) {
+ (*a->reccount)++;
+ return writerecord(a->mainfile, key, val);
+}
+
+/*---------- compact main entrypoint ----------*/
+
+static int compact_core(Tcl_Interp *ip, Rw *rw, unsigned long logsz,
+ long *reccount_r) {
+ /* creates new .cdb and .main
+ * closes logfile
+ * leaves .jrn with old data
+ * leaves cdb fd open onto old db
+ * leaves logincore full of crap
+ */
+ int r, rc;
+ int cdbfd, cdbmaking;
+ off_t errpos, newmainsz;
+ char buf[100];
+ Tcl_Obj *res;
+ struct ht_forall_ctx a;
+
+ a.mainfile= 0;
+ cdbfd= -1;
+ cdbmaking= 0;
+ *reccount_r= 0;
+ a.reccount= reccount_r;
+
+ r= fclose(rw->logfile);
+ rw->logfile= 0;
+ if (r) { rc= cht_posixerr(ip, errno, "probable data loss! failed to fclose"
+ " logfile during compact"); goto x_rc; }
+
+ rc= infocb(ip, rw, "compact-start", "log=%luby main=%luby",
+ logsz, (unsigned long)rw->mainsz);
+ if (rc) goto x_rc;
+
+ if (cht_scriptinv_interp(&rw->on_lexminval)) {
+ rc= cht_scriptinv_invoke_fg(&rw->on_lexminval, 0,0);
+ if (rc) goto x_rc;
+
+ res= Tcl_GetObjResult(ip); assert(res);
+ a.lexminval= Tcl_GetStringFromObj(res, &a.lexminvall);
+ assert(a.lexminval);
+
+ /* we rely not calling Tcl_Eval during the actual compaction;
+ * if we did Tcl_Eval then the interp result would be trashed.
+ */
+ rc= ht_forall(&rw->logincore, delete_ifexpired, &a);
+
+ } else {
+ a.lexminvall= 0;
+ }
+
+ /* merge unsuperseded records from main into hash table */
+
+ a.mainfile= fopen(pathbuf_sfx(&rw->pbsome,".main"), "r");
+ if (!a.mainfile) PE("failed to open .main for reading during compact");
+
+ for (;;) {
+ r= readstorelogrecord(a.mainfile, &rw->logincore,
+ expiredp, &a,
+ ht_maybeupdate);
+ if (ferror(a.mainfile)) { rc= cht_posixerr(ip, errno, "error reading"
+ " .main during compact"); goto x_rc; }
+ if (r==-3) {
+ break;
+ } else if (r==-1 || r==-2) {
+ errpos= ftello(a.mainfile);
+ if (errpos<0) PE("ftello .main during report of syntax error");
+ snprintf(buf,sizeof(buf), "CDB %s MAIN %lu",
+ r==-1 ? "TRUNCATED" : "SYNTAX", (unsigned long)errpos);
+ Tcl_SetObjErrorCode(ip, Tcl_NewStringObj(buf,-1));
+ snprintf(buf,sizeof(buf), "%lu", (unsigned long)errpos);
+ Tcl_ResetResult(ip);
+ Tcl_AppendResult(ip,
+ r==-1 ? "unexpected eof (truncated file)"
+ " in .main during compact, at file position "
+ : "syntax error"
+ " in .main during compact, at file position ",
+ buf, (char*)0);
+ rc= TCL_ERROR;
+ goto x_rc;
+ } else {
+ assert(!rc);
+ }
+ }
+ fclose(a.mainfile);
+ a.mainfile= 0;
+
+ /* create new cdb */
+
+ cdbfd= open(pathbuf_sfx(&rw->pbsome,".tmp"), O_WRONLY|O_CREAT|O_TRUNC, 0666);
+ if (cdbfd<0) PE("create .tmp for new cdb during compact");
+
+ r= cdb_make_start(&a.cdbm, cdbfd);
+ if (r) PE("cdb_make_start during compact");
+ cdbmaking= 1;
+
+ r= ht_forall(&rw->logincore, addto_cdb, &a);
+ if (r) PE("cdb_make_add during compact");
+
+ r= cdb_make_finish(&a.cdbm);
+ if(r) PE("cdb_make_finish during compact");
+ cdbmaking= 0;
+
+ r= fdatasync(cdbfd); if (r) PE("fdatasync new cdb during compact");
+ r= close(cdbfd); if (r) PE("close new cdb during compact");
+ cdbfd= -1;
+
+ r= rename(rw->pbsome.buf, pathbuf_sfx(&rw->pbother,".cdb"));
+ if (r) PE("install new .cdb during compact");
+
+ /* create new main */
+
+ a.mainfile= fopen(pathbuf_sfx(&rw->pbsome,".tmp"), "w");
+ if (!a.mainfile) PE("create .tmp for new main during compact");
+
+ r= ht_forall(&rw->logincore, addto_main, &a);
+ if (r) { rc= cht_posixerr(ip, errno, "error writing to new .main"
+ " during compact"); goto x_rc; }
+
+ r= putc('\n', a.mainfile);
+ if (r==EOF) PE("write trailing \n to main during compact");
+
+ r= fflush(a.mainfile); if (r) PE("fflush new main during compact");
+ r= fdatasync(fileno(a.mainfile));
+ if (r) PE("fdatasync new main during compact");
+
+ newmainsz= ftello(a.mainfile);
+ if (newmainsz<0) PE("ftello new main during compact");
+
+ r= fclose(a.mainfile); if (r) PE("fclose new main during compact");
+ a.mainfile= 0;
+
+ r= rename(rw->pbsome.buf, pathbuf_sfx(&rw->pbother,".main"));
+ if (r) PE("install new .main during compact");
+
+ rw->mainsz= newmainsz;
+
+ /* done! */
+
+ rc= infocb(ip, rw, "compact-end", "main=%luby nrecs=%ld",
+ (unsigned long)rw->mainsz, *a.reccount);
+ if (rc) goto x_rc;
+
+ return rc;
+
+x_rc:
+ if (a.mainfile) fclose(a.mainfile);
+ if (cdbmaking) cdb_make_finish(&a.cdbm);
+ maybe_close(cdbfd);
+ remove(pathbuf_sfx(&rw->pbsome,".tmp")); /* for tidyness */
+ return rc;
+}
+
+/*---------- Closing ----------*/
+
+static int compact_forclose(Tcl_Interp *ip, Rw *rw, long *reccount_r) {
+ off_t logsz;
+ int r, rc;
+
+ logsz= ftello(rw->logfile);
+ if (logsz < 0) PE("ftello logfile (during tidy close)");
+
+ rc= compact_core(ip, rw, logsz, reccount_r); if (rc) goto x_rc;
+
+ r= remove(pathbuf_sfx(&rw->pbsome,".jrn"));
+ if (r) PE("remove .jrn (during tidy close)");
+
+ return TCL_OK;
+
+x_rc: return rc;
+}
+
+int cht_do_cdbwr_close(ClientData cd, Tcl_Interp *ip, void *rw_v) {
+ Rw *rw= rw_v;
+ int rc, rc_close;
+ long reccount= -1;
+ off_t logsz;
+
+ if (rw->autocompact) rc= compact_forclose(ip, rw, &reccount);
+ else rc= TCL_OK;
+
+ if (!rc) {
+ if (rw->logfile) {
+ logsz= ftello(rw->logfile);
+ if (logsz < 0)
+ rc= cht_posixerr(ip, errno, "ftell logfile during close info");
+ else
+ rc= infocb(ip, rw, "close", "main=%luby log=%luby",
+ rw->mainsz, logsz);
+ } else if (reccount>=0) {
+ rc= infocb(ip, rw, "close", "main=%luby nrecs=%ld",
+ rw->mainsz, reccount);
+ } else {
+ rc= infocb(ip, rw, "close", "main=%luby", rw->mainsz);
+ }
+ }
+ rc_close= rw_close(ip,rw);
+ if (rc_close) rc= rc_close;
+
+ cht_tabledataid_disposing(ip, rw_v, &cdbtcl_rwdatabases);
+ TFREE(rw);
+ return rc;
+}
+
+/*---------- Other compaction-related entrypoints ----------*/
+
+static int compact_keepopen(Tcl_Interp *ip, Rw *rw, int force) {
+ off_t logsz;
+ long reccount;
+ int rc, r;
+
+ logsz= ftello(rw->logfile);
+ if (logsz < 0) return cht_posixerr(ip, errno, "ftell .jrn"
+ " during compact check or force");
+
+ if (!force && logsz < rw->mainsz / 3 + 1000) return TCL_OK;
+ /* Test case: ^^^ testing best value for this
+ * main=9690434by nrecs=122803 read all in one go
+ * no autocompact, : 6.96user 0.68system 0:08.93elapsed
+ * auto, mulitplier 2: 7.10user 0.79system 0:09.54elapsed
+ * auto, unity: 7.80user 0.98system 0:11.84elapsed
+ * auto, divisor 2: 8.23user 1.05system 0:13.30elapsed
+ * auto, divisor 3: 8.55user 1.12system 0:12.88elapsed
+ * auto, divisor 5: 9.95user 1.43system 0:15.72elapsed
+ */
+
+ rc= compact_core(ip, rw, logsz, &reccount); if (rc) goto x_rc;
+
+ rw_cdb_close(ip,rw);
+ ht_destroy(&rw->logincore);
+ ht_setup(&rw->logincore);
+
+ rw->cdb_fd= open(pathbuf_sfx(&rw->pbsome,".cdb"), O_RDONLY);
+ if (rw->cdb_fd < 0) PE("reopen .cdb after compact");
+
+ rc= cdbinit(ip, rw); if (rc) goto x_rc;
+
+ rw->logfile= fopen(pathbuf_sfx(&rw->pbsome,".jrn"), "w");
+ if (!rw->logfile) PE("reopen .jrn after compact");
+
+ r= fsync(fileno(rw->logfile)); if (r) PE("fsync .jrn after compact reopen");
+
+ return TCL_OK;
+
+x_rc:
+ /* doom! all updates fail after this (because rw->logfile is 0), and
+ * we may be using a lot more RAM than would be ideal. Program will
+ * have to reopen if it really wants sanity. */
+ return rc;
+}
+
+int cht_do_cdbwr_compact_force(ClientData cd, Tcl_Interp *ip, void *rw_v) {
+ return compact_keepopen(ip, rw_v, 1);
+}
+int cht_do_cdbwr_compact_check(ClientData cd, Tcl_Interp *ip, void *rw_v) {
+ return compact_keepopen(ip, rw_v, 0);
+}
+
+int cht_do_cdbwr_compact_explicit(ClientData cd, Tcl_Interp *ip, void *rw_v) {
+ Rw *rw= rw_v;
+ rw->autocompact= 0;
+ return TCL_OK;
+}
+int cht_do_cdbwr_compact_auto(ClientData cd, Tcl_Interp *ip, void *rw_v) {
+ Rw *rw= rw_v;
+ rw->autocompact= 1;
+ return TCL_OK;
+}
+
+/*---------- Updateing ----------*/
+
+static int update(Tcl_Interp *ip, Rw *rw, const char *key,
+ const Byte *data, int dlen) {
+ HashValue *val;
+ const char *failed;
+ int rc, r;
+ off_t recstart;
+
+ if (strlen(key) >= KEYLEN_MAX)
+ return cht_staticerr(ip, "key too long", "CDB KEYOVERFLOW");
+
+ if (!rw->logfile) return cht_staticerr
+ (ip, "failure during previous compact or error recovery;"
+ " cdbwr must be closed and reopened before any further updates",
+ "CDB BROKEN");
+
+ recstart= ftello(rw->logfile);
+ if (recstart < 0)
+ return cht_posixerr(ip, errno, "failed to ftello .jrn during update");
+
+ val= htv_prep(dlen); assert(val);
+ memcpy(htv_fillptr(val), data, dlen);
+
+ r= writerecord(rw->logfile, key, val);
+ if (!r) r= fflush(rw->logfile);
+ if (r) PE("write update to logfile");
+
+ ht_update(&rw->logincore, key, val);
+
+ if (!rw->autocompact) return TCL_OK;
+ return compact_keepopen(ip, rw, 0);
+
+ x_rc:
+ TFREE(val);
+ assert(rc);
+
+ /* Now, we have to try to sort out the journal so that it's
+ * truncated and positioned to where this abortively-written record
+ * started, with no buffered output and the error indicator clear.
+ *
+ * There seems to be no portable way to ensure the buffered unwritten
+ * output is discarded, so we close and reopen the stream.
+ */
+ fclose(rw->logfile);
+
+ rw->logfile= fopen(pathbuf_sfx(&rw->pbsome,".jrn"), "r+");
+ if (!rw->logfile) { failed= "fopen"; goto reset_fail; }
+
+ r= ftruncate(fileno(rw->logfile), recstart);
+ if (r) { failed= "ftruncate"; goto reset_fail; }
+
+ r= fseeko(rw->logfile, recstart, SEEK_SET);
+ if (r) { failed= "fseeko"; goto reset_fail; }
+
+ return rc;
+
+ reset_fail:
+ Tcl_AppendResult(ip, " (additionally, ", failed, " failed"
+ " in error recovery: ", strerror(errno), ")", (char*)0);
+ if (rw->logfile) { fclose(rw->logfile); rw->logfile= 0; }
+
+ return rc;
+}
+
+int cht_do_cdbwr_update(ClientData cd, Tcl_Interp *ip,
+ void *rw_v, const char *key, Tcl_Obj *value) {
+ int dlen;
+ const char *data;
+ data= Tcl_GetStringFromObj(value, &dlen); assert(data);
+ return update(ip, rw_v, key, data, dlen);
+}
+
+int cht_do_cdbwr_update_hb(ClientData cd, Tcl_Interp *ip,
+ void *rw_v, const char *key, HBytes_Value value) {
+ return update(ip, rw_v, key, cht_hb_data(&value), cht_hb_len(&value));
+}
+
+int cht_do_cdbwr_delete(ClientData cd, Tcl_Interp *ip, void *rw_v,
+ const char *key) {
+ return update(ip, rw_v, key, 0, 0);
+}
+
+/*---------- Lookups ----------*/
+
+static int lookup_rw(Tcl_Interp *ip, void *rw_v, const char *key,
+ const Byte **data_r, int *len_r /* -1 => notfound */) {
+ Rw *rw= rw_v;
+ const HashValue *val;
+
+ val= ht_lookup(&rw->logincore, key);
+ if (val) {
+ if (val->len) { *data_r= val->data; *len_r= val->len; return TCL_OK; }
+ else goto not_found;
+ }
+
+ if (rw->cdb_fd<0) goto not_found;
+
+ return cht_cdb_lookup_cdb(ip, &rw->cdb, key, strlen(key), data_r, len_r);
+
+ not_found:
+ *data_r= 0;
+ *len_r= -1;
+ return TCL_OK;
+}
+
+int cht_do_cdbwr_lookup(ClientData cd, Tcl_Interp *ip, void *rw_v,
+ const char *key, Tcl_Obj *def,
+ Tcl_Obj **result) {
+ const Byte *data;
+ int dlen, r;
+
+ r= lookup_rw(ip, rw_v, key, &data, &dlen); if (r) return r;
+ return cht_cdb_donesomelookup(ip, rw_v, def, result, data, dlen,
+ cht_cdb_storeanswer_string);
+}
+
+int cht_do_cdbwr_lookup_hb(ClientData cd, Tcl_Interp *ip, void *rw_v,
+ const char *key, Tcl_Obj *def,
+ Tcl_Obj **result) {
+ const Byte *data;
+ int dlen, r;
+
+ r= lookup_rw(ip, rw_v, key, &data, &dlen); if (r) return r;
+ return cht_cdb_donesomelookup(ip, rw_v, def, result, data, dlen,
+ cht_cdb_storeanswer_hb);
+}
--- /dev/null
+# crypto - Tcl bindings for parts of the `nettle' crypto library
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+BASE_DIR = ../base
+EXTBASE = crypto
+CFILES = algtables bcmode crypto hook hash
+OTHER_TCTS = ../hbytes/hbytes-base.tct
+OTHER_EXTS = hbytes/hbytes
+LDLIBS += -lnettle
+
+include ../base/extension.make
+
--- /dev/null
+/*
+ * crypto - Tcl bindings for parts of the `nettle' crypto library
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+
+#include "chiark_tcl_crypto.h"
+
+#include <nettle/md5.h>
+#include <nettle/sha.h>
+#include <nettle/serpent.h>
+#include <nettle/twofish.h>
+#include <nettle/aes.h>
+#include <nettle/blowfish.h>
+
+#define NETTLE_BLOCKCIPHERS \
+ DO(serpent, SERPENT) \
+ DO(twofish, TWOFISH) \
+/* DO(aes, AES) */ \
+ DO(blowfish, BLOWFISH) \
+ /* ALIAS(rijndael, aes, AES)*/
+
+#define ALIAS(alias,name,NAME)
+#define DO(name,NAME) \
+ static void alg_##name##_makekey(void *sch, const void *key, int keylen) { \
+ name##_set_key(sch, keylen, key); \
+ } \
+ static void alg_##name##_encr(const void *sch, const void *in, void *out) { \
+ name##_encrypt((void*)sch, NAME##_BLOCK_SIZE, out, in); \
+ } \
+ static void alg_##name##_decr(const void *sch, const void *in, void *out) { \
+ name##_decrypt((void*)sch, NAME##_BLOCK_SIZE, out, in); \
+ }
+ NETTLE_BLOCKCIPHERS
+#undef DO
+#undef ALIAS
+
+const BlockCipherAlgInfo cht_blockcipheralginfo_entries[]= {
+#define ALIAS(alias,name,NAME) \
+ { #alias, NAME##_BLOCK_SIZE, sizeof(struct name##_ctx), \
+ NAME##_MIN_KEY_SIZE, NAME##_MAX_KEY_SIZE, \
+ { alg_##name##_makekey, alg_##name##_encr }, \
+ { alg_##name##_makekey, alg_##name##_decr } \
+ },
+#define DO(name,NAME) ALIAS(name,name,NAME)
+ NETTLE_BLOCKCIPHERS
+#undef DO
+#undef ALIAS
+ { 0 }
+};
+
+const BlockCipherPropInfo cht_blockcipherpropinfo_entries[]= {
+ { "blocklen", offsetof(BlockCipherAlgInfo, blocksize) },
+ { "minkeylen", offsetof(BlockCipherAlgInfo, key_min) },
+ { "maxkeylen", offsetof(BlockCipherAlgInfo, key_max) },
+ { 0 }
+};
+
+#define NETTLE_DIGESTS \
+ DO(sha1, SHA1) \
+ DO(sha256, SHA256) \
+ DO(md5, MD5)
+
+#define DO(name,NAME) \
+ static void alg_##name##_init(void *state) { \
+ name##_init(state); \
+ } \
+ static void alg_##name##_update(void *state, const void *data, int len) { \
+ name##_update(state, len, data); \
+ } \
+ static void alg_##name##_final(void *state, void *digest) { \
+ name##_digest(state,NAME##_DIGEST_SIZE,digest); \
+ } \
+ static void alg_##name##_oneshot(void *digest, const void *data, int len) { \
+ struct name##_ctx ctx; \
+ name##_init(&ctx); \
+ name##_update(&ctx, len, data); \
+ name##_digest(&ctx,NAME##_DIGEST_SIZE,digest); \
+ }
+ NETTLE_DIGESTS
+#undef DO
+
+const HashAlgPropInfo cht_hashalgpropinfo_entries[]= {
+ { "hashlen", offsetof(HashAlgInfo, hashsize) },
+ { "blocklen", offsetof(HashAlgInfo, blocksize) },
+ { 0 }
+};
+
+const HashAlgInfo cht_hashalginfo_entries[]= {
+#define DO(name,NAME) \
+ { #name, NAME##_DIGEST_SIZE, NAME##_DATA_SIZE, sizeof(struct name##_ctx), \
+ alg_##name##_init, alg_##name##_update, alg_##name##_final, \
+ alg_##name##_oneshot },
+ NETTLE_DIGESTS
+#undef DO
+ { 0 }
+};
--- /dev/null
+/*
+ * crypto - Tcl bindings for parts of the `nettle' crypto library
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+
+#include "chiark_tcl_crypto.h"
+
+static const char *mode_cbc_encrypt(Byte *data, int blocks,
+ const Byte *iv, Byte *chain,
+ const BlockCipherAlgInfo *alg, int encr,
+ const void *sch) {
+ int blocksize= alg->blocksize;
+ memcpy(chain,iv,blocksize);
+
+ while (blocks > 0) {
+ memxor(data, chain, blocksize);
+ alg->encrypt.crypt(sch, data, data);
+ memcpy(chain, data, blocksize);
+
+ blocks--; data += blocksize;
+ }
+ return 0;
+}
+
+static const char *mode_cbc_decrypt(Byte *data, int blocks,
+ const Byte *iv, Byte *chain,
+ const BlockCipherAlgInfo *alg, int encr,
+ const void *sch) {
+ int blocksize= alg->blocksize;
+ int cchain= 0;
+
+ memcpy(chain,iv,blocksize);
+
+ while (blocks > 0) {
+ memcpy(chain + (cchain^blocksize), data, blocksize);
+ alg->decrypt.crypt(sch, data, data);
+ memxor(data, chain + cchain, blocksize);
+ cchain ^= blocksize;
+
+ blocks--; data += blocksize;
+ }
+ return 0;
+}
+
+static void cbcmac_core(const Byte *data, int blocks,
+ const Byte *iv, Byte *buf,
+ const BlockCipherAlgInfo *alg,
+ const void *sch) {
+ int blocksize= alg->blocksize;
+
+ memcpy(buf,iv,blocksize);
+
+ while (blocks > 0) {
+ memcpy(buf + blocksize, data, blocksize);
+ memxor(buf, buf + blocksize, blocksize);
+
+ alg->encrypt.crypt(sch, buf, buf);
+
+ blocks--; data += blocksize;
+ }
+}
+
+static const char *mode_cbc_mac(const Byte *data, int blocks,
+ const Byte *iv, Byte *buf,
+ const BlockCipherAlgInfo *alg,
+ const void *sch) {
+ cbcmac_core(data,blocks,iv,buf,alg,sch);
+ return 0;
+}
+
+static const char *mode_cbc_mac2(const Byte *data, int blocks,
+ const Byte *iv, Byte *buf,
+ const BlockCipherAlgInfo *alg,
+ const void *sch) {
+ cbcmac_core(data,blocks,iv,buf,alg,sch);
+ alg->encrypt.crypt(sch, buf, buf);
+ return 0;
+}
+
+static const char *mode_ecb(Byte *data, int blocks,
+ const Byte *iv, Byte *chain,
+ const BlockCipherAlgInfo *alg, int encr,
+ const void *sch) {
+ int blocksize= alg->blocksize;
+
+ while (blocks > 0) {
+ (encr ? &alg->encrypt : &alg->decrypt)->crypt(sch, data, data);
+ blocks--; data += blocksize;
+ }
+ return 0;
+}
+
+static const char *mode_ctr(Byte *data, int blocks,
+ const Byte *iv, Byte *counter,
+ const BlockCipherAlgInfo *alg, int encr,
+ const void *sch) {
+ int blocksize= alg->blocksize;
+ Byte *cipher= counter + blocksize;
+ int byte;
+
+ memcpy(counter, iv, blocksize);
+ while (blocks > 0) {
+ alg->encrypt.crypt(sch, counter, cipher);
+ memxor(data, cipher, blocksize);
+ for (byte=blocksize-1; byte>=0; byte--) {
+ if (++counter[byte]) break;
+ /* new value of zero implies carry, so increment next byte */
+ }
+ blocks--;
+ data += blocksize;
+ }
+ return 0;
+}
+
+const BlockCipherModeInfo cht_blockciphermodeinfo_entries[]= {
+ { "cbc", 1, 2, 1, mode_cbc_encrypt, mode_cbc_decrypt, mode_cbc_mac },
+ { "cbc-mac2", 1, 2, 1, 0, 0, mode_cbc_mac2 },
+ { "ecb", 0, 0, 0, mode_ecb, mode_ecb, 0 },
+ { "ctr-sif", 1, 2, 0, mode_ctr, mode_ctr, 0 },
+ { 0 }
+};
--- /dev/null
+/*
+ * crypto - Tcl bindings for parts of the `nettle' crypto library
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+
+#include <stdint.h>
+#include <stddef.h>
+#include <netinet/in.h>
+
+#include <endian.h>
+
+#include "hbytes.h"
+#include "crypto.h"
+#include "crypto+tcmdif.h"
--- /dev/null
+/*
+ * crypto - Tcl bindings for parts of the `nettle' crypto library
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+
+#include "chiark_tcl_crypto.h"
+
+const PadOp cht_padop_entries[]= {
+ { "un", 0, 0 },
+ { "ua", 0, 1 },
+ { "pn", 1, 0 },
+ { "pa", 1, 1 },
+ { 0 }
+};
+
+typedef struct {
+ HBytes_Value *hb;
+ int pad, blocksize; /* 0 or 1 */
+} PadMethodClientData;
+
+int cht_do_hbcrypto_pad(ClientData cd, Tcl_Interp *ip, const PadOp *op,
+ HBytes_Var v, Tcl_Obj *blocksz, const PadMethodInfo *meth,
+ int methargsc, Tcl_Obj *const *methargsv) {
+ PadMethodClientData pmcd;
+ int rc;
+
+ if (op->use_algname) {
+ const BlockCipherAlgInfo *alg;
+ alg= enum_lookup_cached(ip,blocksz, cht_blockcipheralginfo_entries,
+ "blockcipher alg for pad");
+ if (!alg) return TCL_ERROR;
+ pmcd.blocksize= alg->blocksize;
+ } else {
+ rc= Tcl_GetIntFromObj(ip, blocksz, &pmcd.blocksize); if (rc) return rc;
+ if (pmcd.blocksize < 1) cht_staticerr(ip, "block size must be at least 1", 0);
+ }
+
+ pmcd.hb= v.hb;
+ pmcd.pad= op->pad;
+
+ return meth->func(&pmcd,ip,methargsc,methargsv);
+}
+
+int cht_do_padmethodinfo_rfc2406(ClientData cd, Tcl_Interp *ip,
+ Tcl_Obj *nxthdr_arg, int *ok) {
+ const PadMethodClientData *pmcd= (const void*)cd;
+ int i, rc, padlen, old_len;
+
+ if (pmcd->blocksize > 256)
+ return cht_staticerr(ip, "block size too large for RFC2406 padding", 0);
+
+ if (pmcd->pad) {
+ Byte *padding;
+ HBytes_Value nxthdr;
+
+ rc= cht_pat_hb(ip,nxthdr_arg,&nxthdr);
+ if (rc) return rc;
+
+ if (cht_hb_len(&nxthdr) != 1) return
+ cht_staticerr(ip, "RFC2406 next header field must be exactly 1 byte", 0);
+ padlen= pmcd->blocksize-1 - ((cht_hb_len(pmcd->hb)+1) % pmcd->blocksize);
+ padding= cht_hb_append(pmcd->hb, padlen+2);
+ for (i=1; i<=padlen; i++)
+ *padding++ = i;
+ *padding++ = padlen;
+ *padding++ = cht_hb_data(&nxthdr)[0];
+ *ok= 1;
+
+ } else {
+ const Byte *padding, *trailer;
+ HBytes_Value nxthdr;
+ Tcl_Obj *nxthdr_valobj, *ro;
+
+ *ok= 0;
+ old_len= cht_hb_len(pmcd->hb); if (old_len % pmcd->blocksize) goto quit;
+ trailer= cht_hb_unappend(pmcd->hb, 2); if (!trailer) goto quit;
+
+ padlen= trailer[0];
+ cht_hb_array(&nxthdr,trailer+1,1);
+ nxthdr_valobj= cht_ret_hb(ip,nxthdr);
+ ro= Tcl_ObjSetVar2(ip,nxthdr_arg,0,nxthdr_valobj,TCL_LEAVE_ERR_MSG);
+ if (!ro) { Tcl_DecrRefCount(nxthdr_valobj); return TCL_ERROR; }
+
+ padding= cht_hb_unappend(pmcd->hb, padlen);
+ for (i=1; i<=padlen; i++)
+ if (*padding++ != i) goto quit;
+
+ *ok= 1;
+
+ quit:;
+
+ }
+
+ return TCL_OK;
+}
+
+int cht_do_padmethodinfo_pkcs5(ClientData cd, Tcl_Interp *ip, int *ok) {
+ const PadMethodClientData *pmcd= (const void*)cd;
+ int padlen, old_len, i;
+
+ if (pmcd->blocksize > 255)
+ return cht_staticerr(ip, "block size too large for pkcs#5", 0);
+
+ if (pmcd->pad) {
+
+ Byte *padding;
+
+ padlen= pmcd->blocksize - (cht_hb_len(pmcd->hb) % pmcd->blocksize);
+ padding= cht_hb_append(pmcd->hb, padlen);
+ memset(padding, padlen, padlen);
+
+ } else {
+
+ const Byte *padding;
+
+ old_len= cht_hb_len(pmcd->hb); if (old_len % pmcd->blocksize) goto bad;
+ padding= cht_hb_unappend(pmcd->hb, 1); if (!padding) goto bad;
+ padlen= *padding;
+ if (padlen < 1 || padlen > pmcd->blocksize) goto bad;
+ padding= cht_hb_unappend(pmcd->hb, padlen-1); if (!padding) goto bad;
+
+ for (i=0; i<padlen-1; i++, padding++) if (*padding != padlen) goto bad;
+
+ }
+
+ *ok= 1;
+ return TCL_OK;
+
+ bad:
+ *ok= 0;
+ return TCL_OK;
+}
+
+#define OBJ_CIPHKEY(o) ((CiphKeyValue*)(o)->internalRep.otherValuePtr)
+
+typedef struct {
+ int valuelen, bufferslen;
+ Byte *value, *buffers;
+ const void *alg;
+ void *alpha, *beta; /* key schedules etc.; each may be 0 */
+} CiphKeyValue;
+
+static void freealg(CiphKeyValue *key) {
+ TFREE(key->alpha);
+ TFREE(key->beta);
+}
+
+static void key_t_free(Tcl_Obj *obj) {
+ CiphKeyValue *key= OBJ_CIPHKEY(obj);
+ freealg(key);
+ TFREE(key->value);
+ TFREE(key->buffers);
+}
+
+static void noalg(CiphKeyValue *key) {
+ key->alg= 0;
+ key->alpha= key->beta= 0;
+}
+
+static void key_t_dup(Tcl_Obj *src_obj, Tcl_Obj *dup_obj) {
+ CiphKeyValue *src= OBJ_CIPHKEY(src_obj);
+ CiphKeyValue *dup= TALLOC(sizeof(*dup));
+ dup->valuelen= src->valuelen;
+ dup->value= src->valuelen ? TALLOC(src->valuelen) : 0;
+ dup->buffers= 0; dup->bufferslen= 0;
+ memcpy(dup->value, src->value, src->valuelen);
+ noalg(dup);
+ dup_obj->internalRep.otherValuePtr= dup;
+ dup_obj->typePtr= &cht_blockcipherkey_type;
+}
+
+static void key_t_ustr(Tcl_Obj *o) {
+ cht_obj_updatestr_array(o, OBJ_CIPHKEY(o)->value, OBJ_CIPHKEY(o)->valuelen);
+}
+
+static int key_t_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
+ int rc, l;
+ CiphKeyValue *val;
+
+ rc= Tcl_ConvertToType(ip,o,&cht_hbytes_type); if (rc) return rc;
+ val= TALLOC(sizeof(*val));
+ val->valuelen= l= cht_hb_len(OBJ_HBYTES(o));
+ val->value= TALLOC(l);
+ val->buffers= 0;
+ val->bufferslen= 0;
+ memcpy(val->value, cht_hb_data(OBJ_HBYTES(o)), l);
+ noalg(val);
+
+ cht_objfreeir(o);
+ o->internalRep.otherValuePtr= val;
+ o->typePtr= &cht_blockcipherkey_type;
+
+ return TCL_OK;
+}
+
+Tcl_ObjType cht_blockcipherkey_type = {
+ "blockcipher-key",
+ key_t_free, key_t_dup, key_t_ustr, key_t_sfa
+};
+
+static CiphKeyValue *get_key(Tcl_Interp *ip, Tcl_Obj *key_obj,
+ const void *alg, int want_bufferslen) {
+ CiphKeyValue *key;
+ int rc;
+
+ rc= Tcl_ConvertToType(ip,key_obj,&cht_blockcipherkey_type); if (rc) return 0;
+ key= OBJ_CIPHKEY(key_obj);
+
+ if (key->alg != alg) {
+ freealg(key);
+ noalg(key);
+ key->alg= alg;
+ }
+
+ if (key->bufferslen < want_bufferslen) {
+ TFREE(key->buffers);
+ key->buffers= TALLOC(want_bufferslen);
+ key->bufferslen= want_bufferslen;
+ }
+ return key;
+}
+
+int cht_do_hbcrypto_blockcipher(ClientData cd, Tcl_Interp *ip,
+ const BlockCipherOp *op,
+ int objc, Tcl_Obj *const *objv) {
+ return op->func((void*)op,ip,objc,objv);
+}
+
+static int blockcipher_prep(Tcl_Interp *ip, Tcl_Obj *key_obj,
+ const HBytes_Value *iv, int decrypt,
+ const BlockCipherAlgInfo *alg,
+ const BlockCipherModeInfo *mode, int data_len,
+ const CiphKeyValue **key_r, const void **sched_r,
+ const Byte **iv_r, int *iv_lenbytes_r,
+ Byte **buffers_r, int *nblocks_r) {
+ void *sched, **schedp;
+ int want_bufferslen, want_iv;
+ int rc;
+ CiphKeyValue *key;
+
+ if (data_len % alg->blocksize)
+ return cht_staticerr(ip, "block cipher input not whole number of blocks",
+ "HBYTES BLOCKCIPHER LENGTH");
+
+ want_bufferslen= alg->blocksize * (mode->buf_blocks + mode->iv_blocks);
+ key= get_key(ip, key_obj, alg, want_bufferslen); if (!key) return TCL_ERROR;
+
+ schedp= (alg->decrypt.make_schedule==alg->encrypt.make_schedule
+ || !decrypt) ? &key->alpha : &key->beta;
+ sched= *schedp;
+ if (!sched) {
+ if (key->valuelen < alg->key_min)
+ return cht_staticerr(ip, "key too short", "HBYTES BLOCKCIPHER PARAMS");
+ if (key->valuelen > alg->key_max)
+ return cht_staticerr(ip, "key too long", "HBYTES BLOCKCIPHER PARAMS");
+
+ sched= TALLOC(alg->schedule_size);
+ (decrypt ? &alg->decrypt : &alg->encrypt)->make_schedule
+ (sched, key->value, key->valuelen);
+ *schedp= sched;
+ }
+
+ want_iv= alg->blocksize * mode->iv_blocks;
+ if (!want_iv) {
+ if (!cht_hb_issentinel(iv))
+ return cht_staticerr(ip,"iv supplied but mode does not take one", 0);
+ } else if (cht_hb_issentinel(iv)) {
+ if (decrypt) return cht_staticerr(ip,"must supply iv when decrypting", 0);
+ rc= cht_get_urandom(ip, key->buffers, want_iv);
+ if (rc) return rc;
+ } else {
+ int iv_supplied= cht_hb_len(iv);
+ if (iv_supplied > want_iv)
+ return cht_staticerr(ip, "iv too large for algorithm and mode",
+ "HBYTES BLOCKCIPHER PARAMS");
+ memcpy(key->buffers, cht_hb_data(iv), iv_supplied);
+ memset(key->buffers + iv_supplied, 0, want_iv - iv_supplied);
+ }
+
+ *key_r= key;
+ *sched_r= sched;
+
+ *iv_r= key->buffers;
+ *iv_lenbytes_r= want_iv;
+
+ *buffers_r= key->buffers + want_iv;
+ *nblocks_r= data_len / alg->blocksize;
+
+ return TCL_OK;
+}
+
+int cht_do_blockcipherop_d(ClientData cd, Tcl_Interp *ip,
+ HBytes_Var v, const BlockCipherAlgInfo *alg,
+ Tcl_Obj *key_obj, const BlockCipherModeInfo *mode,
+ HBytes_Value iv, HBytes_Value *result) {
+ return cht_do_blockcipherop_e(cd,ip,v,alg,key_obj,mode,iv,result);
+}
+
+int cht_do_blockcipherop_e(ClientData cd, Tcl_Interp *ip,
+ HBytes_Var v, const BlockCipherAlgInfo *alg,
+ Tcl_Obj *key_obj, const BlockCipherModeInfo *mode,
+ HBytes_Value iv, HBytes_Value *result) {
+ const BlockCipherOp *op= (const void*)cd;
+ int encrypt= op->encrypt;
+ int rc, iv_lenbytes;
+ const CiphKeyValue *key;
+ const char *failure;
+ const Byte *ivbuf;
+ Byte *buffers;
+ const void *sched;
+ int nblocks;
+
+ if (!mode->encrypt)
+ return cht_staticerr(ip, "mode does not support encrypt/decrypt", 0);
+
+ rc= blockcipher_prep(ip,key_obj,&iv,!encrypt,
+ alg,mode, cht_hb_len(v.hb),
+ &key,&sched,
+ &ivbuf,&iv_lenbytes,
+ &buffers,&nblocks);
+ if (rc) return rc;
+
+ failure=
+ (encrypt ? mode->encrypt : mode->decrypt)
+ (cht_hb_data(v.hb), nblocks, ivbuf, buffers, alg, encrypt, sched);
+
+ if (failure)
+ return cht_staticerr(ip, failure, "HBYTES BLOCKCIPHER CRYPTFAIL CRYPT");
+
+ cht_hb_array(result, ivbuf, iv_lenbytes);
+
+ return TCL_OK;
+}
+
+int cht_do_blockcipherop_mac(ClientData cd, Tcl_Interp *ip,
+ HBytes_Value msg, const BlockCipherAlgInfo *alg,
+ Tcl_Obj *key_obj, const BlockCipherModeInfo *mode,
+ HBytes_Value iv, HBytes_Value *result) {
+ const CiphKeyValue *key;
+ const char *failure;
+ const Byte *ivbuf;
+ Byte *buffers;
+ const void *sched;
+ int nblocks, iv_lenbytes;
+ int rc;
+
+ if (!mode->mac)
+ return cht_staticerr(ip, "mode does not support mac generation", 0);
+
+ rc= blockcipher_prep(ip,key_obj,&iv,0,
+ alg,mode, cht_hb_len(&msg),
+ &key,&sched,
+ &ivbuf,&iv_lenbytes,
+ &buffers,&nblocks);
+ if (rc) return rc;
+
+ failure= mode->mac(cht_hb_data(&msg), nblocks, ivbuf, buffers, alg, sched);
+ if (failure)
+ return cht_staticerr(ip,failure, "HBYTES BLOCKCIPHER CRYPTFAIL MAC");
+
+ cht_hb_array(result, buffers, alg->blocksize * mode->mac_blocks);
+
+ return TCL_OK;
+}
+
+int cht_do_hbcrypto_hmac(ClientData cd, Tcl_Interp *ip, const HashAlgInfo *alg,
+ HBytes_Value message, Tcl_Obj *key_obj,
+ Tcl_Obj *maclen_obj, HBytes_Value *result) {
+ /* key->alpha = state after H(K XOR ipad <unfinished>
+ * key->beta = state after H(K XOR opad <unfinished>
+ * key->buffers = room for one block, or one state
+ */
+ CiphKeyValue *key;
+ Byte *dest;
+ int i, ml, rc;
+
+ if (maclen_obj) {
+ rc= Tcl_GetIntFromObj(ip, maclen_obj, &ml); if (rc) return rc;
+ if (ml<0 || ml>alg->hashsize)
+ return cht_staticerr(ip, "requested hmac output size out of range",
+ "HBYTES HMAC PARAMS");
+ } else {
+ ml= alg->hashsize;
+ }
+
+ key= get_key(ip, key_obj, alg,
+ alg->blocksize > alg->statesize
+ ? alg->blocksize : alg->statesize);
+
+ if (!key->alpha) {
+ assert(!key->beta);
+
+ if (key->valuelen > alg->blocksize)
+ return cht_staticerr(ip, "key to hmac longer than hash block size",
+ "HBYTES HMAC PARAMS");
+
+ memcpy(key->buffers, key->value, key->valuelen);
+ memset(key->buffers + key->valuelen, 0, alg->blocksize - key->valuelen);
+ for (i=0; i<alg->blocksize; i++) key->buffers[i] ^= 0x36;
+
+ key->alpha= TALLOC(alg->statesize);
+ alg->init(key->alpha);
+ alg->update(key->alpha, key->buffers, alg->blocksize);
+
+ key->beta= TALLOC(alg->statesize);
+ alg->init(key->beta);
+ for (i=0; i<alg->blocksize; i++) key->buffers[i] ^= (0x5c ^ 0x36);
+ alg->update(key->beta, key->buffers, alg->blocksize);
+ }
+ assert(key->beta);
+
+ dest= cht_hb_arrayspace(result, alg->hashsize);
+
+ memcpy(key->buffers, key->alpha, alg->statesize);
+ alg->update(key->buffers, cht_hb_data(&message), cht_hb_len(&message));
+ alg->final(key->buffers, dest);
+
+ memcpy(key->buffers, key->beta, alg->statesize);
+ alg->update(key->buffers, dest, alg->hashsize);
+ alg->final(key->buffers, dest);
+
+ cht_hb_unappend(result, alg->hashsize - ml);
+
+ return TCL_OK;
+}
+
+int cht_do_blockcipherop_prop(ClientData cd, Tcl_Interp *ip,
+ const BlockCipherPropInfo *prop,
+ const BlockCipherAlgInfo *alg, int *result) {
+ *result= *(const int*)((const char*)alg + prop->int_offset);
+ return TCL_OK;
+}
+
+int cht_do_hbcrypto_hash_prop(ClientData cd, Tcl_Interp *ip,
+ const HashAlgPropInfo *prop,
+ const HashAlgInfo *alg, int *result) {
+ *result= *(const int*)((const char*)alg + prop->int_offset);
+ return TCL_OK;
+}
--- /dev/null
+/*
+ * crypto - Tcl bindings for parts of the `nettle' crypto library
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+
+#ifndef CRYPTO_H
+#define CRYPTO_H
+
+#include "chiark-tcl.h"
+
+/* from crypto.c */
+
+void memxor(Byte *dest, const Byte *src, int l);
+
+typedef struct {
+ const char *name;
+ int pad, use_algname;
+} PadOp;
+
+extern Tcl_ObjType cht_blockcipherkey_type;
+
+/* from algtables.c */
+
+typedef struct {
+ const char *name;
+ int int_offset;
+} BlockCipherPropInfo, HashAlgPropInfo;
+
+typedef struct {
+ const char *name;
+ int hashsize, blocksize, statesize;
+ void (*init)(void *state);
+ void (*update)(void *state, const void *data, int len);
+ void (*final)(void *state, void *digest);
+ void (*oneshot)(void *digest, const void *data, int len);
+} HashAlgInfo;
+
+extern const HashAlgInfo cht_hashalginfo_entries[];
+
+typedef struct {
+ void (*make_schedule)(void *schedule, const void *key, int keylen);
+ void (*crypt)(const void *schedule, const void *in, void *out);
+ /* in and out may be the same, but if they aren't they may not overlap */
+ /* in and out for crypt will have been through block_byteswap */
+} BlockCipherPerDirectionInfo;
+
+typedef struct {
+ const char *name;
+ int blocksize, schedule_size, key_min, key_max;
+ BlockCipherPerDirectionInfo encrypt, decrypt;
+} BlockCipherAlgInfo;
+
+extern const BlockCipherAlgInfo cht_blockcipheralginfo_entries[];
+
+/* from bcmode.c */
+
+typedef struct {
+ const char *name;
+ int iv_blocks, buf_blocks, mac_blocks;
+
+ /* Each function is allowed to use up to buf_blocks * blocksize
+ * bytes of space in buf. data is blocks * blocksize bytes
+ * long. data should be modified in place by encrypt and decrypt;
+ * modes may not change the size of data. iv is always provided and
+ * is always of length iv_blocks * blocksize; encrypt and
+ * decrypt may modify the iv value (in which case the Tcl caller
+ * will get the modified IV) but this is not recommended. mac
+ * should leave the mac, which must be mac_blocks * blocksize
+ * bytes, in buf. (Therefore mac_blocks must be at least
+ * buf_blocks.)
+ */
+ const char *(*encrypt)(Byte *data, int nblocks,
+ const Byte *iv, Byte *buf,
+ const BlockCipherAlgInfo *alg, int encr,
+ const void *sch);
+ const char *(*decrypt)(Byte *data, int nblocks,
+ const Byte *iv, Byte *buf,
+ const BlockCipherAlgInfo *alg, int encr,
+ const void *sch);
+ const char *(*mac)(const Byte *data, int nblocks,
+ const Byte *iv, Byte *buf,
+ const BlockCipherAlgInfo *alg,
+ const void *sch);
+} BlockCipherModeInfo;
+
+extern const IdDataSpec cht_hash_states;
+extern const BlockCipherModeInfo cht_blockciphermodeinfo_entries[];
+
+#include "crypto+tcmdif.h"
+
+#endif /*CRYPTO_H*/
--- /dev/null
+# crypto - Tcl bindings for parts of the `nettle' crypto library
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+Table *hbcryptotoplevel TopLevel_Command
+ hbcrypto
+ dispatch(HBCrypto/_SubCommand, "hbcrypto subcommand")
+
+Table hbcrypto HBCrypto_SubCommand
+ pad
+ op enum(PadOp/, "hbcrypto pad subcommand")
+ v hbv
+ blocksz obj
+ meth enum(PadMethodInfo/, "pad method")
+ ... methargs
+ blockcipher
+ op enum(BlockCipherOp/, "op")
+ ... obj
+ hash
+ alg enum(HashAlgInfo/, "hash alg")
+ message hb
+ => hb
+ hash-init
+ alg enum(HashAlgInfo/, "hash alg")
+ => iddata(&cht_hash_states)
+ hash-update
+ stateh iddata(&cht_hash_states)
+ message hb
+ hash-final
+ stateh iddata(&cht_hash_states)
+ => hb
+ hash-discard
+ stateh iddata(&cht_hash_states)
+ hash-clonestate
+ stateh iddata(&cht_hash_states)
+ => iddata(&cht_hash_states)
+ hmac
+ alg enum(HashAlgInfo/, "hash alg for hmac")
+ message hb
+ key obj
+ ?maclen obj
+ => hb
+ hash-prop
+ prop enum(HashAlgPropInfo/, "prop")
+ alg enum(HashAlgInfo/, "alg")
+ => int
+
+Table padmethodinfo PadMethodInfo
+ pkcs5
+ => int
+ rfc2406
+ nxthdr obj
+ => int
+
+Table blockcipherop BlockCipherOp
+ e 1
+ v hbv
+ alg enum(BlockCipherAlgInfo/, "alg")
+ key obj
+ mode enum(BlockCipherModeInfo/, "mode")
+ ?iv hb
+ => hb
+ d 0
+ v hbv
+ alg enum(BlockCipherAlgInfo/, "alg")
+ key obj
+ mode enum(BlockCipherModeInfo/, "mode")
+ ?iv hb
+ => hb
+ mac -1
+ msg hb
+ alg enum(BlockCipherAlgInfo/, "alg")
+ key obj
+ mode enum(BlockCipherModeInfo/, "mode")
+ iv hb
+ => hb
+ prop -1
+ prop enum(BlockCipherPropInfo/, "prop")
+ alg enum(BlockCipherAlgInfo/, "alg")
+ => int
+
+EntryExtra BlockCipherOp
+ int encrypt;
--- /dev/null
+/*
+ * crypto - Tcl bindings for parts of the `nettle' crypto library
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+
+#include "chiark_tcl_crypto.h"
+
+typedef struct {
+ int ix;
+ const HashAlgInfo *alg;
+ Byte d[1];
+} HashState;
+
+int cht_do_hbcrypto_hash(ClientData cd, Tcl_Interp *ip, const HashAlgInfo *alg,
+ HBytes_Value message, HBytes_Value *result) {
+ Byte *dest;
+
+ dest= cht_hb_arrayspace(result,alg->hashsize);
+ alg->oneshot(dest, cht_hb_data(&message), cht_hb_len(&message));
+ return TCL_OK;
+}
+
+int cht_do_hbcrypto_hash_init(ClientData cd, Tcl_Interp *ip,
+ const HashAlgInfo *alg, void **state_r) {
+ HashState *state= TALLOC(sizeof(*state) + alg->statesize - 1);
+ state->ix= -1;
+ state->alg= alg;
+ alg->init(state->d);
+ *state_r= state;
+ return TCL_OK;
+}
+
+int cht_do_hbcrypto_hash_update(ClientData cd, Tcl_Interp *ip,
+ void *state_v, HBytes_Value data) {
+ HashState *state= state_v;
+ state->alg->update(&state->d, cht_hb_data(&data), cht_hb_len(&data));
+ return TCL_OK;
+}
+
+int cht_do_hbcrypto_hash_final(ClientData cd, Tcl_Interp *ip,
+ void *state_v, HBytes_Value *result) {
+ HashState *state= state_v;
+ Byte *digest;
+
+ digest= cht_hb_arrayspace(result,state->alg->hashsize);
+ state->alg->final(&state->d, digest);
+ return cht_do_hbcrypto_hash_discard(cd,ip,state_v);
+}
+
+int cht_do_hbcrypto_hash_discard(ClientData cd, Tcl_Interp *ip,
+ void *state_v) {
+ cht_tabledataid_disposing(ip,state_v,&cht_hash_states);
+ free(state_v);
+ return TCL_OK;
+}
+
+int cht_do_hbcrypto_hash_clonestate(ClientData cd, Tcl_Interp *ip,
+ void *old_v, void **new_r) {
+ HashState *old= old_v;
+ int len= sizeof(*old) + old->alg->statesize - 1;
+ void *new_v= TALLOC(len);
+ memcpy(new_v, old, len);
+ ((HashState*)new_v)->ix= -1;
+ *new_r= new_v;
+ return TCL_OK;
+}
+
+
+static void destroy_idtabcb(Tcl_Interp *ip, void *state_v) {
+ free(state_v);
+}
+
+const IdDataSpec cht_hash_states= {
+ "hashstate", "hashstate-table", destroy_idtabcb
+};
--- /dev/null
+/*
+ * crypto - Tcl bindings for parts of the `nettle' crypto library
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+
+#include "chiark_tcl_crypto.h"
+
+CHT_INIT(crypto,
+ CHTI_OTHER(hbytes) CHTI_TYPE(cht_blockcipherkey_type),
+ CHTI_COMMANDS(cht_hbcryptotoplevel_entries))
--- /dev/null
+ chiark-tcl - some useful Tcl bindings
+ -------------------------------------
+
+This package contains, basically, shared libraries
+ chiark_tcl_<something>-1.so
+in /usr/lib.
+
+Each of these is a Tcl extension which can be loaded into a Tcl
+interpreter with
+ load chiark_tcl_<something>-1.so
+and then the new commands will immediately be available.
+
+The documentation for each extension is regrettably rather sketchy but
+the following information should be enough to get you started:
+
+ <something>.tct
+
+ This is the input file to the automatic Tcl<->C glue generator
+ used by all of the extensions provided in this package. This
+ lists the commands and subcommands available.
+
+ <something>.[ch].txt
+
+ Some of the extensions have additional usage documentation in a
+ source code comment. This comment has been mechanically
+ extracted from the source file for your comfort and convenience.
+
+To gain an understanding of the way the *.tct files work, take a
+look at adns.c.txt which describes the `adns' command provided by
+the adns binding.
+
+Note that the file /usr/lib/libchiark_tcl-1.so is NOT an amalgam of
+all of the extensions. It is a set of common routines which will be
+loaded automatically when required. Each extension must be loaded
+explicitly with the Tcl `load' command to bring the additional
+commands into the Tcl command namespace.
+
+To use the adns and nettle bindings you need to have the appropriate
+libraries installed too, although these are not listed as
+dependencies. Programs which use these extensions should list
+dependencies on (currently) libadns1 and libnettle2. Regrettably,
+there is no clear way to get the dependencies completely correct in
+the case where chiark-tcl is rebuilt against some other versions of
+adns and/or nettle.
--- /dev/null
+chiark-tcl (1.1.1+nmu1) unstable; urgency=low
+
+ * Non-maintainer upload.
+ * Build against the default Tcl version instead of deprecated 8.4
+ (closes: #725248).
+
+ -- Sergei Golovan <sgolovan@debian.org> Tue, 15 Oct 2013 21:12:46 +0400
+
+chiark-tcl (1.1.1) unstable; urgency=low
+
+ Bugfix:
+ * Handling of errors reading /dev/urandom fixed.
+
+ User-visible change:
+ * Mention dgram, tuntap and maskmap in Description. Fix typo.
+
+ Build improvements:
+ * Fix FTBFS in sid due to warning from recent versions of gcc
+ about set but not used variables.
+ * Update default TCL_VERSION for upstream build to 8.4.
+
+ Packaging improvements:
+ * Remove the pointless copyright notice from the end of the changelog.
+ * Add ${misc:Depends} to Depends field (has no effect on the .deb).
+ * Provide build-arch and build-indep targets.
+ * Suppress lintian warning about package-name-doesnt-match-sonames.
+ * Remove lintian override for non-PIC cdb, due to tinycdb not having
+ PIC code in it. This is now fixed in libcdb-dev.
+ * Remove linda overrides.
+ * Add a .gitignore.
+ * Update debian/compat to 5. No changes needed.
+ * Update Standards-Version. No changes needed.
+ * Update Copyright dates.
+ * Remove FSF street address from copyright notices.
+ * Change my email address.
+
+ -- Ian Jackson <ijackson@chiark.greenend.org.uk> Sat, 02 Jun 2012 14:20:35 +0100
+
+chiark-tcl (1.1.0+nmu2) unstable; urgency=low
+
+ * Non-maintainer upload.
+ * debian/rules: add invocation of dh_makeshlibs and dh_installdeb, so
+ that ldconfig is invoked in postinst (Closes: #553122)
+ * debian/control: replace libnettle-dev by nettle-dev (which replaces
+ the former) in build-dependencies
+
+ -- Stefano Zacchiroli <zack@debian.org> Thu, 19 Nov 2009 09:09:57 +0100
+
+chiark-tcl (1.1.0+nmu1) unstable; urgency=medium
+
+ * Non-maintainer upload.
+ * Fix FTBFS with gcc-4.3 by adding <limits.h> include to
+ base/chiark-tcl.h as suggested by Michael Bienia (Closes: #489901).
+ * Set urgency to “medium” as this bug affects testing too.
+
+ -- Cyril Brulebois <kibi@debian.org> Sun, 19 Jul 2009 18:23:54 +0200
+
+chiark-tcl (1.1.0) unstable; urgency=high
+
+ New features:
+ * hbcrypto hash-{init,update,final} etc. for incremental hashing.
+
+ Bugfixes:
+ * Do not adns_cancel in the middle of adns_forallqueries.
+ * cdb: When cdbwr update writerecord fails, try to recover the
+ situation to sanity so we don't corrupt the log later; if this
+ fails, mark the cdb broken.
+ * strlen returns size_t, not int; fixed up everywhere relevant.
+ Closes #393970. (Bug exists only where int and ssize_t differ.)
+ * Use correct errno value for error writing to new .main during compact.
+ * Do not coredump if fclose journal fails during compact.
+ * Do not fail lookups on cdb-wr's opened from just-created dbs.
+ * Do not leak cdb innards on compact.
+
+ Portability fixes:
+ * Remove unecessary assertion of val<=0xffffffffUL where uint32_t val;
+ Closes: #394039 (FTBFS due to unhelpful GCC warning).
+ * Use -fno-strict-aliasing because gcc-4.3 apparently ignores
+ -Wno-strict-aliasing! Closes: #471004.
+
+ Internal improvements:
+ * Add a few assertions about *_LLEN in adns.c.
+ * Comprehensive review of use of `int' and defence against overflow.
+
+ -- Ian Jackson <ian@davenant.greenend.org.uk> Fri, 20 Jun 2008 22:50:25 +0100
+
+chiark-tcl (1.0.1) unstable; urgency=low
+
+ New features:
+ * adns: Provide txt RRs.
+ * dgram: New extension for datagram sockets; dgram-socket command.
+ * tuntap: New extension for tun/tap interfaces (currently, tun only).
+
+ Documentation, build and packaging fixes:
+ * Correct doc comment for supplying query options to adns asynch.
+ * Replace #include <tcl8.3/tcl.h> with <tcl.h> and in build system find
+ Tcl version and pass appropriate -I option. Closes: #362806.
+ * Declare versioned build-dependency on libadns1-dev >= 1.2
+ since we need adns_init_logfn. Closes: #382287.
+ * Declare build-dependency on libcdb-dev | tinycdb (<= 0.75)
+ since cdb.h etc. is in libcdb-dev off nowadays. Closes: #387904.
+ * Pass -Wno-strict-aliasing. The compiler is wrong.
+ * Do not run dpkg-shlibdeps on adns and nettle plugins.
+ This prevents them turning up in Depends - see the README.
+ * Use correct syntax for avoiding compressing doc/*/*.[ch].txt.
+ * Use correct variable name for cht_adnstcl_{queries,resolvers}
+ everywhere (prevents coredump accessing uninitialised version).
+
+ Internal changes:
+ * New way of doing toplevels with tcmdifgen dispatch() primitive.
+
+ -- Ian Jackson <ian@davenant.greenend.org.uk> Wed, 18 Oct 2006 17:05:03 +0100
+
+chiark-tcl (1.0.0) unstable; urgency=low
+
+ * Initial release. Extensions included: adns cdb crypto hbytes
+ (of which cdb and adns will be needed for new SAUCE).
+
+ -- Ian Jackson <ian@davenant.greenend.org.uk> Thu, 30 Mar 2006 18:34:51 +0100
--- /dev/null
+Source: chiark-tcl
+Maintainer: Ian Jackson <ijackson@chiark.greenend.org.uk>
+Priority: optional
+Section: interpreters
+Standards-Version: 3.9.1
+Build-Depends: libadns1-dev (>= 1.2), nettle-dev, libcdb-dev | tinycdb (<= 0.75), tcl-dev | tcl8.4-dev | tcl8.3-dev | tcl8.2-dev, debhelper (>= 5)
+
+Package: libtcl-chiark-1
+Architecture: any
+Description: Tcl interfaces for adns, cdb, crypto, etc.
+ Tcl bindings for:
+ * adns (resolver library)
+ * cdb (constant database) plus journalling writable database
+ * crypto: the nettle cryptographic library
+ * hbytes: bytestrings with hex as string representation but efficient
+ * dgram: datagram sockets
+ * tuntap: tun/tap interfaces
+ * maskmap: address masks and maps
+ To make sensible use of these you will need a version of Tcl installed
+ (this package is compatible with at least Tcl 8.0 to 8.4 inclusive).
+ To use the adns and nettle bindings you need to have the
+ appropriate libraries installed too.
+Depends: ${shlibs:Depends}, ${misc:Depends}
+
+
+# chiark-tcl - various Tcl bindings and extensions
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
--- /dev/null
+chiark-tcl is a collection of Tcl extensions
+This Debian package was prepared by Ian Jackson, also the upstream
+author.
+
+
+Copyright 2006-2012 Ian Jackson
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License as
+published by the Free Software Foundation; either version 2 of the
+License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+A copy of the GNU General Public License, version 2, should be
+installed on your Debian system in /usr/share/common-licenses/GPL.
--- /dev/null
+#!/usr/bin/perl -w
+$o= '';
+for (;;) {
+ exit 0 unless defined ($_= <STDIN>);
+ $o .= $_;
+ last if / \-\-\-8\<\-\-\- end of documentation /;
+}
+($before, $_, $after)= @ARGV;
+s,.*/,,;
+$of= $before.$_.$after;
+open F, "> $of" or die $!;
+print F $o or die $!;
+close F or die $!;
+print " wrote $of\n" or die $!;
--- /dev/null
+# These things are not linkable against with ld; they're plugin modules
+# for use with dlopen but want to be on the default load path for Tcl's
+# convenience:
+libtcl-chiark-1 binary: no-shlibs-control-file usr/lib/chiark_tcl_adns-1.so
+libtcl-chiark-1 binary: no-shlibs-control-file usr/lib/chiark_tcl_hbytes-1.so
+libtcl-chiark-1 binary: no-shlibs-control-file usr/lib/chiark_tcl_crypto-1.so
+libtcl-chiark-1 binary: no-shlibs-control-file usr/lib/chiark_tcl_cdb-1.so
+libtcl-chiark-1 binary: no-shlibs-control-file usr/lib/libchiark_tcl-1.so
+
+# Our Description ends in `etc.' which makes lintian think it's a
+# sentence.
+libtcl-chiark-1 binary: description-synopsis-might-not-be-phrased-properly
+
+libtcl-chiark-1: package-name-doesnt-match-sonames
--- /dev/null
+#!/usr/bin/make -f
+
+# chiark-tcl - various Tcl bindings and extensions
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+majversion=1
+srcpackage=chiark-tcl
+libpackage=libtcl-chiark-$(majversion)
+docpackage=libtcl-chiark-$(majversion)
+docdir=usr/share/doc/$(docpackage)
+
+tclh:=$(firstword $(wildcard /usr/include/tcl8.*/tcl.h))
+tclversion:=$(patsubst /usr/include/tcl%/tcl.h,%,$(tclh))
+
+define checkdir
+ test -f hbytes/hbytes.tct
+endef
+
+build: build-arch build-indep
+build-arch:
+ $(checkdir)
+ $(MAKE) prefix=/usr VERSION=$(majversion) TCL_VERSION=$(tclversion)
+
+build-indep:
+
+clean:
+ $(checkdir)
+ $(MAKE) clean
+ rm -rf *~ debian/tmp debian/*~ debian/files* debian/substvars*
+ dh_clean
+
+binary-indep:
+
+binary-arch: checkroot build
+ $(checkdir)
+ -rm -rf debian/$(docpackage) debian/$(libpackage)
+ install -d debian/$(libpackage)/usr/lib
+ install -d debian/$(docpackage)/usr/share/doc/$(docpackage)
+
+ set -e; for f in lintian; do \
+ install -d debian/$(libpackage)/usr/share/$$f/overrides; \
+ cp debian/$$f-overrides \
+ debian/$(libpackage)/usr/share/$$f/overrides/$(libpackage); \
+ done
+
+ cp */*.so debian/$(libpackage)/usr/lib/.
+
+ set -e; for f in */*.[ch]; do \
+ perl debian/extractdoc <$$f \
+ debian/$(docpackage)/$(docdir)/ $$f .txt; \
+ done
+ cp */*.tct debian/README debian/copyright \
+ debian/$(docpackage)/$(docdir)
+
+ dh_installchangelogs
+ dh_strip
+
+ dh_makeshlibs
+ dh_shlibdeps -Xchiark_tcl_adns -Xchiark_tcl_crypto
+
+ # be consistent about what we compress:
+ dh_compress -X.c.txt -X.h.txt
+
+ dh_fixperms
+ dh_installdeb
+ dh_gencontrol
+ dh_md5sums
+ dh_builddeb
+
+# Below here is fairly generic really
+
+binary: binary-indep binary-arch
+
+source diff:
+ @echo >&2 'source and diff are obsolete - use dpkg-source -b'; false
+
+checkroot:
+ $(checkdir)
+ dh_testroot
+
+.PHONY: binary binary-arch binary-indep clean checkroot
--- /dev/null
+# dgram - Tcl extension for udp datagrams
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+BASE_DIR = ../base
+EXTBASE = dgram
+CFILES = dgram misc sockaddr hook
+OTHER_TCTS = ../hbytes/hbytes-base.tct
+OTHER_EXTS = hbytes/hbytes
+
+include ../base/extension.make
+
--- /dev/null
+/* dgram - Tcl extension for udp datagrams
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+
+#include "hbytes.h"
+#include "dgram.h"
+#include "dgram+tcmdif.h"
--- /dev/null
+/*
+ */
+/*
+ * 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 "dgram.h"
+
+typedef struct DgramSocket {
+ int ix; /* first ! */
+ int fd;
+ Tcl_Interp *ip;
+ ScriptToInvoke script;
+ void *addr_buf, *msg_buf;
+ int addr_buflen, msg_buflen;
+} DgramSocket;
+
+int cht_do_dgramsocket_create(ClientData cd, Tcl_Interp *ip,
+ SockAddr_Value local, void **sock_r) {
+ int fd, al, r;
+ DgramSocket *sock;
+ const struct sockaddr *sa;
+
+ sa= cht_sockaddr_addr(&local);
+ al= cht_sockaddr_len(&local);
+
+ fd= socket(sa->sa_family, SOCK_DGRAM, 0);
+ if (fd<0) return cht_posixerr(ip,errno,"socket");
+ r= bind(fd, sa, al); if (r) return cht_newfdposixerr(ip,fd,"bind");
+ r= cht_setnonblock(fd, 1); if (r) return cht_newfdposixerr(ip,fd,"setnonblock");
+
+ sock= TALLOC(sizeof(DgramSocket));
+ sock->ix= -1;
+ sock->fd= fd;
+ sock->addr_buflen= al+1;
+ sock->addr_buf= TALLOC(sock->addr_buflen);
+ sock->msg_buflen= 0;
+ sock->msg_buf= 0;
+ cht_scriptinv_init(&sock->script);
+
+ *sock_r= sock;
+ return TCL_OK;
+}
+
+int cht_do_dgramsocket_transmit(ClientData cd, Tcl_Interp *ip,
+ void *sock_v, HBytes_Value data,
+ SockAddr_Value remote) {
+ DgramSocket *sock= sock_v;
+ int l, r;
+
+ r= sendto(sock->fd,
+ cht_hb_data(&data), l=cht_hb_len(&data),
+ 0,
+ cht_sockaddr_addr(&remote), cht_sockaddr_len(&remote));
+ if (r==-1) return cht_posixerr(ip,errno,"sendto");
+ else if (r!=l) return cht_staticerr(ip,"sendto gave wrong answer",0);
+ return TCL_OK;
+}
+
+static void cancel(DgramSocket *sock) {
+ if (sock->script.script) {
+ cht_scriptinv_cancel(&sock->script);
+ Tcl_DeleteFileHandler(sock->fd);
+ }
+}
+
+static void recv_call(ClientData sock_cd, int mask) {
+ DgramSocket *sock= (void*)sock_cd;
+ Tcl_Interp *ip= sock->script.ipq;
+ int sz, rc, peek;
+ HBytes_Value message_val;
+ SockAddr_Value peer_val;
+ Tcl_Obj *args[3];
+ struct msghdr mh;
+ struct iovec iov;
+
+ cht_hb_empty(&message_val);
+ cht_sockaddr_clear(&peer_val);
+
+ 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) {
+ if (errno == EAGAIN || errno == EWOULDBLOCK) rc=0;
+ else rc= cht_posixerr(ip,errno,"recvmsg");
+ 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);
+ assert(sock->msg_buflen < INT_MAX/4);
+ sock->msg_buflen *= 2;
+ sock->msg_buflen += 100;
+ sock->msg_buf= TALLOC(sock->msg_buflen);
+ }
+
+ cht_hb_array(&message_val, iov.iov_base, sz);
+ cht_sockaddr_create(&peer_val, mh.msg_name, mh.msg_namelen);
+
+ args[0]= cht_ret_hb(ip, message_val); cht_hb_empty(&message_val);
+ args[1]= cht_ret_sockaddr(ip, peer_val); cht_sockaddr_clear(&peer_val);
+ args[2]= cht_ret_iddata(ip, sock, &cht_dgram_socks);
+ cht_scriptinv_invoke(&sock->script,3,args);
+
+ rc= 0;
+
+x_rc:
+ if (rc)
+ Tcl_BackgroundError(ip);
+}
+
+int cht_do_dgramsocket_on_receive(ClientData cd, Tcl_Interp *ip,
+ void *sock_v, Tcl_Obj *newscript) {
+ DgramSocket *sock= sock_v;
+ int rc;
+
+ cancel(sock);
+
+ if (newscript) {
+ rc= cht_scriptinv_set(&sock->script, ip, newscript, 0);
+ if (rc) return rc;
+ }
+
+ Tcl_CreateFileHandler(sock->fd, TCL_READABLE, recv_call, sock);
+ return TCL_OK;
+}
+
+static void destroy(DgramSocket *sock) {
+ cancel(sock);
+ close(sock->fd); /* nothing useful to be done with errors */
+ TFREE(sock->addr_buf);
+ TFREE(sock->msg_buf);
+ TFREE(sock);
+}
+
+static void destroy_idtabcb(Tcl_Interp *ip, void *sock_v) {
+ destroy(sock_v);
+}
+
+int cht_do_dgramsocket_close(ClientData cd, Tcl_Interp *ip, void *sock_v) {
+ cht_tabledataid_disposing(ip,sock_v,&cht_dgram_socks);
+ destroy(sock_v);
+ return TCL_OK;
+}
+
+const IdDataSpec cht_dgram_socks= {
+ "dgramsock", "dgramsock-table", destroy_idtabcb
+};
--- /dev/null
+/* dgram - Tcl extension for udp datagrams
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#ifndef DGRAM_H
+#define DGRAM_H
+
+#include "hbytes.h"
+
+/* from sockaddr.c */
+
+typedef struct {
+ Byte *begin, *end;
+} SockAddr_Value;
+
+extern Tcl_ObjType sockaddr_type;
+
+void cht_sockaddr_clear(SockAddr_Value*);
+void cht_sockaddr_create(SockAddr_Value*, const struct sockaddr *addr, int al);
+int cht_sockaddr_len(const SockAddr_Value*);
+const struct sockaddr *cht_sockaddr_addr(const SockAddr_Value*);
+void cht_sockaddr_free(const SockAddr_Value*);
+
+/* from dgram.c */
+
+extern const IdDataSpec cht_dgram_socks;
+
+/* from misc.c */
+
+int cht_setnonblock(int fd, int isnonblock);
+
+#include "dgram+tcmdif.h"
+
+#endif /*DGRAM_H*/
--- /dev/null
+# dgram - Tcl extension for udp datagrams
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+Type sockaddr: SockAddr_Value @
+Init sockaddr cht_sockaddr_clear(&@);
+
+Table *dgramsockettoplevel TopLevel_Command
+ dgram-socket
+ dispatch(DgramSocket/_SubCommand,"dgram-socket subcommand")
+
+Table dgramsocket DgramSocket_SubCommand
+ create
+ local sockaddr
+ => iddata(&cht_dgram_socks)
+ close
+ sock iddata(&cht_dgram_socks)
+ transmit
+ sock iddata(&cht_dgram_socks)
+ data hb
+ remote sockaddr
+ on-receive
+ sock iddata(&cht_dgram_socks)
+ ?script obj
--- /dev/null
+/* dgram - Tcl extension for udp datagrams
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include "dgram.h"
+
+CHT_INIT(dgram, CHTI_TYPE(sockaddr_type),
+ CHTI_COMMANDS(cht_dgramsockettoplevel_entries))
--- /dev/null
+/**/
+
+#include "dgram.h"
+
+int cht_setnonblock(int fd, int isnonblock) {
+ int r;
+
+ r= fcntl(fd,F_GETFL);
+ if (r==-1) return -1;
+ r= fcntl(fd,F_SETFL, isnonblock ? r|O_NONBLOCK : r&~O_NONBLOCK);
+ if (r==-1) return -1;
+ return 0;
+}
+
--- /dev/null
+/*
+ * struct sockaddr
+ *
+ * syntaxes:
+ * ddd.ddd.ddd.ddd,nnnn IPv4 address and port
+ * ... host or port may be `*'
+ * /abs/path/to/socket AF_UNIX
+ * ./rel/path/to/socket AF_UNIX
+ */
+
+#include "dgram.h"
+
+#define SOCKADDR_LEN(sa) ((sa)->end - (sa)->begin)
+
+/* parsing */
+
+int cht_pat_sockaddr(Tcl_Interp *ip, Tcl_Obj *o, SockAddr_Value *val) {
+ int rc;
+
+ rc= Tcl_ConvertToType(ip,o,&sockaddr_type);
+ if (rc) return rc;
+
+ *val= *OBJ_SOCKADDR(o);
+ return TCL_OK;
+}
+
+Tcl_Obj *cht_ret_sockaddr(Tcl_Interp *ip, SockAddr_Value val) {
+ Tcl_Obj *o;
+
+ o= Tcl_NewObj();
+ Tcl_InvalidateStringRep(o);
+ *OBJ_SOCKADDR(o)= val;
+ o->typePtr= &sockaddr_type;
+ return o;
+}
+
+/* native type methods */
+
+void cht_sockaddr_clear(SockAddr_Value *v) { v->begin= v->end= 0; }
+
+void cht_sockaddr_create(SockAddr_Value *v, const struct sockaddr *a, int al) {
+ Byte *begin;
+
+ v->begin= begin= TALLOC(al);
+ memcpy(begin, a, al);
+ v->end= begin + al;
+}
+
+int cht_sockaddr_len(const SockAddr_Value *v) {
+ return SOCKADDR_LEN(v);
+}
+
+const struct sockaddr *cht_sockaddr_addr(const SockAddr_Value *v) {
+ return (const void*)v->begin;
+}
+
+void cht_sockaddr_free(const SockAddr_Value *v) {
+ TFREE(v->begin);
+}
+
+/* Sockaddr Tcl type */
+
+static void sockaddr_t_dup(Tcl_Obj *src, Tcl_Obj *dup) {
+ cht_sockaddr_create(OBJ_SOCKADDR(dup),
+ cht_sockaddr_addr(OBJ_SOCKADDR(src)),
+ cht_sockaddr_len(OBJ_SOCKADDR(src)));
+ dup->typePtr= &cht_hbytes_type;
+}
+
+static void sockaddr_t_free(Tcl_Obj *o) {
+ cht_sockaddr_free(OBJ_SOCKADDR(o));
+}
+
+static void sockaddr_t_ustr(Tcl_Obj *o) {
+ const struct sockaddr *sa;
+ char i46buf[INET6_ADDRSTRLEN], portbuf[50];
+ const struct sockaddr_in *sin;
+ int al;
+ const char *string, *prepend;
+
+ sa= cht_sockaddr_addr(OBJ_SOCKADDR(o));
+ al= cht_sockaddr_len(OBJ_SOCKADDR(o));
+
+ switch (sa->sa_family) {
+ case AF_INET:
+ case AF_INET6:
+ assert(sizeof(i46buf) >= INET_ADDRSTRLEN);
+ assert(al >= sizeof(struct sockaddr_in));
+ sin= (const void*)sa;
+ inet_ntop(sa->sa_family, &sin->sin_addr, i46buf, al);
+ snprintf(portbuf,sizeof(portbuf),",%d",(int)ntohs(sin->sin_port));
+ prepend= i46buf;
+ string= portbuf;
+ break;
+
+ case AF_UNIX:
+ string= ((const struct sockaddr_un*)sa)->sun_path;
+ prepend= "";
+ if (!string[0]) string="//";
+ else if (string[0] != '/' || string[1] == '/') prepend= "./";
+ break;
+
+ default: /* ouch ! */
+ cht_obj_updatestr_array_prefix(o,(const void*)sa,al,"?");
+ return;
+ }
+
+ cht_obj_updatestr_vstringls(o,
+ prepend, strlen(prepend),
+ string, strlen(string),
+ (char*)0);
+}
+
+static int sockaddr_t_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
+ union {
+ struct sockaddr_un sun;
+ struct sockaddr_in sin;
+ } s;
+ unsigned long port_l;
+
+ char *str, *ep, *copy;
+ int sl, pl, iprv;
+ const char *comma, *path;
+
+ str= Tcl_GetStringFromObj(o,0); assert(str);
+ cht_objfreeir(o);
+ memset(&s,0,sizeof(s));
+
+ if (str[0]=='/' || (str[0]=='.' && str[1]=='/')) {
+
+ sl= sizeof(s.sun);
+ s.sun.sun_family= AF_UNIX;
+
+ if (!strcmp(str,"//")) path= "";
+ else if (!memcmp(str,"./",2) && str[2]) path= str+2;
+ else { assert(str[0]=='/' && str[1]!='/'); path=str; }
+
+ if (strlen(str) >= sizeof(s.sun.sun_path))
+ return cht_staticerr(ip, "AF_UNIX path too long", "SOCKADDR AFUNIX LENGTH");
+
+ strcpy(s.sun.sun_path, path);
+
+ } else if ((comma= strchr(str, ','))) {
+
+ sl= sizeof(s.sin);
+ s.sin.sin_family= AF_INET;
+
+ pl= comma - str;
+ copy= TALLOC(pl+1);
+ memcpy(copy, str, pl);
+ copy[pl]= 0;
+
+ if (!strcmp(copy,"*")) {
+ s.sin.sin_addr.s_addr= INADDR_ANY;
+ iprv= 1;
+ } else {
+ iprv= inet_pton(AF_INET, copy, &s.sin.sin_addr);
+ }
+ TFREE(copy);
+
+ if (!iprv)
+ return cht_staticerr(ip, "bad IPv4 address syntax", "SOCKADDR SYNTAX IPV4");
+
+ comma++;
+ if (!strcmp(comma,"*")) {
+ s.sin.sin_port= 0;
+ } else {
+ errno=0; port_l=strtoul(comma,&ep,10);
+ if (errno || *ep)
+ return cht_staticerr(ip, "bad IPv4 port", "SOCKADDR SYNTAX IPV4");
+ if (port_l > 65535)
+ return cht_staticerr(ip, "IPv4 port out of range", "SOCKADDR SYNTAX IPV4");
+ s.sin.sin_port= htons(port_l);
+ }
+
+ } else {
+
+ return cht_staticerr(ip, "bad socket address syntax", "SOCKADDR SYNTAX OTHER");
+
+ }
+
+ cht_sockaddr_create(OBJ_SOCKADDR(o), (void*)&s, sl);
+
+ o->typePtr = &sockaddr_type;
+ return TCL_OK;
+}
+
+Tcl_ObjType sockaddr_type = {
+ "sockaddr",
+ sockaddr_t_free, sockaddr_t_dup, sockaddr_t_ustr, sockaddr_t_sfa
+};
--- /dev/null
+# hbytes - hex-stringrep efficient byteblocks for Tcl
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+BASE_DIR = ../base
+EXTBASE = hbytes
+CFILES = chop hbytes hook parse ulongs
+OTHER_TCTS = hbytes-base.tct
+
+include ../base/extension.make
+
--- /dev/null
+/*
+ * hbytes - hex-stringrep efficient byteblocks for Tcl
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+
+#ifndef CHIARK_TCL_HBYTES_H
+#define CHIARK_TCL_HBYTES_H
+
+#include "hbytes.h"
+
+typedef struct {
+ Byte *start; /* byl bytes */
+ Tcl_Obj *data; /* may be 0 to mean empty */
+} AddrMap_Entry;
+
+struct AddrMap_Value {
+ int byl, used, space;
+ AddrMap_Entry *entries;
+ /* Entries are sorted by start. Each entry gives value (or lack of
+ * it) for all A st START <= A < NEXT-START. Last entry has value
+ * (or lack of it) for all A >= START. First entry is always
+ * present and always has start all-bits-0. */
+}; /* internalRep.otherValuePtr */
+
+#include "hbytes+tcmdif.h"
+
+#endif /*CHIARK_TCL_HBYTES_H*/
--- /dev/null
+/*
+ * hbytes - hex-stringrep efficient byteblocks for Tcl
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+
+#include "chiark_tcl_hbytes.h"
+
+static int strs1(Tcl_Interp *ip, int strc, Tcl_Obj *const *strv, int *l_r) {
+ int rc, l, i, pl;
+
+ l= 0;
+ for (i=1; i<strc; i++) {
+ rc= Tcl_ConvertToType(ip,strv[i],&cht_hbytes_type);
+ if (rc) return rc;
+ pl= cht_hb_len(OBJ_HBYTES(strv[i]));
+ assert(l < INT_MAX/2 && pl < INT_MAX/2);
+ l += pl;
+ }
+ *l_r= l;
+ return TCL_OK;
+}
+
+static void strs2(Byte *dest, int strc, Tcl_Obj *const *strv) {
+ int tl, i;
+
+ for (i=1; i<strc; i++) {
+ tl= cht_hb_len(OBJ_HBYTES(strv[i]));
+ memcpy(dest, cht_hb_data(OBJ_HBYTES(strv[i])), tl);
+ dest += tl;
+ }
+}
+
+int cht_do_hbytes_prepend(ClientData cd, Tcl_Interp *ip,
+ HBytes_Var v, int strc, Tcl_Obj *const *strv) {
+ int rc, el;
+ Byte *dest;
+
+ rc= strs1(ip,strc,strv,&el); if (rc) return rc;
+ dest= cht_hb_prepend(v.hb, el);
+ strs2(dest, strc,strv);
+ return TCL_OK;
+}
+
+int cht_do_hbytes_append(ClientData cd, Tcl_Interp *ip,
+ HBytes_Var v, int strc, Tcl_Obj *const *strv) {
+ int rc, el;
+ Byte *dest;
+
+ rc= strs1(ip,strc,strv,&el); if (rc) return rc;
+ dest= cht_hb_append(v.hb, el);
+ strs2(dest, strc,strv);
+ return TCL_OK;
+}
+
+int cht_do_hbytes_concat(ClientData cd, Tcl_Interp *ip,
+ int strc, Tcl_Obj *const *strv, HBytes_Value *result) {
+ int rc, l;
+ Byte *dest;
+
+ rc= strs1(ip,strc,strv,&l); if (rc) return rc;
+ dest= cht_hb_arrayspace(result,l);
+ strs2(dest, strc,strv);
+ return TCL_OK;
+}
+
+static int underrun(Tcl_Interp *ip) {
+ return cht_staticerr(ip,"data underrun","HBYTES LENGTH UNDERRUN");
+}
+
+int cht_do_hbytes_unprepend(ClientData cd, Tcl_Interp *ip,
+ HBytes_Var v, int preflength, HBytes_Value *result) {
+ const Byte *rdata= cht_hb_unprepend(v.hb, preflength);
+ if (!rdata) return underrun(ip);
+ cht_hb_array(result, rdata, preflength);
+ return TCL_OK;
+}
+
+int cht_do_hbytes_unappend(ClientData cd, Tcl_Interp *ip,
+ HBytes_Var v, int suflength, HBytes_Value *result) {
+ const Byte *rdata= cht_hb_unappend(v.hb, suflength);
+ if (!rdata) return underrun(ip);
+ cht_hb_array(result, rdata, suflength);
+ return TCL_OK;
+}
+
+int cht_do_hbytes_chopto(ClientData cd, Tcl_Interp *ip,
+ HBytes_Var v, int newlength, HBytes_Value *result) {
+ int suflength= cht_hb_len(v.hb) - newlength;
+ return cht_do_hbytes_unappend(0,ip,v, suflength, result);
+}
--- /dev/null
+# hbytes - hex-stringrep efficient byteblocks for Tcl
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+Type hb: HBytes_Value @
+Init hb cht_hb_sentinel(&@);
+
+Type hbv: HBytes_Var @
+Init hbv @.hb=0; cht_init_somethingv(&@.sth);
+Fini hbv cht_fini_somethingv(ip, rc, &@.sth);
+
+Type addrmapv: AddrMap_Var @
+Init addrmapv @.am=0; cht_init_somethingv(&@.sth);
+Fini addrmapv cht_fini_somethingv(ip, rc, &@.sth);
--- /dev/null
+/*
+ * hbytes - hex-stringrep efficient byteblocks for Tcl
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+
+#include "hbytes.h"
+
+#define COMPLEX(hb) ((HBytes_ComplexValue*)hb->begin_complex)
+#define SIMPLE_LEN(hb) ((Byte*)(hb)->end_0 - (Byte*)(hb)->begin_complex)
+
+/* enquirers */
+
+int cht_hb_len(const HBytes_Value *hb) {
+ if (HBYTES_ISEMPTY(hb)) return 0;
+ else if (HBYTES_ISCOMPLEX(hb)) return COMPLEX(hb)->len;
+ else return SIMPLE_LEN(hb);
+}
+
+Byte *cht_hb_data(const HBytes_Value *hb) {
+ if (HBYTES_ISEMPTY(hb)) return 0;
+ else if (HBYTES_ISCOMPLEX(hb)) return COMPLEX(hb)->dstart;
+ else return hb->begin_complex;
+}
+
+int cht_hb_issentinel(const HBytes_Value *hb) {
+ return HBYTES_ISSENTINEL(hb);
+}
+
+/* constructors */
+
+void cht_hb_empty(HBytes_Value *returns) {
+ returns->begin_complex= returns->end_0= 0;
+}
+
+void cht_hb_sentinel(HBytes_Value *returns) {
+ returns->begin_complex= 0;
+ returns->end_0= (void*)&cht_hbytes_type;
+}
+
+Byte *cht_hb_arrayspace(HBytes_Value *returns, int l) {
+ if (!l) { cht_hb_empty(returns); return 0; }
+ returns->begin_complex= TALLOC(l);
+ returns->end_0= returns->begin_complex + l;
+ return returns->begin_complex;
+}
+
+void cht_hb_array(HBytes_Value *returns, const Byte *array, int l) {
+ memcpy(cht_hb_arrayspace(returns,l), array, l);
+}
+
+/* destructor */
+
+void cht_hb_free(const HBytes_Value *frees) {
+ if (HBYTES_ISCOMPLEX(frees)) {
+ HBytes_ComplexValue *cx= COMPLEX(frees);
+ TFREE(cx->dstart - cx->prespace);
+ }
+ TFREE(frees->begin_complex);
+}
+
+/* mutators */
+
+static HBytes_ComplexValue *complex(HBytes_Value *hb) {
+ HBytes_ComplexValue *cx;
+
+ if (HBYTES_ISCOMPLEX(hb)) return hb->begin_complex;
+
+ cx= TALLOC(sizeof(*cx));
+ cx->dstart= hb->begin_complex;
+ cx->len= cx->avail= SIMPLE_LEN(hb);
+ cx->prespace= 0;
+
+ hb->begin_complex= cx;
+ hb->end_0= 0;
+
+ return cx;
+}
+
+Byte *cht_hb_prepend(HBytes_Value *hb, int el) {
+ HBytes_ComplexValue *cx;
+ int new_prespace;
+ Byte *old_block, *new_block, *new_dstart;
+
+ cx= complex(hb);
+
+ assert(el < INT_MAX/4 && cx->len < INT_MAX/2);
+
+ if (cx->prespace < el) {
+ new_prespace= el*2 + cx->len;
+ old_block= cx->dstart - cx->prespace;
+ new_block= Tcl_Realloc(old_block, new_prespace + cx->avail);
+ new_dstart= new_block + new_prespace;
+ memmove(new_dstart, new_block + cx->prespace, cx->len);
+ cx->prespace= new_prespace;
+ cx->dstart= new_dstart;
+ }
+ cx->dstart -= el;
+ cx->prespace -= el;
+ cx->len += el;
+ cx->avail += el;
+ return cx->dstart;
+}
+
+Byte *cht_hb_append(HBytes_Value *hb, int el) {
+ HBytes_ComplexValue *cx;
+ int new_len, new_avail;
+ Byte *newpart, *new_block, *old_block;
+
+ cx= complex(hb);
+ assert(el < INT_MAX/4 && cx->len < INT_MAX/4);
+
+ new_len= cx->len + el;
+ if (new_len > cx->avail) {
+ new_avail= new_len*2;
+ old_block= cx->dstart - cx->prespace;
+ new_block= Tcl_Realloc(old_block, cx->prespace + new_avail);
+ cx->dstart= new_block + cx->prespace;
+ cx->avail= new_avail;
+ }
+ newpart= cx->dstart + cx->len;
+ cx->len= new_len;
+ return newpart;
+}
+
+static HBytes_ComplexValue*
+prechop(HBytes_Value *hb, int cl, const Byte **rv) {
+ HBytes_ComplexValue *cx;
+
+ if (cl<0) { *rv=0; return 0; }
+ if (cl==0) { *rv= (const void*)&cht_hbytes_type; return 0; }
+
+ cx= complex(hb);
+ if (cl > cx->len) { *rv=0; return 0; }
+ return cx;
+}
+
+const Byte *cht_hb_unprepend(HBytes_Value *hb, int pl) {
+ const Byte *chopped;
+ HBytes_ComplexValue *cx= prechop(hb,pl,&chopped);
+ if (!cx) return chopped;
+
+ chopped= cx->dstart;
+ cx->dstart += pl;
+ cx->prespace += pl;
+ cx->len -= pl;
+ cx->avail -= pl;
+ return chopped;
+}
+
+const Byte *cht_hb_unappend(HBytes_Value *hb, int sl) {
+ const Byte *chopped;
+ HBytes_ComplexValue *cx= prechop(hb,sl,&chopped);
+ if (!cx) return chopped;
+
+ cx->len -= sl;
+ return cx->dstart + cx->len;
+}
+
+void memxor(Byte *dest, const Byte *src, int l) {
+ while (l--) *dest++ ^= *src++;
+}
--- /dev/null
+/*
+ * hbytes raw2h BINARY => hex
+ * hbytes h2raw HEX => binary
+ *
+ * hbytes length VALUE => count
+ * hbytes prepend VAR [VALUE ...] = set VAR [concat VALUE ... $VAR]
+ * hbytes append VAR [VALUE ...] = set VAR [concat $VAR VALUE ...]
+ * hbytes concat VAR [VALUE ...] = set VAR [concat VALUE ...]
+ * hbytes unprepend VAR PREFIXLENGTH => prefix (removed from VAR)
+ * hbytes unappend VAR SUFFIXLENGTH => suffix (removed from VAR)
+ * hbytes chopto VAR NEWVARLENGTH => suffix (removed from VAR)
+ * (too short? error)
+ *
+ * hbytes range VALUE START SIZE => substring (or error)
+ * hbytes overwrite VAR START VALUE
+ * hbytes trimleft VAR removes any leading 0 octets
+ * hbytes repeat VALUE COUNT => COUNT copies of VALUE
+ * hbytes zeroes COUNT => COUNT zero bytes
+ * hbytes random COUNT => COUNT random bytes
+ * hbytes xor VAR VALUE $VAR (+)= VALUE
+ *
+ * hbytes ushort2h LONG => LONG must be <2^16, returns as hex
+ * hbytes h2ushort HEX => |HEX| must be 2 bytes, returns as ulong
+ *
+ * hbytes compare A B
+ * => -2 A is lexically earlier than B and not a prefix of B (A<B)
+ * -1 A is prefix of B but not equal (A<B)
+ * 0 A == B
+ * +1 A is B plus a nonempty suffix (ie, A has B as a prefix)
+ * +2 A is lexically later than B and does not have B as a prefix
+ *
+ * hbytes pad pa|ua VAR ALG METH [METHARGS] => worked? (always 1 for p)
+ * hbytes pad pn|un VAR BS METH [METHARGS] => worked? (always 1 for p)
+ * hbytes pad pa|pn VAR ALG|BS pkcs5 => 1
+ * hbytes pad ua|un VAR ALG|BS pkcs5 => worked?
+ * hbytes pad pa|pn VAR ALG|BS rfc2406 NXTHDR => 1
+ * hbytes pad ua|un VAR ALG|BS rfc2406 NXTHDRVAR => worked?
+ *
+ * hbytes blockcipher d|e VAR ALG KEY MODE [IV] => IV
+ * hbytes blockcipher mac MSG ALG KEY MODE IV => final block
+ * hbytes blockcipher prop PROPERTY ALG => property value
+ *
+ * hbytes hash ALG MESSAGE => hash
+ * hbytes hmac ALG MESSAGE KEY [MACLENGTH] => mac
+ * hbytes hash-prop PROPERTY ALG => property value
+ *
+ * ulong ul2int ULONG => INT can fail if >INT_MAX
+ * ulong int2ul INT => ULONG can fail if <0
+ * ulong mask A B => A & B
+ * ulong add A B => A + B (mod 2^32)
+ * ulong subtract A B => A - B (mod 2^32)
+ * ulong compare A B => 0 -1 (A<B) +1 (A>B)
+ * ulong shift l|r ULONG BITS fails if BITS >32
+ *
+ * ulong ul2bitfields VALUE [SIZE TYPE [TYPE-ARG...] ...] => 0/1
+ * ulong bitfields2ul BASE [SIZE TYPE [TYPE-ARG...] ...] => ULONG
+ * goes from left (MSbit) to right (LSbit) where
+ * SIZE is size in bits
+ * TYPE [TYPE-ARGS...] is as below
+ * zero
+ * ignore
+ * fixed ULONG-VALUE
+ * uint VARNAME/VALUE (VARNAME if ul2bitfields;
+ * ulong VARNAME/VALUE VALUE if bitfields2ul)
+ *
+ * Address ranges (addrmap.c):
+ *
+ * An address range is a slightly efficient partial mapping from
+ * addresses to arbitrary data values. An address is a number of
+ * octets expressed as an hbytes. All the addresses covered by the
+ * same addrmap should have the same length.
+ *
+ * hbytes addr-map lookup MAP-VAR ADDRESS [DEFAULT] => DATA
+ * Error on missing default or if any prefix longer than ADDRESS.
+ *
+ * hbytes addr-map amend-range MAP-VAR START END DATA
+ * hbytes addr-map amend-mask MAP-VAR PREFIX PREFIX-LENGTH DATA
+ * Sets all of the addresses in PREFIX/PREFIX-LENGTH to the
+ * relevant value.
+ *
+ * Representation:
+ * An address map MAP is
+ * [list BIT-LENGTH \
+ * [list START END DATA-VALUE] \
+ * [list START' END' DATA-VALUE'] \
+ * ...
+ * ]
+ * The list is sorted by ascending START and entries do not overlap.
+ * START and END are both inclusive. BIT-LENGTH is in usual Tcl
+ * integer notation and must be a multiple of 8.
+ *
+ * Error codes
+ *
+ * HBYTES BLOCKCIPHER CRYPTFAIL CRYPT block cipher mode failed somehow (!)
+ * HBYTES BLOCKCIPHER CRYPTFAIL MAC HMAC failed somehow (!)
+ * HBYTES BLOCKCIPHER LENGTH block cipher input has unsuitable length
+ * HBYTES BLOCKCIPHER PARAMS key or iv not suitable
+ * HBYTES HMAC PARAMS key, input or output size not suitable
+ * HBYTES LENGTH OVERRUN block too long
+ * HBYTES LENGTH RANGE input length or offset is -ve or silly
+ * HBYTES LENGTH UNDERRUN block too short (or offset too big)
+ * HBYTES LENGTH MISMATCH when blocks must be exactly same length
+ * HBYTES SYNTAX supposed hex block had wrong syntax
+ * HBYTES VALUE OVERFLOW value to be conv'd to hex too big/long
+ * HBYTES ADDRMAP NOMATCH no addr/mask matches address for lookup
+ * HBYTES ADDRMAP UNDERRUN addr for lookup or amend is too short
+ * HBYTES ADDRMAP OVERRUN addr for lookup or amend is too long
+ * HBYTES ADDRMAP EXCLBITS amend-mask 1-bits outside prefix len
+ * HBYTES ADDRMAP BADRANGE amend-range start > end
+ * HBYTES ADDRMAP VALUE addr-map string value is erroneous
+ * SOCKADDR AFUNIX LENGTH path for AF_UNIX socket too long
+ * SOCKADDR SYNTAX IPV4 bad IPv4 socket address &/or port
+ * SOCKADDR SYNTAX OTHER bad socket addr, couldn't tell what kind
+ * ULONG BITCOUNT NEGATIVE -ve bitcount specified where not allowed
+ * ULONG BITCOUNT OVERRUN attempt to use more than 32 bits
+ * ULONG BITCOUNT UNDERRUN bitfields add up to less than 32
+ * ULONG VALUE NEGATIVE attempt convert -ve integers to ulong
+ * ULONG VALUE OVERFLOW converted value does not fit in result
+ * TUNTAP IFNAME LENGTH tun/tap interface name too long
+ * TUNTAP MTU OVERRUN tun/tap mtu limited to 2^16 bytes
+ *
+ * Refs: HMAC: RFC2104
+ */
+/* ---8<--- end of documentation comment --8<-- */
+
+/*
+ * hbytes - hex-stringrep efficient byteblocks for Tcl
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+
+#ifndef HBYTES_H
+#define HBYTES_H
+
+#include <assert.h>
+#include <stdlib.h>
+#include <errno.h>
+#include <unistd.h>
+#include <fcntl.h>
+#include <sys/socket.h>
+#include <sys/uio.h>
+#include <sys/un.h>
+#include <arpa/inet.h>
+#include <string.h>
+
+#include "chiark-tcl.h"
+
+/* from hbytes.c */
+
+int Hbytes_Init(Tcl_Interp *ip); /* called by Tcl's "load" */
+
+/* Internal representation details: */
+#define HBYTES_ISEMPTY(hb) (!(hb)->begin_complex && !(hb)->end_0)
+#define HBYTES_ISSENTINEL(hb) (!(hb)->begin_complex && (hb)->end_0)
+#define HBYTES_ISSIMPLE(hb) ((hb)->begin_complex && (hb)->end_0)
+#define HBYTES_ISCOMPLEX(hb) ((hb)->begin_complex && !(hb)->end_0)
+
+typedef struct {
+ void *begin_complex, *end_0;
+} HBytes_Value; /* overlays internalRep */
+
+typedef struct {
+ Byte *dstart; /* always allocated dynamically */
+ int prespace, len, avail;
+ /*
+ * | SPARE | USED | SPARE |
+ * |<-prespace->|<-len->| |
+ * | |<----avail---->|
+ * ^start
+ */
+} HBytes_ComplexValue; /* pointed to from internalRep.otherValuePtr */
+
+void memxor(Byte *dest, const Byte *src, int l);
+extern int Chiark_tcl_hbytes_Init(Tcl_Interp *ip);
+ /* called by load(3tcl) and also by extensions which depend on this one */
+
+/* Public interfaces: */
+
+extern Tcl_ObjType cht_hbytes_type;
+
+int cht_hb_len(const HBytes_Value *v);
+Byte *cht_hb_data(const HBytes_Value *v); /* caller may then modify data! */
+int cht_hb_issentinel(const HBytes_Value *v);
+
+Byte *cht_hb_prepend(HBytes_Value *upd, int el);
+Byte *cht_hb_append(HBytes_Value *upd, int el);
+ /* return value is where to put the data */
+
+const Byte *cht_hb_unprepend(HBytes_Value *upd, int rl);
+const Byte *cht_hb_unappend(HBytes_Value *upd, int rl);
+ /* return value points to the removed data, which remains valid
+ * until next op on the HBytes_Value. If original value is
+ * shorter than rl or negative, returns 0 and does nothing. */
+
+void cht_hb_empty(HBytes_Value *returns);
+void cht_hb_sentinel(HBytes_Value *returns);
+void cht_hb_array(HBytes_Value *returns, const Byte *array, int l);
+Byte *cht_hb_arrayspace(HBytes_Value *returns, int l);
+void cht_hb_free(const HBytes_Value *frees);
+ /* _empty, _sentinel and _array do not free or read the old value;
+ * _free it first if needed. _free leaves it garbage, so you
+ * have to call _empty to reuse it. _arrayspace doesn't fill
+ * the array; you get a pointer and must fill it with data
+ * yourself. */
+
+/* The value made by cht_hb_sentinel should not be passed to
+ * anything except HBYTES_IS..., and cht_hb_free. */
+
+/* from hook.c */
+
+void cht_obj_updatestr_array(Tcl_Obj *o, const Byte *array, int l);
+void cht_obj_updatestr_array_prefix(Tcl_Obj *o, const Byte *byte,
+ int l, const char *prefix);
+
+/* from parse.c */
+
+typedef struct {
+ HBytes_Value *hb;
+ Something_Var sth;
+} HBytes_Var;
+
+/* from addrmap.c */
+
+typedef struct AddrMap_Value AddrMap_Value;
+
+typedef struct {
+ AddrMap_Value *am;
+ Something_Var sth;
+} AddrMap_Var;
+
+extern Tcl_ObjType cht_addrmap_type;
+
+/* from chop.c */
+ /* only do_... functions declared in tables.h */
+
+/* from ulong.c */
+
+Tcl_ObjType cht_ulong_type;
+
+/* useful macros */
+
+#define OBJ_HBYTES(o) ((HBytes_Value*)&(o)->internalRep.twoPtrValue)
+#define OBJ_SOCKADDR(o) ((SockAddr_Value*)&(o)->internalRep.twoPtrValue)
+
+#endif /*HBYTES_H*/
--- /dev/null
+# hbytes - hex-stringrep efficient byteblocks for Tcl
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+Table *hbytestoplevel TopLevel_Command
+ hbytes
+ dispatch(HBytes/_SubCommand, "hbytes subcommand")
+ ulong
+ dispatch(ULong/_SubCommand, "ulong subcommand")
+
+Table ulong ULong_SubCommand
+ ul2int
+ v ulong
+ => int
+ int2ul
+ v int
+ => ulong
+ mask
+ a ulong
+ b ulong
+ => ulong
+ add
+ a ulong
+ b ulong
+ => ulong
+ multiply
+ a ulong
+ b ulong
+ => ulong
+ subtract
+ a ulong
+ b ulong
+ => ulong
+ compare
+ a ulong
+ b ulong
+ => int
+ shift
+ right charfrom("lr", "shift direction")
+ v ulong
+ bits int
+ => ulong
+ ul2bitfields
+ value ulong
+ ... obj
+ => int
+ bitfields2ul
+ base ulong
+ ... obj
+ => ulong
+
+Table hbytes HBytes_SubCommand
+ raw2h
+ binary obj
+ => hb
+ h2raw
+ hex hb
+ => obj
+ ushort2h
+ value long
+ => hb
+ h2ushort
+ hex hb
+ => long
+ length
+ v hb
+ => int
+ compare
+ a hb
+ b hb
+ => int
+ range
+ v hb
+ start int
+ size int
+ => hb
+ prepend
+ v hbv
+ ... str
+ append
+ v hbv
+ ... str
+ rep-info
+ v obj
+ => obj
+ concat
+ ... str
+ => hb
+ unprepend
+ v hbv
+ length int
+ => hb
+ unappend
+ v hbv
+ length int
+ => hb
+ chopto
+ v hbv
+ length int
+ => hb
+ overwrite
+ v hbv
+ start int
+ sub hb
+ trimleft
+ v hbv
+ zeroes
+ length int
+ => hb
+ repeat
+ v hb
+ count int
+ => hb
+ xor
+ v hbv
+ d hb
+ random
+ length int
+ => hb
--- /dev/null
+/*
+ * hbytes - hex-stringrep efficient byteblocks for Tcl
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+
+#include <errno.h>
+
+#include "chiark_tcl_hbytes.h"
+
+int cht_do_hbytes_rep_info(ClientData cd, Tcl_Interp *ip,
+ Tcl_Obj *obj, Tcl_Obj **result) {
+ const char *tn;
+ int nums[3], i, lnl;
+ Tcl_Obj *objl[4];
+
+ if (obj->typePtr == &cht_hbytes_type) {
+ HBytes_Value *v= OBJ_HBYTES(obj);
+ memset(nums,0,sizeof(nums));
+ nums[1]= cht_hb_len(v);
+
+ if (HBYTES_ISEMPTY(v)) tn= "empty";
+ else if (HBYTES_ISSENTINEL(v)) tn= "sentinel!";
+ else if (HBYTES_ISSIMPLE(v)) tn= "simple";
+ else {
+ HBytes_ComplexValue *cx= v->begin_complex;
+ tn= "complex";
+ nums[0]= cx->prespace;
+ nums[2]= cx->avail - cx->len;
+ }
+ lnl= 3;
+ } else {
+ tn= "other";
+ lnl= 0;
+ }
+
+ objl[0]= Tcl_NewStringObj((char*)tn,-1);
+ for (i=0; i<lnl; i++) objl[i+1]= Tcl_NewIntObj(nums[i]);
+ *result= Tcl_NewListObj(lnl+1,objl);
+
+ return TCL_OK;
+}
+
+static void hbytes_t_dup(Tcl_Obj *src, Tcl_Obj *dup) {
+ cht_hb_array(OBJ_HBYTES(dup),
+ cht_hb_data(OBJ_HBYTES(src)),
+ cht_hb_len(OBJ_HBYTES(src)));
+ dup->typePtr= &cht_hbytes_type;
+}
+
+static void hbytes_t_free(Tcl_Obj *o) {
+ cht_hb_free(OBJ_HBYTES(o));
+}
+
+void cht_obj_updatestr_array_prefix(Tcl_Obj *o, const Byte *byte,
+ int l, const char *prefix) {
+ char *str;
+ int pl;
+
+ pl= strlen(prefix);
+ assert(l < INT_MAX/2 - 1 - pl);
+ o->length= l*2+pl;
+ str= o->bytes= TALLOC(o->length+1);
+
+ memcpy(str,prefix,pl);
+ str += pl;
+
+ while (l>0) {
+ sprintf(str,"%02x",*byte);
+ str+=2; byte++; l--;
+ }
+ *str= 0;
+}
+
+void cht_obj_updatestr_array(Tcl_Obj *o, const Byte *byte, int l) {
+ cht_obj_updatestr_array_prefix(o,byte,l,"");
+}
+
+static void hbytes_t_ustr(Tcl_Obj *o) {
+ cht_obj_updatestr_array(o,
+ cht_hb_data(OBJ_HBYTES(o)),
+ cht_hb_len(OBJ_HBYTES(o)));
+}
+
+static int hbytes_t_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
+ char *str, *ep;
+ Byte *bytes;
+ int l;
+ char cbuf[3];
+
+ if (o->typePtr == &cht_ulong_type) {
+ uint32_t ul;
+
+ ul= htonl(*(const uint32_t*)&o->internalRep.longValue);
+ cht_hb_array(OBJ_HBYTES(o), (const Byte*)&ul, 4);
+
+ } else {
+
+ str= Tcl_GetStringFromObj(o,&l); assert(str);
+ cht_objfreeir(o);
+
+ if (l & 1) return cht_staticerr(ip, "hbytes: conversion from hex:"
+ " odd length in hex", "HBYTES SYNTAX");
+
+ bytes= cht_hb_arrayspace(OBJ_HBYTES(o), l/2);
+
+ cbuf[2]= 0;
+ while (l>0) {
+ cbuf[0]= *str++;
+ cbuf[1]= *str++;
+ *bytes++= strtoul(cbuf,&ep,16);
+ if (ep != cbuf+2) {
+ cht_hb_free(OBJ_HBYTES(o));
+ return cht_staticerr(ip, "hbytes: conversion from hex:"
+ " bad hex digit", "HBYTES SYNTAX");
+ }
+ l -= 2;
+ }
+
+ }
+
+ o->typePtr = &cht_hbytes_type;
+ return TCL_OK;
+}
+
+Tcl_ObjType cht_hbytes_type = {
+ "hbytes",
+ hbytes_t_free, hbytes_t_dup, hbytes_t_ustr, hbytes_t_sfa
+};
+
+int cht_do_hbytes_raw2h(ClientData cd, Tcl_Interp *ip,
+ Tcl_Obj *binary, HBytes_Value *result) {
+ const unsigned char *str;
+ int l;
+
+ str= Tcl_GetByteArrayFromObj(binary,&l);
+ cht_hb_array(result, str, l);
+ return TCL_OK;
+}
+
+int cht_do_hbytes_h2raw(ClientData cd, Tcl_Interp *ip,
+ HBytes_Value hex, Tcl_Obj **result) {
+ *result= Tcl_NewByteArrayObj(cht_hb_data(&hex), cht_hb_len(&hex));
+ return TCL_OK;
+}
+
+int cht_do_hbytes_length(ClientData cd, Tcl_Interp *ip,
+ HBytes_Value v, int *result) {
+ *result= cht_hb_len(&v);
+ return TCL_OK;
+}
+
+int cht_do_hbytes_random(ClientData cd, Tcl_Interp *ip,
+ int length, HBytes_Value *result) {
+ Byte *space;
+ int rc;
+
+ space= cht_hb_arrayspace(result, length);
+ rc= cht_get_urandom(ip, space, length);
+ if (rc) { cht_hb_free(result); return rc; }
+ return TCL_OK;
+}
+
+int cht_do_hbytes_overwrite(ClientData cd, Tcl_Interp *ip,
+ HBytes_Var v, int start, HBytes_Value sub) {
+ int sub_l;
+
+ sub_l= cht_hb_len(&sub);
+ if (start < 0)
+ return cht_staticerr(ip, "hbytes overwrite start -ve",
+ "HBYTES LENGTH RANGE");
+ if (start + sub_l > cht_hb_len(v.hb))
+ return cht_staticerr(ip, "hbytes overwrite out of range",
+ "HBYTES LENGTH UNDERRUN");
+ memcpy(cht_hb_data(v.hb) + start, cht_hb_data(&sub), sub_l);
+ return TCL_OK;
+}
+
+int cht_do_hbytes_trimleft(ClientData cd, Tcl_Interp *ip, HBytes_Var v) {
+ const Byte *o, *p, *e;
+ o= p= cht_hb_data(v.hb);
+ e= p + cht_hb_len(v.hb);
+
+ while (p<e && !*p) p++;
+ if (p != o)
+ cht_hb_unprepend(v.hb, p-o);
+
+ return TCL_OK;
+}
+
+int cht_do_hbytes_repeat(ClientData cd, Tcl_Interp *ip,
+ HBytes_Value sub, int count, HBytes_Value *result) {
+ int sub_l;
+ Byte *data;
+ const Byte *sub_d;
+
+ sub_l= cht_hb_len(&sub);
+ if (count < 0) return cht_staticerr(ip, "hbytes repeat count -ve",
+ "HBYTES LENGTH RANGE");
+ if (count > INT_MAX/sub_l) return cht_staticerr(ip, "hbytes repeat too long", 0);
+
+ data= cht_hb_arrayspace(result, sub_l*count);
+ sub_d= cht_hb_data(&sub);
+ while (count) {
+ memcpy(data, sub_d, sub_l);
+ count--; data += sub_l;
+ }
+ return TCL_OK;
+}
+
+int cht_do_hbytes_xor(ClientData cd, Tcl_Interp *ip,
+ HBytes_Var v, HBytes_Value d) {
+ int l;
+ Byte *dest;
+ const Byte *source;
+
+ l= cht_hb_len(v.hb);
+ if (cht_hb_len(&d) != l) return
+ cht_staticerr(ip, "hbytes xor lengths do not match", "HBYTES LENGTH MISMATCH");
+
+ dest= cht_hb_data(v.hb);
+ source= cht_hb_data(&d);
+ memxor(dest,source,l);
+ return TCL_OK;
+}
+
+int cht_do_hbytes_zeroes(ClientData cd, Tcl_Interp *ip,
+ int length, HBytes_Value *result) {
+ Byte *space;
+ space= cht_hb_arrayspace(result, length);
+ memset(space,0,length);
+ return TCL_OK;
+}
+
+int cht_do_hbytes_compare(ClientData cd, Tcl_Interp *ip,
+ HBytes_Value a, HBytes_Value b, int *result) {
+ int al, bl, minl, r;
+
+ al= cht_hb_len(&a);
+ bl= cht_hb_len(&b);
+ minl= al<bl ? al : bl;
+
+ r= memcmp(cht_hb_data(&a), cht_hb_data(&b), minl);
+
+ if (r<0) *result= -2;
+ else if (r>0) *result= +2;
+ else {
+ if (al<bl) *result= -1;
+ else if (al>bl) *result= +1;
+ else *result= 0;
+ }
+ return TCL_OK;
+}
+
+int cht_do_hbytes_range(ClientData cd, Tcl_Interp *ip,
+ HBytes_Value v, int start, int size,
+ HBytes_Value *result) {
+ const Byte *data;
+ int l;
+
+ l= cht_hb_len(&v);
+ if (start<0 || size<0)
+ return cht_staticerr(ip,"hbytes range subscript(s) -ve","HBYTES LENGTH RANGE");
+ if (l<start+size)
+ return cht_staticerr(ip, "hbytes range subscripts too big",
+ "HBYTES LENGTH UNDERRUN");
+
+ data= cht_hb_data(&v);
+ cht_hb_array(result, data+start, size);
+ return TCL_OK;
+}
+
+/* hbytes representing uint16_t's */
+
+int cht_do_hbytes_h2ushort(ClientData cd, Tcl_Interp *ip,
+ HBytes_Value hex, long *result) {
+ const Byte *data;
+ int l;
+
+ l= cht_hb_len(&hex);
+ if (l>2)
+ return cht_staticerr(ip, "hbytes h2ushort input more than 4 hex digits",
+ "HBYTES VALUE OVERFLOW");
+
+ data= cht_hb_data(&hex);
+ *result= data[l-1] | (l>1 ? data[0]<<8 : 0);
+ return TCL_OK;
+}
+
+int cht_do_hbytes_ushort2h(ClientData cd, Tcl_Interp *ip,
+ long input, HBytes_Value *result) {
+ uint16_t us;
+
+ if (input > 0x0ffff)
+ return cht_staticerr(ip, "hbytes ushort2h input >2^16",
+ "HBYTES VALUE OVERFLOW");
+
+ us= htons(input);
+ cht_hb_array(result,(const Byte*)&us,2);
+ return TCL_OK;
+}
+
+/* toplevel functions */
+
+CHT_INIT(hbytes,
+ CHTI_TYPE(cht_hbytes_type) CHTI_TYPE(cht_ulong_type),
+ CHTI_COMMANDS(cht_hbytestoplevel_entries))
--- /dev/null
+/*
+ * hbytes - hex-stringrep efficient byteblocks for Tcl
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include "chiark_tcl_hbytes.h"
+
+int cht_pat_hbv(Tcl_Interp *ip, Tcl_Obj *var, HBytes_Var *agg) {
+ int rc;
+ rc= cht_pat_somethingv(ip,var,&agg->sth,&cht_hbytes_type);
+ if (rc) return rc;
+ agg->hb= OBJ_HBYTES(agg->sth.obj);
+ return TCL_OK;
+}
+int cht_pat_hb(Tcl_Interp *ip, Tcl_Obj *obj, HBytes_Value *val) {
+ int rc;
+ rc= Tcl_ConvertToType(ip,obj,&cht_hbytes_type); if (rc) return rc;
+ *val= *OBJ_HBYTES(obj);
+ return TCL_OK;
+}
+
+Tcl_Obj *cht_ret_hb(Tcl_Interp *ip, HBytes_Value val) {
+ Tcl_Obj *obj;
+ obj= Tcl_NewObj();
+ Tcl_InvalidateStringRep(obj);
+ *OBJ_HBYTES(obj)= val;
+ obj->typePtr= &cht_hbytes_type;
+ return obj;
+}
--- /dev/null
+/*
+ * hbytes - hex-stringrep efficient byteblocks for Tcl
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include "chiark_tcl_hbytes.h"
+
+/* nice simple functions */
+
+int cht_do_ulong_int2ul(ClientData cd, Tcl_Interp *ip, int v,
+ uint32_t *result) {
+ if (v<0) return cht_staticerr(ip,"cannot convert"
+ " -ve integer to ulong","ULONG VALUE NEGATIVE");
+ *result= v;
+ return TCL_OK;
+}
+
+int cht_do_ulong_add(ClientData cd, Tcl_Interp *ip,
+ uint32_t a, uint32_t b, uint32_t *result) {
+ *result= a + b;
+ return TCL_OK;
+}
+
+int cht_do_ulong_multiply(ClientData cd, Tcl_Interp *ip,
+ uint32_t a, uint32_t b, uint32_t *result) {
+ *result= a * b;
+ return TCL_OK;
+}
+
+int cht_do_ulong_subtract(ClientData cd, Tcl_Interp *ip,
+ uint32_t a, uint32_t b, uint32_t *result) {
+ *result= a - b;
+ return TCL_OK;
+}
+
+int cht_do_ulong_compare(ClientData cd, Tcl_Interp *ip,
+ uint32_t a, uint32_t b, int *result) {
+ *result=
+ a == b ? 0 :
+ a < b ? -1 : 1;
+ return TCL_OK;
+}
+
+int cht_do_ulong_ul2int(ClientData cd, Tcl_Interp *ip,
+ uint32_t v, int *result) {
+ if (v>INT_MAX) return
+ cht_staticerr(ip,"ulong too large"
+ " to fit in an int", "ULONG VALUE OVERFLOW");
+ *result= v;
+ return TCL_OK;
+}
+
+int cht_do_ulong_mask(ClientData cd, Tcl_Interp *ip,
+ uint32_t a, uint32_t b, uint32_t *result) {
+ *result= a & b;
+ return TCL_OK;
+}
+
+int cht_do_ulong_shift(ClientData cd, Tcl_Interp *ip, int right,
+ uint32_t v, int bits, uint32_t *result) {
+ if (bits < 0) { bits= -bits; right= !right; }
+ if (bits > 32) return cht_staticerr(ip,"shift out of range (32) bits",
+ "ULONG BITCOUNT OVERRUN");
+ *result= (bits==32 ? 0 :
+ right ? v >> bits : v << bits);
+ return TCL_OK;
+}
+
+/* bitfields */
+
+typedef struct {
+ const char *name;
+ int want_arg;
+ int (*reader_writer[2])(Tcl_Interp *ip, uint32_t *value_io,
+ int *ok_io, Tcl_Obj *arg);
+} BitFieldType;
+
+static int bf_zero_read(Tcl_Interp *ip, uint32_t *value_io,
+ int *ok_io, Tcl_Obj *arg) {
+ if (*value_io) *ok_io= 0;
+ return TCL_OK;
+}
+
+static int bf_zero_write(Tcl_Interp *ip, uint32_t *value_io,
+ int *ok_io, Tcl_Obj *arg) {
+ *value_io= 0;
+ return TCL_OK;
+}
+
+static int bf_ignore(Tcl_Interp *ip, uint32_t *value_io,
+ int *ok_io, Tcl_Obj *arg) {
+ return TCL_OK;
+}
+
+static int bf_fixed_read(Tcl_Interp *ip, uint32_t *value_io,
+ int *ok_io, Tcl_Obj *arg) {
+ uint32_t ul;
+ int rc;
+
+ rc= cht_pat_ulong(ip, arg, &ul); if (rc) return rc;
+ if (*value_io != ul) *ok_io= 0;
+ return TCL_OK;
+}
+
+static int bf_ulong_write(Tcl_Interp *ip, uint32_t *value_io,
+ int *ok_io, Tcl_Obj *arg) {
+ uint32_t ul;
+ int rc;
+
+ rc= cht_pat_ulong(ip, arg, &ul); if (rc) return rc;
+ *value_io= ul;
+ return TCL_OK;
+}
+
+static int bf_var_read(Tcl_Interp *ip, Tcl_Obj *varname, Tcl_Obj *val) {
+ Tcl_Obj *rp;
+ rp= Tcl_ObjSetVar2(ip,varname,0,val,TCL_LEAVE_ERR_MSG);
+ if (!rp) return TCL_ERROR;
+ return TCL_OK;
+}
+
+static int bf_ulong_read(Tcl_Interp *ip, uint32_t *value_io,
+ int *ok_io, Tcl_Obj *arg) {
+ return bf_var_read(ip,arg, cht_ret_ulong(ip,*value_io));
+}
+
+static int bf_uint_write(Tcl_Interp *ip, uint32_t *value_io,
+ int *ok_io, Tcl_Obj *arg) {
+ int rc, v;
+ rc= cht_pat_int(ip, arg, &v); if (rc) return rc;
+ if (v<0) return cht_staticerr(ip,"value for bitfield is -ve",
+ "ULONG VALUE NEGATIVE");
+ *value_io= v;
+ return TCL_OK;
+}
+
+static int bf_uint_read(Tcl_Interp *ip, uint32_t *value_io,
+ int *ok_io, Tcl_Obj *arg) {
+ if (*value_io > INT_MAX)
+ return cht_staticerr(ip,"value from bitfield"
+ " exceeds INT_MAX","ULONG VALUE OVERFLOW");
+ return bf_var_read(ip,arg, cht_ret_int(ip,*value_io));
+}
+
+#define BFT(t,a) { #t, a, { bf_read_##t, bf_write_##t } }
+static const BitFieldType bitfieldtypes[]= {
+ { "zero", 0, { bf_zero_read, bf_zero_write } },
+ { "ignore", 0, { bf_ignore, bf_ignore } },
+ { "fixed", 1, { bf_fixed_read, bf_ulong_write } },
+ { "ulong", 1, { bf_ulong_read, bf_ulong_write } },
+ { "uint", 1, { bf_uint_read, bf_uint_write } },
+ { 0 }
+};
+
+static int do_bitfields(Tcl_Interp *ip, int writing, int *ok_r,
+ uint32_t *value_io,
+ int objc, Tcl_Obj *const *objv) {
+ const BitFieldType *ftype;
+ Tcl_Obj *arg;
+ int sz, pos, rc;
+ uint32_t value, sz_mask, this_mask, this_field;
+
+ pos= 32;
+ value= *value_io;
+ *ok_r= 1;
+
+ while (--objc) {
+ rc= Tcl_GetIntFromObj(ip,*++objv,&sz); if (rc) return rc;
+ if (!--objc)
+ return cht_staticerr(ip,"wrong # args: missing bitfield type",0);
+
+ if (sz<0)
+ return cht_staticerr(ip,"bitfield size is -ve",
+ "ULONG BITCOUNT NEGATIVE");
+ if (sz>pos)
+ return cht_staticerr(ip,"total size of bitfields >32",
+ "ULONG BITCOUNT OVERRUN");
+
+ pos -= sz;
+
+ sz_mask= ~(~0UL << sz);
+ this_mask= (sz_mask << pos);
+ this_field= (value & this_mask) >> pos;
+
+ ftype= enum_lookup_cached(ip,*++objv,bitfieldtypes,"bitfield type");
+ if (!ftype) return TCL_ERROR;
+
+ if (ftype->want_arg) {
+ if (!--objc)
+ return cht_staticerr(ip,"wrong # args: missing arg for bitfield",0);
+ arg= *++objv;
+ } else {
+ arg= 0;
+ }
+ rc= ftype->reader_writer[writing](ip, &this_field, ok_r, arg);
+ if (rc) return rc;
+
+ if (!*ok_r) return TCL_OK;
+
+ if (this_field & ~sz_mask)
+ return cht_staticerr(ip,"bitfield value has more bits than bitfield",
+ "ULONG VALUE OVERFLOW");
+
+ value &= ~this_mask;
+ value |= (this_field << pos);
+ }
+
+ if (pos != 0) return
+ cht_staticerr(ip,"bitfield sizes add up to <32","ULONG BITCOUNT UNDERRUN");
+
+ *value_io= value;
+ return TCL_OK;
+}
+
+int cht_do_ulong_bitfields2ul(ClientData cd, Tcl_Interp *ip,
+ uint32_t base,
+ int objc, Tcl_Obj *const *objv,
+ uint32_t *result) {
+ int ok, rc;
+
+ *result= base;
+ rc= do_bitfields(ip,1,&ok,result,objc,objv);
+ assert(ok);
+ return rc;
+}
+
+int cht_do_ulong_ul2bitfields(ClientData cd, Tcl_Interp *ip,
+ uint32_t value,
+ int objc, Tcl_Obj *const *objv,
+ int *result) {
+ return do_bitfields(ip,0,result,&value,objc,objv);
+}
+
+/* Arg parsing */
+
+int cht_pat_ulong(Tcl_Interp *ip, Tcl_Obj *o, uint32_t *val) {
+ int rc;
+
+ rc= Tcl_ConvertToType(ip,o,&cht_ulong_type);
+ if (rc) return rc;
+ *val= *(const uint32_t*)&o->internalRep.longValue;
+ return TCL_OK;
+}
+
+Tcl_Obj *cht_ret_ulong(Tcl_Interp *ip, uint32_t val) {
+ Tcl_Obj *o;
+
+ o= Tcl_NewObj();
+ Tcl_InvalidateStringRep(o);
+ *(uint32_t*)&o->internalRep.longValue= val;
+ o->typePtr= &cht_ulong_type;
+ return o;
+}
+
+/* Tcl ulong type */
+
+static void ulong_t_free(Tcl_Obj *o) { }
+
+static void ulong_t_dup(Tcl_Obj *src, Tcl_Obj *dup) {
+ dup->internalRep= src->internalRep;
+ dup->typePtr= &cht_ulong_type;
+}
+
+static void ulong_t_ustr(Tcl_Obj *o) {
+ uint32_t val;
+ char buf[9];
+
+ val= *(const uint32_t*)&o->internalRep.longValue;
+ snprintf(buf,sizeof(buf), "%08lx", (unsigned long)val);
+ cht_obj_updatestr_vstringls(o, buf, sizeof(buf)-1, (char*)0);
+}
+
+static int ulong_t_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
+ char *str, *ep;
+ uint32_t ul;
+
+ if (o->typePtr == &cht_hbytes_type) {
+ int l;
+
+ l= cht_hb_len(OBJ_HBYTES(o));
+ if (l > 4) return cht_staticerr(ip,"hbytes as ulong with length >4",
+ "HBYTES LENGTH OVERRUN");
+ ul= 0;
+ memcpy((Byte*)&ul + 4 - l, cht_hb_data(OBJ_HBYTES(o)), l);
+ ul= htonl(ul);
+
+ } else {
+
+ str= Tcl_GetString(o);
+ errno=0;
+ if (str[0]=='0' && str[1]=='b' && str[2]) {
+ ul= strtoul(str+2,&ep,2);
+ } else if (str[0]=='0' && str[1]=='d' && str[2]) {
+ ul= strtoul(str+2,&ep,10);
+ } else {
+ ul= strtoul(str,&ep,16);
+ }
+ if (*ep || errno) return cht_staticerr(ip, "bad unsigned long value", 0);
+
+ }
+
+ cht_objfreeir(o);
+ *(uint32_t*)&o->internalRep.longValue= ul;
+ o->typePtr= &cht_ulong_type;
+ return TCL_OK;
+}
+
+Tcl_ObjType cht_ulong_type = {
+ "ulong-nearly",
+ ulong_t_free, ulong_t_dup, ulong_t_ustr, ulong_t_sfa
+};
--- /dev/null
+/*
+ * maskmap - Tcl extension for address mask map data structures
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+
+#include "chiark_tcl_hbytes.h"
+
+/*---------- operations on AddrMap_Entry ----------*/
+
+static void ame_free(AddrMap_Entry *ame) {
+ TFREE(ame->start); ame->start=0;
+ if (ame->data) { Tcl_DecrRefCount(ame->data); ame->data=0; }
+}
+
+static const Byte *ame_parsecheck_addr(Tcl_Interp *ip, const AddrMap_Value *am,
+ const HBytes_Value *hb) {
+ int hbl= cht_hb_len(hb);
+ if (hbl < am->byl) {
+ cht_staticerr(ip,"addr-map address too short","HBYTES ADDRMAP UNDERRUN");
+ return 0;
+ }
+ if (hbl > am->byl) {
+ cht_staticerr(ip,"addr-map address too long","HBYTES ADDRMAP OVERRUN");
+ return 0;
+ }
+ return cht_hb_data(hb);
+}
+
+static int ame_parsecheck_range(Tcl_Interp *ip, const AddrMap_Value *am,
+ const HBytes_Value *starthb,
+ const HBytes_Value *endhb,
+ const Byte *p_r[2]) {
+ p_r[0]= ame_parsecheck_addr(ip,am,starthb); if (!p_r[0]) return TCL_ERROR;
+ p_r[1]= ame_parsecheck_addr(ip,am,endhb); if (!p_r[0]) return TCL_ERROR;
+ if (memcmp(p_r[0],p_r[1],am->byl) > 0)
+ return cht_staticerr(ip, "addr-map range start is after end",
+ "HBYTES ADDRMAP BADRANGE");
+ return TCL_OK;
+}
+
+static int ame_ba_addsubtractone(Byte *out, const Byte *in, int byl,
+ unsigned signum, unsigned onoverflow) {
+ /* On entry:
+ * *in is an array of byl bytes
+ * signum is 0xff or 0x01
+ * onoverflow is what counts as overflowed value,
+ * ie (for unsigned arith) 0x00 for add and 0xff for subtract
+ * On exit:
+ * *out is the resulting value (subject to overflow truncation)
+ * return value is TCL_OK, or TCL_ERROR if overflow happened
+ * (but interpreter result is not set on overflow)
+ */
+ int j;
+
+ for (j= byl, in += byl, out += byl;
+ in--, out--, j>0;
+ j--) {
+ *out = (*out) + signum;
+ if (*out != onoverflow)
+ return TCL_OK;
+ }
+ return TCL_ERROR;
+}
+
+/*---------- useful operations on AddrMap_Value etc. ----------*/
+
+static void am_init0(AddrMap_Value *am, int byl) {
+ am->byl= byl;
+ am->used= 0;
+ am->space= 0;
+ am->entries= 0;
+}
+
+static void am_reallocentries(AddrMap_Value *am, int len) {
+ AddrMap_Entry *newentries;
+
+ assert(len >= am->space);
+ if (!len) return;
+
+ assert(len < INT_MAX/sizeof(*newentries));
+ newentries= TREALLOC(am->entries, sizeof(*newentries)*len);
+ assert(newentries);
+
+ am->space= len;
+ am->entries= newentries;
+}
+
+static void am_free(AddrMap_Value *am) {
+ AddrMap_Entry *ame;
+ int i;
+
+ if (!am) return;
+
+ for (i=0, ame=am->entries; i<am->used; i++, ame++)
+ ame_free(ame);
+
+ TFREE(am->entries);
+ TFREE(am);
+}
+
+/*---------- Tcl type and arg parsing functions ----------*/
+
+int cht_pat_addrmapv(Tcl_Interp *ip, Tcl_Obj *var, AddrMap_Var *agg) {
+ int rc;
+ rc= cht_pat_somethingv(ip,var,&agg->sth,&cht_addrmap_type);
+ if (rc) return rc;
+ agg->am= agg->sth.obj->internalRep.otherValuePtr;
+ return TCL_OK;
+}
+
+static void addrmap_t_free(Tcl_Obj *o) {
+ AddrMap_Value *am= o->internalRep.otherValuePtr;
+ am_free(am);
+}
+
+static void addrmap_t_dup(Tcl_Obj *sob, Tcl_Obj *dob) {
+ AddrMap_Value *sm= sob->internalRep.otherValuePtr;
+ AddrMap_Value *dm;
+ AddrMap_Entry *sme, *dme;
+ int i;
+
+ assert(sob->typePtr == &cht_addrmap_type);
+ cht_objfreeir(dob);
+ dm= TALLOC(sizeof(*dm));
+
+ am_init0(dm,sm->byl);
+ am_reallocentries(dm,sm->used);
+ dm->used= sm->used;
+ for (i=0, sme=sm->entries, dme=dm->entries;
+ i < dm->used;
+ i++, sme++, dme++) {
+ *dme= *sme;
+ dme->start= TALLOC(sm->byl); assert(dme->start);
+ memcpy(dme->start, sme->start, sm->byl);
+ Tcl_IncrRefCount(dme->data);
+ }
+ dob->internalRep.otherValuePtr= dm;
+ dob->typePtr= &cht_addrmap_type;
+}
+
+static void addrmap_t_ustr(Tcl_Obj *so) {
+ AddrMap_Value *sm= so->internalRep.otherValuePtr;
+ Tcl_Obj **mainlobjsl, *surrogate;
+ AddrMap_Entry *sme;
+ int entnum, listlength;
+
+ assert(so->typePtr == &cht_addrmap_type);
+ mainlobjsl= TALLOC(sizeof(*mainlobjsl) * (sm->used+1)); assert(mainlobjsl);
+ mainlobjsl[0]= Tcl_NewIntObj(sm->byl * 8);
+ listlength= 1;
+
+ for (entnum=0, sme=sm->entries; entnum<sm->used; entnum++, sme++) {
+ HBytes_Value hb;
+ Tcl_Obj *subl[3], *sublo;
+
+ if (!sme->data) continue;
+
+ cht_hb_array(&hb, sme->start, sm->byl);
+ subl[0]= cht_ret_hb(0, hb); assert(subl[0]);
+
+ if (entnum+1 < sm->used) {
+ ame_ba_addsubtractone(cht_hb_arrayspace(&hb, sm->byl),
+ (sme+1)->start, sm->byl,
+ /*subtract:*/ 0x0ffu, 0x0ffu);
+ } else {
+ memset(cht_hb_arrayspace(&hb, sm->byl),
+ 0x0ffu, sm->byl);
+ }
+
+ subl[1]= cht_ret_hb(0, hb); assert(subl[1]);
+ subl[2]= sme->data;
+
+ sublo= Tcl_NewListObj(3,subl); assert(sublo);
+ mainlobjsl[listlength++]= sublo;
+ }
+ assert(listlength <= sm->used+1);
+ surrogate= Tcl_NewListObj(listlength,mainlobjsl); assert(surrogate);
+ assert(surrogate);
+
+ so->bytes= Tcl_GetStringFromObj(surrogate, &so->length); assert(so->bytes);
+ surrogate->bytes= 0; surrogate->length= 0; /* we stole it */
+}
+
+static AddrMap_Entry *ame_sfa_alloc(AddrMap_Value *am) {
+ AddrMap_Entry *ame;
+
+ ame= am->entries + am->used;
+
+ am->used++;
+ assert(am->used <= am->space);
+
+ ame->start= TALLOC(am->byl); assert(ame->start);
+ ame->data= 0;
+ return ame;
+}
+
+static int addrmap_t_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
+ int rc, inlen, eol, innum, bitlen, cmp;
+ Tcl_Obj *eo, *starto, *endo;
+ HBytes_Value starthb, endhb;
+ const Byte *rangeptrs[2];
+ AddrMap_Value *am;
+ AddrMap_Entry *ame;
+
+ am= TALLOC(sizeof(*am)); assert(am);
+ am_init0(am,0);
+
+ rc= Tcl_ListObjLength(ip,o,&inlen); if (rc) goto x_badvalue_rc;
+
+ if (inlen<0) {
+ rc= cht_staticerr(ip, "addr-map overall length < 1", 0);
+ goto x_badvalue_rc;
+ }
+
+ rc= Tcl_ListObjIndex(ip,o,0,&eo); if (rc) goto x_badvalue_rc;
+ rc= Tcl_GetIntFromObj(ip,eo,&bitlen); if (rc) goto x_badvalue_rc;
+
+ if (bitlen<0 || bitlen % 8) {
+ rc= cht_staticerr(ip, "addr-map overall length < 1", 0);
+ goto x_badvalue_rc;
+ }
+
+ am->byl= bitlen/8;
+ assert(inlen < INT_MAX/2);
+ am_reallocentries(am, (inlen-1)*2+1);
+
+ ame= ame_sfa_alloc(am);
+ memset(ame->start,0,am->byl);
+
+ for (innum=1; innum < inlen; innum++) {
+ rc= Tcl_ListObjIndex(ip,o,innum,&eo); if (rc) goto x_badvalue_rc;
+ rc= Tcl_ListObjLength(ip,eo,&eol); if (rc) goto x_badvalue_rc;
+
+ if (eol != 3) {
+ rc= cht_staticerr(ip, "addr-map entry length != 3", 0);
+ goto x_badvalue_rc;
+ }
+ rc= Tcl_ListObjIndex(ip,eo,0,&starto); if (rc) goto x_badvalue_rc;
+ rc= Tcl_ListObjIndex(ip,eo,1,&endo); if (rc) goto x_badvalue_rc;
+
+ rc= cht_pat_hb(ip,starto,&starthb); if (rc) goto x_badvalue_rc;
+ rc= cht_pat_hb(ip,endo,&endhb); if (rc) goto x_badvalue_rc;
+
+ rc= ame_parsecheck_range(ip,am,&starthb,&endhb,rangeptrs);
+ if (rc) goto x_badvalue_rc;
+
+ cmp= memcmp(ame->start, rangeptrs[0], am->byl);
+ if (cmp < 0) {
+ rc= cht_staticerr(ip, "addr-map entries out of order", 0);
+ goto x_badvalue_rc;
+ }
+ if (cmp > 0) {
+ ame= ame_sfa_alloc(am);
+ memcpy(ame->start, rangeptrs[0], am->byl);
+ }
+
+ assert(!ame->data);
+ rc= Tcl_ListObjIndex(ip,eo,2,&ame->data); if (rc) goto x_badvalue_rc;
+ Tcl_IncrRefCount(ame->data);
+
+ ame= ame_sfa_alloc(am);
+ rc= ame_ba_addsubtractone(ame->start, rangeptrs[1], am->byl,
+ /*add:*/ 0x01u, 0x00u);
+ if (rc) {
+ /* we've overflowed. it must have been ffffffff.... */
+ if (innum != inlen-1) {
+ rc= cht_staticerr(ip, "addr-map non-last entry end is all-bits-1", 0);
+ goto x_badvalue_rc;
+ }
+ TFREE(ame->start);
+ am->used--;
+ break;
+ }
+ }
+
+ /* we commit now */
+ cht_objfreeir(o);
+ o->internalRep.otherValuePtr= am;
+ o->typePtr= &cht_addrmap_type;
+ return TCL_OK;
+
+ x_badvalue_rc:
+ if (rc == TCL_ERROR)
+ Tcl_SetObjErrorCode(ip, Tcl_NewStringObj("HBYTES ADDRMAP VALUE", -1));
+
+ am_free(am);
+ return rc;
+}
+
+Tcl_ObjType cht_addrmap_type = {
+ "addr-map",
+ addrmap_t_free, addrmap_t_dup, addrmap_t_ustr, addrmap_t_sfa
+};
--- /dev/null
+/*
+ * maskmap - Tcl extension for address mask map data structures
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+
+int cht_do_hbytes_addr_map(ClientData cd, Tcl_Interp *ip,
+ const AddrMap_SubCommand *subcmd,
+ int objc, Tcl_Obj *const *objv) {
+ return subcmd->func(0,ip,objc,objv);
+}
+
+xxxx
+extern int Chiark_tcl_hbytes_Init(Tcl_Interp *ip); /*called by load(3tcl)*/
+int Chiark_tcl_hbytes_Init(Tcl_Interp *ip) {
+ static int initd;
+
+ return cht_initextension(ip, cht_hbytestoplevel_entries, &initd,
+ &cht_addrmap_type,
+ (Tcl_ObjType*)0);
+}
--- /dev/null
+/*
+ * maskmap - Tcl extension for address mask map data structures
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#include "chiark_tcl_hbytes.h"
+
+/*---------- operations on AddrMap_Entry ----------*/
+
+static void ame_init(AddrMap_Entry *ame) {
+ ame->prefixlen= -1;
+ ame->prefix= 0;
+ ame->data= 0;
+}
+
+static unsigned ame_clear_unwanted(AddrMap_Entry *ame, int bytes) {
+ /* returns non-0 iff some bits were cleared */
+ int sparebits;
+ unsigned result, sparemask;
+ Byte *datap;
+
+ sparebits= bytes * 8 - ame->prefixlen;
+ if (!sparebits) return 0;
+
+ sparemask= (1u << sparebits) - 1;
+ datap= &ame->prefix[bytes-1];
+
+ result= *datap & sparemask;
+ *datap &= ~sparemask;
+
+ return result;
+}
+
+static int ame_parsekey(Tcl_Interp *ip, AddrMap_Entry *ame,
+ Tcl_Obj *prefixo, Tcl_Obj *prefixbitso,
+ int inmap) {
+ /* *ame should be blank entry; after exit (even error exit) it will be valid
+ * - on errors, it will be blank. inmap is 1 if we're parsing an existing
+ * map or 0 if it's an entry to be added or modified. */
+ HBytes_Value prefix;
+ int suppliedprefixbytes, prefixbits, wantprefixbytes;
+ const Byte *data;
+ int rc;
+
+ hbytes_empty(&prefix);
+
+ rc= pat_hb(ip,prefixo,&prefix); if (rc) goto x_rc;
+ rc= pat_int(ip,prefixbitso,&prefixbits); if (rc) goto x_rc;
+
+ wantprefixbytes= prefix_bytes(prefixbits);
+ suppliedprefixbytes= hbytes_len(&prefix);
+
+ if (suppliedprefixbytes < wantprefixbytes) {
+ rc= staticerr(ip, "addr-map entry PREFIX too short for PREFIX-LEN",
+ "HBYTES ADDRMAP SYNTAX UNDERRUN");
+ goto x_rc;
+ }
+ if (inmap && suppliedprefixbytes > wantprefixbytes) {
+ rc= staticerr(ip, "addr-map existing entry PREFIX too long for PREFIX-LEN",
+ "HBYTES ADDRMAP SYNTAX OVERRUN");
+ goto x_rc;
+ }
+
+ ame->prefixlen= prefixbits;
+ ame->prefix= TALLOC(wantprefixbytes); assert(ame->prefix);
+ memcpy(ame->prefix, data, wantprefixbytes);
+
+ if (ame_clear_unwanted(ame, wantprefixbytes)) {
+ rc= staticerr(ip, "addr-map entry PREFIX contains bits excluded"
+ " by PREFIX-LEN", "HBYTES ADDRMAP SYNTAX EXCLBITS");
+ goto x_rc;
+ }
+
+ return TCL_OK;
+
+ x_rc:
+ ame_free(ame);
+ return rc;
+}
+
+static int ame_contains(const AddrMap_Entry *ref, const Byte *addr, int len) {
+ int directbytes, leftoverbits;
+
+ assert(len >= ref->prefixlen);
+
+ directbytes= ref->prefixlen / 8;
+ if (memcmp(ref->prefix, addr, directbytes)) return 0;
+
+ leftoverbits= ref->prefixlen % 8;
+ if (leftoverbits)
+ if ((addr[directbytes] & (0xffu << leftoverbits))
+ != search->prefix[directbytes])
+ return 0;
+
+ return 1;
+}
+
+static int ame_compare(const AddrMap_Entry *a, const AddrMap_Entry *b) {
+ /* +2 = a covers later range of address space than b
+ * +1 = a wholly contains but is not equal to b
+ * 0 = a is identical to b
+ * -1 = b wholly contains but is not equal to a
+ * -2 = b covers later range of address space than a
+ */
+ int al= a->prefixlen;
+ int bl= b->prefixlen;
+ int ml, d;
+
+ if (al==bl) { ml=al; }
+ else if (al<bl) { ml=al; if (ame_contains(a,b->prefix,bl)) return +1; }
+ else if (bl<al) { ml=bl; if (ame_contains(b,a->prefix,al)) return -1; }
+
+ d= memcmp(b->prefix, a->prefix, prefix_bytes(ml));
+ return (d > 0 ? +2 :
+ d < 0 ? -2 :
+ 0);
+}
+
+/*---------- searching maps ----------*/
+
+typedef enum {
+ sr_notfound,
+ sr_exact,
+ sr_inbig,
+ sr_aroundsmall
+} Search_Result;
+
+static int
+am_binarychop(AddrMap_Value *am, int low_oreq, int high_strict, void *u,
+ int (*test)(AddrMap_Entry *am, void *u) /* -ve => look left */,
+ int *found_r) {
+ int mid, cmp;
+
+ for (;;) {
+ if (high_strict <= low_oreq) {
+ assert(high_strict == low_oreq);
+ *found_r= 0;
+ return high_strict;
+ }
+
+ mid= (high_strict + low_oreq) / 2;
+ cmp= test(&am->entries[mid], u);
+
+ if (!cmp) {
+ *found_r= 1;
+ return mid;
+ }
+
+ if (cmp < 0)
+ high_strict= mid;
+ else
+ low_oreq= mid+1;
+ }
+}
+
+struct am_search_u {
+ int forbid_aroundsmall;
+ AddrMap_Entry proposed;
+ Search_Result sr;
+};
+
+static int
+am_search_binchoptest(AddrMap_Entry *ame, void *u_v) {
+ struct am_search_u *u= u_v;
+ int cmp;
+
+ cmp= ame_compare(&u.proposed, ame);
+ switch (cmp) {
+ case -1: u->sr= sr_inbig; return 0;
+ case 0: u->sr= sr_exact; return 0;
+ case +1: u->sr= sr_aroundsmall; return 0;
+ default: return cmp;
+ }
+}
+
+static Search_Result
+am_search(AddrMap_Value *am, const AddrMap_Entry *proposed, int *place_r) {
+ int place, found;
+ struct am_search_u u;
+
+ u.forbid_aroundsmall= forbid_aroundsmall;
+ u.proposed= proposed;
+ u.sr= sr_notfound;
+
+ *place_r= am_binarychop(am, 0, am.used, &u, am_search_binchoptest, &found);
+
+ assert(!!found == (u.sr != sr_notfound));
+ return u.sr;
+}
+
+/*---------- useful operations on AddrMap_Value etc. ----------*/
+
+/*---------- amendment (complex algorithm) ----------*/
+
+struct am_amend_aroundsmall_u {
+ AddrMap_Entry *new;
+ int sign;
+};
+
+
+static int
+am_amend_aroundsmall_binchoptest(AddrMap_Entry *search, void *u_v) {
+ struct am_amend_aroundsmall_u *u= u_v;
+
+ cmp= u->sign * ame_compare(search, u->new);
+
+ switch (cmp) {
+ case +2: return -u->sign;
+ case +1: return +u->sign;
+ default: abort();
+ }
+}
+
+int do_addrmap_amend(ClientData cd, Tcl_Interp *ip,
+ AddrMap_Var map, Tcl_Obj *prefix,
+ Tcl_Obj *preflen, Tcl_Obj *data) {
+ AddrMap_Value *am= map.am;
+ AddrMap_Entry new, *fragment;
+ AddrMap_Entry *breaking, *replacements;
+ int rc, insertat, findend, cmp, nreplacements, new_used;
+ struct am_amend_aroundsmall_u u;
+
+ ame_init(&new);
+
+ rc= ame_parsekey(ip,&new,prefix,preflen,0); if (rc) return rc;
+
+ sr= am_search(am, &new, &searched);
+
+ replacements= &new;
+ nreplacements= 1;
+ replace_start= searched;
+ replace_end= searched;
+
+ switch (sr) {
+
+ case sr_notfound:
+ break;
+
+ case sr_exact:
+ replace_end= searched+1;
+ break;
+
+ case sr_aroundsmall:
+ u.ame= new;
+ u.sign= -1;
+ replace_start= am_binarychop(am, 0, searched, &u,
+ am_amend_aroundsmall_binchoptest, &dummy);
+ u.sign= +1;
+ replace_end= am_binarychop(am, searched+1, am.used, &u,
+ am_amend_aroundsmall_binchoptest, &dummy);
+ break;
+
+ case sr_inbig:
+ /* Urgh, we need to break it up. This produces
+ * - innermost prefix (the new one) as specified
+ * - one for each bitlength
+ * <= innermost
+ * > outermost (the existing one)
+ * each one specifying the outermost prefix plus zero, one,
+ * two, etc. bits of the innermost followed by one bit
+ * opposite to the innermost, with the outermost's data
+ * Eg, if we have ff/8=>A and want to amend so that ffff/16=>B
+ * then we replace ff/8 with ff0/9=>A ff8/10=>A ffc/11=>A ...
+ * ... fff8/14=>A fffc/15=>A fffe/16=>A ffff/16=>B.
+ */
+
+ breaking= &am.entries[searched];
+ nreplacements= new.prefix - breaking->prefixlen + 1;
+ fixme check integer overflow ^
+ replacements= TALLOC(sizeof(*replacements) * nreplacements);
+
+ for (fragmentlen= breaking->prefixlen + 1,
+ left_insert= 0, right_insert= nreplacements;
+ fragmentlen <= new.prefix;
+ fragmentlen++) {
+ int fragmentbytes;
+
+ fragmentbytes= prefix_bytes(fragmentlen)
+ fragment->prefixlen= fragmentlen;
+ fragment->prefix= TALLOC(fragmentbytes);
+ memcpy(fragment->prefix, new.prefix, fragmentbytes);
+ ame_clear_unwanted(fragment, fragmentbytes);
+
+ fragment->prefix[fragmentbytes] ^=
+ 0x80u >> ((fragmentlen+7) & 7);
+
+ switch (ame_compare(&fragment, &new)) {
+ case -2: replacements[left_insert++]= fragment; break;
+ case +2: replacements[--right_insert]= fragment; break;
+ default: abort();
+ }
+ }
+ assert(left_insert == right_insert-1);
+ replacements[left_insert]= new;
+ ame_init(&new);
+
+ replace_end= searched+1;
+ break;
+
+ }
+
+ new_used= am.used - (replace_end - replace_start) + nreplacements;
+
+ if (new_used > am.space)
+ am_reallocentries(am, new_used * 2);
+
+ for (scan=replacements, i=0;
+ i < nreplacements;
+ scan++, i++) {
+ scan->data= data;
+ Tcl_IncrRefCount(scan->data);
+ }
+
+ for (i= replace_start, scan= am.entries+i;
+ i < replace_end;
+ i++, scan++) {
+ ame_free(scan);
+ }
+
+ memmove(am.entries + replace_start + nreplacements,
+ am.entries + replace_end,
+ sizeof(*am.entries) * (am.used - replace_end));
+
+ memcpy(am.entries + replace_start,
+ replacements,
+ sizeof(*am.entries) * nreplacements);
+
+ am.used= new_used;
+ if (replacements != &new)
+ /* we don't bother freeing the actual array elements because
+ * if replacements!=&new the array is only full if we're
+ * committed and have already copied the values into the actual
+ * AddrMap_Value. */
+ TFREE(replacements);
+
+ return TCL_OK;
+}
+
+/*---------- other substantial operations on mask maps ----------*/
+
+int do_addrmap_lookup(ClientData cd, Tcl_Interp *ip,
+ Tcl_Obj *mapo, HBytes_Value addrhb, Tcl_Obj *def,
+ Tcl_Obj **result) {
+ AddrMap_Value *am= (void*)&mapo->internalRep;
+ const Byte *addr= hbytes_data(&addrhb);
+ int addrbytes= hbytes_len(&addrhb);
+ int i, addrbits, place;
+ Search_Result sr;
+
+ addrbits= addrbytes * 8;
+ sr= am_search(am, addr, addrbits, &place);
+
+ switch (sr) {
+
+ case sr_notfound:
+ if (!def) return staticerr(ip, "address not found in addr-map",
+ "HBYTES ADDRMAP NOMATCH");
+ *result= def;
+ break;
+
+ case sr_aroundsmall:
+ return staticerr(ip, "address shorter than mask in map",
+ "HBYTES ADDRMAP UNDERRUN");
+
+ case sr_exact:
+ case sr_inbig:
+ *result= am.entres[place].data;
+ break;
+
+ }
+
+ return TCL_OK;
+}
+
+/*---------- Tcl type and arg parsing functions ----------*/
+
--- /dev/null
+# maskmap - Tcl extension for address mask map data structures
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+Table *maskmaptoplevel TopLevel_Command
+ addr-map
+ subcmd enum(AddrMap/_SubCommand, "addr-map subcommand")
+ ... obj
+
+Table addrmap AddrMap_SubCommand
+ lookup
+ map constv(&cht_addrmap_type)
+ addr hb
+ ?def obj
+ => obj
+ amend-range
+ map addrmapv
+ start hb
+ end hb
+ data obj
+ amend-mask
+ map addrmapv
+ prefix hb
+ preflen obj
+ data obj
+
--- /dev/null
+BASE_DIR = ../base
+EXTBASE = tuntap
+CFILES = tuntap
+OTHER_TCTS = ../hbytes/hbytes-base.tct
+OTHER_EXTS = hbytes/hbytes dgram/dgram
+##LDLIBS += -ladns
+
+include ../base/extension.make
+
--- /dev/null
+/*
+ * tuntap - Tcl bindings for tun/tap userspace network interfaces
+ * Copyright 2006-2012 Ian Jackson
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this library; if not, see <http://www.gnu.org/licenses/>.
+ */
+
+#ifndef TUNTAPTCL_H
+#define TUNTAPTCL_H
+
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <sys/ioctl.h>
+#include <linux/if.h>
+#include <linux/if_tun.h>
+
+#include "hbytes.h"
+#include "dgram.h"
+#include "tuntap+tcmdif.h"
+
+/* from tuntap.c */
+
+extern const IdDataSpec cht_tuntap_socks;
+
+#endif /*TUNTAPTCL_H*/
--- /dev/null
+/*
+ */
+/*
+ * tuntap-socket-raw create [<ifname>] => <sockid>
+ * tuntap-socket-raw ifname <sockid> => <ifname>
+ * tuntap-socket-raw close <sockid>
+ * tuntap-socket-raw receive <sockid> <data>
+ * tuntap-socket-raw on-transmit <sockid> <mtu> [<script>]
+ * calls, effectively, eval <script> [list <data> <socket>]
+ * if script not supplied, cancel
+ */
+
+#include "chiark_tcl_tuntap.h"
+
+typedef struct TunSocket {
+ int ix, fd, script_llength;
+ Tcl_Interp *ip;
+ ScriptToInvoke script;
+ int mtu;
+ unsigned char *msg_buf;
+ char *ifname;
+} TuntapSocket;
+
+int cht_do_tuntapsocket_create_tun(ClientData cd, Tcl_Interp *ip,
+ const char *ifname, void **sock_r) {
+ int fd, r;
+ struct ifreq ifr;
+ TuntapSocket *sock;
+
+ memset(&ifr,0,sizeof(ifr));
+ ifr.ifr_flags= IFF_TUN | IFF_NO_PI;
+
+ if (ifname) {
+ if (strlen(ifname) > IFNAMSIZ-1) return
+ cht_staticerr(ip,"tun interface name too long","TUNTAP IFNAME LENGTH");
+ strcpy(ifr.ifr_name, ifname);
+ }
+
+ fd= open("/dev/net/tun", O_RDWR);
+ if (fd<0) return cht_posixerr(ip,errno,"open /dev/net/tun");
+
+ r= cht_setnonblock(fd,1);
+ if (r) return cht_posixerr(ip,errno,"setnonblock tun");
+
+ r= ioctl(fd, TUNSETIFF, (void*)&ifr);
+ if (r) return cht_newfdposixerr(ip,fd,"ioctl TUNSETIFF");
+
+ sock= TALLOC(sizeof(TuntapSocket));
+ sock->ix= -1;
+ sock->fd= fd;
+ sock->mtu= 0;
+ sock->msg_buf= 0;
+ sock->ifname= TALLOC(strlen(ifr.ifr_name)+1);
+ strcpy(sock->ifname, ifr.ifr_name);
+ cht_scriptinv_init(&sock->script);
+
+ *sock_r= sock;
+ return TCL_OK;
+}
+
+int cht_do_tuntapsocket_receive(ClientData cd, Tcl_Interp *ip,
+ void *sock_v, HBytes_Value data) {
+ TuntapSocket *sock= sock_v;
+ int l, r;
+
+ r= write(sock->fd,
+ cht_hb_data(&data), l=cht_hb_len(&data));
+ if (r==-1) return cht_posixerr(ip,errno,"write tuntap");
+ else if (r!=l) return cht_staticerr(ip,"write tuntap gave wrong answer",0);
+ return TCL_OK;
+}
+
+int cht_do_tuntapsocket_ifname(ClientData cd, Tcl_Interp *ip,
+ void *sock_v, const char **result) {
+ TuntapSocket *sock= sock_v;
+ *result= sock->ifname;
+ return TCL_OK;
+}
+
+static void cancel(TuntapSocket *sock) {
+ if (sock->script.script) {
+ cht_scriptinv_cancel(&sock->script);
+ Tcl_DeleteFileHandler(sock->fd);
+ TFREE(sock->msg_buf);
+ sock->msg_buf= 0;
+ }
+}
+
+static void read_call(ClientData sock_cd, int mask) {
+ TuntapSocket *sock= (void*)sock_cd;
+ Tcl_Interp *ip= sock->ip;
+ int rc;
+ ssize_t sz;
+ HBytes_Value message_val;
+ Tcl_Obj *args[2];
+
+ for (;;) {
+ sz= read(sock->fd, sock->msg_buf, sock->mtu);
+ if (sz == -1) {
+ if (errno == EAGAIN || errno == EWOULDBLOCK) rc=0;
+ else rc= cht_posixerr(ip,errno,"read tuntap");
+ goto x_rc;
+ }
+
+ assert(sz <= sock->mtu);
+
+ cht_hb_array(&message_val, sock->msg_buf, sz);
+ args[0]= cht_ret_hb(ip, message_val); cht_hb_empty(&message_val);
+ args[1]= cht_ret_iddata(ip, sock, &cht_tuntap_socks);
+ cht_scriptinv_invoke(&sock->script, 2, args);
+ }
+
+x_rc:
+ if (rc) Tcl_BackgroundError(ip);
+}
+
+int cht_do_tuntapsocket_on_transmit(ClientData cd, Tcl_Interp *ip,
+ void *sock_v,
+ long mtu, Tcl_Obj *newscript) {
+ TuntapSocket *sock= sock_v;
+ int rc;
+
+ if (mtu > 65536)
+ return cht_staticerr(ip,"tuntap mtu >2^16","TUNTAP MTU OVERRUN");
+
+ cancel(sock);
+
+ if (newscript) {
+ rc= cht_scriptinv_set(&sock->script,ip,newscript,0);
+ if (rc) return rc;
+
+ sock->mtu= mtu;
+ sock->msg_buf= TALLOC(mtu);
+ Tcl_CreateFileHandler(sock->fd, TCL_READABLE, read_call, sock);
+ }
+ return TCL_OK;
+}
+
+static void destroy(void *sock_v) {
+ TuntapSocket *sock= sock_v;
+ cancel(sock);
+ close(sock->fd); /* nothing useful to be done with errors */
+ TFREE(sock->msg_buf);
+ TFREE(sock);
+}
+
+static void destroy_idtabcb(Tcl_Interp *ip, void *sock_v) {
+ destroy(sock_v);
+}
+
+int cht_do_tuntapsocket_close(ClientData cd, Tcl_Interp *ip, void *sock) {
+ cht_tabledataid_disposing(ip,sock,&cht_tuntap_socks);
+ destroy(sock);
+ return TCL_OK;
+}
+
+const IdDataSpec cht_tuntap_socks= {
+ "tuntap", "tuntap-table", destroy_idtabcb
+};
+
+CHT_INIT(tuntap, { }, CHTI_COMMANDS(cht_tuntaptoplevel_entries))
--- /dev/null
+# tuntap - Tcl extension for tun/tap network device
+# Copyright 2006-2012 Ian Jackson
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2 of the
+# License, or (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+Table *tuntaptoplevel TopLevel_Command
+ tuntap-socket
+ dispatch(TunTapSocket/_SubCommand,"tuntap-socket-raw subcommand")
+
+Table tuntapsocket TunTapSocket_SubCommand
+ create-tun
+ ?ifname string
+ => iddata(&cht_tuntap_socks)
+ close
+ sock iddata(&cht_tuntap_socks)
+ ifname
+ sock iddata(&cht_tuntap_socks)
+ => string
+ receive
+ sock iddata(&cht_tuntap_socks)
+ data hb
+ on-transmit
+ sock iddata(&cht_tuntap_socks)
+ mtu long
+ ?script obj
+
~ian / chiark-tcl.git / commitdiff