KitCreator
Check-in [7bfc5cf0e2]
Login
HomeDownloadsSource CodeTicketsWiki
Overview
Comment:Began work on new pure-Tcl metakit, which will replace readkit-converted mk4tcl
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 7bfc5cf0e25159c5f43a0786167eea2b69d0911e
User & Date: rkeene on 2010-09-26 04:41:04
Other Links: manifest | tags
Context
2010-09-26
04:41
Updated to not produce spurious newline check-in: 0aa038624e user: rkeene tags: trunk
04:41
Began work on new pure-Tcl metakit, which will replace readkit-converted mk4tcl check-in: 7bfc5cf0e2 user: rkeene tags: trunk
04:41
Updated to be less verbose on missing directories check-in: ea9a5ecf91 user: rkeene tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Added kitsh/buildsrc/kitsh-0.0/mk4tcl-new.tcl version [737d3e66d5]. 






































































































































































































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

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

#! /usr/bin/env tclsh

namespace eval ::mk {}
namespace eval ::mk::file {}
namespace eval ::mk::view {}
namespace eval ::mk::cursor {}
namespace eval ::mk::row {}
namespace eval ::mk::private {}

proc ::mk::file {cmd args} {
	set args [lindex $args 0 ::mk::file::${cmd}]

	return [eval $args]
}

proc ::mk::file::open {args} {
	if {[llength $args] == 0} {
		# Return open tags

		set retval [list]
		foreach tag [array names ::mk::private::tags] {
			unset -nocomplain taginfo
			array set taginfo $::mk::private::tags($tag)

			lappend retval $tag $taginfo(file)
		}

		return 
	}

	set tag [lindex $args 0]
	if {[info exists ::mk::private::tags($tag)]} {
		return -code error "tag is already open"
	}

	set taginfo(writable) 1
	set taginfo(commit_on_close) 1
	set taginfo(commit_on_set) 0
	set taginfo(extend) 0
	set taginfo(shared) 0

	if {[llength $args] == 1} {
		# Use in-memory file

		set taginfo(file) ""
		set taginfo(fd) ""
	} else {
		set filename [lindex $args 1]

		foreach opt [lrange $args 2 end] {
			switch -- $opt {
				"-readonly" {
					set taginfo(writable) 0
				}
				"-nocommit" {
					set taginfo(commit_on_close) 0
				}
				"-extend" {
					set taginfo(extend) 1
				}
				"-shared" {
					set taginfo(shared) 1
				}
			}
		}

		if {$taginfo(writable)} {
			set fd [open $filename a+]
			seek $fd 0 start
		} else {
			set fd [open $filename r]
		}

		set taginfo(file) $filename
		set taginfo(fd) $fd
	}

	set ::mk::private::changes($tag) [list]
	set ::mk::private::tags($tag) [array get taginfo]
}

proc ::mk::file::close {tag} {
	if {![info exists ::mk::private::tags($tag)]} {
		return -code error "no storage with this name"
	}

	array set taginfo $::mk::private::tags($tag)

	if {$taginfo(commit_on_close) && $taginfo(writable) && $taginfo(fd) != ""} {
		mk::file commit $tag -full
	}

	if {$taginfo(fd) != ""} {
		close $taginfo(fd)
	}

	unset ::mk::private::changes($tag)
	unset ::mk::private::tags($tag)
}

proc ::mk::file::views {{tag ""}} {
	return -code error "Not Implemented"
}

proc ::mk::file::commit {tag {fullOpt ""}} {
	if {![info exists ::mk::private::tags($tag)]} {
		return -code error "no storage with this name"
	}

	array set taginfo $::mk::private::tags($tag)

	if {$fullOpt == "-full"} {
		# Flush asides
		# XXX: TODO
	}

	if {$taginfo(fd) == ""} {
		# We can't commit if we weren't asked to write to stable
		# storage
		return
	}

	# XXX: TODO
	return -code error "Not Implemented"
}

proc ::mk::file::rollback {tag {fullOpt ""}} {
	if {![info exists ::mk::private::tags($tag)]} {
		return -code error "no storage with this name"
	}

	if {$fullOpt == "-full"} {
		# Clear asides ...
		# XXX: TODO
	}

	set ::mk::private::changes($tag) ""
}

proc ::mk::file::load {{tag ""} {channel ""}} {
	return -code error "Not Implemented"
}

proc ::mk::file::save {{tag ""} {channel ""}} {
	return -code error "Not Implemented"
}

proc ::mk::file::aside {{tag1 ""} {tag2 ""}} {
	return -code error "Not Implemented"
}

proc ::mk::file::autocommit {tag} {
	if {![info exists ::mk::private::tags($tag)]} {
		return -code error "no storage with this name"
	}

	array set taginfo $::mk::private::tags($tag)

	set taginfo(commit_on_close) 1

	set ::mk::private::tags($tag) [array get taginfo]
}

proc ::mk::view {cmd args} {
	return -code error "Not Implemented"
}

proc ::mk::cursor {cmd args} {
	return -code error "Not Implemented"
}

proc ::mk::row {cmd args} {
	return -code error "Not Implemented"
}

proc ::mk::get {args} {
	return -code error "Not Implemented"
}

proc ::mk::set {args} {
	return -code error "Not Implemented"
}

proc ::mk::loop {args} {
	return -code error "Not Implemented"
}

proc ::mk::select {args} {
	return -code error "Not Implemented"
}

proc ::mk::channel {args} {
	return -code error "Not Implemented"
}

package provide Mk4tcl 2.4.9.6

















Powered by Fossil · RSS