ADDED kitsh/build.sh Index: kitsh/build.sh ================================================================== --- kitsh/build.sh +++ kitsh/build.sh @@ -0,0 +1,56 @@ +#! /bin/bash + +if [ ! -f 'build.sh' ]; then + echo 'ERROR: This script must be run from the directory it is in' >&2 + + exit 1 +fi +if [ -z "${TCLVERS}" ]; then + echo 'ERROR: The TCLVERS environment variable is not set' >&2 + + exit 1 +fi + +KITSHVERS="0.0" +BUILDDIR="$(pwd)/build/kitsh-${KITSHVERS}" +OUTDIR="$(pwd)/out" +INSTDIR="$(pwd)/inst" +OTHERPKGSDIR="$(pwd)/../" +export KITSHVERS BUILDDIR OUTDIR INSTDIR OTHERPKGSDIR + +rm -rf 'build' 'out' 'inst' +mkdir 'out' 'inst' || exit 1 + + +( + cp -r 'buildsrc' 'build' + cd "${BUILDDIR}" || exit 1 + + # Compile all objects... + ## XXX + ${CC:-cc} -I${TCLCONFIGDIR} -I${TCLCONFIGDIR}/../generic -o kit *.c $(find "${OTHERPKGSDIR}" -name '*.a' | grep '/inst/') -lz -lm -ldl -Wl,-Bstatic -lstdc++ -Wl,-Bdynamic + + # Create VFS directory + mkdir "starpack.vfs" + mkdir "starpack.vfs/lib" + + ## Copy in all built directories + cp -r "${OTHERPKGSDIR}"/*/out/* 'starpack.vfs/' + + ## Rename the "vfs" package directory to what "boot.tcl" expects + mv 'starpack.vfs/lib'/vfs* 'starpack.vfs/lib/vfs' + + ## Install "boot.tcl" + cp 'boot.tcl' 'starpack.vfs/' + + # Intall VFS onto kit + ## Copy installed data for packages + mkdir "installed-pkgs" + cp -r "${OTHERPKGSDIR}"/*/inst/* 'installed-pkgs/' + + ## Call installer + ${TCLCONFIGDIR}/tclsh installvfs.tcl kit starpack.vfs + +) || exit 1 + +exit 0 ADDED kitsh/buildsrc/kitsh-0.0/boot.tcl Index: kitsh/buildsrc/kitsh-0.0/boot.tcl ================================================================== --- kitsh/buildsrc/kitsh-0.0/boot.tcl +++ kitsh/buildsrc/kitsh-0.0/boot.tcl @@ -0,0 +1,79 @@ +proc tclInit {} { + rename tclInit {} + + global auto_path tcl_library tcl_libPath + global tcl_version tcl_rcFileName + + set noe [info nameofexecutable] + + # Resolve symlinks + set noe [file dirname [file normalize [file join $noe __dummy__]]] + + set tcl_library [file join $noe lib tcl$tcl_version] + set tcl_libPath [list $tcl_library [file join $noe lib]] + + # get rid of a build residue + unset -nocomplain ::tclDefaultLibrary + + # the following code only gets executed once on startup + if {[info exists tcl_rcFileName]} { + load {} vfs + + # lookup and emulate "source" of lib/vfs/{vfs*.tcl,mk4vfs.tcl} + # must use raw MetaKit calls because VFS is not yet in place + set d [mk::select exe.dirs parent 0 name lib] + set d [mk::select exe.dirs parent $d name vfs] + + foreach x {vfsUtils vfslib mk4vfs} { + set n [mk::select exe.dirs!$d.files name $x.tcl] + set s [mk::get exe.dirs!$d.files!$n contents] + catch {set s [zlib decompress $s]} + uplevel #0 $s + } + + # use on-the-fly decompression, if mk4vfs understands that + set mk4vfs::zstreamed 1 + + # mount the executable, i.e. make all runtime files available + vfs::filesystem mount $noe [list ::vfs::mk4::handler exe] + + # alter path to find encodings + if {[info tclversion] eq "8.4"} { + load {} pwb + librarypath [info library] + } else { + encoding dirs [list [file join [info library] encoding]] ;# TIP 258 + } + + # fix system encoding, if it wasn't properly set up (200207.004 bug) + if {[encoding system] eq "identity"} { + switch $::tcl_platform(platform) { + windows { encoding system cp1252 } + macintosh { encoding system macRoman } + default { encoding system iso8859-1 } + } + } + + # now remount the executable with the correct encoding + #vfs::filesystem unmount $noe + vfs::filesystem unmount [lindex [::vfs::filesystem info] 0] + + set noe [info nameofexecutable] + + # Resolve symlinks + set noe [file dirname [file normalize [file join $noe __dummy__]]] + + set tcl_library [file join $noe lib tcl$tcl_version] + set tcl_libPath [list $tcl_library [file join $noe lib]] + vfs::filesystem mount $noe [list ::vfs::mk4::handler exe] + } + + # load config settings file if present + namespace eval ::vfs { variable tclkit_version 1 } + catch { uplevel #0 [list source [file join $noe config.tcl]] } + + uplevel #0 [list source [file join $tcl_library init.tcl]] + +# reset auto_path, so that init.tcl's search outside of tclkit is cancelled + set auto_path $tcl_libPath +} ADDED kitsh/buildsrc/kitsh-0.0/installvfs.tcl Index: kitsh/buildsrc/kitsh-0.0/installvfs.tcl ================================================================== --- kitsh/buildsrc/kitsh-0.0/installvfs.tcl +++ kitsh/buildsrc/kitsh-0.0/installvfs.tcl @@ -0,0 +1,59 @@ +#! /usr/bin/env tclsh + +lappend auto_path [file join installed-pkgs lib] +package require vfs::mk4 + +if {[llength $argv] != 2} { + puts stderr "Usage: installvfs.tcl " + + exit 1 +} + +proc copy_file {srcfile destfile} { + switch -glob -- $srcfile { + "*.tcl" { + set ifd [open $srcfile r] + set ofd [open $destfile w] + + fcopy $ifd $ofd + + close $ofd + close $ifd + } + default { + file copy -- $srcfile $destfile + } + } + + puts "Copied $srcfile to $destfile" +} + +proc recursive_copy {srcdir destdir} { + foreach file [glob -nocomplain -directory $srcdir *] { + set filetail [file tail $file] + set destfile [file join $destdir $filetail] + + if {[file isdirectory $file]} { + file mkdir $destfile + + recursive_copy $file $destfile + + continue + } + + if {[catch { + copy_file $file $destfile + } err]} { + puts stderr "Failed to copy: $file: $err" + } + } +} + +set kitfile [lindex $argv 0] +set vfsdir [lindex $argv 1] + +set handle [vfs::mk4::Mount $kitfile /kit] + +recursive_copy $vfsdir /kit + +vfs::mk4::Unmount $handle /kit ADDED kitsh/buildsrc/kitsh-0.0/kitInit.c Index: kitsh/buildsrc/kitsh-0.0/kitInit.c ================================================================== --- kitsh/buildsrc/kitsh-0.0/kitInit.c +++ kitsh/buildsrc/kitsh-0.0/kitInit.c @@ -0,0 +1,204 @@ +/* + * tclAppInit.c -- + * + * Provides a default version of the main program and Tcl_AppInit + * procedure for Tcl applications (without Tk). Note that this + * program must be built in Win32 console mode to work properly. + * + * Copyright (c) 1996-1997 by Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 2000-2002 Jean-Claude Wippler + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id$ + */ + +#ifdef KIT_INCLUDES_TK +#include +#else +#include +#endif + +#ifdef _WIN32 +#define WIN32_LEAN_AND_MEAN +#include +#undef WIN32_LEAN_AND_MEAN +#endif + +#ifndef MB_TASKMODAL +#define MB_TASKMODAL 0 +#endif + +#include "tclInt.h" + +#ifdef KIT_INCLUDES_ITCL +Tcl_AppInitProc Itcl_Init; +#endif +Tcl_AppInitProc Mk4tcl_Init, Vfs_Init, Rechan_Init, Zlib_Init; +#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85 +Tcl_AppInitProc Pwb_Init; +#endif +#ifdef TCL_THREADS +Tcl_AppInitProc Thread_Init; +#endif +#ifdef _WIN32 +Tcl_AppInitProc Dde_Init, Registry_Init; +#endif + +char *tclExecutableName; + + /* + * Attempt to load a "boot.tcl" entry from the embedded MetaKit file. + * If there isn't one, try to open a regular "setup.tcl" file instead. + * If that fails, this code will throw an error, using a message box. + */ + +static char *preInitCmd = +#ifdef _WIN32_WCE +/* silly hack to get wince port to launch, some sort of std{in,out,err} problem */ +"open /kitout.txt a; open /kitout.txt a; open /kitout.txt a\n" +/* this too seems to be needed on wince - it appears to be related to the above */ +"catch {rename source ::tcl::source}\n" +"proc source file {\n" + "set old [info script]\n" + "info script $file\n" + "set fid [open $file]\n" + "set data [read $fid]\n" + "close $fid\n" + "set code [catch {uplevel 1 $data} res]\n" + "info script $old\n" + "if {$code == 2} { set code 0 }\n" + "return -code $code $res\n" +"}\n" +#endif +"proc tclKitInit {} {\n" + "rename tclKitInit {}\n" + "load {} Mk4tcl\n" + "mk::file open exe [info nameofexecutable] -readonly\n" + "set n [mk::select exe.dirs!0.files name boot.tcl]\n" + "if {$n != \"\"} {\n" + "set s [mk::get exe.dirs!0.files!$n contents]\n" + "if {![string length $s]} { error \"empty boot.tcl\" }\n" + "catch {load {} zlib}\n" + "if {[mk::get exe.dirs!0.files!$n size] != [string length $s]} {\n" + "set s [zlib decompress $s]\n" + "}\n" + "} else {\n" + "set f [open setup.tcl]\n" + "set s [read $f]\n" + "close $f\n" + "}\n" + "uplevel #0 $s\n" +#ifdef _WIN32 + "package ifneeded dde 1.3.1 {load {} dde}\n" + "package ifneeded registry 1.1.5 {load {} registry}\n" +#endif +"}\n" +"tclKitInit" +; + +static const char initScript[] = +"if {[file isfile [file join [info nameofexe] main.tcl]]} {\n" + "if {[info commands console] != {}} { console hide }\n" + "set tcl_interactive 0\n" + "incr argc\n" + "set argv [linsert $argv 0 $argv0]\n" + "set argv0 [file join [info nameofexe] main.tcl]\n" +"} else continue\n" +; + +/* SetExecName -- + + Hack to get around Tcl bug 1224888. +*/ + +void SetExecName(Tcl_Interp *interp) { + if (tclExecutableName == NULL) { + int len = 0; + Tcl_Obj *execNameObj; + Tcl_Obj *lobjv[1]; + + lobjv[0] = Tcl_GetVar2Ex(interp, "argv0", NULL, TCL_GLOBAL_ONLY); + execNameObj = Tcl_FSJoinToPath(Tcl_FSGetCwd(interp), 1, lobjv); + + tclExecutableName = strdup(Tcl_GetStringFromObj(execNameObj, &len)); + } +} + +int +TclKit_AppInit(Tcl_Interp *interp) +{ +#ifdef KIT_INCLUDES_ITCL + Tcl_StaticPackage(0, "Itcl", Itcl_Init, NULL); +#endif + Tcl_StaticPackage(0, "Mk4tcl", Mk4tcl_Init, NULL); +#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85 + Tcl_StaticPackage(0, "pwb", Pwb_Init, NULL); +#endif + Tcl_StaticPackage(0, "rechan", Rechan_Init, NULL); + Tcl_StaticPackage(0, "vfs", Vfs_Init, NULL); + Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL); +#ifdef TCL_THREADS + Tcl_StaticPackage(0, "Thread", Thread_Init, NULL); +#endif +#ifdef _WIN32 + Tcl_StaticPackage(0, "dde", Dde_Init, NULL); + Tcl_StaticPackage(0, "registry", Registry_Init, NULL); +#endif +#ifdef KIT_INCLUDES_TK + Tcl_StaticPackage(0, "Tk", Tk_Init, Tk_SafeInit); +#endif + + /* the tcl_rcFileName variable only exists in the initial interpreter */ +#ifdef _WIN32 + Tcl_SetVar(interp, "tcl_rcFileName", "~/tclkitrc.tcl", TCL_GLOBAL_ONLY); +#else + Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclkitrc", TCL_GLOBAL_ONLY); +#endif + + /* Hack to get around Tcl bug 1224888. This must be run here and + * in LibraryPathObjCmd because this information is needed both + * before and after that command is run. */ + SetExecName(interp); + + TclSetPreInitScript(preInitCmd); + if (Tcl_Init(interp) == TCL_ERROR) + goto error; + +#ifdef KIT_INCLUDES_TK +#ifdef _WIN32 + if (Tk_Init(interp) == TCL_ERROR) + goto error; + if (Tk_CreateConsoleWindow(interp) == TCL_ERROR) + goto error; +#endif +#endif + + /* messy because TclSetStartupScriptPath is called slightly too late */ + if (Tcl_Eval(interp, initScript) == TCL_OK) { + Tcl_Obj* path = TclGetStartupScriptPath(); + TclSetStartupScriptPath(Tcl_GetObjResult(interp)); + if (path == NULL) + Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]"); + } + + Tcl_SetVar(interp, "errorInfo", "", TCL_GLOBAL_ONLY); + Tcl_ResetResult(interp); + return TCL_OK; + +error: +#ifdef KIT_INCLUDES_TK +#ifdef _WIN32 + MessageBeep(MB_ICONEXCLAMATION); +#ifndef _WIN32_WCE + MessageBox(NULL, Tcl_GetStringResult(interp), "Error in TclKit", + MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND); + ExitProcess(1); +#endif + /* we won't reach this, but we need the return */ +#endif +#endif + return TCL_ERROR; +} ADDED kitsh/buildsrc/kitsh-0.0/main.c Index: kitsh/buildsrc/kitsh-0.0/main.c ================================================================== --- kitsh/buildsrc/kitsh-0.0/main.c +++ kitsh/buildsrc/kitsh-0.0/main.c @@ -0,0 +1,13 @@ +#include + +int TclKit_AppInit(Tcl_Interp *interp); + +int main(int argc, char **argv) { + Tcl_Interp *x; + + x = Tcl_CreateInterp(); + + Tcl_Main(argc, argv, TclKit_AppInit); + + return(0); +} ADDED kitsh/buildsrc/kitsh-0.0/pwb.c Index: kitsh/buildsrc/kitsh-0.0/pwb.c ================================================================== --- kitsh/buildsrc/kitsh-0.0/pwb.c +++ kitsh/buildsrc/kitsh-0.0/pwb.c @@ -0,0 +1,45 @@ +/* Written by Matt Newman and Jean-Claude Wippler, as part of Tclkit. + * March 2003 - placed in the public domain by the authors. + * + * Expose TclSetLibraryPath to scripts (in 8.4 only, 8.5 has "encoding dirs"). + */ + +#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85 + +#include +#include /* TclGetLibraryPath */ + +void SetExecName(Tcl_Interp *); + +/* Support for encodings, from Vince Darley */ +static int +LibraryPathObjCmd(dummy, interp, objc, objv) + ClientData dummy; + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +{ + if (objc == 1) { + Tcl_SetObjResult(interp, TclGetLibraryPath()); + } else { + Tcl_Obj *path=Tcl_DuplicateObj(objv[1]); + TclSetLibraryPath(Tcl_NewListObj(1,&path)); + TclpSetInitialEncodings(); + Tcl_FindExecutable(Tcl_GetVar(interp, "argv0", TCL_GLOBAL_ONLY)); + /* Hack to get around Tcl bug 1224888 */ + SetExecName(interp); + } + return TCL_OK; +} + +/* + * Public Entrypoint + */ + +DLLEXPORT int Pwb_Init(Tcl_Interp *interp) +{ + Tcl_CreateObjCommand(interp, "librarypath", LibraryPathObjCmd, 0, 0); + return Tcl_PkgProvide( interp, "pwb", "1.1"); +} + +#endif ADDED kitsh/buildsrc/kitsh-0.0/rechan.c Index: kitsh/buildsrc/kitsh-0.0/rechan.c ================================================================== --- kitsh/buildsrc/kitsh-0.0/rechan.c +++ kitsh/buildsrc/kitsh-0.0/rechan.c @@ -0,0 +1,295 @@ +/* Written by Matt Newman and Jean-Claude Wippler, as part of Tclkit. + * March 2003 - placed in the public domain by the authors. + * + * Reflecting channel interface + */ + +#include + +#ifndef TCL_DECLARE_MUTEX +#define TCL_DECLARE_MUTEX(v) +#define Tcl_MutexLock(v) +#define Tcl_MutexUnlock(v) +#endif + + static int mkChanSeq = 0; + TCL_DECLARE_MUTEX(rechanMutex) + +/* Uncomment for Linux or other non-Solaris OS's for memcpy declaration */ +#include + +/* Uncomment for Solaris (and comment above) for memcpy declaration */ +/* #include */ + +#ifndef EINVAL +#define EINVAL 9 +#endif + +typedef struct +{ + Tcl_Channel _chan; + int _validMask; + int _watchMask; + Tcl_Interp* _interp; + Tcl_Obj* _context; + Tcl_Obj* _seek; + Tcl_Obj* _read; + Tcl_Obj* _write; + Tcl_Obj* _name; + Tcl_TimerToken _timer; +} ReflectingChannel; + +static ReflectingChannel* +rcCreate (Tcl_Interp* ip_, Tcl_Obj* context_, int mode_, const char* name_) +{ + ReflectingChannel* cp = (ReflectingChannel*) Tcl_Alloc (sizeof *cp); + + cp->_validMask = mode_; + cp->_watchMask = 0; + cp->_chan = 0; + cp->_context = context_; + cp->_interp = ip_; + cp->_name = Tcl_NewStringObj(name_, -1); + cp->_timer = NULL; + + /* support Tcl_GetIndexFromObj by keeping these objectified */ + cp->_seek = Tcl_NewStringObj("seek", -1); + cp->_read = Tcl_NewStringObj("read", -1); + cp->_write = Tcl_NewStringObj("write", -1); + + Tcl_IncrRefCount(cp->_context); + Tcl_IncrRefCount(cp->_seek); + Tcl_IncrRefCount(cp->_read); + Tcl_IncrRefCount(cp->_write); + Tcl_IncrRefCount(cp->_name); + + return cp; +} + +static Tcl_Obj* +rcBuildCmdList(ReflectingChannel* chan_, Tcl_Obj* cmd_) +{ + Tcl_Obj* vec = Tcl_DuplicateObj(chan_->_context); + Tcl_IncrRefCount(vec); + + Tcl_ListObjAppendElement(chan_->_interp, vec, cmd_); + Tcl_ListObjAppendElement(chan_->_interp, vec, chan_->_name); + + return vec; /* with refcount 1 */ +} + +static int +rcClose (ClientData cd_, Tcl_Interp* interp) +{ + ReflectingChannel* chan = (ReflectingChannel*) cd_; + int n = -1; + + Tcl_SavedResult sr; + Tcl_Obj* cmd = rcBuildCmdList(chan, Tcl_NewStringObj("close", -1)); + Tcl_Interp* ip = chan->_interp; + + Tcl_SaveResult(ip, &sr); + + if (Tcl_EvalObjEx(ip, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT) == TCL_OK) + Tcl_GetIntFromObj(NULL, Tcl_GetObjResult(ip), &n); + + Tcl_RestoreResult(ip, &sr); + Tcl_DecrRefCount(cmd); + + if (chan->_timer != NULL) { + Tcl_DeleteTimerHandler(chan->_timer); + chan->_timer = NULL; + } + + Tcl_DecrRefCount(chan->_context); + Tcl_DecrRefCount(chan->_seek); + Tcl_DecrRefCount(chan->_read); + Tcl_DecrRefCount(chan->_write); + Tcl_DecrRefCount(chan->_name); + Tcl_Free((char*) chan); + + return TCL_OK; +} + +static int +rcInput (ClientData cd_, char* buf, int toRead, int* errorCodePtr) +{ + ReflectingChannel* chan = (ReflectingChannel*) cd_; + int n = -1; + + if (chan->_validMask & TCL_READABLE) { + Tcl_SavedResult sr; + Tcl_Obj* cmd = rcBuildCmdList(chan, chan->_read); + Tcl_Interp* ip = chan->_interp; + + Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewIntObj(toRead)); + Tcl_SaveResult(ip, &sr); + + if (Tcl_EvalObjEx(ip, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT) == TCL_OK) { + void* s = Tcl_GetByteArrayFromObj(Tcl_GetObjResult(ip), &n); + if (0 <= n && n <= toRead) + if (n > 0) + memcpy(buf, s, n); + else + chan->_watchMask &= ~TCL_READABLE; + else + n = -1; + } + + Tcl_RestoreResult(ip, &sr); + Tcl_DecrRefCount(cmd); + } + + if (n < 0) + *errorCodePtr = EINVAL; + return n; +} + +static int +rcOutput (ClientData cd_, const char* buf, int toWrite, int* errorCodePtr) +{ + ReflectingChannel* chan = (ReflectingChannel*) cd_; + int n = -1; + + if (chan->_validMask & TCL_WRITABLE) { + Tcl_SavedResult sr; + Tcl_Obj* cmd = rcBuildCmdList(chan, chan->_write); + Tcl_Interp* ip = chan->_interp; + + Tcl_ListObjAppendElement(NULL, cmd, + Tcl_NewByteArrayObj((unsigned char*) buf, toWrite)); + Tcl_SaveResult(ip, &sr); + + if (Tcl_EvalObjEx(ip, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT) == TCL_OK && + Tcl_GetIntFromObj(NULL, Tcl_GetObjResult(ip), &n) == TCL_OK) + if (0 <= n && n <= toWrite) + chan->_watchMask = chan->_validMask; + else + n = -1; + + Tcl_RestoreResult(ip, &sr); + Tcl_DecrRefCount(cmd); + } + + if (n < 0) + *errorCodePtr = EINVAL; + return n; +} + +static int +rcSeek (ClientData cd_, long offset, int seekMode, int* errorCodePtr) +{ + ReflectingChannel* chan = (ReflectingChannel*) cd_; + int n = -1; + + Tcl_SavedResult sr; + Tcl_Obj* cmd = rcBuildCmdList(chan, chan->_seek); + Tcl_Interp* ip = chan->_interp; + + Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewLongObj(offset)); + Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewIntObj(seekMode)); + Tcl_SaveResult(ip, &sr); + + if (Tcl_EvalObjEx(ip, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT) == TCL_OK && + Tcl_GetIntFromObj(NULL, Tcl_GetObjResult(ip), &n) == TCL_OK) + chan->_watchMask = chan->_validMask; + + Tcl_RestoreResult(ip, &sr); + Tcl_DecrRefCount(cmd); + + if (n < 0) + *errorCodePtr = EINVAL; + return n; +} + +static void +rcTimerProc (ClientData cd_) +{ + ReflectingChannel* chan = (ReflectingChannel*) cd_; + + if (chan->_timer != NULL) + Tcl_DeleteTimerHandler(chan->_timer); + chan->_timer = NULL; + Tcl_NotifyChannel(chan->_chan, chan->_watchMask); +} + +static void +rcWatchChannel (ClientData cd_, int mask) +{ + ReflectingChannel* chan = (ReflectingChannel*) cd_; + + /* Dec 2001: adopting logic used in Andreas Kupries' memchan, i.e. timers */ + + if (mask) { + chan->_watchMask = mask & chan->_validMask; + if (chan->_watchMask && chan->_timer == NULL) + chan->_timer = Tcl_CreateTimerHandler(5, rcTimerProc, cd_); + } else if (chan->_timer != NULL) { + Tcl_DeleteTimerHandler(chan->_timer); + chan->_timer = NULL; + } +} + +static int +rcGetFile (ClientData cd_, int direction, ClientData* handlePtr) +{ + return TCL_ERROR; +} + +static int +rcBlock (ClientData cd_, int mode) +{ + return 0; +} + +static Tcl_ChannelType reChannelType = { + "rechan", /* Type name. */ + (Tcl_ChannelTypeVersion) rcBlock, /* Set blocking/nonblocking behaviour */ + rcClose, /* Close channel, clean instance data */ + rcInput, /* Handle read request */ + rcOutput, /* Handle write request */ + rcSeek, /* Move location of access point. NULL'able */ + 0, /* Set options. NULL'able */ + 0, /* Get options. NULL'able */ + rcWatchChannel, /* Initialize notifier */ + rcGetFile /* Get OS handle from the channel. */ +}; + +static int +cmd_rechan(ClientData cd_, Tcl_Interp* ip_, int objc_, Tcl_Obj*const* objv_) +{ + ReflectingChannel *rc; + int mode; + char buffer [20]; + + if (objc_ != 3) { + Tcl_WrongNumArgs(ip_, 1, objv_, "command mode"); + return TCL_ERROR; + } + + if (Tcl_ListObjLength(ip_, objv_[1], &mode) == TCL_ERROR || + Tcl_GetIntFromObj(ip_, objv_[2], &mode) == TCL_ERROR) + return TCL_ERROR; + + Tcl_MutexLock(&rechanMutex); + sprintf(buffer, "rechan%d", ++mkChanSeq); + Tcl_MutexUnlock(&rechanMutex); + + rc = rcCreate (ip_, objv_[1], mode, buffer); + rc->_chan = Tcl_CreateChannel(&reChannelType, buffer, (ClientData) rc, mode); + + Tcl_RegisterChannel(ip_, rc->_chan); + Tcl_SetChannelOption(ip_, rc->_chan, "-buffering", "none"); + Tcl_SetChannelOption(ip_, rc->_chan, "-blocking", "0"); + + Tcl_SetResult(ip_, buffer, TCL_VOLATILE); + return TCL_OK; +} + +DLLEXPORT int Rechan_Init(Tcl_Interp* interp) +{ + if (!Tcl_InitStubs(interp, "8.4", 0)) + return TCL_ERROR; + Tcl_CreateObjCommand(interp, "rechan", cmd_rechan, 0, 0); + return Tcl_PkgProvide(interp, "rechan", "1.0"); +} ADDED kitsh/buildsrc/kitsh-0.0/zlib.c Index: kitsh/buildsrc/kitsh-0.0/zlib.c ================================================================== --- kitsh/buildsrc/kitsh-0.0/zlib.c +++ kitsh/buildsrc/kitsh-0.0/zlib.c @@ -0,0 +1,211 @@ +/* Written by Jean-Claude Wippler, as part of Tclkit. + * March 2003 - placed in the public domain by the author. + * + * Interface to the "zlib" compression library + */ + +#include "zlib.h" +#include + +typedef struct { + z_stream stream; + Tcl_Obj *indata; +} zlibstream; + +static int +zstreamincmd(ClientData cd, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]) +{ + zlibstream *zp = (zlibstream*) cd; + int count = 0; + int e, index; + Tcl_Obj *obj; + + static CONST84 char* cmds[] = { "fill", "drain", NULL, }; + + if (Tcl_GetIndexFromObj(ip, objv[1], cmds, "option", 0, &index) != TCL_OK) + return TCL_ERROR; + + switch (index) { + + case 0: /* fill ?data? */ + if (objc >= 3) { + Tcl_IncrRefCount(objv[2]); + Tcl_DecrRefCount(zp->indata); + zp->indata = objv[2]; + zp->stream.next_in = Tcl_GetByteArrayFromObj(zp->indata, + (int*) &zp->stream.avail_in); + } + Tcl_SetObjResult(ip, Tcl_NewIntObj(zp->stream.avail_in)); + break; + + case 1: /* drain count */ + if (objc != 3) { + Tcl_WrongNumArgs(ip, 2, objv, "count"); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(ip, objv[2], &count) != TCL_OK) + return TCL_ERROR; + obj = Tcl_GetObjResult(ip); + Tcl_SetByteArrayLength(obj, count); + zp->stream.next_out = Tcl_GetByteArrayFromObj(obj, + (int*) &zp->stream.avail_out); + e = inflate(&zp->stream, Z_NO_FLUSH); + if (e != 0 && e != Z_STREAM_END) { + Tcl_SetResult(ip, (char*) zError(e), TCL_STATIC); + return TCL_ERROR; + } + Tcl_SetByteArrayLength(obj, count - zp->stream.avail_out); + break; + } + return TCL_OK; +} + +void zstreamdelproc(ClientData cd) +{ + zlibstream *zp = (zlibstream*) cd; + inflateEnd(&zp->stream); + Tcl_DecrRefCount(zp->indata); + Tcl_Free((void*) zp); +} + +static int +ZlibCmd(ClientData dummy, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]) +{ + int e = TCL_OK, index, dlen, wbits = -MAX_WBITS; + long flag; + Byte *data; + z_stream stream; + Tcl_Obj *obj = Tcl_GetObjResult(ip); + + static CONST84 char* cmds[] = { + "adler32", "crc32", "compress", "deflate", "decompress", "inflate", + "sdecompress", "sinflate", NULL, + }; + + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(ip, 1, objv, "option data ?...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(ip, objv[1], cmds, "option", 0, &index) != TCL_OK || + objc > 3 && Tcl_GetLongFromObj(ip, objv[3], &flag) != TCL_OK) + return TCL_ERROR; + + data = Tcl_GetByteArrayFromObj(objv[2], &dlen); + + switch (index) { + + case 0: /* adler32 str ?start? -> checksum */ + if (objc < 4) + flag = (long) adler32(0, 0, 0); + Tcl_SetLongObj(obj, (long) adler32((uLong) flag, data, dlen)); + return TCL_OK; + + case 1: /* crc32 str ?start? -> checksum */ + if (objc < 4) + flag = (long) crc32(0, 0, 0); + Tcl_SetLongObj(obj, (long) crc32((uLong) flag, data, dlen)); + return TCL_OK; + + case 2: /* compress data ?level? -> data */ + wbits = MAX_WBITS; + case 3: /* deflate data ?level? -> data */ + if (objc < 4) + flag = Z_DEFAULT_COMPRESSION; + + stream.avail_in = (uInt) dlen; + stream.next_in = data; + + stream.avail_out = (uInt) dlen + dlen / 1000 + 12; + Tcl_SetByteArrayLength(obj, stream.avail_out); + stream.next_out = Tcl_GetByteArrayFromObj(obj, NULL); + + stream.zalloc = 0; + stream.zfree = 0; + stream.opaque = 0; + + e = deflateInit2(&stream, (int) flag, Z_DEFLATED, wbits, + MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); + if (e != Z_OK) + break; + + e = deflate(&stream, Z_FINISH); + if (e != Z_STREAM_END) { + deflateEnd(&stream); + if (e == Z_OK) e = Z_BUF_ERROR; + } else + e = deflateEnd(&stream); + break; + + case 4: /* decompress data ?bufsize? -> data */ + wbits = MAX_WBITS; + case 5: /* inflate data ?bufsize? -> data */ + { + if (objc < 4) + flag = 16 * 1024; + + for (;;) { + stream.zalloc = 0; + stream.zfree = 0; + + /* +1 because ZLIB can "over-request" input (but ignore it) */ + stream.avail_in = (uInt) dlen + 1; + stream.next_in = data; + + stream.avail_out = (uInt) flag; + Tcl_SetByteArrayLength(obj, stream.avail_out); + stream.next_out = Tcl_GetByteArrayFromObj(obj, NULL); + + /* Negative value suppresses ZLIB header */ + e = inflateInit2(&stream, wbits); + if (e == Z_OK) { + e = inflate(&stream, Z_FINISH); + if (e != Z_STREAM_END) { + inflateEnd(&stream); + if (e == Z_OK) e = Z_BUF_ERROR; + } else + e = inflateEnd(&stream); + } + + if (e == Z_OK || e != Z_BUF_ERROR) break; + + Tcl_SetByteArrayLength(obj, 0); + flag *= 2; + } + + break; + } + + case 6: /* sdecompress cmdname -> */ + wbits = MAX_WBITS; + case 7: /* sinflate cmdname -> */ + { + zlibstream *zp = (zlibstream*) Tcl_Alloc(sizeof (zlibstream)); + zp->indata = Tcl_NewObj(); + Tcl_IncrRefCount(zp->indata); + zp->stream.zalloc = 0; + zp->stream.zfree = 0; + zp->stream.opaque = 0; + zp->stream.next_in = 0; + zp->stream.avail_in = 0; + inflateInit2(&zp->stream, wbits); + Tcl_CreateObjCommand(ip, Tcl_GetStringFromObj(objv[2], 0), zstreamincmd, + (ClientData) zp, zstreamdelproc); + return TCL_OK; + } + } + + if (e != Z_OK) { + Tcl_SetResult(ip, (char*) zError(e), TCL_STATIC); + return TCL_ERROR; + } + + Tcl_SetByteArrayLength(obj, stream.total_out); + return TCL_OK; +} + +int Zlib_Init(Tcl_Interp *interp) +{ + Tcl_CreateObjCommand(interp, "zlib", ZlibCmd, 0, 0); + return Tcl_PkgProvide( interp, "zlib", "1.1"); +}