base/hook.c

   1 /*
   2  */
   3
   4 #include <errno.h>
   5
   6 #include "chiark-tcl.h"
   7
   8 int cht_staticerr(Tcl_Interp *ip, const char *m, const char *ec) {
   9   Tcl_SetResult(ip, (char*)m, TCL_STATIC);
  10   if (ec) Tcl_SetObjErrorCode(ip, Tcl_NewStringObj(ec,-1));
  11   return TCL_ERROR;
  12 }
  13
  14 int cht_posixerr(Tcl_Interp *ip, int errnoval, const char *m) {
  15   const char *em;
  16
  17   Tcl_ResetResult(ip);
  18   errno= errnoval;
  19   em= Tcl_PosixError(ip);
  20   Tcl_AppendResult(ip, m, ": ", em, (char*)0);
  21   return TCL_ERROR;
  22 }
  23
  24 int cht_newfdposixerr(Tcl_Interp *ip, int fd, const char *m) {
  25   int e;
  26   e= errno;
  27   close(fd);
  28   return cht_posixerr(ip,e,m);
  29 }
  30
  31 void cht_objfreeir(Tcl_Obj *o) {
  32   if (o->typePtr && o->typePtr->freeIntRepProc)
  33     o->typePtr->freeIntRepProc(o);
  34   o->typePtr= 0;
  35 }
  36
  37 void cht_obj_updatestr_vstringls(Tcl_Obj *o, ...) {
  38   va_list al;
  39   char *p;
  40   const char *part;
  41   int l, pl;
  42
  43   va_start(al,o);
  44   for (l=0; (part= va_arg(al, const char*)); )
  45     l+= va_arg(al, int);
  46   va_end(al);
  47
  48   o->length= l;
  49   o->bytes= TALLOC(l+1);
  50
  51   va_start(al,o);
  52   for (p= o->bytes; (part= va_arg(al, const char*)); p += pl) {
  53     pl= va_arg(al, int);
  54     memcpy(p, part, pl);
  55   }
  56   va_end(al);
  57
  58   *p= 0;
  59 }
  60
  61 void cht_obj_updatestr_string(Tcl_Obj *o, const char *str) {
  62   cht_obj_updatestr_vstringls(o, str, strlen(str), (char*)0);
  63 }
  64
  65 #define URANDOM "/dev/urandom"
  66
  67 int cht_get_urandom(Tcl_Interp *ip, Byte *buffer, int l) {
  68   static FILE *urandom;
  69
  70   int r, esave;
  71
  72   if (!urandom) {
  73     urandom= fopen(URANDOM,"rb");
  74     if (!urandom) return cht_posixerr(ip,errno,"open " URANDOM);
  75   }
  76   r= fread(buffer,1,l,urandom);
  77   if (r==l) return 0;
  78
  79   esave= errno;
  80   fclose(urandom); urandom=0;
  81
  82   if (ferror(urandom)) {
  83     return cht_posixerr(ip,errno,"read " URANDOM);
  84   } else {
  85     assert(feof(urandom));
  86     return cht_staticerr(ip, URANDOM " gave eof!", 0);
  87   }
  88 }
  89
  90 int cht_initextension(Tcl_Interp *ip, const TopLevel_Command *cmds,
  91                         int *donep /* or 0, meaning no types follow */,
  92                         ... /* types, terminated by 0 */) {
  93   static int cht_initd;
  94
  95   const TopLevel_Command *cmd;
  96   Tcl_ObjType *ot;
  97
  98   va_list al;
  99
 100   if (!cht_initd) {
 101     cht_initd= 1;
 102     Tcl_RegisterObjType(&cht_tabledataid_nearlytype);
 103     Tcl_RegisterObjType(&cht_enum_nearlytype);
 104     Tcl_RegisterObjType(&cht_enum1_nearlytype);
 105   }
 106
 107   if (donep && !*donep) {
 108     *donep= 1;
 109     va_start(al, donep);
 110     while ((ot= va_arg(al, Tcl_ObjType*)))
 111       Tcl_RegisterObjType(ot);
 112   }
 113
 114   for (cmd= cmds;
 115        cmd->name;
 116        cmd++)
 117     Tcl_CreateObjCommand(ip, (char*)cmd->name, cmd->func, 0,0);
 118
 119   return TCL_OK;
 120 }