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 int cht_initextension(Tcl_Interp *ip, const TopLevel_Command *cmds,
 106                         int *donep /* or 0, meaning no types follow */,
 107                         ... /* types, terminated by 0 */) {
 108   static int cht_initd;
 109
 110   const TopLevel_Command *cmd;
 111   Tcl_ObjType *ot;
 112
 113   va_list al;
 114
 115   if (!cht_initd) {
 116     cht_initd= 1;
 117     Tcl_RegisterObjType(&cht_tabledataid_nearlytype);
 118     Tcl_RegisterObjType(&cht_enum_nearlytype);
 119     Tcl_RegisterObjType(&cht_enum1_nearlytype);
 120   }
 121
 122   if (donep && !*donep) {
 123     *donep= 1;
 124     va_start(al, donep);
 125     while ((ot= va_arg(al, Tcl_ObjType*)))
 126       Tcl_RegisterObjType(ot);
 127   }
 128
 129   for (cmd= cmds;
 130        cmd->name;
 131        cmd++)
 132     Tcl_CreateObjCommand(ip, (char*)cmd->name, cmd->func, 0,0);
 133
 134   return TCL_OK;
 135 }