From 6fd9d63aabc27f4bffc59fcb84e19792cfed6294 Mon Sep 17 00:00:00 2001 From: Sergei Golovan Date: Tue, 15 Oct 2013 18:12:46 +0100 Subject: [PATCH] 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). # imported from the archive --- Makefile | 14 + adns/Makefile | 7 + adns/adns.c | 814 ++++++++++++++++++++++++++++++ adns/adns.tct | 55 +++ adns/chiark_tcl_adns.h | 33 ++ base/Makefile | 32 ++ base/base.tct | 26 + base/chiark-tcl-base.h | 24 + base/chiark-tcl.h | 229 +++++++++ base/common.make | 47 ++ base/enum.c | 129 +++++ base/extension.make | 44 ++ base/final.make | 30 ++ base/hook.c | 123 +++++ base/idtable.c | 216 ++++++++ base/parse.c | 103 ++++ base/scriptinv.c | 91 ++++ base/shlib.make | 27 + base/tcmdifgen | 575 ++++++++++++++++++++++ base/tcmdiflib.c | 44 ++ cdb/Makefile | 35 ++ cdb/cdb.tct | 135 +++++ cdb/chiark_tcl_cdb.h | 60 +++ cdb/lookup.c | 65 +++ cdb/readonly.c | 95 ++++ cdb/writeable.c | 985 +++++++++++++++++++++++++++++++++++++ crypto/Makefile | 26 + crypto/algtables.c | 110 +++++ crypto/bcmode.c | 135 +++++ crypto/chiark_tcl_crypto.h | 28 ++ crypto/crypto.c | 453 +++++++++++++++++ crypto/crypto.h | 105 ++++ crypto/crypto.tct | 96 ++++ crypto/hash.c | 89 ++++ crypto/hook.c | 24 + debian/README | 44 ++ debian/changelog | 119 +++++ debian/compat | 1 + debian/control | 40 ++ debian/copyright | 23 + debian/extractdoc | 14 + debian/lintian-overrides | 14 + debian/rules | 95 ++++ dgram/Makefile | 25 + dgram/chiark_tcl_dgram.h | 21 + dgram/dgram.c | 173 +++++++ dgram/dgram.h | 47 ++ dgram/dgram.tct | 37 ++ dgram/hook.c | 21 + dgram/misc.c | 14 + dgram/sockaddr.c | 191 +++++++ hbytes/Makefile | 24 + hbytes/chiark_tcl_hbytes.h | 41 ++ hbytes/chop.c | 104 ++++ hbytes/hbytes-base.tct | 27 + hbytes/hbytes.c | 175 +++++++ hbytes/hbytes.h | 258 ++++++++++ hbytes/hbytes.tct | 132 +++++ hbytes/hook.c | 320 ++++++++++++ hbytes/parse.c | 42 ++ hbytes/ulongs.c | 324 ++++++++++++ maskmap/addrmap.c | 307 ++++++++++++ maskmap/maskmap-bits.c | 34 ++ maskmap/maskmap.c | 389 +++++++++++++++ maskmap/maskmap.tct | 39 ++ tuntap/Makefile | 9 + tuntap/chiark_tcl_tuntap.h | 36 ++ tuntap/tuntap.c | 161 ++++++ tuntap/tuntap.tct | 38 ++ 69 files changed, 8443 insertions(+) create mode 100644 Makefile create mode 100644 adns/Makefile create mode 100644 adns/adns.c create mode 100644 adns/adns.tct create mode 100644 adns/chiark_tcl_adns.h create mode 100644 base/Makefile create mode 100644 base/base.tct create mode 100644 base/chiark-tcl-base.h create mode 100644 base/chiark-tcl.h create mode 100644 base/common.make create mode 100644 base/enum.c create mode 100644 base/extension.make create mode 100644 base/final.make create mode 100644 base/hook.c create mode 100644 base/idtable.c create mode 100644 base/parse.c create mode 100644 base/scriptinv.c create mode 100644 base/shlib.make create mode 100755 base/tcmdifgen create mode 100644 base/tcmdiflib.c create mode 100644 cdb/Makefile create mode 100644 cdb/cdb.tct create mode 100644 cdb/chiark_tcl_cdb.h create mode 100644 cdb/lookup.c create mode 100644 cdb/readonly.c create mode 100644 cdb/writeable.c create mode 100644 crypto/Makefile create mode 100644 crypto/algtables.c create mode 100644 crypto/bcmode.c create mode 100644 crypto/chiark_tcl_crypto.h create mode 100644 crypto/crypto.c create mode 100644 crypto/crypto.h create mode 100644 crypto/crypto.tct create mode 100644 crypto/hash.c create mode 100644 crypto/hook.c create mode 100644 debian/README create mode 100644 debian/changelog create mode 100644 debian/compat create mode 100644 debian/control create mode 100644 debian/copyright create mode 100644 debian/extractdoc create mode 100644 debian/lintian-overrides create mode 100755 debian/rules create mode 100644 dgram/Makefile create mode 100644 dgram/chiark_tcl_dgram.h create mode 100644 dgram/dgram.c create mode 100644 dgram/dgram.h create mode 100644 dgram/dgram.tct create mode 100644 dgram/hook.c create mode 100644 dgram/misc.c create mode 100644 dgram/sockaddr.c create mode 100644 hbytes/Makefile create mode 100644 hbytes/chiark_tcl_hbytes.h create mode 100644 hbytes/chop.c create mode 100644 hbytes/hbytes-base.tct create mode 100644 hbytes/hbytes.c create mode 100644 hbytes/hbytes.h create mode 100644 hbytes/hbytes.tct create mode 100644 hbytes/hook.c create mode 100644 hbytes/parse.c create mode 100644 hbytes/ulongs.c create mode 100644 maskmap/addrmap.c create mode 100644 maskmap/maskmap-bits.c create mode 100644 maskmap/maskmap.c create mode 100644 maskmap/maskmap.tct create mode 100644 tuntap/Makefile create mode 100644 tuntap/chiark_tcl_tuntap.h create mode 100644 tuntap/tuntap.c create mode 100644 tuntap/tuntap.tct diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..e815676 --- /dev/null +++ b/Makefile @@ -0,0 +1,14 @@ + +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 +# % diff --git a/adns/Makefile b/adns/Makefile new file mode 100644 index 0000000..869d890 --- /dev/null +++ b/adns/Makefile @@ -0,0 +1,7 @@ +BASE_DIR = ../base +EXTBASE = adns +CFILES = adns +LDLIBS += -ladns + +include ../base/extension.make + diff --git a/adns/adns.c b/adns/adns.c new file mode 100644 index 0000000..7dde69c --- /dev/null +++ b/adns/adns.c @@ -0,0 +1,814 @@ +/* + * 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 . + */ + +#define _GNU_SOURCE + +#include + +#include + +#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; + inrrs; + 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)) diff --git a/adns/adns.tct b/adns/adns.tct new file mode 100644 index 0000000..74ef451 --- /dev/null +++ b/adns/adns.tct @@ -0,0 +1,55 @@ +# 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 . + + +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) + diff --git a/adns/chiark_tcl_adns.h b/adns/chiark_tcl_adns.h new file mode 100644 index 0000000..40cb735 --- /dev/null +++ b/adns/chiark_tcl_adns.h @@ -0,0 +1,33 @@ +/* + * 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 . + */ + +#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*/ diff --git a/base/Makefile b/base/Makefile new file mode 100644 index 0000000..1bbfd21 --- /dev/null +++ b/base/Makefile @@ -0,0 +1,32 @@ +# 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 . + +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 diff --git a/base/base.tct b/base/base.tct new file mode 100644 index 0000000..27ea098 --- /dev/null +++ b/base/base.tct @@ -0,0 +1,26 @@ +# 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 . + + +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 diff --git a/base/chiark-tcl-base.h b/base/chiark-tcl-base.h new file mode 100644 index 0000000..303e72d --- /dev/null +++ b/base/chiark-tcl-base.h @@ -0,0 +1,24 @@ +/* + * 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 . + */ + + +#include +#include + +#include "chiark-tcl.h" +#include "base+tcmdif.h" diff --git a/base/chiark-tcl.h b/base/chiark-tcl.h new file mode 100644 index 0000000..2f4ae7d --- /dev/null +++ b/base/chiark-tcl.h @@ -0,0 +1,229 @@ +/* + * 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 . + */ + +#ifndef CHIARK_TCL_H +#define CHIARK_TCL_H + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#ifndef _TCL /* if someone already included some tcl.h, use that */ +#include +#endif /*_TCL*/ + +#include + +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(, + * , + * ) + * where + * + * is the short name eg `hbytes' + * and should correspond to EXTBASE from the Makefile. + * + * 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. + * + * 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 + * initialisations) and also when another extension declares a + * dependency on this one with CHTI_OTHER. + * + * Both and 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__entries) + * where the .tct file contains + * Table * TopLevel_Command + * + * CHTI_OTHER() + * which does the of that extension + * (if they have not already been done). + * + * CHTI_TYPE(cht__type) + * where extern Tcl_ObjType cht__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*/ diff --git a/base/common.make b/base/common.make new file mode 100644 index 0000000..b0d4bae --- /dev/null +++ b/base/common.make @@ -0,0 +1,47 @@ +# 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 . + + +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 + diff --git a/base/enum.c b/base/enum.c new file mode 100644 index 0000000..28189c7 --- /dev/null +++ b/base/enum.c @@ -0,0 +1,129 @@ +/* + * 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 . + */ + +#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; itypePtr == &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; +} diff --git a/base/extension.make b/base/extension.make new file mode 100644 index 0000000..23e72ee --- /dev/null +++ b/base/extension.make @@ -0,0 +1,44 @@ +# 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 . + + + +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 diff --git a/base/final.make b/base/final.make new file mode 100644 index 0000000..12db93d --- /dev/null +++ b/base/final.make @@ -0,0 +1,30 @@ +# 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 . + + +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)) + diff --git a/base/hook.c b/base/hook.c new file mode 100644 index 0000000..6e4b3a1 --- /dev/null +++ b/base/hook.c @@ -0,0 +1,123 @@ +/* + * 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 . + */ + +#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); +} diff --git a/base/idtable.c b/base/idtable.c new file mode 100644 index 0000000..6e7aafa --- /dev/null +++ b/base/idtable.c @@ -0,0 +1,216 @@ +/* + * 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 . + */ + +#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; ixn; 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; ixn && 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 (ixn) 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 +}; diff --git a/base/parse.c b/base/parse.c new file mode 100644 index 0000000..ad9b7e7 --- /dev/null +++ b/base/parse.c @@ -0,0 +1,103 @@ +/* + * 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 . + */ + +#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); +} diff --git a/base/scriptinv.c b/base/scriptinv.c new file mode 100644 index 0000000..7b67d29 --- /dev/null +++ b/base/scriptinv.c @@ -0,0 +1,91 @@ +/* + * 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 . + */ + +#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; iscript); + 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; iipq); +} diff --git a/base/shlib.make b/base/shlib.make new file mode 100644 index 0000000..c48fe4c --- /dev/null +++ b/base/shlib.make @@ -0,0 +1,27 @@ +# 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 . + + + +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) diff --git a/base/tcmdifgen b/base/tcmdifgen new file mode 100755 index 0000000..f944799 --- /dev/null +++ b/base/tcmdifgen @@ -0,0 +1,575 @@ +#!/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 . + + +# 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\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 *@ diff --git a/base/tcmdiflib.c b/base/tcmdiflib.c new file mode 100644 index 0000000..e14eba0 --- /dev/null +++ b/base/tcmdiflib.c @@ -0,0 +1,44 @@ +/* + * 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 . + */ + +#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); +} diff --git a/cdb/Makefile b/cdb/Makefile new file mode 100644 index 0000000..9f4cfa4 --- /dev/null +++ b/cdb/Makefile @@ -0,0 +1,35 @@ +# 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 . + + +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> diff --git a/cdb/cdb.tct b/cdb/cdb.tct new file mode 100644 index 0000000..889e72a --- /dev/null +++ b/cdb/cdb.tct @@ -0,0 +1,135 @@ +# 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 . + + +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: + # .main + # .lock + # .cdb + # .jrn + # .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 ...: + # on_info open-clean + # on_info open-dirty-start + # on_info open-dirty-junk \ + # + # on_info open-dirty-done + # on_info compact-start + # on_info compact-done + # on_info close + 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; diff --git a/cdb/chiark_tcl_cdb.h b/cdb/chiark_tcl_cdb.h new file mode 100644 index 0000000..fef668c --- /dev/null +++ b/cdb/chiark_tcl_cdb.h @@ -0,0 +1,60 @@ +/* + * 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 . + */ + +#ifndef CHIARK_TCL_CDB_H +#define CHIARK_TCL_CDB_H + +#include +#include +#include +#include + +#include +#include + +#include + +#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*/ diff --git a/cdb/lookup.c b/cdb/lookup.c new file mode 100644 index 0000000..fb73f1f --- /dev/null +++ b/cdb/lookup.c @@ -0,0 +1,65 @@ +/* + * 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 . + */ + +#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)) diff --git a/cdb/readonly.c b/cdb/readonly.c new file mode 100644 index 0000000..53823b8 --- /dev/null +++ b/cdb/readonly.c @@ -0,0 +1,95 @@ +/* + * 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 . + */ + +#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); +} diff --git a/cdb/writeable.c b/cdb/writeable.c new file mode 100644 index 0000000..6b072ff --- /dev/null +++ b/cdb/writeable.c @@ -0,0 +1,985 @@ +/* + * 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 . + */ + +#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); +} diff --git a/crypto/Makefile b/crypto/Makefile new file mode 100644 index 0000000..8633082 --- /dev/null +++ b/crypto/Makefile @@ -0,0 +1,26 @@ +# 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 . + + +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 + diff --git a/crypto/algtables.c b/crypto/algtables.c new file mode 100644 index 0000000..e0d6cc8 --- /dev/null +++ b/crypto/algtables.c @@ -0,0 +1,110 @@ +/* + * 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 . + */ + + +#include "chiark_tcl_crypto.h" + +#include +#include +#include +#include +#include +#include + +#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 } +}; diff --git a/crypto/bcmode.c b/crypto/bcmode.c new file mode 100644 index 0000000..9545af3 --- /dev/null +++ b/crypto/bcmode.c @@ -0,0 +1,135 @@ +/* + * 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 . + */ + + +#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 } +}; diff --git a/crypto/chiark_tcl_crypto.h b/crypto/chiark_tcl_crypto.h new file mode 100644 index 0000000..8ff4cbf --- /dev/null +++ b/crypto/chiark_tcl_crypto.h @@ -0,0 +1,28 @@ +/* + * 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 . + */ + + +#include +#include +#include + +#include + +#include "hbytes.h" +#include "crypto.h" +#include "crypto+tcmdif.h" diff --git a/crypto/crypto.c b/crypto/crypto.c new file mode 100644 index 0000000..aee2556 --- /dev/null +++ b/crypto/crypto.c @@ -0,0 +1,453 @@ +/* + * 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 . + */ + + +#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; iinternalRep.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 + * key->beta = state after H(K XOR opad + * 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; iblocksize; 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; iblocksize; 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; +} diff --git a/crypto/crypto.h b/crypto/crypto.h new file mode 100644 index 0000000..13b5654 --- /dev/null +++ b/crypto/crypto.h @@ -0,0 +1,105 @@ +/* + * 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 . + */ + + +#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*/ diff --git a/crypto/crypto.tct b/crypto/crypto.tct new file mode 100644 index 0000000..37794db --- /dev/null +++ b/crypto/crypto.tct @@ -0,0 +1,96 @@ +# 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 . + + +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; diff --git a/crypto/hash.c b/crypto/hash.c new file mode 100644 index 0000000..f7c6c44 --- /dev/null +++ b/crypto/hash.c @@ -0,0 +1,89 @@ +/* + * 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 . + */ + + +#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 +}; diff --git a/crypto/hook.c b/crypto/hook.c new file mode 100644 index 0000000..00ca7c5 --- /dev/null +++ b/crypto/hook.c @@ -0,0 +1,24 @@ +/* + * 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 . + */ + + +#include "chiark_tcl_crypto.h" + +CHT_INIT(crypto, + CHTI_OTHER(hbytes) CHTI_TYPE(cht_blockcipherkey_type), + CHTI_COMMANDS(cht_hbcryptotoplevel_entries)) diff --git a/debian/README b/debian/README new file mode 100644 index 0000000..7102c8a --- /dev/null +++ b/debian/README @@ -0,0 +1,44 @@ + chiark-tcl - some useful Tcl bindings + ------------------------------------- + +This package contains, basically, shared libraries + chiark_tcl_-1.so +in /usr/lib. + +Each of these is a Tcl extension which can be loaded into a Tcl +interpreter with + load chiark_tcl_-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: + + .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. + + .[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. diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..9368743 --- /dev/null +++ b/debian/changelog @@ -0,0 +1,119 @@ +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 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 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 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 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 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 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 with 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 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 Thu, 30 Mar 2006 18:34:51 +0100 diff --git a/debian/compat b/debian/compat new file mode 100644 index 0000000..7ed6ff8 --- /dev/null +++ b/debian/compat @@ -0,0 +1 @@ +5 diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..7aa0918 --- /dev/null +++ b/debian/control @@ -0,0 +1,40 @@ +Source: chiark-tcl +Maintainer: Ian Jackson +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 . diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..24265ae --- /dev/null +++ b/debian/copyright @@ -0,0 +1,23 @@ +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 . + + +A copy of the GNU General Public License, version 2, should be +installed on your Debian system in /usr/share/common-licenses/GPL. diff --git a/debian/extractdoc b/debian/extractdoc new file mode 100644 index 0000000..318c8cc --- /dev/null +++ b/debian/extractdoc @@ -0,0 +1,14 @@ +#!/usr/bin/perl -w +$o= ''; +for (;;) { + exit 0 unless defined ($_= ); + $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 $!; diff --git a/debian/lintian-overrides b/debian/lintian-overrides new file mode 100644 index 0000000..654fd7b --- /dev/null +++ b/debian/lintian-overrides @@ -0,0 +1,14 @@ +# 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 diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..faa763a --- /dev/null +++ b/debian/rules @@ -0,0 +1,95 @@ +#!/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 . + + +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 diff --git a/dgram/Makefile b/dgram/Makefile new file mode 100644 index 0000000..e07cfca --- /dev/null +++ b/dgram/Makefile @@ -0,0 +1,25 @@ +# 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 . + + +BASE_DIR = ../base +EXTBASE = dgram +CFILES = dgram misc sockaddr hook +OTHER_TCTS = ../hbytes/hbytes-base.tct +OTHER_EXTS = hbytes/hbytes + +include ../base/extension.make + diff --git a/dgram/chiark_tcl_dgram.h b/dgram/chiark_tcl_dgram.h new file mode 100644 index 0000000..2fd88e4 --- /dev/null +++ b/dgram/chiark_tcl_dgram.h @@ -0,0 +1,21 @@ +/* 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 . + */ + + +#include "hbytes.h" +#include "dgram.h" +#include "dgram+tcmdif.h" diff --git a/dgram/dgram.c b/dgram/dgram.c new file mode 100644 index 0000000..24c5446 --- /dev/null +++ b/dgram/dgram.c @@ -0,0 +1,173 @@ +/* + */ +/* + * dgram-socket create => + * dgram-socket close + * dgram-socket transmit + * dgram-socket on-receive [