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
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
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 version [22b7e78c5d].
















































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
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 version [52a8d482f1].




























































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
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 <kitfile> <vfsdir>"

	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 version [56adb92a48].













































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
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 <jcw@equi4.com>
 *
 * 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 <tk.h>
#else
#include <tcl.h>
#endif

#ifdef _WIN32
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#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 version [adc8789527].














1
2
3
4
5
6
7
8
9
10
11
12
13
+
+
+
+
+
+
+
+
+
+
+
+
+
#include <tcl.h>

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 version [5ee0d76582].














































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
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 <tcl.h>
#include <tclInt.h> /* TclGetLibraryPath */

void SetExecName(Tcl_Interp *);

/* Support for encodings, from Vince Darley <vince.darley@eurobios.com> */
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 version [95be374a42].








































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
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 <tcl.h>

#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 <memory.h>

/* Uncomment for Solaris (and comment above) for memcpy declaration */
/* #include <string.h> */

#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 version [84ad9e9f88].




















































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
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 <tcl.h>

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");
}