chiark / gitweb /
Lots of stuff seems to work
[chiark-tcl.git] / base / hook.c
1 /*
2  */
3
4 #include "hbytes.h"
5 #include "tables.h"
6
7 int staticerr(Tcl_Interp *ip, const char *m) {
8   Tcl_SetResult(ip, (char*)m, TCL_STATIC);
9   return TCL_ERROR;
10 }
11
12 void objfreeir(Tcl_Obj *o) {
13   if (o->typePtr && o->typePtr->freeIntRepProc)
14     o->typePtr->freeIntRepProc(o);
15   o->typePtr= 0;
16 }  
17
18 int do_hbytes_rep_info(ClientData cd, Tcl_Interp *ip,
19                        HBytes_Value v, Tcl_Obj **result) {
20   const char *tn;
21   int nums[3], i;
22   Tcl_Obj *objl[4];
23
24   memset(nums,0,sizeof(nums));
25   nums[1]= hbytes_len(&v);
26   
27   if (HBYTES_ISEMPTY(&v)) tn= "empty";
28   else if (HBYTES_ISSENTINEL(&v)) tn= "sentinel!";
29   else if (HBYTES_ISSIMPLE(&v)) tn= "simple";
30   else {
31     HBytes_ComplexValue *cx= v.begin_complex;
32     tn= "complex";
33     nums[0]= cx->prespace;
34     nums[2]= cx->avail - cx->len;
35   }
36     
37   objl[0]= Tcl_NewStringObj((char*)tn,-1);
38   for (i=0; i<3; i++) objl[i+1]= Tcl_NewIntObj(nums[i]);
39   *result= Tcl_NewListObj(4,objl);
40   return TCL_OK;
41 }
42
43 static void hbytes_t_dup(Tcl_Obj *src, Tcl_Obj *dup) {
44   objfreeir(dup);
45   hbytes_array(OBJ_HBYTES(dup),
46                hbytes_data(OBJ_HBYTES(src)),
47                hbytes_len(OBJ_HBYTES(src)));
48 }
49
50 static void hbytes_t_free(Tcl_Obj *o) {
51   hbytes_free(OBJ_HBYTES(o));
52 }
53
54 static void hbytes_t_ustr(Tcl_Obj *o) {
55   int l;
56   char *str;
57   const Byte *byte;
58
59   byte= hbytes_data(OBJ_HBYTES(o));
60   l= hbytes_len(OBJ_HBYTES(o));
61   str= o->bytes= TALLOC(l*2+1);
62   o->length= l*2;
63   while (l>0) {
64     sprintf(str,"%02x",*byte);
65     str+=2; byte++; l--;
66   }
67   *str= 0;
68 }
69
70 static int hbytes_t_sfa(Tcl_Interp *ip, Tcl_Obj *o) {
71   char *str, *ep, *os;
72   Byte *startbytes, *bytes;
73   int l;
74   char cbuf[3];
75
76   os= str= Tcl_GetStringFromObj(o,&l);  assert(str);
77   objfreeir(o);
78
79   if (l & 1) return staticerr(ip, "hbytes: conversion from hex:"
80                               " odd length in hex");
81
82   startbytes= bytes= hbytes_arrayspace(OBJ_HBYTES(o), l/2);
83
84   cbuf[2]= 0;
85   while (l>0) {
86     cbuf[0]= *str++;
87     cbuf[1]= *str++;
88     *bytes++= strtoul(cbuf,&ep,16);
89     if (ep != cbuf+2) {
90       hbytes_free(OBJ_HBYTES(o));
91       return staticerr(ip, "hbytes: conversion from hex:"
92                        " bad hex digit");
93     }
94     l -= 2;
95   }
96
97   o->typePtr = &hbytes_type;
98   return TCL_OK;
99 }
100
101 Tcl_ObjType hbytes_type = {
102   "hbytes",
103   hbytes_t_free, hbytes_t_dup, hbytes_t_ustr, hbytes_t_sfa
104 };
105
106 int do_hbytes_raw2h(ClientData cd, Tcl_Interp *ip,
107                     Tcl_Obj *binary, HBytes_Value *result) {
108   const char *str;
109   int l;
110
111   str= Tcl_GetStringFromObj(binary,&l);
112   hbytes_array(result, str, l);
113   return TCL_OK;
114 }
115
116 int do_hbytes_h2raw(ClientData cd, Tcl_Interp *ip,
117                     HBytes_Value hex, Tcl_Obj **result) {
118   *result= Tcl_NewStringObj(hbytes_data(&hex), hbytes_len(&hex));
119   return TCL_OK;
120 }
121
122 #if 0
123 HC_DEFINE(pkcs5) {
124   static const PadKindInfo padkindinfos[0]= {
125     { "pa", 1, 1 },
126     { "pn", 1, 0 },
127     { "ua", 0, 1 },
128     { "un", 0, 0 },
129     { 0 }
130   };
131
132   HC_DECLS_HBV;
133   Tcl_Obj *v;
134   int blocksize;
135   const PadKindInfo *pk;
136   const BlockCipherInfo *bc;
137
138   HC_ARG_ENUM(pk, padkindinfos);
139   HC_ARG_HBV;
140   if (!pk->algname) HC_ARG_INTRANGE(blocksize, 1,255);
141   else { HC_ARG_ENUM(bc, blockciphers); blocksize= bc->blocksize; }
142   HC_ARGS_E;
143
144   /* do nothing :-) */
145
146   HC_FINI_HBV;
147 }
148 #endif
149
150 int do__hbytes(ClientData cd, Tcl_Interp *ip,
151                const HBytes_SubCommand *subcmd,
152                int objc, Tcl_Obj *const *objv) {
153   return subcmd->func(0,ip,objc,objv);
154 }
155
156 int Hbytes_Init(Tcl_Interp *ip) {
157   Tcl_RegisterObjType(&hbytes_type);
158   Tcl_RegisterObjType(&enum_nearlytype);
159   Tcl_RegisterObjType(&enum1_nearlytype);
160   Tcl_CreateObjCommand(ip,"hbytes", pa__hbytes,0,0);
161   return TCL_OK;
162 }