Overview
| Comment: | Added kitsh code |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA1: | 9315fecb01de210133c0825b73bb47d5043c7d71 |
| User & Date: | rkeene on 2010-09-26 04:37:13 |
| Other Links: | manifest | tags |
Context
|
2010-09-26
| ||
| 04:37 |
Updated to use existing Tclkit if found for final step
Updated to build all pieces needed for a tclkit check-in: 74dad5670f user: rkeene tags: trunk | |
| 04:37 | Added kitsh code check-in: 9315fecb01 user: rkeene tags: trunk | |
| 04:37 |
Updated to build shared objects of Mk4tcl and Tclvfs
Added memchan package (needed for tclvfs) check-in: a66d18a60b user: rkeene tags: trunk | |
Changes
Added kitsh/build.sh version [daa9b2e9bc].
1 +#! /bin/bash 2 + 3 +if [ ! -f 'build.sh' ]; then 4 + echo 'ERROR: This script must be run from the directory it is in' >&2 5 + 6 + exit 1 7 +fi 8 +if [ -z "${TCLVERS}" ]; then 9 + echo 'ERROR: The TCLVERS environment variable is not set' >&2 10 + 11 + exit 1 12 +fi 13 + 14 +KITSHVERS="0.0" 15 +BUILDDIR="$(pwd)/build/kitsh-${KITSHVERS}" 16 +OUTDIR="$(pwd)/out" 17 +INSTDIR="$(pwd)/inst" 18 +OTHERPKGSDIR="$(pwd)/../" 19 +export KITSHVERS BUILDDIR OUTDIR INSTDIR OTHERPKGSDIR 20 + 21 +rm -rf 'build' 'out' 'inst' 22 +mkdir 'out' 'inst' || exit 1 23 + 24 + 25 +( 26 + cp -r 'buildsrc' 'build' 27 + cd "${BUILDDIR}" || exit 1 28 + 29 + # Compile all objects... 30 + ## XXX 31 + ${CC:-cc} -I${TCLCONFIGDIR} -I${TCLCONFIGDIR}/../generic -o kit *.c $(find "${OTHERPKGSDIR}" -name '*.a' | grep '/inst/') -lz -lm -ldl -Wl,-Bstatic -lstdc++ -Wl,-Bdynamic 32 + 33 + # Create VFS directory 34 + mkdir "starpack.vfs" 35 + mkdir "starpack.vfs/lib" 36 + 37 + ## Copy in all built directories 38 + cp -r "${OTHERPKGSDIR}"/*/out/* 'starpack.vfs/' 39 + 40 + ## Rename the "vfs" package directory to what "boot.tcl" expects 41 + mv 'starpack.vfs/lib'/vfs* 'starpack.vfs/lib/vfs' 42 + 43 + ## Install "boot.tcl" 44 + cp 'boot.tcl' 'starpack.vfs/' 45 + 46 + # Intall VFS onto kit 47 + ## Copy installed data for packages 48 + mkdir "installed-pkgs" 49 + cp -r "${OTHERPKGSDIR}"/*/inst/* 'installed-pkgs/' 50 + 51 + ## Call installer 52 + ${TCLCONFIGDIR}/tclsh installvfs.tcl kit starpack.vfs 53 + 54 +) || exit 1 55 + 56 +exit 0
Added kitsh/buildsrc/kitsh-0.0/boot.tcl version [22b7e78c5d].
1 +proc tclInit {} { 2 + rename tclInit {} 3 + 4 + global auto_path tcl_library tcl_libPath 5 + global tcl_version tcl_rcFileName 6 + 7 + set noe [info nameofexecutable] 8 + 9 + # Resolve symlinks 10 + set noe [file dirname [file normalize [file join $noe __dummy__]]] 11 + 12 + set tcl_library [file join $noe lib tcl$tcl_version] 13 + set tcl_libPath [list $tcl_library [file join $noe lib]] 14 + 15 + # get rid of a build residue 16 + unset -nocomplain ::tclDefaultLibrary 17 + 18 + # the following code only gets executed once on startup 19 + if {[info exists tcl_rcFileName]} { 20 + load {} vfs 21 + 22 + # lookup and emulate "source" of lib/vfs/{vfs*.tcl,mk4vfs.tcl} 23 + # must use raw MetaKit calls because VFS is not yet in place 24 + set d [mk::select exe.dirs parent 0 name lib] 25 + set d [mk::select exe.dirs parent $d name vfs] 26 + 27 + foreach x {vfsUtils vfslib mk4vfs} { 28 + set n [mk::select exe.dirs!$d.files name $x.tcl] 29 + set s [mk::get exe.dirs!$d.files!$n contents] 30 + catch {set s [zlib decompress $s]} 31 + uplevel #0 $s 32 + } 33 + 34 + # use on-the-fly decompression, if mk4vfs understands that 35 + set mk4vfs::zstreamed 1 36 + 37 + # mount the executable, i.e. make all runtime files available 38 + vfs::filesystem mount $noe [list ::vfs::mk4::handler exe] 39 + 40 + # alter path to find encodings 41 + if {[info tclversion] eq "8.4"} { 42 + load {} pwb 43 + librarypath [info library] 44 + } else { 45 + encoding dirs [list [file join [info library] encoding]] ;# TIP 258 46 + } 47 + 48 + # fix system encoding, if it wasn't properly set up (200207.004 bug) 49 + if {[encoding system] eq "identity"} { 50 + switch $::tcl_platform(platform) { 51 + windows { encoding system cp1252 } 52 + macintosh { encoding system macRoman } 53 + default { encoding system iso8859-1 } 54 + } 55 + } 56 + 57 + # now remount the executable with the correct encoding 58 + #vfs::filesystem unmount $noe 59 + vfs::filesystem unmount [lindex [::vfs::filesystem info] 0] 60 + 61 + set noe [info nameofexecutable] 62 + 63 + # Resolve symlinks 64 + set noe [file dirname [file normalize [file join $noe __dummy__]]] 65 + 66 + set tcl_library [file join $noe lib tcl$tcl_version] 67 + set tcl_libPath [list $tcl_library [file join $noe lib]] 68 + vfs::filesystem mount $noe [list ::vfs::mk4::handler exe] 69 + } 70 + 71 + # load config settings file if present 72 + namespace eval ::vfs { variable tclkit_version 1 } 73 + catch { uplevel #0 [list source [file join $noe config.tcl]] } 74 + 75 + uplevel #0 [list source [file join $tcl_library init.tcl]] 76 + 77 +# reset auto_path, so that init.tcl's search outside of tclkit is cancelled 78 + set auto_path $tcl_libPath 79 +}
Added kitsh/buildsrc/kitsh-0.0/installvfs.tcl version [52a8d482f1].
1 +#! /usr/bin/env tclsh 2 + 3 +lappend auto_path [file join installed-pkgs lib] 4 +package require vfs::mk4 5 + 6 +if {[llength $argv] != 2} { 7 + puts stderr "Usage: installvfs.tcl <kitfile> <vfsdir>" 8 + 9 + exit 1 10 +} 11 + 12 +proc copy_file {srcfile destfile} { 13 + switch -glob -- $srcfile { 14 + "*.tcl" { 15 + set ifd [open $srcfile r] 16 + set ofd [open $destfile w] 17 + 18 + fcopy $ifd $ofd 19 + 20 + close $ofd 21 + close $ifd 22 + } 23 + default { 24 + file copy -- $srcfile $destfile 25 + } 26 + } 27 + 28 + puts "Copied $srcfile to $destfile" 29 +} 30 + 31 +proc recursive_copy {srcdir destdir} { 32 + foreach file [glob -nocomplain -directory $srcdir *] { 33 + set filetail [file tail $file] 34 + set destfile [file join $destdir $filetail] 35 + 36 + if {[file isdirectory $file]} { 37 + file mkdir $destfile 38 + 39 + recursive_copy $file $destfile 40 + 41 + continue 42 + } 43 + 44 + if {[catch { 45 + copy_file $file $destfile 46 + } err]} { 47 + puts stderr "Failed to copy: $file: $err" 48 + } 49 + } 50 +} 51 + 52 +set kitfile [lindex $argv 0] 53 +set vfsdir [lindex $argv 1] 54 + 55 +set handle [vfs::mk4::Mount $kitfile /kit] 56 + 57 +recursive_copy $vfsdir /kit 58 + 59 +vfs::mk4::Unmount $handle /kit
Added kitsh/buildsrc/kitsh-0.0/kitInit.c version [56adb92a48].
1 +/* 2 + * tclAppInit.c -- 3 + * 4 + * Provides a default version of the main program and Tcl_AppInit 5 + * procedure for Tcl applications (without Tk). Note that this 6 + * program must be built in Win32 console mode to work properly. 7 + * 8 + * Copyright (c) 1996-1997 by Sun Microsystems, Inc. 9 + * Copyright (c) 1998-1999 by Scriptics Corporation. 10 + * Copyright (c) 2000-2002 Jean-Claude Wippler <jcw@equi4.com> 11 + * 12 + * See the file "license.terms" for information on usage and redistribution 13 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 14 + * 15 + * RCS: @(#) $Id$ 16 + */ 17 + 18 +#ifdef KIT_INCLUDES_TK 19 +#include <tk.h> 20 +#else 21 +#include <tcl.h> 22 +#endif 23 + 24 +#ifdef _WIN32 25 +#define WIN32_LEAN_AND_MEAN 26 +#include <windows.h> 27 +#undef WIN32_LEAN_AND_MEAN 28 +#endif 29 + 30 +#ifndef MB_TASKMODAL 31 +#define MB_TASKMODAL 0 32 +#endif 33 + 34 +#include "tclInt.h" 35 + 36 +#ifdef KIT_INCLUDES_ITCL 37 +Tcl_AppInitProc Itcl_Init; 38 +#endif 39 +Tcl_AppInitProc Mk4tcl_Init, Vfs_Init, Rechan_Init, Zlib_Init; 40 +#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85 41 +Tcl_AppInitProc Pwb_Init; 42 +#endif 43 +#ifdef TCL_THREADS 44 +Tcl_AppInitProc Thread_Init; 45 +#endif 46 +#ifdef _WIN32 47 +Tcl_AppInitProc Dde_Init, Registry_Init; 48 +#endif 49 + 50 +char *tclExecutableName; 51 + 52 + /* 53 + * Attempt to load a "boot.tcl" entry from the embedded MetaKit file. 54 + * If there isn't one, try to open a regular "setup.tcl" file instead. 55 + * If that fails, this code will throw an error, using a message box. 56 + */ 57 + 58 +static char *preInitCmd = 59 +#ifdef _WIN32_WCE 60 +/* silly hack to get wince port to launch, some sort of std{in,out,err} problem */ 61 +"open /kitout.txt a; open /kitout.txt a; open /kitout.txt a\n" 62 +/* this too seems to be needed on wince - it appears to be related to the above */ 63 +"catch {rename source ::tcl::source}\n" 64 +"proc source file {\n" 65 + "set old [info script]\n" 66 + "info script $file\n" 67 + "set fid [open $file]\n" 68 + "set data [read $fid]\n" 69 + "close $fid\n" 70 + "set code [catch {uplevel 1 $data} res]\n" 71 + "info script $old\n" 72 + "if {$code == 2} { set code 0 }\n" 73 + "return -code $code $res\n" 74 +"}\n" 75 +#endif 76 +"proc tclKitInit {} {\n" 77 + "rename tclKitInit {}\n" 78 + "load {} Mk4tcl\n" 79 + "mk::file open exe [info nameofexecutable] -readonly\n" 80 + "set n [mk::select exe.dirs!0.files name boot.tcl]\n" 81 + "if {$n != \"\"} {\n" 82 + "set s [mk::get exe.dirs!0.files!$n contents]\n" 83 + "if {![string length $s]} { error \"empty boot.tcl\" }\n" 84 + "catch {load {} zlib}\n" 85 + "if {[mk::get exe.dirs!0.files!$n size] != [string length $s]} {\n" 86 + "set s [zlib decompress $s]\n" 87 + "}\n" 88 + "} else {\n" 89 + "set f [open setup.tcl]\n" 90 + "set s [read $f]\n" 91 + "close $f\n" 92 + "}\n" 93 + "uplevel #0 $s\n" 94 +#ifdef _WIN32 95 + "package ifneeded dde 1.3.1 {load {} dde}\n" 96 + "package ifneeded registry 1.1.5 {load {} registry}\n" 97 +#endif 98 +"}\n" 99 +"tclKitInit" 100 +; 101 + 102 +static const char initScript[] = 103 +"if {[file isfile [file join [info nameofexe] main.tcl]]} {\n" 104 + "if {[info commands console] != {}} { console hide }\n" 105 + "set tcl_interactive 0\n" 106 + "incr argc\n" 107 + "set argv [linsert $argv 0 $argv0]\n" 108 + "set argv0 [file join [info nameofexe] main.tcl]\n" 109 +"} else continue\n" 110 +; 111 + 112 +/* SetExecName -- 113 + 114 + Hack to get around Tcl bug 1224888. 115 +*/ 116 + 117 +void SetExecName(Tcl_Interp *interp) { 118 + if (tclExecutableName == NULL) { 119 + int len = 0; 120 + Tcl_Obj *execNameObj; 121 + Tcl_Obj *lobjv[1]; 122 + 123 + lobjv[0] = Tcl_GetVar2Ex(interp, "argv0", NULL, TCL_GLOBAL_ONLY); 124 + execNameObj = Tcl_FSJoinToPath(Tcl_FSGetCwd(interp), 1, lobjv); 125 + 126 + tclExecutableName = strdup(Tcl_GetStringFromObj(execNameObj, &len)); 127 + } 128 +} 129 + 130 +int 131 +TclKit_AppInit(Tcl_Interp *interp) 132 +{ 133 +#ifdef KIT_INCLUDES_ITCL 134 + Tcl_StaticPackage(0, "Itcl", Itcl_Init, NULL); 135 +#endif 136 + Tcl_StaticPackage(0, "Mk4tcl", Mk4tcl_Init, NULL); 137 +#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85 138 + Tcl_StaticPackage(0, "pwb", Pwb_Init, NULL); 139 +#endif 140 + Tcl_StaticPackage(0, "rechan", Rechan_Init, NULL); 141 + Tcl_StaticPackage(0, "vfs", Vfs_Init, NULL); 142 + Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL); 143 +#ifdef TCL_THREADS 144 + Tcl_StaticPackage(0, "Thread", Thread_Init, NULL); 145 +#endif 146 +#ifdef _WIN32 147 + Tcl_StaticPackage(0, "dde", Dde_Init, NULL); 148 + Tcl_StaticPackage(0, "registry", Registry_Init, NULL); 149 +#endif 150 +#ifdef KIT_INCLUDES_TK 151 + Tcl_StaticPackage(0, "Tk", Tk_Init, Tk_SafeInit); 152 +#endif 153 + 154 + /* the tcl_rcFileName variable only exists in the initial interpreter */ 155 +#ifdef _WIN32 156 + Tcl_SetVar(interp, "tcl_rcFileName", "~/tclkitrc.tcl", TCL_GLOBAL_ONLY); 157 +#else 158 + Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclkitrc", TCL_GLOBAL_ONLY); 159 +#endif 160 + 161 + /* Hack to get around Tcl bug 1224888. This must be run here and 162 + * in LibraryPathObjCmd because this information is needed both 163 + * before and after that command is run. */ 164 + SetExecName(interp); 165 + 166 + TclSetPreInitScript(preInitCmd); 167 + if (Tcl_Init(interp) == TCL_ERROR) 168 + goto error; 169 + 170 +#ifdef KIT_INCLUDES_TK 171 +#ifdef _WIN32 172 + if (Tk_Init(interp) == TCL_ERROR) 173 + goto error; 174 + if (Tk_CreateConsoleWindow(interp) == TCL_ERROR) 175 + goto error; 176 +#endif 177 +#endif 178 + 179 + /* messy because TclSetStartupScriptPath is called slightly too late */ 180 + if (Tcl_Eval(interp, initScript) == TCL_OK) { 181 + Tcl_Obj* path = TclGetStartupScriptPath(); 182 + TclSetStartupScriptPath(Tcl_GetObjResult(interp)); 183 + if (path == NULL) 184 + Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]"); 185 + } 186 + 187 + Tcl_SetVar(interp, "errorInfo", "", TCL_GLOBAL_ONLY); 188 + Tcl_ResetResult(interp); 189 + return TCL_OK; 190 + 191 +error: 192 +#ifdef KIT_INCLUDES_TK 193 +#ifdef _WIN32 194 + MessageBeep(MB_ICONEXCLAMATION); 195 +#ifndef _WIN32_WCE 196 + MessageBox(NULL, Tcl_GetStringResult(interp), "Error in TclKit", 197 + MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND); 198 + ExitProcess(1); 199 +#endif 200 + /* we won't reach this, but we need the return */ 201 +#endif 202 +#endif 203 + return TCL_ERROR; 204 +}
Added kitsh/buildsrc/kitsh-0.0/main.c version [adc8789527].
1 +#include <tcl.h> 2 + 3 +int TclKit_AppInit(Tcl_Interp *interp); 4 + 5 +int main(int argc, char **argv) { 6 + Tcl_Interp *x; 7 + 8 + x = Tcl_CreateInterp(); 9 + 10 + Tcl_Main(argc, argv, TclKit_AppInit); 11 + 12 + return(0); 13 +}
Added kitsh/buildsrc/kitsh-0.0/pwb.c version [5ee0d76582].
1 +/* Written by Matt Newman and Jean-Claude Wippler, as part of Tclkit. 2 + * March 2003 - placed in the public domain by the authors. 3 + * 4 + * Expose TclSetLibraryPath to scripts (in 8.4 only, 8.5 has "encoding dirs"). 5 + */ 6 + 7 +#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85 8 + 9 +#include <tcl.h> 10 +#include <tclInt.h> /* TclGetLibraryPath */ 11 + 12 +void SetExecName(Tcl_Interp *); 13 + 14 +/* Support for encodings, from Vince Darley <vince.darley@eurobios.com> */ 15 +static int 16 +LibraryPathObjCmd(dummy, interp, objc, objv) 17 + ClientData dummy; 18 + Tcl_Interp *interp; 19 + int objc; 20 + Tcl_Obj *CONST objv[]; 21 +{ 22 + if (objc == 1) { 23 + Tcl_SetObjResult(interp, TclGetLibraryPath()); 24 + } else { 25 + Tcl_Obj *path=Tcl_DuplicateObj(objv[1]); 26 + TclSetLibraryPath(Tcl_NewListObj(1,&path)); 27 + TclpSetInitialEncodings(); 28 + Tcl_FindExecutable(Tcl_GetVar(interp, "argv0", TCL_GLOBAL_ONLY)); 29 + /* Hack to get around Tcl bug 1224888 */ 30 + SetExecName(interp); 31 + } 32 + return TCL_OK; 33 +} 34 + 35 +/* 36 + * Public Entrypoint 37 + */ 38 + 39 +DLLEXPORT int Pwb_Init(Tcl_Interp *interp) 40 +{ 41 + Tcl_CreateObjCommand(interp, "librarypath", LibraryPathObjCmd, 0, 0); 42 + return Tcl_PkgProvide( interp, "pwb", "1.1"); 43 +} 44 + 45 +#endif
Added kitsh/buildsrc/kitsh-0.0/rechan.c version [95be374a42].
1 +/* Written by Matt Newman and Jean-Claude Wippler, as part of Tclkit. 2 + * March 2003 - placed in the public domain by the authors. 3 + * 4 + * Reflecting channel interface 5 + */ 6 + 7 +#include <tcl.h> 8 + 9 +#ifndef TCL_DECLARE_MUTEX 10 +#define TCL_DECLARE_MUTEX(v) 11 +#define Tcl_MutexLock(v) 12 +#define Tcl_MutexUnlock(v) 13 +#endif 14 + 15 + static int mkChanSeq = 0; 16 + TCL_DECLARE_MUTEX(rechanMutex) 17 + 18 +/* Uncomment for Linux or other non-Solaris OS's for memcpy declaration */ 19 +#include <memory.h> 20 + 21 +/* Uncomment for Solaris (and comment above) for memcpy declaration */ 22 +/* #include <string.h> */ 23 + 24 +#ifndef EINVAL 25 +#define EINVAL 9 26 +#endif 27 + 28 +typedef struct 29 +{ 30 + Tcl_Channel _chan; 31 + int _validMask; 32 + int _watchMask; 33 + Tcl_Interp* _interp; 34 + Tcl_Obj* _context; 35 + Tcl_Obj* _seek; 36 + Tcl_Obj* _read; 37 + Tcl_Obj* _write; 38 + Tcl_Obj* _name; 39 + Tcl_TimerToken _timer; 40 +} ReflectingChannel; 41 + 42 +static ReflectingChannel* 43 +rcCreate (Tcl_Interp* ip_, Tcl_Obj* context_, int mode_, const char* name_) 44 +{ 45 + ReflectingChannel* cp = (ReflectingChannel*) Tcl_Alloc (sizeof *cp); 46 + 47 + cp->_validMask = mode_; 48 + cp->_watchMask = 0; 49 + cp->_chan = 0; 50 + cp->_context = context_; 51 + cp->_interp = ip_; 52 + cp->_name = Tcl_NewStringObj(name_, -1); 53 + cp->_timer = NULL; 54 + 55 + /* support Tcl_GetIndexFromObj by keeping these objectified */ 56 + cp->_seek = Tcl_NewStringObj("seek", -1); 57 + cp->_read = Tcl_NewStringObj("read", -1); 58 + cp->_write = Tcl_NewStringObj("write", -1); 59 + 60 + Tcl_IncrRefCount(cp->_context); 61 + Tcl_IncrRefCount(cp->_seek); 62 + Tcl_IncrRefCount(cp->_read); 63 + Tcl_IncrRefCount(cp->_write); 64 + Tcl_IncrRefCount(cp->_name); 65 + 66 + return cp; 67 +} 68 + 69 +static Tcl_Obj* 70 +rcBuildCmdList(ReflectingChannel* chan_, Tcl_Obj* cmd_) 71 +{ 72 + Tcl_Obj* vec = Tcl_DuplicateObj(chan_->_context); 73 + Tcl_IncrRefCount(vec); 74 + 75 + Tcl_ListObjAppendElement(chan_->_interp, vec, cmd_); 76 + Tcl_ListObjAppendElement(chan_->_interp, vec, chan_->_name); 77 + 78 + return vec; /* with refcount 1 */ 79 +} 80 + 81 +static int 82 +rcClose (ClientData cd_, Tcl_Interp* interp) 83 +{ 84 + ReflectingChannel* chan = (ReflectingChannel*) cd_; 85 + int n = -1; 86 + 87 + Tcl_SavedResult sr; 88 + Tcl_Obj* cmd = rcBuildCmdList(chan, Tcl_NewStringObj("close", -1)); 89 + Tcl_Interp* ip = chan->_interp; 90 + 91 + Tcl_SaveResult(ip, &sr); 92 + 93 + if (Tcl_EvalObjEx(ip, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT) == TCL_OK) 94 + Tcl_GetIntFromObj(NULL, Tcl_GetObjResult(ip), &n); 95 + 96 + Tcl_RestoreResult(ip, &sr); 97 + Tcl_DecrRefCount(cmd); 98 + 99 + if (chan->_timer != NULL) { 100 + Tcl_DeleteTimerHandler(chan->_timer); 101 + chan->_timer = NULL; 102 + } 103 + 104 + Tcl_DecrRefCount(chan->_context); 105 + Tcl_DecrRefCount(chan->_seek); 106 + Tcl_DecrRefCount(chan->_read); 107 + Tcl_DecrRefCount(chan->_write); 108 + Tcl_DecrRefCount(chan->_name); 109 + Tcl_Free((char*) chan); 110 + 111 + return TCL_OK; 112 +} 113 + 114 +static int 115 +rcInput (ClientData cd_, char* buf, int toRead, int* errorCodePtr) 116 +{ 117 + ReflectingChannel* chan = (ReflectingChannel*) cd_; 118 + int n = -1; 119 + 120 + if (chan->_validMask & TCL_READABLE) { 121 + Tcl_SavedResult sr; 122 + Tcl_Obj* cmd = rcBuildCmdList(chan, chan->_read); 123 + Tcl_Interp* ip = chan->_interp; 124 + 125 + Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewIntObj(toRead)); 126 + Tcl_SaveResult(ip, &sr); 127 + 128 + if (Tcl_EvalObjEx(ip, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT) == TCL_OK) { 129 + void* s = Tcl_GetByteArrayFromObj(Tcl_GetObjResult(ip), &n); 130 + if (0 <= n && n <= toRead) 131 + if (n > 0) 132 + memcpy(buf, s, n); 133 + else 134 + chan->_watchMask &= ~TCL_READABLE; 135 + else 136 + n = -1; 137 + } 138 + 139 + Tcl_RestoreResult(ip, &sr); 140 + Tcl_DecrRefCount(cmd); 141 + } 142 + 143 + if (n < 0) 144 + *errorCodePtr = EINVAL; 145 + return n; 146 +} 147 + 148 +static int 149 +rcOutput (ClientData cd_, const char* buf, int toWrite, int* errorCodePtr) 150 +{ 151 + ReflectingChannel* chan = (ReflectingChannel*) cd_; 152 + int n = -1; 153 + 154 + if (chan->_validMask & TCL_WRITABLE) { 155 + Tcl_SavedResult sr; 156 + Tcl_Obj* cmd = rcBuildCmdList(chan, chan->_write); 157 + Tcl_Interp* ip = chan->_interp; 158 + 159 + Tcl_ListObjAppendElement(NULL, cmd, 160 + Tcl_NewByteArrayObj((unsigned char*) buf, toWrite)); 161 + Tcl_SaveResult(ip, &sr); 162 + 163 + if (Tcl_EvalObjEx(ip, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT) == TCL_OK && 164 + Tcl_GetIntFromObj(NULL, Tcl_GetObjResult(ip), &n) == TCL_OK) 165 + if (0 <= n && n <= toWrite) 166 + chan->_watchMask = chan->_validMask; 167 + else 168 + n = -1; 169 + 170 + Tcl_RestoreResult(ip, &sr); 171 + Tcl_DecrRefCount(cmd); 172 + } 173 + 174 + if (n < 0) 175 + *errorCodePtr = EINVAL; 176 + return n; 177 +} 178 + 179 +static int 180 +rcSeek (ClientData cd_, long offset, int seekMode, int* errorCodePtr) 181 +{ 182 + ReflectingChannel* chan = (ReflectingChannel*) cd_; 183 + int n = -1; 184 + 185 + Tcl_SavedResult sr; 186 + Tcl_Obj* cmd = rcBuildCmdList(chan, chan->_seek); 187 + Tcl_Interp* ip = chan->_interp; 188 + 189 + Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewLongObj(offset)); 190 + Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewIntObj(seekMode)); 191 + Tcl_SaveResult(ip, &sr); 192 + 193 + if (Tcl_EvalObjEx(ip, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT) == TCL_OK && 194 + Tcl_GetIntFromObj(NULL, Tcl_GetObjResult(ip), &n) == TCL_OK) 195 + chan->_watchMask = chan->_validMask; 196 + 197 + Tcl_RestoreResult(ip, &sr); 198 + Tcl_DecrRefCount(cmd); 199 + 200 + if (n < 0) 201 + *errorCodePtr = EINVAL; 202 + return n; 203 +} 204 + 205 +static void 206 +rcTimerProc (ClientData cd_) 207 +{ 208 + ReflectingChannel* chan = (ReflectingChannel*) cd_; 209 + 210 + if (chan->_timer != NULL) 211 + Tcl_DeleteTimerHandler(chan->_timer); 212 + chan->_timer = NULL; 213 + Tcl_NotifyChannel(chan->_chan, chan->_watchMask); 214 +} 215 + 216 +static void 217 +rcWatchChannel (ClientData cd_, int mask) 218 +{ 219 + ReflectingChannel* chan = (ReflectingChannel*) cd_; 220 + 221 + /* Dec 2001: adopting logic used in Andreas Kupries' memchan, i.e. timers */ 222 + 223 + if (mask) { 224 + chan->_watchMask = mask & chan->_validMask; 225 + if (chan->_watchMask && chan->_timer == NULL) 226 + chan->_timer = Tcl_CreateTimerHandler(5, rcTimerProc, cd_); 227 + } else if (chan->_timer != NULL) { 228 + Tcl_DeleteTimerHandler(chan->_timer); 229 + chan->_timer = NULL; 230 + } 231 +} 232 + 233 +static int 234 +rcGetFile (ClientData cd_, int direction, ClientData* handlePtr) 235 +{ 236 + return TCL_ERROR; 237 +} 238 + 239 +static int 240 +rcBlock (ClientData cd_, int mode) 241 +{ 242 + return 0; 243 +} 244 + 245 +static Tcl_ChannelType reChannelType = { 246 + "rechan", /* Type name. */ 247 + (Tcl_ChannelTypeVersion) rcBlock, /* Set blocking/nonblocking behaviour */ 248 + rcClose, /* Close channel, clean instance data */ 249 + rcInput, /* Handle read request */ 250 + rcOutput, /* Handle write request */ 251 + rcSeek, /* Move location of access point. NULL'able */ 252 + 0, /* Set options. NULL'able */ 253 + 0, /* Get options. NULL'able */ 254 + rcWatchChannel, /* Initialize notifier */ 255 + rcGetFile /* Get OS handle from the channel. */ 256 +}; 257 + 258 +static int 259 +cmd_rechan(ClientData cd_, Tcl_Interp* ip_, int objc_, Tcl_Obj*const* objv_) 260 +{ 261 + ReflectingChannel *rc; 262 + int mode; 263 + char buffer [20]; 264 + 265 + if (objc_ != 3) { 266 + Tcl_WrongNumArgs(ip_, 1, objv_, "command mode"); 267 + return TCL_ERROR; 268 + } 269 + 270 + if (Tcl_ListObjLength(ip_, objv_[1], &mode) == TCL_ERROR || 271 + Tcl_GetIntFromObj(ip_, objv_[2], &mode) == TCL_ERROR) 272 + return TCL_ERROR; 273 + 274 + Tcl_MutexLock(&rechanMutex); 275 + sprintf(buffer, "rechan%d", ++mkChanSeq); 276 + Tcl_MutexUnlock(&rechanMutex); 277 + 278 + rc = rcCreate (ip_, objv_[1], mode, buffer); 279 + rc->_chan = Tcl_CreateChannel(&reChannelType, buffer, (ClientData) rc, mode); 280 + 281 + Tcl_RegisterChannel(ip_, rc->_chan); 282 + Tcl_SetChannelOption(ip_, rc->_chan, "-buffering", "none"); 283 + Tcl_SetChannelOption(ip_, rc->_chan, "-blocking", "0"); 284 + 285 + Tcl_SetResult(ip_, buffer, TCL_VOLATILE); 286 + return TCL_OK; 287 +} 288 + 289 +DLLEXPORT int Rechan_Init(Tcl_Interp* interp) 290 +{ 291 + if (!Tcl_InitStubs(interp, "8.4", 0)) 292 + return TCL_ERROR; 293 + Tcl_CreateObjCommand(interp, "rechan", cmd_rechan, 0, 0); 294 + return Tcl_PkgProvide(interp, "rechan", "1.0"); 295 +}
Added kitsh/buildsrc/kitsh-0.0/zlib.c version [84ad9e9f88].
1 +/* Written by Jean-Claude Wippler, as part of Tclkit. 2 + * March 2003 - placed in the public domain by the author. 3 + * 4 + * Interface to the "zlib" compression library 5 + */ 6 + 7 +#include "zlib.h" 8 +#include <tcl.h> 9 + 10 +typedef struct { 11 + z_stream stream; 12 + Tcl_Obj *indata; 13 +} zlibstream; 14 + 15 +static int 16 +zstreamincmd(ClientData cd, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]) 17 +{ 18 + zlibstream *zp = (zlibstream*) cd; 19 + int count = 0; 20 + int e, index; 21 + Tcl_Obj *obj; 22 + 23 + static CONST84 char* cmds[] = { "fill", "drain", NULL, }; 24 + 25 + if (Tcl_GetIndexFromObj(ip, objv[1], cmds, "option", 0, &index) != TCL_OK) 26 + return TCL_ERROR; 27 + 28 + switch (index) { 29 + 30 + case 0: /* fill ?data? */ 31 + if (objc >= 3) { 32 + Tcl_IncrRefCount(objv[2]); 33 + Tcl_DecrRefCount(zp->indata); 34 + zp->indata = objv[2]; 35 + zp->stream.next_in = Tcl_GetByteArrayFromObj(zp->indata, 36 + (int*) &zp->stream.avail_in); 37 + } 38 + Tcl_SetObjResult(ip, Tcl_NewIntObj(zp->stream.avail_in)); 39 + break; 40 + 41 + case 1: /* drain count */ 42 + if (objc != 3) { 43 + Tcl_WrongNumArgs(ip, 2, objv, "count"); 44 + return TCL_ERROR; 45 + } 46 + if (Tcl_GetIntFromObj(ip, objv[2], &count) != TCL_OK) 47 + return TCL_ERROR; 48 + obj = Tcl_GetObjResult(ip); 49 + Tcl_SetByteArrayLength(obj, count); 50 + zp->stream.next_out = Tcl_GetByteArrayFromObj(obj, 51 + (int*) &zp->stream.avail_out); 52 + e = inflate(&zp->stream, Z_NO_FLUSH); 53 + if (e != 0 && e != Z_STREAM_END) { 54 + Tcl_SetResult(ip, (char*) zError(e), TCL_STATIC); 55 + return TCL_ERROR; 56 + } 57 + Tcl_SetByteArrayLength(obj, count - zp->stream.avail_out); 58 + break; 59 + } 60 + return TCL_OK; 61 +} 62 + 63 +void zstreamdelproc(ClientData cd) 64 +{ 65 + zlibstream *zp = (zlibstream*) cd; 66 + inflateEnd(&zp->stream); 67 + Tcl_DecrRefCount(zp->indata); 68 + Tcl_Free((void*) zp); 69 +} 70 + 71 +static int 72 +ZlibCmd(ClientData dummy, Tcl_Interp *ip, int objc, Tcl_Obj *CONST objv[]) 73 +{ 74 + int e = TCL_OK, index, dlen, wbits = -MAX_WBITS; 75 + long flag; 76 + Byte *data; 77 + z_stream stream; 78 + Tcl_Obj *obj = Tcl_GetObjResult(ip); 79 + 80 + static CONST84 char* cmds[] = { 81 + "adler32", "crc32", "compress", "deflate", "decompress", "inflate", 82 + "sdecompress", "sinflate", NULL, 83 + }; 84 + 85 + if (objc < 3 || objc > 4) { 86 + Tcl_WrongNumArgs(ip, 1, objv, "option data ?...?"); 87 + return TCL_ERROR; 88 + } 89 + 90 + if (Tcl_GetIndexFromObj(ip, objv[1], cmds, "option", 0, &index) != TCL_OK || 91 + objc > 3 && Tcl_GetLongFromObj(ip, objv[3], &flag) != TCL_OK) 92 + return TCL_ERROR; 93 + 94 + data = Tcl_GetByteArrayFromObj(objv[2], &dlen); 95 + 96 + switch (index) { 97 + 98 + case 0: /* adler32 str ?start? -> checksum */ 99 + if (objc < 4) 100 + flag = (long) adler32(0, 0, 0); 101 + Tcl_SetLongObj(obj, (long) adler32((uLong) flag, data, dlen)); 102 + return TCL_OK; 103 + 104 + case 1: /* crc32 str ?start? -> checksum */ 105 + if (objc < 4) 106 + flag = (long) crc32(0, 0, 0); 107 + Tcl_SetLongObj(obj, (long) crc32((uLong) flag, data, dlen)); 108 + return TCL_OK; 109 + 110 + case 2: /* compress data ?level? -> data */ 111 + wbits = MAX_WBITS; 112 + case 3: /* deflate data ?level? -> data */ 113 + if (objc < 4) 114 + flag = Z_DEFAULT_COMPRESSION; 115 + 116 + stream.avail_in = (uInt) dlen; 117 + stream.next_in = data; 118 + 119 + stream.avail_out = (uInt) dlen + dlen / 1000 + 12; 120 + Tcl_SetByteArrayLength(obj, stream.avail_out); 121 + stream.next_out = Tcl_GetByteArrayFromObj(obj, NULL); 122 + 123 + stream.zalloc = 0; 124 + stream.zfree = 0; 125 + stream.opaque = 0; 126 + 127 + e = deflateInit2(&stream, (int) flag, Z_DEFLATED, wbits, 128 + MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY); 129 + if (e != Z_OK) 130 + break; 131 + 132 + e = deflate(&stream, Z_FINISH); 133 + if (e != Z_STREAM_END) { 134 + deflateEnd(&stream); 135 + if (e == Z_OK) e = Z_BUF_ERROR; 136 + } else 137 + e = deflateEnd(&stream); 138 + break; 139 + 140 + case 4: /* decompress data ?bufsize? -> data */ 141 + wbits = MAX_WBITS; 142 + case 5: /* inflate data ?bufsize? -> data */ 143 + { 144 + if (objc < 4) 145 + flag = 16 * 1024; 146 + 147 + for (;;) { 148 + stream.zalloc = 0; 149 + stream.zfree = 0; 150 + 151 + /* +1 because ZLIB can "over-request" input (but ignore it) */ 152 + stream.avail_in = (uInt) dlen + 1; 153 + stream.next_in = data; 154 + 155 + stream.avail_out = (uInt) flag; 156 + Tcl_SetByteArrayLength(obj, stream.avail_out); 157 + stream.next_out = Tcl_GetByteArrayFromObj(obj, NULL); 158 + 159 + /* Negative value suppresses ZLIB header */ 160 + e = inflateInit2(&stream, wbits); 161 + if (e == Z_OK) { 162 + e = inflate(&stream, Z_FINISH); 163 + if (e != Z_STREAM_END) { 164 + inflateEnd(&stream); 165 + if (e == Z_OK) e = Z_BUF_ERROR; 166 + } else 167 + e = inflateEnd(&stream); 168 + } 169 + 170 + if (e == Z_OK || e != Z_BUF_ERROR) break; 171 + 172 + Tcl_SetByteArrayLength(obj, 0); 173 + flag *= 2; 174 + } 175 + 176 + break; 177 + } 178 + 179 + case 6: /* sdecompress cmdname -> */ 180 + wbits = MAX_WBITS; 181 + case 7: /* sinflate cmdname -> */ 182 + { 183 + zlibstream *zp = (zlibstream*) Tcl_Alloc(sizeof (zlibstream)); 184 + zp->indata = Tcl_NewObj(); 185 + Tcl_IncrRefCount(zp->indata); 186 + zp->stream.zalloc = 0; 187 + zp->stream.zfree = 0; 188 + zp->stream.opaque = 0; 189 + zp->stream.next_in = 0; 190 + zp->stream.avail_in = 0; 191 + inflateInit2(&zp->stream, wbits); 192 + Tcl_CreateObjCommand(ip, Tcl_GetStringFromObj(objv[2], 0), zstreamincmd, 193 + (ClientData) zp, zstreamdelproc); 194 + return TCL_OK; 195 + } 196 + } 197 + 198 + if (e != Z_OK) { 199 + Tcl_SetResult(ip, (char*) zError(e), TCL_STATIC); 200 + return TCL_ERROR; 201 + } 202 + 203 + Tcl_SetByteArrayLength(obj, stream.total_out); 204 + return TCL_OK; 205 +} 206 + 207 +int Zlib_Init(Tcl_Interp *interp) 208 +{ 209 + Tcl_CreateObjCommand(interp, "zlib", ZlibCmd, 0, 0); 210 + return Tcl_PkgProvide( interp, "zlib", "1.1"); 211 +}