Check-in [9315fecb01]
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  +}