chiark-tcl/ 0000775 0000000 0000000 00000000000 13041662524 007772 5 ustar chiark-tcl/.gitignore 0000664 0000000 0000000 00000000310 13041654034 011751 0 ustar *~
*.o
*.so
*.d
*.test.tcl
*+tcmdif.[ch]
debian/files
debian/libtcl-chiark-1
debian/libtcl-chiark-1.debhelper.log
debian/libtcl-chiark-1.*.debhelper
debian/libtcl-chiark-1.substvars
debian/.debhelper
chiark-tcl/Makefile 0000664 0000000 0000000 00000001142 13041654034 011425 0 ustar
SUBDIRS= base adns hbytes cdb crypto dgram
ifneq ($(wildcard /usr/include/linux/if_tun.h),)
SUBDIRS+= tuntap
endif
ifneq ($(wildcard /usr/include/wiringPi.h /usr/include/arm-*/wiringPi.h),)
SUBDIRS+= wiringpi
endif
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
# %
chiark-tcl/adns/ 0000775 0000000 0000000 00000000000 13063446750 010724 5 ustar chiark-tcl/adns/Makefile 0000664 0000000 0000000 00000000142 11762372314 012357 0 ustar BASE_DIR = ../base
EXTBASE = adns
CFILES = adns
LDLIBS += -ladns
include ../base/extension.make
chiark-tcl/adns/adns.c 0000664 0000000 0000000 00000053476 11762372314 012032 0 ustar /*
* 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))
chiark-tcl/adns/adns.tct 0000664 0000000 0000000 00000002665 11762372314 012374 0 ustar # 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)
chiark-tcl/adns/chiark_tcl_adns.h 0000664 0000000 0000000 00000001716 11762372314 014210 0 ustar /*
* 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*/
chiark-tcl/base/ 0000775 0000000 0000000 00000000000 13063446750 010711 5 ustar chiark-tcl/base/Makefile 0000664 0000000 0000000 00000001711 11762372314 012347 0 ustar # 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
chiark-tcl/base/base.tct 0000664 0000000 0000000 00000001673 11762372314 012344 0 ustar # 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
chiark-tcl/base/chiark-tcl-base.h 0000664 0000000 0000000 00000001465 11762372314 014017 0 ustar /*
* 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"
chiark-tcl/base/chiark-tcl.h 0000664 0000000 0000000 00000020320 11762372314 013076 0 ustar /*
* 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*/
chiark-tcl/base/common.make 0000664 0000000 0000000 00000002612 12726256107 013041 0 ustar # 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.5
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
chiark-tcl/base/enum.c 0000664 0000000 0000000 00000007414 11762372314 012025 0 ustar /*
* 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;
}
chiark-tcl/base/extension.make 0000664 0000000 0000000 00000003431 12726256541 013567 0 ustar # 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)
OTHER_DIRS += ../base/
OTHER_DIRS += $(addprefix ../,$(dir $(OTHER_EXTS)))
OTHER_DIRS += .
null :=
space := $(null) #
$(SHLIB).test.tcl:
echo >$@ "load $(SHLIB).so"
test-load: $(SHLIB).so $(SHLIB).test.tcl
@set -x; LD_LIBRARY_PATH=$(subst $(space),:,$(strip $(OTHER_DIRS)))$${LD_LIBRARY_PATH+:}$${LD_LIBRARY_PATH} \
tclsh$(TCL_VERSION) $(SHLIB).test.tcl
include $(BASE_DIR)/final.make
chiark-tcl/base/final.make 0000664 0000000 0000000 00000001654 11762372314 012645 0 ustar # 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))
chiark-tcl/base/hook.c 0000664 0000000 0000000 00000005752 11762402332 012016 0 ustar /*
* 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);
}
chiark-tcl/base/idtable.c 0000664 0000000 0000000 00000012135 11762403141 012452 0 ustar /*
* 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
};
chiark-tcl/base/parse.c 0000664 0000000 0000000 00000005071 11762372314 012170 0 ustar /*
* 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);
}
chiark-tcl/base/scriptinv.c 0000664 0000000 0000000 00000004664 11762372314 013106 0 ustar /*
* 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);
}
chiark-tcl/base/shlib.make 0000664 0000000 0000000 00000001672 12725657670 012670 0 ustar # 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)
chiark-tcl/base/tcmdifgen 0000775 0000000 0000000 00000043503 11762372314 012602 0 ustar #!/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 *@
chiark-tcl/base/tcmdiflib.c 0000664 0000000 0000000 00000002516 11762372314 013014 0 ustar /*
* 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);
}
chiark-tcl/cdb/ 0000775 0000000 0000000 00000000000 13063446750 010527 5 ustar chiark-tcl/cdb/Makefile 0000664 0000000 0000000 00000002217 11762372314 012167 0 ustar # 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>
chiark-tcl/cdb/cdb.tct 0000664 0000000 0000000 00000007552 11762372314 012002 0 ustar # 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;
chiark-tcl/cdb/chiark_tcl_cdb.h 0000664 0000000 0000000 00000003526 13041655620 013613 0 ustar /*
* 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
#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*/
chiark-tcl/cdb/lookup.c 0000664 0000000 0000000 00000004323 11762372314 012204 0 ustar /*
* 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))
chiark-tcl/cdb/readonly.c 0000664 0000000 0000000 00000004741 11762372314 012514 0 ustar /*
* 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);
}
chiark-tcl/cdb/writeable.c 0000664 0000000 0000000 00000065135 13041655663 012664 0 ustar /*
* 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(offsetof(typeof(*hd), data) + 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);
}
chiark-tcl/crypto/ 0000775 0000000 0000000 00000000000 13063446750 011317 5 ustar chiark-tcl/crypto/Makefile 0000664 0000000 0000000 00000001645 11762372314 012763 0 ustar # 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
chiark-tcl/crypto/algtables.c 0000664 0000000 0000000 00000007173 11762372314 013427 0 ustar /*
* 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 }
};
chiark-tcl/crypto/bcmode.c 0000664 0000000 0000000 00000007506 11762372314 012722 0 ustar /*
* 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 }
};
chiark-tcl/crypto/chiark_tcl_crypto.h 0000664 0000000 0000000 00000001617 11762372314 015176 0 ustar /*
* 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"
chiark-tcl/crypto/crypto.c 0000664 0000000 0000000 00000031742 11762372314 013010 0 ustar /*
* 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;
}
chiark-tcl/crypto/crypto.h 0000664 0000000 0000000 00000006432 11762372314 013013 0 ustar /*
* 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*/
chiark-tcl/crypto/crypto.tct 0000664 0000000 0000000 00000004352 11762372314 013355 0 ustar # 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;
chiark-tcl/crypto/hash.c 0000664 0000000 0000000 00000005072 11762372314 012410 0 ustar /*
* 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
};
chiark-tcl/crypto/hook.c 0000664 0000000 0000000 00000001617 11762372314 012426 0 ustar /*
* 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))
chiark-tcl/debian/ 0000775 0000000 0000000 00000000000 13063446750 011221 5 ustar chiark-tcl/debian/README 0000664 0000000 0000000 00000003417 10414062765 012103 0 ustar 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.
chiark-tcl/debian/changelog 0000664 0000000 0000000 00000015122 13063446750 013074 0 ustar chiark-tcl (1.2.1) unstable; urgency=high
* Multiarch: Use correct M-A triplet (DEB_HOST_MULTIARCH) for
libsubdir. Closes:#856526.
-- Ian Jackson Sun, 19 Mar 2017 09:22:48 +0000
chiark-tcl (1.2.0) unstable; urgency=medium
* wiringpi module. Built only if the wiringpi headers are actually
installed (so not in the official Debian release).
* Update .gitignore for recent debhelper droppings.
* Do not build tuntap on non-Linux platforms. Ideally this would
be replaced with similar functionality elsewhere, but for now
this change fixes the FTBFS on Debian hurd-* and kfreebsd-*.
* Update build-dependencies to permit tcl8.6. Closes:#818475.
* Replace ad-hocery with use of offsetof/typeof. Closes:#812718.
* Honour dpkg-architecture's DEB_HOST_GNU_TYPE, to fix cross-building.
* Multiarch: Move .so's to triplet paths, and declare M-A: same.
-- Ian Jackson Tue, 24 Jan 2017 14:32:11 +0000
chiark-tcl (1.1.3) unstable; urgency=low
* Build-Depends: Add tcl8.5-dev to the front of the list of
possibilities. Current Tcl packages do not provide tcl-dev, and no
earlier version than 8.5 is, in fact, in jessie (8.4 was removed in
April 2014). Closes:#775635. (FTBFS)
-- Ian Jackson Thu, 22 Jan 2015 19:00:22 +0000
chiark-tcl (1.1.2) unstable; urgency=low
* tuntap: Use not . Closes:#768766. (FTBFS)
* Build-Depends: move tcl-dev to the end, so that we prefer tcl8.4-dev.
This is necessary because we want to build against tcl8.4 in jessie
to avoid requiring a newer Tcl ABI.
* Reintroduce .gitignore which a build tool brokenly deleted.
* Remove .cvsignore files from git repo.
-- Ian Jackson Sun, 09 Nov 2014 12:44:18 +0000
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
chiark-tcl/debian/compat 0000664 0000000 0000000 00000000002 11762371023 012411 0 ustar 5
chiark-tcl/debian/control 0000664 0000000 0000000 00000003337 13041662170 012622 0 ustar 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), tcl8.6-dev | tcl8.5-dev | tcl8.4-dev | tcl8.3-dev | tcl8.2-dev | tcl-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}
Multi-arch: same
# 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 .
chiark-tcl/debian/copyright 0000664 0000000 0000000 00000001602 11762371263 013153 0 ustar 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.
chiark-tcl/debian/extractdoc 0000664 0000000 0000000 00000000470 10413026534 013273 0 ustar #!/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 $!;
chiark-tcl/debian/lintian-overrides 0000664 0000000 0000000 00000001352 11762367047 014610 0 ustar # 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
chiark-tcl/debian/rules 0000775 0000000 0000000 00000005253 13063446573 012311 0 ustar #!/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))
march := $(shell dpkg-architecture -q DEB_HOST_MULTIARCH)
libsubdir = /$(march)
garch := $(shell dpkg-architecture -q DEB_HOST_GNU_TYPE)
ifneq ($(garch),)
ifeq ($(origin CC),default)
export CC=$(garch)-gcc
endif
endif # $garch
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$(libsubdir)
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$(libsubdir)/.
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
chiark-tcl/dgram/ 0000775 0000000 0000000 00000000000 13063446750 011071 5 ustar chiark-tcl/dgram/Makefile 0000664 0000000 0000000 00000001561 11762372314 012532 0 ustar # 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
chiark-tcl/dgram/chiark_tcl_dgram.h 0000664 0000000 0000000 00000001435 11762372314 014520 0 ustar /* 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"
chiark-tcl/dgram/dgram.c 0000664 0000000 0000000 00000010344 11762372314 012327 0 ustar /*
*/
/*
* dgram-socket create =>
* dgram-socket close
* dgram-socket transmit
* dgram-socket on-receive [