chiark / gitweb /
e0b16d4fac762d7feb2ddb59948f63b89d7917be
[chiark-tcl.git] / base / hook.c
1 /*
2  * base code for various Tcl extensions
3  * Copyright 2006 Ian Jackson
4  *
5  * This program is free software; you can redistribute it and/or
6  * modify it under the terms of the GNU General Public License as
7  * published by the Free Software Foundation; either version 2 of the
8  * License, or (at your option) any later version.
9  *
10  * This program is distributed in the hope that it will be useful, but
11  * WITHOUT ANY WARRANTY; without even the implied warranty of
12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13  * General Public License for more details.
14  *
15  * You should have received a copy of the GNU General Public License
16  * along with this library; if not, write to the Free Software
17  * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
18  * 02110-1301, USA.
19  */
20
21 #include "chiark-tcl-base.h"
22
23 int cht_staticerr(Tcl_Interp *ip, const char *m, const char *ec) {
24   Tcl_SetResult(ip, (char*)m, TCL_STATIC);
25   if (ec) Tcl_SetObjErrorCode(ip, Tcl_NewStringObj(ec,-1));
26   return TCL_ERROR;
27 }
28
29 int cht_posixerr(Tcl_Interp *ip, int errnoval, const char *m) {
30   const char *em;
31   
32   Tcl_ResetResult(ip);
33   errno= errnoval;
34   em= Tcl_PosixError(ip);
35   Tcl_AppendResult(ip, m, ": ", em, (char*)0);
36   return TCL_ERROR;
37 }
38
39 int cht_newfdposixerr(Tcl_Interp *ip, int fd, const char *m) {
40   int e;
41   e= errno;
42   close(fd);
43   return cht_posixerr(ip,e,m);
44 }
45
46 void cht_objfreeir(Tcl_Obj *o) {
47   if (o->typePtr && o->typePtr->freeIntRepProc)
48     o->typePtr->freeIntRepProc(o);
49   o->typePtr= 0;
50 }  
51
52 void cht_obj_updatestr_vstringls(Tcl_Obj *o, ...) {
53   va_list al;
54   char *p;
55   const char *part;
56   int l, pl;
57
58   va_start(al,o);
59   for (l=0; (part= va_arg(al, const char*)); )
60     l+= va_arg(al, int);
61   va_end(al);
62   
63   o->length= l;
64   o->bytes= TALLOC(l+1);
65
66   va_start(al,o);
67   for (p= o->bytes; (part= va_arg(al, const char*)); p += pl) {
68     pl= va_arg(al, int);
69     memcpy(p, part, pl);
70   }
71   va_end(al);
72
73   *p= 0;
74 }
75
76 void cht_obj_updatestr_string(Tcl_Obj *o, const char *str) {
77   cht_obj_updatestr_vstringls(o, str, strlen(str), (char*)0);
78 }
79
80 #define URANDOM "/dev/urandom"
81
82 int cht_get_urandom(Tcl_Interp *ip, Byte *buffer, int l) {
83   static FILE *urandom;
84
85   int r, esave;
86
87   if (!urandom) {
88     urandom= fopen(URANDOM,"rb");
89     if (!urandom) return cht_posixerr(ip,errno,"open " URANDOM);
90   }
91   r= fread(buffer,1,l,urandom);
92   if (r==l) return 0;
93
94   esave= errno;
95   fclose(urandom); urandom=0;
96
97   if (ferror(urandom)) {
98     return cht_posixerr(ip,errno,"read " URANDOM);
99   } else {
100     assert(feof(urandom));
101     return cht_staticerr(ip, URANDOM " gave eof!", 0);
102   }
103 }
104
105 void cht_prepare__basic(Tcl_Interp *ip) {
106   static int prepared;
107
108   if (prepared) return;
109   Tcl_RegisterObjType(&cht_tabledataid_nearlytype);
110   Tcl_RegisterObjType(&cht_enum_nearlytype);
111   Tcl_RegisterObjType(&cht_enum1_nearlytype);
112   prepared= 1;
113 }
114
115 void cht_setup__commands(Tcl_Interp *ip, const TopLevel_Command *cmds) {
116   const TopLevel_Command *cmd;
117   
118   for (cmd= cmds;
119        cmd->name;
120        cmd++)
121     Tcl_CreateObjCommand(ip, (char*)cmd->name, cmd->func, 0,0);
122 }