base/hook.c

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