From 40a4738e440a8412c61a12eca34ed6aa98d71a5a Mon Sep 17 00:00:00 2001 From: ian Date: Sat, 7 Jan 2006 16:16:56 +0000 Subject: [PATCH] initial import and build-faff, wip --- adns/.cvsignore | 2 + adns/Makefile | 6 + adns/adns.c | 49 +++-- adns/adns.tct | 41 +++++ adns/chiark_tcl_adns.h | 18 ++ base/.cvsignore | 2 + base/Makefile | 19 ++ base/base.tct | 11 ++ base/chiark-tcl.h | 384 +++++--------------------------------- base/common.make | 15 ++ base/extension.make | 19 ++ base/hook.c | 387 ++++----------------------------------- base/parse.c | 46 ++--- base/shlib.make | 8 + base/tables-examples.tct | 43 ----- base/tcmdifgen | 57 +++--- base/tcmdiflib.c | 15 +- base/tcmdiflib.h | 2 - base/troglodyte-Makefile | 55 ------ hbytes/hbglue.c | 23 +++ hbytes/hbytes.h | 1 - 21 files changed, 323 insertions(+), 880 deletions(-) create mode 100644 adns/.cvsignore create mode 100644 adns/Makefile create mode 100644 adns/adns.tct create mode 100644 adns/chiark_tcl_adns.h create mode 100644 base/.cvsignore create mode 100644 base/Makefile create mode 100644 base/base.tct create mode 100644 base/common.make create mode 100644 base/extension.make create mode 100644 base/shlib.make delete mode 100644 base/tcmdiflib.h create mode 100644 hbytes/hbglue.c diff --git a/adns/.cvsignore b/adns/.cvsignore new file mode 100644 index 0000000..6796ef3 --- /dev/null +++ b/adns/.cvsignore @@ -0,0 +1,2 @@ +tables.[ch] +*.d diff --git a/adns/Makefile b/adns/Makefile new file mode 100644 index 0000000..da86a24 --- /dev/null +++ b/adns/Makefile @@ -0,0 +1,6 @@ +BASE_DIR = ../base +EXTENSION = chiark-tcl-adns +CFILES = adns + +include ../base/extension.make + diff --git a/adns/adns.c b/adns/adns.c index d57c49b..5248c62 100644 --- a/adns/adns.c +++ b/adns/adns.c @@ -62,8 +62,9 @@ #include -#include "tables.h" -#include "hbytes.h" +#include + +#include "adnstcl.h" /*---------- important types and forward declarations ----------*/ @@ -119,7 +120,7 @@ static int oifn_fs(Tcl_Interp *ip, const OptionInfo *oi, Tcl_Obj *arg, static int oifn_reverse_any(Tcl_Interp *ip, const OptionInfo *oi, Tcl_Obj *arg, OptionParse *op) { - return pat_string(ip,arg,&op->reverseany); + return cht_pat_string(ip,arg,&op->reverseany); } #define OIFA1(t,f,r) { "-" #f, oifn_fa, 0, adns_##t##_##f, r } @@ -144,14 +145,14 @@ static int parse_options(Tcl_Interp *ip, int objc, Tcl_Obj *const *objv, objc--; objv++; for (;;) { if (!objc--) break; - rc= pat_enum(ip, *objv++, &oi_v, opttable, sizeof(OptionInfo), + 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--) { - setstringresult(ip,"missing value for option"); + cht_setstringresult(ip,"missing value for option"); return TCL_ERROR; } arg= *objv++; @@ -189,10 +190,10 @@ static int oifn_errfile(Tcl_Interp *ip, const OptionInfo *oi, int rc; const char *str; - rc= pat_string(ip,arg,&str); if (rc) return rc; + 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 staticerr(ip,"-errfile argument must be stderr or stdout",0); + else return cht_staticerr(ip,"-errfile argument must be stderr or stdout",0); op->aflags &= ~adns_if_noerrprint; op->errcallback= 0; @@ -209,7 +210,7 @@ static int oifn_errcallback(Tcl_Interp *ip, const OptionInfo *oi, static int oifn_config(Tcl_Interp *ip, const OptionInfo *oi, Tcl_Obj *arg, OptionParse *op) { - return pat_string(ip,arg,&op->config_string); + return cht_pat_string(ip,arg,&op->config_string); } static const OptionInfo resolver_optioninfos[]= { @@ -226,7 +227,7 @@ static const OptionInfo resolver_optioninfos[]= { }; static void adnslogfn_flushmessage(Resolver *res) { - scriptinv_invoke(&res->errcallback, 1, &res->errstring_accum); + cht_scriptinv_invoke(&res->errcallback, 1, &res->errstring_accum); Tcl_SetObjLength(res->errstring_accum, 0); } @@ -238,7 +239,7 @@ static void adnslogfn_callback(adns_state ads, void *logfndata, l= vasprintf(&str,fmt,al); if (l<0) { - posixerr(res->interp,errno,"construct adns log callback string"); + cht_posixerr(res->interp,errno,"construct adns log callback string"); Tcl_BackgroundError(res->interp); } @@ -290,7 +291,7 @@ static void destroy_resolver(Tcl_Interp *ip, Resolver *res) { res->ads= 0; } asynch_cancelhandlers(res); - scriptinv_cancel(&res->errcallback); + cht_scriptinv_cancel(&res->errcallback); Tcl_EventuallyFree(res, Tcl_Free); } @@ -301,8 +302,8 @@ static void destroy_resolver_defcb(ClientData resolver_v, Tcl_Interp *ip) { destroy_resolver(ip,resolver_v); } -int do_adns_destroy_resolver(ClientData cd, Tcl_Interp *ip, void *res_v) { - tabledataid_disposing(ip,res_v,&adnstcl_resolvers); +int cht_do_adns_destroy_resolver(ClientData cd, Tcl_Interp *ip, void *res_v) { + cht_tabledataid_disposing(ip,res_v,&adnstcl_resolvers); destroy_resolver(ip,res_v); return TCL_OK; } @@ -319,11 +320,11 @@ static int create_resolver(Tcl_Interp *ip, const OptionParse *op, res->timertoken= 0; res->maxfd= 0; for (i=0; i<3; i++) FD_ZERO(&res->handling[i]); - scriptinv_init(&res->errcallback); + cht_scriptinv_init(&res->errcallback); res->errstring_accum= 0; if (op->errcallback) - scriptinv_set(&res->errcallback, ip, op->errcallback, 0); + cht_scriptinv_set(&res->errcallback, ip, op->errcallback, 0); ec= adns_init_logfn(&res->ads, op->aflags | adns_if_noautosys, @@ -373,7 +374,7 @@ int do_adns_set_default_resolver(ClientData cd, Tcl_Interp *ip, void *res_v) { return TCL_OK; } -const IdDataSpec adnstcl_resolvers= { +static const IdDataSpec adnstcl_resolvers= { "adns-res", "adns-resolvers-table", destroy_resolver_idtabcb }; @@ -781,3 +782,19 @@ static void destroy_query_idtabcb(Tcl_Interp *interp, void *query_v) { const IdDataSpec adnstcl_queries= { "adns", "adns-query-table", destroy_query_idtabcb }; + +/*---------- main hooks for tcl ----------*/ + +int do_toplevel_adns(ClientData cd, Tcl_Interp *ip, + const Adns_SubCommand *subcmd, + int objc, Tcl_Obj *const *objv) { + return subcmd->func(0,ip,objc,objv); +} + +extern int Adns_Init(Tcl_Interp *ip); /* called by Tcl's "load" */ +int Adns_Init( + Tcl_RegisterObjType(&blockcipherkey_type); + Tcl_RegisterObjType(&sockaddr_type); + Tcl_RegisterObjType(&tabledataid_nearlytype); + Tcl_RegisterObjType(&ulong_type); + Tcl_RegisterObjType(&addrmap_type); diff --git a/adns/adns.tct b/adns/adns.tct new file mode 100644 index 0000000..dc62017 --- /dev/null +++ b/adns/adns.tct @@ -0,0 +1,41 @@ +H-Include "adnstcl.h" + +Type adnsresults: adns_answer *@ +Init adnsresults @=0; +Fini adnsresults free(@); + +Table toplevel TopLevel_Command + adns + subcmd enum(Adns_SubCommand,"adns subcommand") + ... obj + +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(&adnstcl_queries) + asynch-cancel + query iddata(&adnstcl_queries) + new-resolver + ... obj + => iddata(&adnstcl_resolvers) + set-default-resolver + res iddata(&adnstcl_resolvers) + destroy-resolver + res iddata(&adnstcl_resolvers) + diff --git a/adns/chiark_tcl_adns.h b/adns/chiark_tcl_adns.h new file mode 100644 index 0000000..de58251 --- /dev/null +++ b/adns/chiark_tcl_adns.h @@ -0,0 +1,18 @@ +/* + */ + +#ifndef ADNSTCL_H +#define ADNSTCL_H + +#include "chiark-tcl.h" + +typedef struct { + const char *name; + adns_rrtype number; +} AdnsTclRRTypeInfo; + +const IdDataSpec adnstcl_queries, adnstcl_resolvers; + +#include "tables.h" + +#endif /*ADNSTCL_H*/ diff --git a/base/.cvsignore b/base/.cvsignore new file mode 100644 index 0000000..6796ef3 --- /dev/null +++ b/base/.cvsignore @@ -0,0 +1,2 @@ +tables.[ch] +*.d diff --git a/base/Makefile b/base/Makefile new file mode 100644 index 0000000..314b2df --- /dev/null +++ b/base/Makefile @@ -0,0 +1,19 @@ +default: all + +SHLIB = chiark-tcl +CFILES = hook parse tcmdiflib +BASE_DIR = . + +AUTO_HDRS += tables.h +AUTO_SRCS += tables.c + +include common.make + +tables.c: $(BASE_TCT) $(TCMDIFGEN) + $(TCMDIFGEN) -wc -o$@ $< + +tables.h: $(BASE_TCT) $(TCMDIFGEN) + $(TCMDIFGEN) -wh -o$@ $< + +include shlib.make +include final.make diff --git a/base/base.tct b/base/base.tct new file mode 100644 index 0000000..0c4a5e6 --- /dev/null +++ b/base/base.tct @@ -0,0 +1,11 @@ +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 + +H-Include "chiark-tcl.h" diff --git a/base/chiark-tcl.h b/base/chiark-tcl.h index 206f97e..4c022cb 100644 --- a/base/chiark-tcl.h +++ b/base/chiark-tcl.h @@ -1,130 +1,8 @@ /* */ -/* - * hbytes raw2h BINARY => hex - * hbytes h2raw HEX => binary - * - * hbytes length VALUE => count - * hbytes prepend VAR [VALUE ...] = set VAR [concat VALUE ... $VAR] - * hbytes append VAR [VALUE ...] = set VAR [concat $VAR VALUE ...] - * hbytes concat VAR [VALUE ...] = set VAR [concat VALUE ...] - * hbytes unprepend VAR PREFIXLENGTH => prefix (removed from VAR) - * hbytes unappend VAR SUFFIXLENGTH => suffix (removed from VAR) - * hbytes chopto VAR NEWVARLENGTH => suffix (removed from VAR) - * (too short? error) - * - * hbytes range VALUE START SIZE => substring (or error) - * hbytes overwrite VAR START VALUE - * hbytes trimleft VAR removes any leading 0 octets - * hbytes repeat VALUE COUNT => COUNT copies of VALUE - * hbytes zeroes COUNT => COUNT zero bytes - * hbytes random COUNT => COUNT random bytes - * hbytes xor VAR VALUE $VAR (+)= VALUE - * - * hbytes ushort2h LONG => LONG must be <2^16, returns as hex - * hbytes h2ushort HEX => |HEX| must be 2 bytes, returns as ulong - * - * hbytes compare A B - * => -2 A is lexically earlier than B and not a prefix of B (A worked? (always 1 for p) - * hbytes pad pn|un VAR BS METH [METHARGS] => worked? (always 1 for p) - * hbytes pad pa|pn VAR ALG|BS pkcs5 => 1 - * hbytes pad ua|un VAR ALG|BS pkcs5 => worked? - * hbytes pad pa|pn VAR ALG|BS rfc2406 NXTHDR => 1 - * hbytes pad ua|un VAR ALG|BS rfc2406 NXTHDRVAR => worked? - * - * hbytes blockcipher d|e VAR ALG KEY MODE [IV] => IV - * hbytes blockcipher mac MSG ALG KEY MODE IV => final block - * hbytes blockcipher prop PROPERTY ALG => property value - * - * hbytes hash ALG MESSAGE => hash - * hbytes hmac ALG MESSAGE KEY [MACLENGTH] => mac - * hbytes hash-prop PROPERTY ALG => property value - * - * ulong ul2int ULONG => INT can fail if >INT_MAX - * ulong int2ul INT => ULONG can fail if <0 - * ulong mask A B => A & B - * ulong add A B => A + B (mod 2^32) - * ulong subtract A B => A - B (mod 2^32) - * ulong compare A B => 0 -1 (AB) - * ulong shift l|r ULONG BITS fails if BITS >32 - * - * ulong ul2bitfields VALUE [SIZE TYPE [TYPE-ARG...] ...] => 0/1 - * ulong bitfields2ul BASE [SIZE TYPE [TYPE-ARG...] ...] => ULONG - * goes from left (MSbit) to right (LSbit) where - * SIZE is size in bits - * TYPE [TYPE-ARGS...] is as below - * zero - * ignore - * fixed ULONG-VALUE - * uint VARNAME/VALUE (VARNAME if ul2bitfields; - * ulong VARNAME/VALUE VALUE if bitfields2ul) - * - * Address ranges (addrmap.c): - * - * An address range is a slightly efficient partial mapping from - * addresses to arbitrary data values. An address is a number of - * octets expressed as an hbytes. All the addresses covered by the - * same addrmap should have the same length. - * - * hbytes addr-map lookup MAP-VAR ADDRESS [DEFAULT] => DATA - * Error on missing default or if any prefix longer than ADDRESS. - * - * hbytes addr-map amend-range MAP-VAR START END DATA - * hbytes addr-map amend-mask MAP-VAR PREFIX PREFIX-LENGTH DATA - * Sets all of the addresses in PREFIX/PREFIX-LENGTH to the - * relevant value. - * - * Representation: - * An address map MAP is - * [list BIT-LENGTH \ - * [list START END DATA-VALUE] \ - * [list START' END' DATA-VALUE'] \ - * ... - * ] - * The list is sorted by ascending START and entries do not overlap. - * START and END are both inclusive. BIT-LENGTH is in usual Tcl - * integer notation and must be a multiple of 8. - * - * Error codes - * - * HBYTES BLOCKCIPHER CRYPTFAIL CRYPT block cipher mode failed somehow (!) - * HBYTES BLOCKCIPHER CRYPTFAIL MAC HMAC failed somehow (!) - * HBYTES BLOCKCIPHER LENGTH block cipher input has unsuitable length - * HBYTES BLOCKCIPHER PARAMS key or iv not suitable - * HBYTES HMAC PARAMS key, input or output size not suitable - * HBYTES LENGTH OVERRUN block too long - * HBYTES LENGTH RANGE input length or offset is -ve or silly - * HBYTES LENGTH UNDERRUN block too short (or offset too big) - * HBYTES LENGTH MISMATCH when blocks must be exactly same length - * HBYTES SYNTAX supposed hex block had wrong syntax - * HBYTES VALUE OVERFLOW value to be conv'd to hex too big/long - * HBYTES ADDRMAP NOMATCH no addr/mask matches address for lookup - * HBYTES ADDRMAP UNDERRUN addr for lookup or amend is too short - * HBYTES ADDRMAP OVERRUN addr for lookup or amend is too long - * HBYTES ADDRMAP EXCLBITS amend-mask 1-bits outside prefix len - * HBYTES ADDRMAP BADRANGE amend-range start > end - * HBYTES ADDRMAP VALUE addr-map string value is erroneous - * SOCKADDR AFUNIX LENGTH path for AF_UNIX socket too long - * SOCKADDR SYNTAX IPV4 bad IPv4 socket address &/or port - * SOCKADDR SYNTAX OTHER bad socket addr, couldn't tell what kind - * ULONG BITCOUNT NEGATIVE -ve bitcount specified where not allowed - * ULONG BITCOUNT OVERRUN attempt to use more than 32 bits - * ULONG BITCOUNT UNDERRUN bitfields add up to less than 32 - * ULONG VALUE NEGATIVE attempt convert -ve integers to ulong - * ULONG VALUE OVERFLOW converted value does not fit in result - * TUNTAP IFNAME LENGTH tun/tap interface name too long - * TUNTAP MTU OVERRUN tun/tap mtu limited to 2^16 bytes - * - * Refs: HMAC: RFC2104 */ - -#ifndef HBYTES_H -#define HBYTES_H + +#ifndef CHIARK_TCL_H +#define CHIARK_TCL_H #include #include @@ -142,76 +20,18 @@ typedef unsigned char Byte; -/* from hbytes.c */ - -int Hbytes_Init(Tcl_Interp *ip); /* called by Tcl's "load" */ - -/* Internal representation details: */ -#define HBYTES_ISEMPTY(hb) (!(hb)->begin_complex && !(hb)->end_0) -#define HBYTES_ISSENTINEL(hb) (!(hb)->begin_complex && (hb)->end_0) -#define HBYTES_ISSIMPLE(hb) ((hb)->begin_complex && (hb)->end_0) -#define HBYTES_ISCOMPLEX(hb) ((hb)->begin_complex && !(hb)->end_0) - -typedef struct { - void *begin_complex, *end_0; -} HBytes_Value; /* overlays internalRep */ - -typedef struct { - Byte *dstart; /* always allocated dynamically */ - int prespace, len, avail; - /* - * | SPARE | USED | SPARE | - * |<-prespace->|<-len->| | - * | |<----avail---->| - * ^start - */ -} HBytes_ComplexValue; /* pointed to from internalRep.otherValuePtr */ +/* for assisting tcmdifgen and tcmdiflib.c */ -/* Public interfaces: */ +typedef struct TopLevel_Command TopLevel_Command; -extern Tcl_ObjType hbytes_type; - -int hbytes_len(const HBytes_Value *v); -Byte *hbytes_data(const HBytes_Value *v); /* caller may then modify data! */ -int hbytes_issentinel(const HBytes_Value *v); - -Byte *hbytes_prepend(HBytes_Value *upd, int el); -Byte *hbytes_append(HBytes_Value *upd, int el); - /* return value is where to put the data */ - -const Byte *hbytes_unprepend(HBytes_Value *upd, int rl); -const Byte *hbytes_unappend(HBytes_Value *upd, int rl); - /* return value points to the removed data, which remains valid - * until next op on the HBytes_Value. If original value is - * shorter than rl or negative, returns 0 and does nothing. */ - -void hbytes_empty(HBytes_Value *returns); -void hbytes_sentinel(HBytes_Value *returns); -void hbytes_array(HBytes_Value *returns, const Byte *array, int l); -Byte *hbytes_arrayspace(HBytes_Value *returns, int l); -void hbytes_free(const HBytes_Value *frees); - /* _empty, _sentinel and _array do not free or read the old value; - * _free it first if needed. _free leaves it garbage, so you - * have to call _empty to reuse it. _arrayspace doesn't fill - * the array; you get a pointer and must fill it with data - * yourself. */ - -/* The value made by hbytes_sentinel should not be passed to - * anything except HBYTES_IS..., and hbytes_free. */ - -/* from sockaddr.c */ - -typedef struct { - Byte *begin, *end; -} SockAddr_Value; - -extern Tcl_ObjType sockaddr_type; +struct TopLevel_Command { + const char *name; + Tcl_ObjCmdProc *func; +}; -void sockaddr_clear(SockAddr_Value*); -void sockaddr_create(SockAddr_Value*, const struct sockaddr *addr, int len); -int sockaddr_len(const SockAddr_Value*); -const struct sockaddr *sockaddr_addr(const SockAddr_Value*); -void sockaddr_free(const SockAddr_Value*); +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 */ @@ -222,13 +42,13 @@ typedef struct { /* semi-opaque - read only, and then only where commented */ int llength; } ScriptToInvoke; -void scriptinv_init(ScriptToInvoke *si); -int scriptinv_set(ScriptToInvoke *si, Tcl_Interp *ip, +void cht_scriptinv_init(ScriptToInvoke *si); +int cht_scriptinv_set(ScriptToInvoke *si, Tcl_Interp *ip, Tcl_Obj *newscript, Tcl_Obj *xargs); -void scriptinv_cancel(ScriptToInvoke *si); /* then don't invoke */ +void cht_scriptinv_cancel(ScriptToInvoke *si); /* then don't invoke */ /* no separate free function - just cancel */ -void scriptinv_invoke(ScriptToInvoke *si, int argc, Tcl_Obj *const *argv); +void cht_scriptinv_invoke(ScriptToInvoke *si, int argc, Tcl_Obj *const *argv); /* from idtable.c */ @@ -242,45 +62,32 @@ typedef struct { * 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 tabledataid_nearlytype; -int tabledataid_parse(Tcl_Interp *ip, Tcl_Obj *o, const IdDataSpec *idds); -void tabledataid_disposing(Tcl_Interp *ip, void *val, const IdDataSpec *idds); +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 adns.c */ - -typedef struct { - const char *name; - adns_rrtype number; -} AdnsTclRRTypeInfo; - -extern const IdDataSpec adnstcl_queries, adnstcl_resolvers; - -/* from dgram.c */ - -extern const IdDataSpec dgram_socks; -int newfdposixerr(Tcl_Interp *ip, int fd, const char *m); - -/* from tuntap.c */ - -extern const IdDataSpec tuntap_socks; - /* from hook.c */ -int staticerr(Tcl_Interp *ip, const char *m, const char *ec); -int posixerr(Tcl_Interp *ip, int errnoval, const char *m); -void objfreeir(Tcl_Obj *o); -int get_urandom(Tcl_Interp *ip, Byte *buffer, int l); +int cht_initextension(Tcl_Interp *ip, const TopLevel_Command *cmds, + int *donep /* or 0, meaning no types follow */, + ... /* types, terminated by 0 */); + +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 obj_updatestr_array(Tcl_Obj *o, const Byte *array, int l); -void obj_updatestr_array_prefix(Tcl_Obj *o, const Byte *byte, +void cht_obj_updatestr_array(Tcl_Obj *o, const Byte *array, int l); +void cht_obj_updatestr_array_prefix(Tcl_Obj *o, const Byte *byte, int l, const char *prefix); -void obj_updatestr_vstringls(Tcl_Obj *o, ...); +void cht_obj_updatestr_vstringls(Tcl_Obj *o, ...); /* const char*, int, const char*, int, ..., (const char*)0 */ -void obj_updatestr_string_len(Tcl_Obj *o, const char *str, int l); -void obj_updatestr_string(Tcl_Obj *o, const char *str); +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); /* from parse.c */ @@ -289,44 +96,21 @@ typedef struct { int copied; } Something_Var; -void init_somethingv(Something_Var *sth); -void fini_somethingv(Tcl_Interp *ip, int rc, Something_Var *sth); -int pat_somethingv(Tcl_Interp *ip, Tcl_Obj *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); -typedef struct { - HBytes_Value *hb; - Something_Var sth; -} HBytes_Var; - -/* from addrmap.c */ - -typedef struct AddrMap_Value AddrMap_Value; - -typedef struct { - AddrMap_Value *am; - Something_Var sth; -} AddrMap_Var; - -extern Tcl_ObjType addrmap_type; - -/* from chop.c */ - /* only do_... functions declared in tables.h */ - -/* from ulong.c */ - -Tcl_ObjType ulong_type; - /* from enum.c */ -extern Tcl_ObjType enum_nearlytype; -extern Tcl_ObjType enum1_nearlytype; +extern Tcl_ObjType cht_enum_nearlytype; +extern Tcl_ObjType cht_enum1_nearlytype; -const void *enum_lookup_cached_func(Tcl_Interp *ip, Tcl_Obj *o, +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) \ - (enum_lookup_cached_func((ip),(o), \ + (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 @@ -336,98 +120,14 @@ const void *enum_lookup_cached_func(Tcl_Interp *ip, Tcl_Obj *o, * set to the error message. */ -int enum1_lookup_cached_func(Tcl_Interp *ip, Tcl_Obj *o, +int cht_enum1_lookup_cached_func(Tcl_Interp *ip, Tcl_Obj *o, const char *opts, const char *what); /* -1 => error */ -/* 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 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 hashalginfos[]; - -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 blockcipheralginfos[]; - -/* 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 BlockCipherModeInfo blockciphermodeinfos[]; - -/* from misc.c */ - -int setnonblock(int fd, int isnonblock); - /* useful macros */ -#define OBJ_HBYTES(o) ((HBytes_Value*)&(o)->internalRep.twoPtrValue) -#define OBJ_SOCKADDR(o) ((SockAddr_Value*)&(o)->internalRep.twoPtrValue) - #define TALLOC(s) ((void*)Tcl_Alloc((s))) #define TFREE(f) (Tcl_Free((void*)(f))) #define TREALLOC(p,l) ((void*)Tcl_Realloc((void*)(p),(l))) -#endif /*HBYTES_H*/ +#endif /*CHIARK_TCL_H*/ diff --git a/base/common.make b/base/common.make new file mode 100644 index 0000000..c24170e --- /dev/null +++ b/base/common.make @@ -0,0 +1,15 @@ +OPTIMISE ?= -O2 +TCL_MEM_DEBUG ?= -DTCL_MEM_DEBUG + +TCMDIFGEN ?= $(BASE_DIR)/tcmdifgen +BASE_TCT ?= $(BASE_DIR)/base.tct + +CFLAGS += -g -Wall -Wmissing-prototypes -Wstrict-prototypes -Werror \ + $(OPTIMISE) +CPPFLAGS += -I$(BASE_DIR) +CPPFLAGS += $(TCL_MEM_DEBUG) + +AUTOS += $(AUTO_SRCS) $(AUTO_HDRS) + +default: all + diff --git a/base/extension.make b/base/extension.make new file mode 100644 index 0000000..8522f48 --- /dev/null +++ b/base/extension.make @@ -0,0 +1,19 @@ + +SHLIB ?= $(EXTENSION) + +AUTO_HDRS += tables.h +AUTO_SRCS += tables.c + +LDLIBS += -L ../base $(addprefix -l,$(EXTDEPENDS)) -lchiark-tcl + +include $(BASE_DIR)/common.make + +include $(BASE_DIR)/shlib.make + +%.c: %.tct $(BASE_TCT) $(TCMDIFGEN) + $(TCMDIFGEN) -wc -p$(EXTENSION) -o$@ $(BASE_TCT) $< + +%.h: %.tct $(BASE_TCT) $(TCMDIFGEN) + $(TCMDIFGEN) -wh -p$(EXTENSION) -o$@ $(BASE_TCT) $< + +include $(BASE_DIR)/final.make diff --git a/base/hook.c b/base/hook.c index 5b163b3..56a3268 100644 --- a/base/hook.c +++ b/base/hook.c @@ -3,16 +3,15 @@ #include -#include "hbytes.h" -#include "tables.h" +#include "chiark-tcl.h" -int staticerr(Tcl_Interp *ip, const char *m, const char *ec) { +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 posixerr(Tcl_Interp *ip, int errnoval, const char *m) { +int cht_posixerr(Tcl_Interp *ip, int errnoval, const char *m) { const char *em; Tcl_ResetResult(ip); @@ -22,87 +21,20 @@ int posixerr(Tcl_Interp *ip, int errnoval, const char *m) { return TCL_ERROR; } -int newfdposixerr(Tcl_Interp *ip, int fd, const char *m) { +int cht_newfdposixerr(Tcl_Interp *ip, int fd, const char *m) { int e; e= errno; close(fd); - return posixerr(ip,e,m); + return cht_posixerr(ip,e,m); } -void objfreeir(Tcl_Obj *o) { +void cht_objfreeir(Tcl_Obj *o) { if (o->typePtr && o->typePtr->freeIntRepProc) o->typePtr->freeIntRepProc(o); o->typePtr= 0; } -int do_hbytes_rep_info(ClientData cd, Tcl_Interp *ip, - Tcl_Obj *obj, Tcl_Obj **result) { - const char *tn; - int nums[3], i, lnl; - Tcl_Obj *objl[4]; - - if (obj->typePtr == &hbytes_type) { - HBytes_Value *v= OBJ_HBYTES(obj); - memset(nums,0,sizeof(nums)); - nums[1]= hbytes_len(v); - - if (HBYTES_ISEMPTY(v)) tn= "empty"; - else if (HBYTES_ISSENTINEL(v)) tn= "sentinel!"; - else if (HBYTES_ISSIMPLE(v)) tn= "simple"; - else { - HBytes_ComplexValue *cx= v->begin_complex; - tn= "complex"; - nums[0]= cx->prespace; - nums[2]= cx->avail - cx->len; - } - lnl= 3; - } else { - tn= "other"; - lnl= 0; - } - - objl[0]= Tcl_NewStringObj((char*)tn,-1); - for (i=0; itypePtr= &hbytes_type; -} - -static void hbytes_t_free(Tcl_Obj *o) { - hbytes_free(OBJ_HBYTES(o)); -} - -void obj_updatestr_array_prefix(Tcl_Obj *o, const Byte *byte, - int l, const char *prefix) { - char *str; - int pl; - - pl= strlen(prefix); - o->length= l*2+pl; - str= o->bytes= TALLOC(o->length+1); - - memcpy(str,prefix,pl); - str += pl; - - while (l>0) { - sprintf(str,"%02x",*byte); - str+=2; byte++; l--; - } - *str= 0; -} - -void obj_updatestr_array(Tcl_Obj *o, const Byte *byte, int l) { - obj_updatestr_array_prefix(o,byte,l,""); -} - -void obj_updatestr_vstringls(Tcl_Obj *o, ...) { +void cht_obj_updatestr_vstringls(Tcl_Obj *o, ...) { va_list al; char *p; const char *part; @@ -126,282 +58,20 @@ void obj_updatestr_vstringls(Tcl_Obj *o, ...) { *p= 0; } -void obj_updatestr_string(Tcl_Obj *o, const char *str) { - obj_updatestr_vstringls(o, str, strlen(str), (char*)0); -} - -static void hbytes_t_ustr(Tcl_Obj *o) { - obj_updatestr_array(o, - hbytes_data(OBJ_HBYTES(o)), - hbytes_len(OBJ_HBYTES(o))); -} - -static int hbytes_t_sfa(Tcl_Interp *ip, Tcl_Obj *o) { - char *str, *ep, *os; - Byte *startbytes, *bytes; - int l; - char cbuf[3]; - - if (o->typePtr == &ulong_type) { - uint32_t ul; - - ul= htonl(*(const uint32_t*)&o->internalRep.longValue); - hbytes_array(OBJ_HBYTES(o), (const Byte*)&ul, 4); - - } else { - - os= str= Tcl_GetStringFromObj(o,&l); assert(str); - objfreeir(o); - - if (l & 1) return staticerr(ip, "hbytes: conversion from hex:" - " odd length in hex", "HBYTES SYNTAX"); - - startbytes= bytes= hbytes_arrayspace(OBJ_HBYTES(o), l/2); - - cbuf[2]= 0; - while (l>0) { - cbuf[0]= *str++; - cbuf[1]= *str++; - *bytes++= strtoul(cbuf,&ep,16); - if (ep != cbuf+2) { - hbytes_free(OBJ_HBYTES(o)); - return staticerr(ip, "hbytes: conversion from hex:" - " bad hex digit", "HBYTES SYNTAX"); - } - l -= 2; - } - - } - - o->typePtr = &hbytes_type; - return TCL_OK; -} - -Tcl_ObjType hbytes_type = { - "hbytes", - hbytes_t_free, hbytes_t_dup, hbytes_t_ustr, hbytes_t_sfa -}; - -int do_hbytes_raw2h(ClientData cd, Tcl_Interp *ip, - Tcl_Obj *binary, HBytes_Value *result) { - const unsigned char *str; - int l; - - str= Tcl_GetByteArrayFromObj(binary,&l); - hbytes_array(result, str, l); - return TCL_OK; -} - -int do_hbytes_h2raw(ClientData cd, Tcl_Interp *ip, - HBytes_Value hex, Tcl_Obj **result) { - *result= Tcl_NewByteArrayObj(hbytes_data(&hex), hbytes_len(&hex)); - return TCL_OK; -} - -int do_hbytes_length(ClientData cd, Tcl_Interp *ip, - HBytes_Value v, int *result) { - *result= hbytes_len(&v); - return TCL_OK; -} - -int do_hbytes_random(ClientData cd, Tcl_Interp *ip, - int length, HBytes_Value *result) { - Byte *space; - int rc; - - space= hbytes_arrayspace(result, length); - rc= get_urandom(ip, space, length); - if (rc) { hbytes_free(result); return rc; } - return TCL_OK; -} - -int do_hbytes_overwrite(ClientData cd, Tcl_Interp *ip, - HBytes_Var v, int start, HBytes_Value sub) { - int sub_l; - - sub_l= hbytes_len(&sub); - if (start < 0) - return staticerr(ip, "hbytes overwrite start -ve", - "HBYTES LENGTH RANGE"); - if (start + sub_l > hbytes_len(v.hb)) - return staticerr(ip, "hbytes overwrite out of range", - "HBYTES LENGTH UNDERRUN"); - memcpy(hbytes_data(v.hb) + start, hbytes_data(&sub), sub_l); - return TCL_OK; -} - -int do_hbytes_trimleft(ClientData cd, Tcl_Interp *ip, HBytes_Var v) { - const Byte *o, *p, *e; - o= p= hbytes_data(v.hb); - e= p + hbytes_len(v.hb); - - while (p INT_MAX/sub_l) return staticerr(ip, "hbytes repeat too long", 0); - - data= hbytes_arrayspace(result, sub_l*count); - sub_d= hbytes_data(&sub); - while (count) { - memcpy(data, sub_d, sub_l); - count--; data += sub_l; - } - return TCL_OK; -} - -int do_hbytes_xor(ClientData cd, Tcl_Interp *ip, - HBytes_Var v, HBytes_Value d) { - int l; - Byte *dest; - const Byte *source; - - l= hbytes_len(v.hb); - if (hbytes_len(&d) != l) return - staticerr(ip, "hbytes xor lengths do not match", "HBYTES LENGTH MISMATCH"); - - dest= hbytes_data(v.hb); - source= hbytes_data(&d); - memxor(dest,source,l); - return TCL_OK; -} - -int do_hbytes_zeroes(ClientData cd, Tcl_Interp *ip, - int length, HBytes_Value *result) { - Byte *space; - space= hbytes_arrayspace(result, length); - memset(space,0,length); - return TCL_OK; -} - -int do_hbytes_compare(ClientData cd, Tcl_Interp *ip, - HBytes_Value a, HBytes_Value b, int *result) { - int al, bl, minl, r; - - al= hbytes_len(&a); - bl= hbytes_len(&b); - minl= al0) *result= +2; - else { - if (albl) *result= +1; - else *result= 0; - } - return TCL_OK; -} - -int do_hbytes_range(ClientData cd, Tcl_Interp *ip, - HBytes_Value v, int start, int size, - HBytes_Value *result) { - const Byte *data; - int l; - - l= hbytes_len(&v); - if (start<0 || size<0) - return staticerr(ip,"hbytes range subscript(s) -ve","HBYTES LENGTH RANGE"); - if (lfunc(0,ip,objc,objv); -} - -/* hbytes representing uint16_t's */ - -int do_hbytes_h2ushort(ClientData cd, Tcl_Interp *ip, - HBytes_Value hex, long *result) { - const Byte *data; - int l; - - l= hbytes_len(&hex); - if (l>2) - return staticerr(ip, "hbytes h2ushort input more than 4 hex digits", - "HBYTES VALUE OVERFLOW"); - - data= hbytes_data(&hex); - *result= data[l-1] | (l>1 ? data[0]<<8 : 0); - return TCL_OK; -} - -int do_hbytes_ushort2h(ClientData cd, Tcl_Interp *ip, - long input, HBytes_Value *result) { - uint16_t us; - - if (input > 0x0ffff) - return staticerr(ip, "hbytes ushort2h input >2^16", - "HBYTES VALUE OVERFLOW"); - - us= htons(input); - hbytes_array(result,(const Byte*)&us,2); - return TCL_OK; -} - -/* toplevel functions */ - -int do_toplevel_hbytes(ClientData cd, Tcl_Interp *ip, - const HBytes_SubCommand *subcmd, - int objc, Tcl_Obj *const *objv) { - return subcmd->func(0,ip,objc,objv); -} - -int do_toplevel_dgram_socket(ClientData cd, Tcl_Interp *ip, - const DgramSocket_SubCommand *subcmd, - int objc, Tcl_Obj *const *objv) { - return subcmd->func(0,ip,objc,objv); -} - -int do_toplevel_tuntap_socket_raw(ClientData cd, Tcl_Interp *ip, - const TunSocket_SubCommand *subcmd, - int objc, Tcl_Obj *const *objv) { - return subcmd->func(0,ip,objc,objv); -} - -int do_toplevel_ulong(ClientData cd, Tcl_Interp *ip, - const ULong_SubCommand *subcmd, - int objc, Tcl_Obj *const *objv) { - return subcmd->func(0,ip,objc,objv); -} - -int do_toplevel_adns(ClientData cd, Tcl_Interp *ip, - const Adns_SubCommand *subcmd, - int objc, Tcl_Obj *const *objv) { - return subcmd->func(0,ip,objc,objv); +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 get_urandom(Tcl_Interp *ip, Byte *buffer, int l) { +int cht_get_urandom(Tcl_Interp *ip, Byte *buffer, int l) { static FILE *urandom; int r, esave; if (!urandom) { urandom= fopen(URANDOM,"rb"); - if (!urandom) return posixerr(ip,errno,"open " URANDOM); + if (!urandom) return cht_posixerr(ip,errno,"open " URANDOM); } r= fread(buffer,1,l,urandom); if (r==l) return 0; @@ -410,26 +80,37 @@ int get_urandom(Tcl_Interp *ip, Byte *buffer, int l) { fclose(urandom); urandom=0; if (ferror(urandom)) { - return posixerr(ip,errno,"read " URANDOM); + return cht_posixerr(ip,errno,"read " URANDOM); } else { assert(feof(urandom)); - return staticerr(ip, URANDOM " gave eof!", 0); + return cht_staticerr(ip, URANDOM " gave eof!", 0); } } -int Hbytes_Init(Tcl_Interp *ip) { +int cht_initextension(Tcl_Interp *ip, const TopLevel_Command *cmds, + int *donep /* or 0, meaning no types follow */, + ... /* types, terminated by 0 */) { + static int cht_initd; + const TopLevel_Command *cmd; + Tcl_ObjType *ot; + + va_list al; - Tcl_RegisterObjType(&hbytes_type); - Tcl_RegisterObjType(&blockcipherkey_type); - Tcl_RegisterObjType(&enum_nearlytype); - Tcl_RegisterObjType(&enum1_nearlytype); - Tcl_RegisterObjType(&sockaddr_type); - Tcl_RegisterObjType(&tabledataid_nearlytype); - Tcl_RegisterObjType(&ulong_type); - Tcl_RegisterObjType(&addrmap_type); + if (!cht_initd) { + cht_initd= 1; + Tcl_RegisterObjType(&cht_enum_nearlytype); + Tcl_RegisterObjType(&cht_enum1_nearlytype); + } + + if (donep && !*donep) { + *donep= 1; + va_start(al, donep); + while ((ot= va_arg(al, Tcl_ObjType*))) + Tcl_RegisterObjType(ot); + } - for (cmd=toplevel_commands; + for (cmd= cmds; cmd->name; cmd++) Tcl_CreateObjCommand(ip, (char*)cmd->name, cmd->func, 0,0); diff --git a/base/parse.c b/base/parse.c index 0fa5acd..341c389 100644 --- a/base/parse.c +++ b/base/parse.c @@ -1,29 +1,30 @@ /* */ +#include "chiark-tcl.h" #include "tables.h" -int pat_charfrom(Tcl_Interp *ip, Tcl_Obj *obj, int *val, +int cht_pat_charfrom(Tcl_Interp *ip, Tcl_Obj *obj, int *val, const char *opts, const char *what) { - *val= enum1_lookup_cached_func(ip,obj,opts,what); + *val= cht_enum1_lookup_cached_func(ip,obj,opts,what); if (*val==-1) return TCL_ERROR; return TCL_OK; } -int pat_int(Tcl_Interp *ip, Tcl_Obj *obj, int *val) { +int cht_pat_int(Tcl_Interp *ip, Tcl_Obj *obj, int *val) { return Tcl_GetIntFromObj(ip, obj, val); } -int pat_long(Tcl_Interp *ip, Tcl_Obj *obj, long *val) { +int cht_pat_long(Tcl_Interp *ip, Tcl_Obj *obj, long *val) { return Tcl_GetLongFromObj(ip, obj, val); } -int pat_string(Tcl_Interp *ip, Tcl_Obj *obj, const char **val) { +int cht_pat_string(Tcl_Interp *ip, Tcl_Obj *obj, const char **val) { *val= Tcl_GetString(obj); return TCL_OK; } -int pat_constv(Tcl_Interp *ip, Tcl_Obj *var, +int cht_pat_constv(Tcl_Interp *ip, Tcl_Obj *var, Tcl_Obj **val_r, Tcl_ObjType *type) { int rc; Tcl_Obj *val; @@ -40,11 +41,11 @@ int pat_constv(Tcl_Interp *ip, Tcl_Obj *var, return TCL_OK; } -void init_somethingv(Something_Var *sth) { +void cht_init_somethingv(Something_Var *sth) { sth->obj=0; sth->var=0; sth->copied=0; } -int pat_somethingv(Tcl_Interp *ip, Tcl_Obj *var, +int cht_pat_somethingv(Tcl_Interp *ip, Tcl_Obj *var, Something_Var *sth, Tcl_ObjType *type) { int rc; Tcl_Obj *val; @@ -67,14 +68,7 @@ int pat_somethingv(Tcl_Interp *ip, Tcl_Obj *var, return TCL_OK; } -int pat_hbv(Tcl_Interp *ip, Tcl_Obj *var, HBytes_Var *agg) { - int rc; - rc= pat_somethingv(ip,var,&agg->sth,&hbytes_type); if (rc) return rc; - agg->hb= OBJ_HBYTES(agg->sth.obj); - return TCL_OK; -} - -void fini_somethingv(Tcl_Interp *ip, int rc, Something_Var *sth) { +void cht_fini_somethingv(Tcl_Interp *ip, int rc, Something_Var *sth) { Tcl_Obj *ro; if (!rc) { @@ -86,26 +80,10 @@ void fini_somethingv(Tcl_Interp *ip, int rc, Something_Var *sth) { Tcl_DecrRefCount(sth->obj); } -int pat_hb(Tcl_Interp *ip, Tcl_Obj *obj, HBytes_Value *val) { - int rc; - rc= Tcl_ConvertToType(ip,obj,&hbytes_type); if (rc) return rc; - *val= *OBJ_HBYTES(obj); - return TCL_OK; -} - -Tcl_Obj *ret_hb(Tcl_Interp *ip, HBytes_Value val) { - Tcl_Obj *obj; - obj= Tcl_NewObj(); - Tcl_InvalidateStringRep(obj); - *OBJ_HBYTES(obj)= val; - obj->typePtr= &hbytes_type; - return obj; -} - -Tcl_Obj *ret_long(Tcl_Interp *ip, long val) { +Tcl_Obj *cht_ret_long(Tcl_Interp *ip, long val) { return Tcl_NewLongObj(val); } -Tcl_Obj *ret_string(Tcl_Interp *ip, const char *val) { +Tcl_Obj *cht_ret_string(Tcl_Interp *ip, const char *val) { return Tcl_NewStringObj(val,-1); } diff --git a/base/shlib.make b/base/shlib.make new file mode 100644 index 0000000..50eeae0 --- /dev/null +++ b/base/shlib.make @@ -0,0 +1,8 @@ + +OBJS_CFILES += $(addsuffix .o, $(CFILES)) +OBJS += $(OBJS_CFILES) + +TARGETS += $(SHLIB).so + +$(SHLIB).so: $(OBJS) + $(CC) $(CFLAGS) $(LDFLAGS) -o $@ -shared $(OBJS) $(LDLIBS) diff --git a/base/tables-examples.tct b/base/tables-examples.tct index 7ce5dc7..6630736 100644 --- a/base/tables-examples.tct +++ b/base/tables-examples.tct @@ -14,19 +14,6 @@ Fini addrmapv fini_somethingv(ip, rc, &@.sth); Type sockaddr: SockAddr_Value @ Init sockaddr sockaddr_clear(&@); -Type iddata(const IdDataSpec *idds): void *@ -Type ulong: uint32_t @ -Type long: long @ -Type string: const char *@ - -Type adnsresults: adns_answer *@ -Init adnsresults @=0; -Fini adnsresults free(@); - -Type charfrom(const char *opts, const char *what): int - -H-Include "hbytes.h" - Table toplevel TopLevel_Command hbytes subcmd enum(HBytes_SubCommand, "hbytes subcommand") @@ -44,36 +31,6 @@ Table toplevel TopLevel_Command subcmd enum(Adns_SubCommand,"adns subcommand") ... obj -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(&adnstcl_queries) - asynch-cancel - query iddata(&adnstcl_queries) - new-resolver - ... obj - => iddata(&adnstcl_resolvers) - set-default-resolver - res iddata(&adnstcl_resolvers) - destroy-resolver - res iddata(&adnstcl_resolvers) - Table addrmap AddrMap_SubCommand lookup map constv(&addrmap_type) diff --git a/base/tcmdifgen b/base/tcmdifgen index 22da4ae..f14249c 100755 --- a/base/tcmdifgen +++ b/base/tcmdifgen @@ -19,16 +19,16 @@ # functions. # # `Type' causes declarations in the .h file of these functions: -# int pat_TYPENAME(Tcl_Interp*, Tcl_Obj *obj, C-TYPE *val, ARGS); -# Tcl_Obj *ret_TYPENAME(Tcl_Interp*, C-TYPE val, ARGS); +# int cht_pat_TYPENAME(Tcl_Interp*, Tcl_Obj *obj, C-TYPE *val, ARGS); +# Tcl_Obj *cht_ret_TYPENAME(Tcl_Interp*, C-TYPE val, ARGS); # -# pat_... must attempt to parse obj into the appropriate type. +# cht_pat_... must attempt to parse obj into the appropriate type. # val will already have been initialised with `Init' statements if -# relevant. Whether pat_... fails or succeeds it may allocate +# relevant. Whether cht_pat_... fails or succeeds it may allocate # memory into the object and must leave the object valid (for # `Fini'). # -# ret_... must convert the value back to a new Tcl_Obj. It may +# cht_ret_... must convert the value back to a new Tcl_Obj. It may # not fail. # # Init TYPENAME C-STATEMENTS @@ -71,13 +71,13 @@ # ... # [ => RESULT-TYPE ] # This will cause the declaration of -# int do_TABLENAME_ENTRYNAME(ClientData cd, Tcl_Interp *ip, +# 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. -# The do_... function should not eat any memory associated with +# 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 @@ -100,10 +100,14 @@ # EXTRA-VALUES; the EXTRA-VALUES are used as initialisers for the # additional structure elements. # -# Also declared are these functions: -# void setstringresult(Tcl_Interp*, const char*); +# 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 pat_enum(Tcl_Interp*, Tcl_Obj*, const void **c_e_t_array, +# 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 @@ -113,8 +117,7 @@ # 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 -# which #includes "tcmdiflib.h" (not supplied). +# unmodified.) The corresponding definitions are in tcmdiflib.c. use IO; use Data::Dumper; @@ -123,8 +126,9 @@ parse('builtins','DATA'); while (@ARGV) { $_= shift @ARGV; - if (m/^\-p(\w+)/) { + if (m/^\-p([-_0-9a-z]+)$/) { $prefix= $1; + $prefix =~ y/-/_/; } elsif (m/^\-w(c|h)$/) { $write= $1; } elsif (m/^\-o(.+)$/) { @@ -163,11 +167,11 @@ sub parse ($$) { unshift @i, $this_indent; } - if (@i==0 && m/^Table\s+(\w+)\s+(\w+)$/) { + if (@i==0 && m/^Table\s+(\*toplevel\*|\w+)\s+(\w+)$/) { zilch(); $c_table= $1; $table_x{$c_table}{C}= $2; - $entrytype_x{$2}= ''; + $entrytype_x{$2}= '' unless exists $entrytype_x{$2}; } elsif (@i==0 && m/^Untabled$/) { zilch(); $c_table= ''; @@ -176,6 +180,9 @@ sub parse ($$) { } 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) { @@ -225,19 +232,20 @@ foreach $t (sort keys %types) { $type= $types{$t}; $c= $type->{C}; $xta= $type->{X}; - $decl= "int pat_$t(Tcl_Interp *ip, Tcl_Obj *obj, "; + $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 *ret_$t(Tcl_Interp *ip, ".subst_in_decl('val',$c); + $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". @@ -257,7 +265,7 @@ foreach $c_table (sort keys %tables) { $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)"; - $do_decl= "int do_${c_table}_${c_entry_c}("; + $do_decl= "int cht_do_${c_table}_${c_entry_c}("; @do_al= ('ClientData cd', 'Tcl_Interp *ip'); @do_aa= qw(cd ip); $pa_init= ''; @@ -310,7 +318,7 @@ foreach $c_table (sort keys %tables) { if (exists $type_fini{$t}) { $pa_fini .= ' '.subst_in("a_$n", $type_fini{$t})."\n"; } - $pa_body .= " rc= pat_$t(ip, *objv++, $paarg"; + $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"; @@ -333,16 +341,16 @@ foreach $c_table (sort keys %tables) { if (exists $r_entry->{R}) { $t= $r_entry->{R}; $xta= $r_entry->{X}; - push @do_al, make_decl("*result", $t, "do_al result"); + 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, ret_$t(ip, 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= do_${c_table}_${c_entry_c}("; + $pa_body .= " rc= cht_do_${c_table}_${c_entry_c}("; $pa_body .= join ', ', @do_aa; $pa_body .= ");\n"; $pa_body .= " if (rc) goto rc_err;\n"; @@ -411,11 +419,6 @@ o(h, 0, "#define INCLUDED_\U${prefix}_H\n\n". "#include \n"); -o(h, 400, - "void setstringresult(Tcl_Interp*, const char*);\n". - "int pat_enum(Tcl_Interp*, Tcl_Obj*, const void**,". - " const void*, size_t, const char *what);\n"); - o(h, 999, "#endif /*INCLUDED_\U${prefix}_H*/\n"); diff --git a/base/tcmdiflib.c b/base/tcmdiflib.c index 8bddc02..25f0084 100644 --- a/base/tcmdiflib.c +++ b/base/tcmdiflib.c @@ -1,29 +1,30 @@ /* */ -#include "tcmdiflib.h" +#include "chiark-tcl.h" +#include "tables.h" -int pat_enum(Tcl_Interp *ip, Tcl_Obj *obj, const void **val, +int cht_pat_enum(Tcl_Interp *ip, Tcl_Obj *obj, const void **val, const void *opts, size_t sz, const char *what) { - *val= enum_lookup_cached_func(ip,obj,opts,sz,what); + *val= cht_enum_lookup_cached_func(ip,obj,opts,sz,what); if (!*val) return TCL_ERROR; return TCL_OK; } -int pat_obj(Tcl_Interp *ip, Tcl_Obj *obj, Tcl_Obj **val) { +int cht_pat_obj(Tcl_Interp *ip, Tcl_Obj *obj, Tcl_Obj **val) { *val= obj; return TCL_OK; } -Tcl_Obj *ret_int(Tcl_Interp *ip, int val) { +Tcl_Obj *cht_ret_int(Tcl_Interp *ip, int val) { return Tcl_NewIntObj(val); } -Tcl_Obj *ret_obj(Tcl_Interp *ip, Tcl_Obj *val) { +Tcl_Obj *cht_ret_obj(Tcl_Interp *ip, Tcl_Obj *val) { return val; } -void setstringresult(Tcl_Interp *ip, const char *m) { +void cht_setstringresult(Tcl_Interp *ip, const char *m) { Tcl_ResetResult(ip); Tcl_AppendResult(ip, m, (char*)0); } diff --git a/base/tcmdiflib.h b/base/tcmdiflib.h deleted file mode 100644 index 0944e20..0000000 --- a/base/tcmdiflib.h +++ /dev/null @@ -1,2 +0,0 @@ -#include "tables.h" -#include "hbytes.h" diff --git a/base/troglodyte-Makefile b/base/troglodyte-Makefile index e458511..ed38b04 100644 --- a/base/troglodyte-Makefile +++ b/base/troglodyte-Makefile @@ -1,58 +1,3 @@ -OBJS= tables.o \ - tcmdiflib.o \ - hbytes.o \ - adns.o \ - enum.o \ - idtable.o \ - scriptinv.o \ - ulongs.o \ - sockaddr.o \ - dgram.o \ - tuntap.o \ - chop.o \ - hook.o \ - bcmode.o \ - misc.o \ - algtables.o \ - crypto.o \ - parse.o \ - addrmap.o - -HDRS= hbytes.h \ - $(AUTO_HDRS) - -AUTO_HDRS= tables.h -AUTO_SRCS= tables.c -AUTOS= $(AUTO_HDRS) $(AUTO_SRCS) - -TARGETS= hbytes.so autocode.tcl autococo.tcl - -CC_CRYPTO= $(CC) $(CFLAGS) $(CPPFLAGS) -O3 -CPPFLAGS= -I../plocal/include $(TCL_MEM_DEBUG) $(CMDLINE_CPPFLAGS) -LDFLAGS= -L../plocal/lib -LDLIBS= -lnettle -ladns -CFLAGS= -g -Wall -Wmissing-prototypes -Wstrict-prototypes -Werror \ - $(OPTIMISE) -OPTIMISE= -O2 -TCL_MEM_DEBUG= -DTCL_MEM_DEBUG - -all: $(TARGETS) $(AUTOS) - -hbytes.so: $(OBJS) - $(CC) $(CFLAGS) $(LDFLAGS) -o $@ -shared $(OBJS) $(LDLIBS) - -autoco%.tcl: deco%gen.tcl decobogen.tcl general.tcl ./hbytes.so \ - protocol.deco - ./$< protocol.deco >$@.new && mv -f $@.new $@ - -%.c: %.tct tcmdifgen - ./tcmdifgen -wc -o$@ $< - -%.h: %.tct tcmdifgen - ./tcmdifgen -wh -o$@ $< - -%.o: %.c $(HDRS) - $(CC) $(CFLAGS) $(CPPFLAGS) -o $@ -c $< #alg.o: alg.c alg.h alg2.h # $(CC_CRYPTO) -o $@ -c $< diff --git a/hbytes/hbglue.c b/hbytes/hbglue.c new file mode 100644 index 0000000..1ac833d --- /dev/null +++ b/hbytes/hbglue.c @@ -0,0 +1,23 @@ +int cht_pat_hbv(Tcl_Interp *ip, Tcl_Obj *var, HBytes_Var *agg) { + int rc; + rc= pat_somethingv(ip,var,&agg->sth,&hbytes_type); if (rc) return rc; + agg->hb= OBJ_HBYTES(agg->sth.obj); + return TCL_OK; +} + +int cht_pat_hb(Tcl_Interp *ip, Tcl_Obj *obj, HBytes_Value *val) { + int rc; + rc= Tcl_ConvertToType(ip,obj,&hbytes_type); if (rc) return rc; + *val= *OBJ_HBYTES(obj); + return TCL_OK; +} + +Tcl_Obj *cht_ret_hb(Tcl_Interp *ip, HBytes_Value val) { + Tcl_Obj *obj; + obj= Tcl_NewObj(); + Tcl_InvalidateStringRep(obj); + *OBJ_HBYTES(obj)= val; + obj->typePtr= &hbytes_type; + return obj; +} + diff --git a/hbytes/hbytes.h b/hbytes/hbytes.h index 206f97e..55a2286 100644 --- a/hbytes/hbytes.h +++ b/hbytes/hbytes.h @@ -260,7 +260,6 @@ extern const IdDataSpec adnstcl_queries, adnstcl_resolvers; /* from dgram.c */ extern const IdDataSpec dgram_socks; -int newfdposixerr(Tcl_Interp *ip, int fd, const char *m); /* from tuntap.c */ -- 2.30.2