Check-in [928d865dd1]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:update XOTcl to version 1.6.8
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 928d865dd19dd11a008adb90dd01389dd09ed560
User & Date: chw 2016-11-15 06:03:19
Context
2016-11-16
05:56
add nsf and xotcl to [undroidwish] build check-in: 6718184d53 user: chw tags: trunk
2016-11-15
06:03
update XOTcl to version 1.6.8 check-in: 928d865dd1 user: chw tags: trunk
2016-11-14
15:42
add tcl upstream changes check-in: 40b3121ca9 user: chw tags: trunk
Changes

Deleted assets/xotcl1.6.7/actiweb/Agent.xotcl.

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
# $Id: Agent.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::actiweb::agent 0.8

package require xotcl::trace
package require xotcl::comm::httpAccess
package require xotcl::actiweb::webObject
package require xotcl::store::persistence

package require XOTcl

#
# current response codes for agent requests:
#
# OK      -- content arrived (can be retrieved with sinks content method)
# ERROR   -- error on the place invocation
# FAILED  -- call itself failed, e.g. cancel
#

namespace eval ::xotcl::actiweb::agent {
    namespace import ::xotcl::*

    Class AgentMemSink \
	-superclass MemorySink \
	-parameter {{agent ""} responseCode}

    AgentMemSink instproc startCb {r}   {
	my set d "" 
	next
    }
    AgentMemSink instproc notifyCb {r} {next}
    AgentMemSink instproc incCb {r t c} {next}
    AgentMemSink instproc endCb {r} {
	if {[Agent exists responseCodes([$r set responseCode])]} {
	    my set responseCode OK
	} else {
	    my set responseCode ERROR
	}
	next
    }
    AgentMemSink instproc cancelCb {r} {
	my set responseCode FAILED
	next
    }
    AgentMemSink instproc endReq {r} {
	my instvar agent 
	if {[Object isobject $agent]} {
	    if {[$agent exists sinks($r)]} {
		$agent unset sinks($r)
	    }
	}
    }

    # sink class that calls the agent's endcmd in async calls
    # the sink is destroyed automatically after endCmd is called
    Class AgentAsyncSink -superclass AgentMemSink
    AgentAsyncSink instproc endCb {r} {
	next
	my instvar endCmd responseCode
	set result [my content]
	if {[info exists endCmd]} {
	    eval [concat $endCmd $responseCode \"$result\"]
	}
	my endReq $r
    }
    AgentAsyncSink instproc cancelCb {r} {
	my instvar endCmd responseCode
	if {[info exists endCmd]} {
	    eval [concat $endCmd $responseCode ""]
	}
	next
	my endReq $r
    }

    # sink type for sync request 
    # has to be destroyed with endReq when content is 
    # read (see createSyncRequest)
    Class AgentSyncSink -superclass AgentMemSink


    Class Agent -superclass WebObject
    Agent array set responseCodes {
	200 {OK}
    }

    Agent instproc init args {
	#my showCall
	#my exportProcs invoke
	my array set endCmds {}
	my array set sinks {}
	next
    }

    #
    # method to create async requests
    #
    # endCmd specifies the command (or object method or proc ...) that
    # is to be called, when the request has ended, empty for sync requests
    #
    # args are to be given in the form -name value, like:
    #   -contentType text/xml
    #   -method PUT 
    #   -data XXX
    #
    # returns the request object name
    #
    Agent instproc createRequest {endCmd url args} {
	#my showCall
	puts stderr "[self] [self proc]"
	my instvar place
	set s [AgentAsyncSink create [$place autoname agentmemsink] \
		   -agent [self]]
	set cmd [list Access createRequest -caching 0 -url $url \
		     -informObject $s]
	foreach {n v} $args {lappend cmd $n $v}
	$s set endCmd $endCmd
	set t ::[string trimleft [::eval $cmd $args] :]
	my set sinks($t) $s
	return $t
    }
    #
    # method to create sync reqs ... url and args identical to
    # async req
    #
    # returns the result of sync request, if "OK" 
    # otherwise: Raises an error
    #
    Agent instproc createSyncRequest {url args} {
	#my showCall
	puts stderr "[self] [self proc]"
	my instvar place
	set s [AgentSyncSink [$place autoname agentmemsink] -agent [self]]
	set cmd [list Access createRequest \
		     -httpVersion 1.0 \
		     -caching 0 -url $url -informObject $s -blocking 1]
	foreach {n v} $args {lappend cmd $n $v}
	set t ::[string trimleft [::eval $cmd] :]
	#puts stderr "After SyncRequest t=$t [$s responseCode]"
	if {[$s responseCode] eq "OK"} {
	    set content [$s content]
	    # kill the sink
	    $s endReq $t
	    return $content
	}
	$s endReq $t
	error "[self] -- Sync request failed: url=$url, responseCode=[$s responseCode]"
    }
    #
    # invoke a remote method directly along the places' dispatcher 
    #
    Agent instproc invoke {endCmd host receiver args} {
	puts stderr [self proc]----host=$host
	#my showCall
	set url http://$host/${receiver}+[url encode $args]
	my createRequest $endCmd $url
    }
    Agent instproc syncInvoke {host receiver args} {
	puts stderr [self proc]----host=$host
	#[self] showCall
	set url http://$host/${receiver}+[url encode $args]
	my createSyncRequest $url
    }

    #
    # invoke a cloning migration 
    #
    Agent instproc cloneImpl {async host startcmd {endCmd ""}} {
	#my showCall
	set ai [my agentInfo]
	set place [Place getInstance]

	# get the full name of the agent ns from the places's agent mgr
	#set ns [${place}::agentMgr::rdfNS searchPrefix agent]

	$ai set agentData(script) [${place}::scriptCreator makeScript [self]]
	$ai append agentData(script) [my makeVarScript]
	$ai set agentData(startcmd) $startcmd

	set data [$ai getXMLScript [$ai name]]
	###puts $data

	#set data [[Place getInstance]::rdfCreator createFromTriples [$ai getTriples]]
	if {$async} {
	    return [my createRequest $endCmd http://$host/[my selfName] \
			-contentType text/xml \
			-method PUT \
			-data $data]
	} else {
	    return [my createSyncRequest http://$host/[my selfName] \
			-contentType text/xml \
			-method PUT \
			-data $data]
	}
    }
    Agent instproc clone {host startCmd endCmd} {
	my cloneImpl 1 $host $startCmd $endCmd
    }
    Agent instproc syncClone {host startCmd} {
	my cloneImpl 0 $host $startCmd
    }

    #
    # invoke a migration that destroys the object in the current place 
    #
    Agent instproc migrateImpl {async host startcmd {endCmd ""}} {
	### GN ???
	puts stderr "--- async=$async"
	if {$async} {
	    set r [my clone $host $startcmd $endCmd]
	} else {
	    set r [my syncClone $host $startcmd]
	}
	puts stderr "--- [self] destroy +++ "
	my destroy  ;### FIXME: this does not work in the asynchronous case
	return $r
    }
    Agent instproc migrate {host startCmd endCmd} {
	#my migrateImpl 1 $host $startCmd $endCmd
	my migrateImpl 0 $host $startCmd $endCmd
    }
    Agent instproc syncMigrate {host startCmd} {
	my migrateImpl 0 $host $startCmd
    }
    #
    # query a place with its hostname for its name
    #
    Agent instproc getPlaceFromHostName {endCb host} {
	set r [my autoname __result]
	my createRequest "[self]::$r set" http://$host/ 
	return [set [self]::$r]
    }

    namespace export AgentMemSink AgentAsyncSink AgentSyncSink Agent
}

namespace import ::xotcl::actiweb::agent::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/actiweb/AgentManagement.xotcl.

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
# $Id: AgentManagement.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::actiweb::agentManagement 0.8

package require xotcl::rdf::parser
package require xotcl::rdf::triple
package require xotcl::actiweb::agent

package require XOTcl

namespace eval ::xotcl::actiweb::agentManagement {
    namespace import ::xotcl::*

    Class AgentInfo -parameter {
	{name ""}
	{changed 1}
    }

    AgentInfo instproc init args {
	next
	#
	# array providing info on a (migrated) agent
	#
	my array set agentData {}
	RDFTripleDB [self]::db
	my trace variable agentData w [list [self] changeOccured]
	my trace variable name w [list [self] changeOccured]
    }

    AgentInfo instproc getXMLScript {name} {
	#my showCall
	set s {<?xml version="1.0"?>
	    <rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
	    xmlns:xotcl="http://www.xotcl.org/agent">
	    <rdf:Description about="$name">}
	set s [subst -nobackslashes $s]
	foreach n [my array name agentData] {
	    append s "
    <agent:$n> [my set agentData($n)] </agent:$n>"
	}
	append s "  
  </rdf:Description>
</rdf:RDF>"
    }

    AgentInfo instproc changeOccured args {my set changed 1}

    AgentInfo instproc getTriples {} {
	#my showCall
	if {[my set changed]} {
	    # build up the triple-db
	    [self]::db reset
	    set place [Place getInstance]
	    set subject "http://[$place set host]:[$place set port]/[my name]"
	    foreach n [my array names agentData] {
		[self]::db add $n $subject [my set agentData($n)]
	    }
	}
	return [[self]::db getTriples]
    }

    AgentInfo instproc print {} {
	puts "AGENT-INFO:"
	puts "Name == [my set name]"
	foreach a [my array names agentData] {
	    puts "$a == [my set agentData($a)]"
	}
    }

    Class AgentVisitor -superclass NodeTreeVisitor -parameter {
	{openProperty ""}
	{agentInfo ""}
	{rdfNS {[my info parent]::rdfNS}}
    }

    AgentVisitor instproc fullName {obj n} {
	set ns [$obj resolveNS]
	return [$ns getFullName $n]
    }

    AgentVisitor instproc visit {objName} {
	#puts stderr "AgentVisitor visit -- $objName"
	set ai [my set agentInfo]
	set cl [$objName info class]
	#puts stderr "AgentVisitor visit -- $objName cl=$cl <[$ai name]>"
	if {[$ai name] eq ""} {
	    #### not fixed yet
	    puts stderr "my fixme (AgentManagement)"
	    if {$cl eq "::About" &&
		[string first "::Description" [[$objName info parent] info class]] == 0} {
		$ai name [$objName set content]
	    }
	} else {  
	    #puts stderr C=<[$objName content]>
	    #$cl showVars
	    switch -exact $cl {
		::RDFProperty {
		    set c [$objName content]
		    #$objName showVars
		    if {[$objName exists pcdata]} {
			$ai set agentData($c) [lindex [$objName getPCdataList] 0]
		    } else {
			#puts stderr "empty PCDATA"
		    }
		}
	    }
	}
    }

    AgentVisitor instproc interpretNodeTree node {
	if {[my set agentInfo] eq "" } {
	    error "Agent Visitor: no agent info provided."
	} 
	$node accept [self]
    }

    Class AgentMgr -superclass Agent \
	-parameter {
	    {acceptedData [list script startcmd senderPlace senderPort senderHost]}
	}

    AgentMgr instproc init args {
	next
	my array set agents {}
	#
	# this ns class holds the prefix/Rdf-ns pairs used by this
	# agent mgr (with default values)
	#
	XMLNamespace [self]::rdfNS
	[self]::rdfNS add agent {http://www.xotcl.org/schema/agent#}
	[self]::rdfNS add service {http://www.xotcl.org/schema/service#}
	[self]::rdfNS add xotcl {http://www.xotcl.org/schema/xotcl#}
	RDFParser [self]::rdfParser 
	AgentVisitor [self]::agentVisitor
	
	#package require xotcl::xml::printVisitor 
	#PrintVisitor [self]::pv
    }

    AgentMgr instproc register {name} {
	set ai [AgentInfo [self]::[my autoname agentInfo]]
	my set agents($name) $ai
	$ai name $name
	return $ai
    }

    AgentMgr instproc deregister {name} {
	if {[my info agents $name]} {
	    # destroy the agents info objects
	    #my showMsg "calling destroy on [my set agents($name)]"
	    [my set agents($name)] destroy
	    # unset the var
	    my unset agents($name)
	}
    }

    AgentMgr instproc info args {
	if {[lindex $args 0] eq "agents"} {
	    if {[llength $args] > 1} {
		return [my exists agents([lindex $args 1])]
	    } else {
		return [my array names agents]
	    }
	}
	next
    }

    #
    # parses the data of a migration request into a new agent
    # info object
    #
    # name must be stringleft : !!
    AgentMgr instproc parseData {name data} {
	set ai [my register $name]
	next

	[self]::rdfParser reset
	[self]::rdfParser parse $data

	#puts stderr ===========================================================
	#[self]::pv interpretAll [self]::rdfParser
	#puts stderr ===========================================================

	[self]::agentVisitor agentInfo $ai
	#foreach tn [[self]::rdfParser info children topNode*] {
	#  [self]::agentVisitor interpretNodeTree $tn
	#}

	[self]::agentVisitor interpretAll [self]::rdfParser
	
	#puts "************** Received Agent:"
	#$ai print
	
	return $ai
    }

    AgentMgr instproc immigrate {AI} {
	#set ns [[self]::rdfNS searchPrefix agent]
	#::eval [$AI set agentData(${ns}script)]

	#puts stderr "immigrate call showVars"
	#$AI showVars
	#puts stderr "immigrate showVars done"

	::eval [$AI set agentData(agent:script)]
	#puts stderr "immigrate persistentVars = '[[$AI name] persistentVars]'"
	#foreach v [[$AI name] info vars] { $n persistent $v }

	if {[$AI exists agentData(agent:startcmd)]} {
	    ::after 10 [list [$AI name] [$AI set agentData(agent:startcmd)]]
	}
	return ""
    }

    namespace export AgentInfo AgentVisitor AgentMgr
}

namespace import ::xotcl::actiweb::agentManagement::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/actiweb/COPYRIGHT.

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
 *  XOTcl - Extended OTcl
 *
 *  Copyright (C) 1999-2008 Gustaf Neumann (a), Uwe Zdun (b)
 *
 * (a) Vienna University of Economics and Business Administration
 *     Dept. of Information Systems / New Media
 *     A-1090, Augasse 2-6
 *     Vienna, Austria
 *
 * (b) University of Essen
 *     Specification of Software Systems
 *     Altendorferstra▀e 97-101
 *     D-45143 Essen, Germany
 *     
 *  Permission to use, copy, modify, distribute, and sell this
 *  software and its documentation for any purpose is hereby granted
 *  without fee, provided that the above copyright notice appear in
 *  all copies and that both that copyright notice and this permission
 *  notice appear in supporting documentation. We make no
 *  representations about the suitability of this software for any
 *  purpose.  It is provided "as is" without express or implied
 *  warranty.
 *
 *
 *  This software is based upon MIT Object Tcl by David Wetherall and
 *  Christopher J. Lindblad, that contains the following copyright
 *  message:
 *
 *   "Copyright 1993 Massachusetts Institute of Technology
 *
 *    Permission to use, copy, modify, distribute, and sell this
 *    software and its documentation for any purpose is hereby granted
 *    without fee, provided that the above copyright notice appear in
 *    all copies and that both that copyright notice and this
 *    permission notice appear in supporting documentation, and that
 *    the name of M.I.T. not be used in advertising or publicity
 *    pertaining to distribution of the software without specific,
 *    written prior permission.  M.I.T. makes no representations about
 *    the suitability of this software for any purpose.  It is
 *    provided "as is" without express or implied warranty."

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































Deleted assets/xotcl1.6.7/actiweb/HtmlPlace.xotcl.

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
# $Id: HtmlPlace.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::actiweb::htmlPlace 0.8

package require xotcl::trace
package require xotcl::actiweb::httpPlace
package require xotcl::store::persistence
package require xotcl::actiweb::agent
package require xotcl::actiweb::pageTemplate

package require XOTcl

namespace eval ::xotcl::actiweb::htmlPlace {
    namespace import ::xotcl::*

    Class HtmlPlace -superclass Place -parameter {allowExit}

    HtmlPlace instproc init args {
	next
	#
	# just define a minimal object that can react 
	# with HTML decoration, if the called object
	# doesn't exist
	PageTemplateHtml create [self]::start.html

	my startingObj [self]::start.html
	if {[my exists allowExit]} {
	    set exitObj [WebObject create [self]::[my set allowExit]]
	    [Place getInstance] exportObjs $exitObj
	    $exitObj proc default {} {after 500 ::exit; return "Server terminates"}
	}
    }
    HtmlPlace instproc default {} {
	set place [string trimleft [self] :]
	set msg "<HTML><TITLE>Place $place</TITLE>
	<BODY><H2>Place $place</H2> Try one of the following links:<UL>"
	foreach o [my exportedObjs] {
	    set o [string trimleft $o :]
	    append msg "<LI><A HREF='[url encodeItem $o]'>$o</A></LI>"
	}
	append msg "</UL></BODY>\n"
    }

    namespace export HtmlPlace
}

namespace import ::xotcl::actiweb::htmlPlace::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































Deleted assets/xotcl1.6.7/actiweb/HttpPlace.xotcl.

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
# $Id: HttpPlace.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::actiweb::httpPlace 0.8

package require xotcl::trace
package require xotcl::actiweb::invoker
package require xotcl::actiweb::webObject
package require xotcl::comm::httpd
package require xotcl::scriptCreation::scriptCreator
package require xotcl::store::persistence
package require xotcl::pattern::singleton
package require xotcl::registry::registry
package require xotcl::actiweb::agentManagement
package require xotcl::rdf::tripleRecreator

package require XOTcl

namespace eval ::xotcl::actiweb::httpPlace {
    namespace import ::xotcl::*


    Singleton Place -superclass Invoker -parameter {
	{exportedObjs ""} 
	{startingObj ""}
	{startCommand ""}
	{root $::env(HOME)/public_html}
	{port 8086}
	{redirect [list]}
	{logdir $::xotcl::logdir} 
	{host localhost}
	{allowImmigrationHosts ""}
	persistenceFile persistenceDir bccFile bccDir dbPackage
	{startHTTPServer 1}
    }

    #    Giving a bccFile (and possibly bccDir) as optional parameter means 
    #    that an identical copy database will be created in that 
    #    location (e.g. for creating a backup on a second hard drive.

    Place instproc exportObjs args {
	foreach obj $args {
	    my lappend exportedObjs [string trimleft $obj :]
	    puts stderr "*** exporting $obj, self=[self], objs=[my set exportedObjs]"
	}
    } 
    Place instproc isExportedObj obj {
	expr {[lsearch [my exportedObjs] [string trimleft $obj :]] != -1}
    }
    Place instproc default {} {
	[self]
    }
    Place instproc init args {
	if {[my set startHTTPServer]} {
	    Httpd [self]::httpd \
		-port [my port] \
		-root [my root] \
		-redirect [my redirect] \
		-logdir [my logdir] \
		-httpdWrk Place::HttpdWrk
	}
	#
	# PersistenceMgr object for web entities
	#
	##### so ist das nicht toll ... init args sollten anders konfigurierbar sein
	PersistenceMgr [self]::agentPersistenceMgr -dbPackage multi

	if {[my exists dbPackage]} {
	    set dbp [my set dbPackage]
	} else {
	    set dbp ""
	}


	if {![my exists persistenceDir]} {
	    my persistenceDir [string trimleft [self] :]
	}
	if {![my exists persistenceFile]} {
	    my persistenceFile persistentObjs-[my port]
	}

	[self]::agentPersistenceMgr store add $dbp \
	    -dirName [my persistenceDir] \
	    -fileName [my persistenceFile]

	if {[my exists bccDir] || [my exists bccFile]} {
	    if {![my exists bccDir]} {
		my bccDir [my set persistenceDir]
	    }
	    if {![my exists bccFile]} {
		my bccFile [my persistenceFile]
	    }
	    [self]::agentPersistenceMgr store add $dbp \
		-dirName [my bccDir] \
		-fileName [my bccFile]
	}

	AgentMgr create [self]::agentMgr 
	RDFCreator create [self]::rdfCreator

	#
	# minimal obj for default behavior of the place -> calls go
	# to web entities default (customize through a redirecting proc
	# as in HtmlPlace or changing startingObj)
	#
	WebObject create [self]::start
	my startingObj [self]::start
	Registry [self]::registry
	ErrorMgr [self]::error

	ScriptCreator [self]::scriptCreator -dependencyChecking 0

	my exportObjs [self]::start [self]::agentMgr [self]::registry
	next
    }

    Place instproc startEventLoop args {
	if {[llength $args] > 0} {
	    set startCommand [lindex $args 0]
	    ::eval $startCommand
	}

	vwait forever  ;# if we are in xotclsh call the event loop...
    }

    ###
    ### Mixin-Classes for Http/Wrk that restricts the usable HTTP methods
    ###
    Class RestrictHTTPMethods -parameter {
	{allowedHTTPMethods "GET PUT HEAD POST CGI"}
    }
    RestrictHTTPMethods instproc init args {
	next
	my lappend workerMixins RestrictHTTPMethods::Wrk
    }
    Class RestrictHTTPMethods::Wrk
    RestrictHTTPMethods::Wrk instproc respond {} {
	my instvar method 
	[my info parent] instvar allowedHTTPMethods
	if {[lsearch $allowedHTTPMethods $method] != -1} {
	    return [next]
	} else {
	    my log Error "Restricted Method $method called"
	    my replyCode 405
	    my replyErrorMsg
	}
    }

    Class Place::HttpdWrk -superclass Httpd::Wrk 

    Place::HttpdWrk instproc init args {
	my set place [Place getInstance] 
	next
	#puts "New Http-Worker: [self class]->[self] on [my set place]" 
    } 

    Place::HttpdWrk instproc parseParams {o m a call} {
	upvar [self callinglevel] $o obj $m method $a args 
	### 
	set decodedCall [url decodeItem $call]
	#my showMsg decodedCall=$decodedCall
	if {[regexp {^([^ ]*) ?([^ ]*) ?(.*)$} $decodedCall _ \
		 obj method args]} {
	    #foreach a [my set formData] {lappend args [$a set content]}
	    #puts stderr "Parsed -- Obj: $obj, Method: $method, Args: $args" 
	    return 1
	} else {
	    puts stderr "could not parse <$decodedCall>"
	    return 0
	}
    }
    Place::HttpdWrk instproc respond-HEAD {} {
	my respond-GET;  ### sendMsg inhibits content for method HEAD
    }
    Place::HttpdWrk instproc respond-GET {} {
	my instvar fileName resourceName place
	if {$resourceName eq ""} {
	    my sendMsg [$place default] text/html  ;# kind of index.html
	} elseif {[my parseParams obj method arguments $resourceName]} {
	    if {![my isobject $obj] && [file readable $fileName]} {
		next      ;# let Httpd handle this
	    } else {
		set response [$place invokeCall obj status $method $arguments]
		#puts stderr "RESPONSE: $response"
		#
		# let the object's sending strategy mixin choose 
		# the appropriate sending mode
		#
		# $obj showClass
		if {[info exists status] && $status >= 300} {
		    my replyCode $status
		    my replyErrorMsg $response
		} else {
		    #my lappend replyHeaderFields Cache-Control maxage=0
		    my lappend replyHeaderFields Pragma no-cache
		    $obj send [self] $response
		}
	    }
	} else {
	    my set version 1.0
	    my replyCode 400
	    my replyErrorMsg [my callError "Could not parse: " $resourceName]
	}
    }
    Place::HttpdWrk instproc respond-POST {} {
	my instvar resourceName place
	my respond-GET
    }


    Place::HttpdWrk instproc respond-PUT {} {
	my instvar resourceName place data
	#my showCall
	
	if {$resourceName ne ""} {
	    if {[my parseParams obj m a $resourceName]} {
		set obj [string trimleft $obj :]
		set AMgr ${place}::agentMgr

		if {[info commands $obj] eq "" &&
		    ![$AMgr info agents $obj]} {
		    #puts stderr "Receiving to put --------------------------------$obj  $data"
		    set AI [$AMgr parseData $obj $data]
		    #puts stderr "parray --${AI}::agentData------------------------"
		    #parray ${AI}::agentData
		    #puts stderr "parray --${AI}::agentData----------------DONE--------"
		    #$AI showVars
		    #puts stderr "----[$AI exists agentData(agent:script)]----"
		    if {[$AI exists agentData(agent:script)]} {
			set immigrateResult [$AMgr immigrate $AI]
			#puts stderr "immigrateResult=<$immigrateResult>"
			my replyCode 200  
			my sendMsg $immigrateResult text/plain
		    } else {
			my set version 1.0
			my replyCode 400
			my replyErrorMsg "Migration failed"
		    }
		} else {
		    my set version 1.0
		    my replyCode 400
		    my replyErrorMsg "Migration: object name already in use."
		}
	    } else {
		my set version 1.0
		my replyCode 400 
		my replyErrorMsg "Migration call must provide object name"
	    }
	} else {
	    # return the own place name -> any client can call the place via
	    # placename::start !
	    my sendMsg $place text/plain
	}
    }

    namespace export RestrictHTTPMethods Place
    namespace eval RestrictHTTPMethods {
	namespace export Wrk
    }
    namespace eval Place {
	namespace export HttpdWrk
    }
}

namespace import ::xotcl::actiweb::httpPlace::*
namespace eval RestrictHTTPMethods {
    namespace import ::xotcl::actiweb::httpPlace::RestrictHTTPMethods::*
}
namespace eval Place {
    namespace import ::xotcl::actiweb::httpPlace::Place::*
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/actiweb/Invoker.xotcl.

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
# $Id: Invoker.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::actiweb::invoker 0.8

package require XOTcl

namespace eval ::xotcl::actiweb::invoker {
    namespace import ::xotcl::*

    Class AbstractInvoker
    AbstractInvoker abstract instproc invokeCall {o method arguments}
    AbstractInvoker abstract instproc eval {obj method arguments}
    #
    # error types are: tclError, invocationError
    #
    AbstractInvoker abstract instproc callError {type msg obj arguments} 

    Class Invoker -superclass AbstractInvoker -parameter {{place [self]}}

    Invoker instproc handleException {response} {
	if {[my isExceptionObject $response]} {
	    set exceptionObj $response
	    switch [$exceptionObj info class] {
		::RedirectException {
		    set obj [$exceptionObj obj]
		    set method [$exceptionObj method]
		    set arguments [$exceptionObj arguments]
		    set response [my eval $obj $method $arguments]
		}
		::ErrorException {
		    set response [$exceptionObj set errorText]
		}
	    }
	    $exceptionObj destroy
	}
	return $response
    }

    Invoker instproc invokeCall {o s method arguments} {
	upvar [self callinglevel] $o obj $s status
	my instvar place
	set response ""
	if {[$place isExportedObj $obj]} {
	    # if method is not given -> call default on the object
	    if {$method eq ""} {
		set method default
	    }
	    if {[$obj isExportedProc $method]} {
		#puts stderr "ExportedProcs of $obj: [$obj exportedProcs]"
		#puts stderr "Call: $obj -- $method -- $arguments"
		set response [my eval $obj $method $arguments]
	    } else {
		#puts stderr "ExportedProcs of $obj: [$obj exportedProcs]"
		set response [my callError invocationError [$place startingObj] \
				  "Method not found or not exported" \
				  "$obj $method $arguments"]
		set status 405
	    }
	} else {
	    set called $obj
	    set obj [$place startingObj]
	    set response [my callError invocationError $obj \
			      "Object '$called' unknown" ""]
	    set status 404
	}
	
	return [my handleException $response]
    }

    #
    # tests whether "name" is an exception object or not
    #
    Invoker instproc isExceptionObject name {
	if {[Object isobject $name] && [$name istype Exception]} {
	    return 1
	}
	return 0
    }

    #
    # central eval  -- all remote call
    # are invoked through this method
    #
    Invoker instproc eval {obj method arguments} {
	puts stderr "[clock format [clock seconds] \
	-format %Y/%m/%d@%H:%M:%S] \
	Eval Call: $obj $method $arguments"
	if {[catch {
	    set r [::eval $obj $method $arguments]
	} ei]} {
	    set r [my callError tclError $obj $ei "$obj $method $::errorInfo"]
	}
	return $r
    }

    Invoker instproc callError {type obj msg arguments} {
	[my set place]::error $type $obj $msg $arguments
    }

    Class ErrorMgr
    ErrorMgr instproc isHtml o {
	if {[my isobject $o]} {
	    if {[$o exists contentType]} {
		if {[$o set contentType] eq "text/html"} {
		    return 1
		}
	    }
	}
	return 0
    }

    ErrorMgr instproc invocationError {obj msg arguments} {
	my showCall
	set ee [ErrorException [self]::[my autoname ee]]
	$ee instvar errorText
	if {[my isHtml $obj]} {
	    set errorText "<p> invocation error: $msg"
	    if {[llength $arguments] > 0} {
		append errorText ":\n<p> object: '[lindex $arguments 0]' \n"
	    } else {
		append errorText \n
	    }
	    if {[llength $arguments] > 1} {
		append errorText "<p> call: '[lrange $arguments 1 end]' \n"
	    }
	} else {
	    set errorText "invocation error: $msg $arguments"
	}
	return $ee
    }

    ErrorMgr instproc tclError {obj msg arguments} {
	set ee [ErrorException [self]::[my autoname ee]]
	if {[my isHtml $obj]} {
	    $ee errorText "<p>tcl error: '$msg' \n<code><p><pre>$arguments</pre></code>"
	} else {
	    $ee errorText "tcl error: '$msg'\n$::errorInfo"
	}
	return $ee
    }

    #
    # exceptions in invocation behavior
    #
    Class Exception
    #
    # Execpetion that tells the invoker to redirect the call to
    # parameters
    #
    Class RedirectException -superclass Exception -parameter {
	{obj ""}
	{method ""}
	{arguments ""}
    }

    Class ErrorException -superclass Exception -parameter {
	{errorText ""}
    }

    namespace export AbstractInvoker \
	Invoker ErrorMgr Exception \
	RedirectException ErrorException
}

namespace import ::xotcl::actiweb::invoker::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































Deleted assets/xotcl1.6.7/actiweb/PlaceAccessControl.xotcl.

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
# $Id: PlaceAccessControl.xotcl,v 1.7 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::actiweb::placeAccessControl 0.8

package require xotcl::comm::httpd
package require xotcl::actiweb::httpPlace

package require XOTcl

#
# Simple Object Pwd Protection with BasicAccessControl
#
#Usage example:
#ConferenceOrgPlace confPlace -port $placeport -root [pwd] \
    #  -mixin PlaceAccessControl
#
#confPlace protect conference.html [confData set password]
#
#confPlace setPasswd conference.html xxx

namespace eval ::xotcl::actiweb::placeAccessControl {
    namespace import ::xotcl::*

    Class ObjectAccessControl -superclass BasicAccessControl

    ObjectAccessControl instproc protectedResource {fn method varAuthMethod varRealm} {
	# check whether access to $fn via $method is protected
	upvar [self callinglevel] $varAuthMethod authMethod $varRealm realm
	my instvar root
	# we check only the current directory, not the parent directories
	set call [url decodeItem $fn]
	regsub "^$root" $call "" call
	set call [string trimleft $call /]
	set call [string trimleft $call :]
	regexp {^([^ ]*)} $call _ call
	set call "$root/$call"

	foreach i [list $call $call:$method] {
	    #puts stderr "check <$i>"
	    if {[my exists protected($i)]} {
		set realm [my set protected($i)]
		set authMethod Basic
		return 1
	    }
	}
	return 0
    }

    Class PlaceAccessControl
    PlaceAccessControl instproc init args {
	next
	[self]::httpd mixin add ObjectAccessControl
	[self]::httpd initWorkerMixins
    }

    PlaceAccessControl instproc protect {objName id pwd} {
	set objName [string trimleft $objName :]
	[self]::httpd protectDir $objName $objName {}
	if {$pwd ne ""} {
	    my setPassword $objName $id $pwd
	} 
    }

    PlaceAccessControl instproc credentialsNotOk {credentials authMethod realm} {
	#my instvar passwd
	#parray passwd
	next
    }

    PlaceAccessControl instproc setPassword {realm id pwd} {
	set httpd [self]::httpd 
	if {[$httpd exists passwd($realm:$id)]} {
	    $httpd unset passwd($realm:$id)
	    $httpd set passwd($realm:$id) $pwd
	} else {
	    $httpd addRealmEntry $realm "$id $pwd"
	}
	#$httpd set passwd($realm:admin) nimda
    }
    PlaceAccessControl instproc removeID {realm id} {
	set httpd [self]::httpd
	if {[$httpd exists passwd($realm:$id)]} {
	    $httpd unset passwd($realm:$id)
	}
    }

    namespace export ObjectAccessControl PlaceAccessControl
}

namespace import ::xotcl::actiweb::placeAccessControl::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































Deleted assets/xotcl1.6.7/actiweb/SecureHtmlPlace.xotcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
# $Id: SecureHtmlPlace.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::actiweb::secureHtmlPlace 0.8

package require xotcl::actiweb::secureHttpPlace
package require xotcl::actiweb::htmlPlace

package require XOTcl

namespace eval ::xotcl::actiweb::secureHtmlPlace {
    namespace import ::xotcl::*

    Class SecureHtmlPlace -superclass {SecurePlace HtmlPlace}

    namespace export SecureHtmlPlace
}

namespace import ::xotcl::actiweb::secureHtmlPlace::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































Deleted assets/xotcl1.6.7/actiweb/SecureHttpPlace.xotcl.

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
# $Id: SecureHttpPlace.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::actiweb::secureHttpPlace 0.8

package require xotcl::actiweb::httpPlace

package require XOTcl

namespace eval ::xotcl::actiweb::secureHttpPlace {
    namespace import ::xotcl::*

    Class SecurePlace -superclass Place -parameter {
	{port 443}
	{requestCert 0}
	{requireValidCert 0}
	{certfile server.pem}
	{keyfile server.key} 
	{cafile cacert.pem}
	{infoCb {}}
    }

    SecurePlace instproc startHttpd {} {
	my instvar port root  requestCert requireValidCert \
	    certfile cafile infoCb keyfile
	Httpsd h1 -port $port \
	    -root $root \
	    -httpdWrk SecurePlace::HttpsdWrk \
	    -infoCb $infoCb \
	    -requestCert $requestCert \
	    -requireValidCert $requireValidCert \
	    -certfile $certfile -cafile $cafile \
	    -keyfile $keyfile
    }

    SecurePlace instproc init args {
	my set startHTTPServer 0
	next
	[self] startHttpd
    }

    Class SecurePlace::HttpsdWrk -superclass {Httpsd::Wrk Place::HttpdWrk} 

    namespace export SecurePlace
    namespace eval SecurePlace {
	namespace export HttpsdWrk
    }
}

namespace import ::xotcl::actiweb::secureHttpPlace::*
namespace eval SecurePlace {
    namespace import ::xotcl::actiweb::secureHttpPlace::SecurePlace::*
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































Deleted assets/xotcl1.6.7/actiweb/SendStrategy.xotcl.

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
# $Id: SendStrategy.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::actiweb::sendStrategy 0.8

package require XOTcl

#
# some simple sending strategy classes -- to be used as mixins
# for web objects
# 

namespace eval ::xotcl::actiweb::sendStrategy {
  namespace import ::xotcl::*

  Class SendStrategy
  SendStrategy abstract instproc send {httpWrk string}

  #
  # send the response given from the place as plain text
  #
  Class Send=PlainString -superclass SendStrategy
  Send=PlainString instproc send {httpWrk string} {
    $httpWrk sendMsg $string text/plain
  }

  #
  # send the response given from the place with content 
  # type of the obj, if it exists
  #
  Class Send=TypedString -superclass SendStrategy
  Send=TypedString instproc send {httpWrk string} {
    $httpWrk sendMsg $string [my set contentType]
  }
  
  #
  # send file specified in obj's instvar filename
  #
  Class Send=File -superclass SendStrategy
  Send=File instproc send {httpWrk {response ""}} {
    if {[my exists contentType]} {
      $httpWrk sendFile [my set filename] [my set contentType]
    } else {
      $httpWrk sendFile [my set filename] ""
    }
  }

  namespace export \
      SendStrategy Send=PlainString Send=TypedString Send=File
}

namespace import ::xotcl::actiweb::sendStrategy::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































Deleted assets/xotcl1.6.7/actiweb/UserMgt.xotcl.

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
# $Id: UserMgt.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::actiweb::userMgt 0.8

package require XOTcl

namespace eval ::xotcl::actiweb::userMgt {
    namespace import ::xotcl::*

    Class UserMgt 
    Class UserMgt::User -parameter {name password}

    UserMgt instproc addUser {name password} {
	[self class]::User [self]::$name -name $name -password $password
    }

    UserMgt set exportedInstprocs [list \
				       addUser \
				       listUsers \
				       deleteUser \
				       userMgtOptions\
				      ]

    UserMgt instproc init args {
	next
	my exportedProcs [concat [my exportedProcs] [[self class] set exportedInstprocs]]
    }

    UserMgt instproc listUsers {} {
	#showCall
	set users ""
	foreach u [my info children] {
	    lappend users [namespace tail $u]
	}
	return $users
    }

    UserMgt instproc deleteUser {name} {
	if {[[self class]::User info instances [self]::$name] != ""} {
	    [self]::$name destroy
	}
    }
    UserMgt instproc userMgtOptions {} {
	return [[self class] set exportedInstprocs]
    }

    Class UserMgtHtml -superclass HtmlRep

    UserMgtHtml instproc addUser args {
	set place [HtmlPlace getInstance]
	if {$args eq ""} {
	    set action [url encodeItem "[my htmlCall] [my repObj] [self proc]"]
	    set c {
		<form method=get action=$action>
		<p> Name: 
		<input name="name" type=text size=30>
		<p> Password:
		<input name="password" type=password typesize=30>
		<p><p>
		<input type=submit value="Submit">
		<input type=reset value="Reset">
	    }
	    set c [subst -nobackslashes -nocommands $c]
	    
	    return [my simplePage $place "New User" $c]
	} else {
	    if {[llength $args] > 1} {
		set name [lindex $args 0]
		set password [lindex $args 1]
		set user [[my repObj] [self proc] $name $password]		
		set c "\n$name entered $place successfully\n"
		return [my simplePage "New User" "New User" $c]
	    } else {
		#
		# error !!!
	    }
	    return [my [self proc]]
	}
    }

    UserMgtHtml instproc listUsers {} {
	set c ""
	foreach u [[my repObj] [self proc]] {
	    append c "<p> $u \n"
	}
	return [my simplePage "User List" "User List" $c]  
    }

    UserMgtHtml instproc userMgtOptions {} {
	set c ""
	foreach u [[my repObj] [self proc]] {
	    append c "<p> <a href=[my selfAction $u]> $u </a>\n"
	}
	return [my simplePage "User Management Options" "User Management Options" $c]  
    }

    namespace export UserMgt UserMgtHtml
}

namespace import ::xotcl::actiweb::userMgt::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































Deleted assets/xotcl1.6.7/actiweb/WebAgent.xotcl.

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
# $Id: WebAgent.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::actiweb::webAgent 0.8

package require xotcl::actiweb::agent
package require xotcl::actiweb::invoker
package require xotcl::mixinStrategy

package require XOTcl

namespace eval ::xotcl::actiweb::webAgent {
    namespace import ::xotcl::*

    #
    # Web Agent are special agents that allow us to define another
    # object in the paramter webfacade as a facade for the web agent
    # itself and the sub-system shielded by the web agent with an interface
    # for agents
    #
    Class WebAgent -superclass Agent

    WebAgent instproc init args {
	next
    }

    #
    # let the web agents facade handle the call -> interprete args
    # as "method args"
    # return result of the invoker
    #
    #WebAgent instproc invokeFacade {args} {
    #  set a ""
    #  set m ""
    #  set l [llength $args]
    #  set o [my webfacade]
    #  if {$l > 0} {
    #    set m [lindex $args 0]
    #  }
    #  if {$l > 1} {
    #    set a [lrange $args 1 end]
    #  } 
    #    
    #  #puts stderr "Web Agent [self]->invoke:  OBJ: $o PROC: $m ARGS: $a"
    #
    #  #
    #  # tell the invoker to redirect the call to the webfacade object
    #  #
    #  set re [RedirectException [self]::[my autoname re] \
    #	    -obj $o -method $m -arguments $a]
    #
    #  return $re
    #}

    #WebAgent instproc default args {
    #  return [next]
    #}

    namespace export WebAgent
}

namespace import ::xotcl::actiweb::webAgent::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































Deleted assets/xotcl1.6.7/actiweb/WebDocument.xotcl.

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
# $Id: WebDocument.xotcl,v 1.9 2007/08/14 16:38:26 neumann Exp $

package provide xotcl::actiweb::webDocument 0.8

package require xotcl::actiweb::webObject
package require xotcl::comm::httpAccess
package require xotcl::mixinStrategy
package require xotcl::actiweb::sendStrategy

package require XOTcl

namespace eval ::xotcl::actiweb::webDocument {
    namespace import ::xotcl::*

    Class WebDocument -superclass WebObject \
	-parameter {
	    {content ""}
	    filename
	}


    WebDocument instproc init args {
	my exportProcs content contentType
	next
	my mixinStrategy ::Send=TypedString
    }

    WebDocument instproc attachFile filename {
	my filename $filename
	my set oldSendStrategy [my mixinStrategy ::Send=File]
	my contentType [Mime guessContentType $filename]
    }

    WebDocument instproc detachFile {} {
	my mixinStrategy [my set oldSendStrategy]
	my unset contentType
	my unset filename
    }

    WebDocument instproc default args {
	if {[my exists content]} {
	    return [my content]
	}
	return ""
    }
    #WebDocument instproc contentLength {} {
    #  my showCall
    #  return [expr {[string length [my content]] + 1}]
    #}


    Class TextDocument -superclass WebDocument
    TextDocument instproc init args {
	next
	my contentType text/plain
    }


    Class HtmlDocument -superclass TextDocument
    HtmlDocument instproc init args {
	next
	my contentType text/html
    }

    Class FileDocument -superclass WebDocument

    #
    # class factory creates classes on the fly if they do not exist
    # already, otherwise return exisiting class
    #
    # auch flyweigth
    Class DocumentClassFactory
    DocumentClassFactory abstract instproc getClass contentType

    Class FileDocumentClassFactory -superclass DocumentClassFactory
    FileDocumentClassFactory instproc getClass contentType {
	if {[FileDocument info classchildren $contentType] eq ""} {
	    Class ::FileDocument::${contentType} -superclass FileDocument
	}
	return ::FileDocument::${contentType}
    }

    Class DocumentFactory
    DocumentFactory abstract instproc create {name args}  

    Class FileDocumentFactory -superclass DocumentFactory
    FileDocumentFactory instproc create {name class filename} {
	$class $name
	#$name contentType [$class set contentType]
	$name attachFile $filename
	return $name
    }

    Class FileObjectifier 

    FileObjectifier instproc init args {
	next
	FileDocumentClassFactory [self]::clFactory
	FileDocumentFactory [self]::objFactory
    }

    #
    # filename must be given with full path ->
    # create objects with filename's tail (prefix can be used to
    # give object name a preceding dir)
    #
    FileObjectifier instproc objectifyFile {place filename {prefix ""}} {
	set obj ""
	if {[file isfile $filename]} {
	    set type [Mime guessContentType $filename]
	    #if {$type ne "unknown/unknown"} {
	    set fn [string trimleft $prefix/[file tail $filename] /]
	    set class [[self]::clFactory getClass $type]
	    set obj [[self]::objFactory create $fn $class $filename]
	    $place exportObjs $obj
	    #puts stderr "...objectified:  $obj of class $class"
	    #}
	}
	return $obj
    }

    #
    # objectify a whole directory tree
    #
    FileObjectifier instproc objectifyTree {place dir {prefix ""}} {
	if {[file isdirectory $dir]} {
	    foreach f [glob  -nocomplain $dir/*] {
		if {[file isfile $f]} {
		    my objectifyFile $place $f $prefix
		} elseif {[file isdirectory $f]} {
		    my objectifyTree $place $f $prefix/[file tail $f]
		}
	    }
	}
    }


    Class GraphicDirectoryObjectifier -superclass FileObjectifier \
	-parameter {{thumbnaildir [::xotcl::tmpdir]}}
    GraphicDirectoryObjectifier instproc objectifyTree {place dir {prefix ""}} {
	if {[file isdirectory $dir]} {
	    set indexpage ""
	    set title ""
	    set date ""
	    foreach f [lsort [glob -nocomplain $dir/* $dir/{.date,.title}]] {
		set exportedfn [string trimleft $prefix/[file tail $f] /]
		if {[file isfile $f]} {
		    set type [Mime guessContentType $f]
		    if {[string match "image/*" $type]} {
			set class [[self]::clFactory getClass $type]
			$class $exportedfn -init -attachFile $f
			$place exportObjs $exportedfn
			#puts stderr "...objectified:  FN=$exportedfn cl=$class d=$dir o=$exportedfn"
			######
			set expThumbnaildir [file dirname $exportedfn]/.thumbnail
			set thumbnaildir    [file dirname $f]/.thumbnail
			if {![file isdirectory $thumbnaildir]} {
			    file mkdir $thumbnaildir
			}
			set thumbnail $thumbnaildir/[file tail $f]
			set expThumbnail $expThumbnaildir/[file tail $f]
			if {![file exists $thumbnail]} {
			    catch {exec djpeg -pnm $f | \
				       pnmscale -xscale .2 -yscale .2 | ppmquant 256 | \
				       ppmtogif > $thumbnail}
			}
			$class $expThumbnail -init -attachFile $thumbnail
			$place exportObjs $expThumbnail
			####
			append indexpage "<A href='/$exportedfn'>" \
			    "<IMG SRC='/$expThumbnail'>$exportedfn</A><br>\n"
		    } elseif {[string match *.title $exportedfn]} {
			set title [my fileContent $f]
		    } elseif {[string match *.date $exportedfn]} {
			set date <H4>[my fileContent $f]</H4>
		    }
		} elseif {[file isdirectory $f]} {
		    if {[file exists $f/.title]} {
			set desc ": [my fileContent $f/.title]"
		    } else {
			set desc ""
		    }
		    append indexpage "<A href='/$exportedfn/gindex.html'>" \
			"$exportedfn</A>$desc<br>\n"
		    my objectifyTree $place $f $exportedfn
		}
		set gindex [string trimleft $prefix/gindex.html /]
		HtmlDocument $gindex -content \
		    "<HTML><TITLE>$title</TITLE><H1>$title</H1>\
		<BODY>$date$indexpage</BODY></HTML>"
		#puts stderr "mixins of HtmlDocument=<[$gindex info mixins]>"
		$gindex mixinStrategy ::Send=TypedString
		#$gindex showVars
		receiver exportObjs $gindex
	    }
	}
    }
    GraphicDirectoryObjectifier instproc fileContent {f} {
	set FILE [open $f r]
	set content [read $FILE]
	close $FILE
	return $content
    }



    Class HtmlProxy -superclass HtmlDocument  -parameter realSubject
    HtmlProxy instproc init args {
	next
	[Place getInstance] exportObjs [self]
    }
    HtmlProxy instproc unknown {m args} {
	my instvar realSubject
	::eval $realSubject $m $args
	return [my default]
    }

    namespace export \
	WebDocument TextDocument HtmlDocument FileDocument \
	DocumentClassFactory FileDocumentClassFactory \
	DocumentFactory FileDocumentFactory \
	FileObjectifier GraphicDirectoryObjectifier \
	HtmlProxy
}

namespace import ::xotcl::actiweb::webDocument::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/actiweb/WebObject.xotcl.

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
# $Id: WebObject.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::actiweb::webObject 0.8

package require xotcl::actiweb::sendStrategy
package require xotcl::mixinStrategy
package require xotcl::store::persistence

package require XOTcl

namespace eval ::xotcl::actiweb::webObject {
    namespace import ::xotcl::*

    #
    # base interface for all web-entitites
    #
    Class WebObject -parameter {
	{exportedProcs {echo default}}
	agentInfo
	{contentType ""}
	{place ""}
    }

    #
    # default send strategy == send the response from the place
    #
    WebObject instproc init args {
	#my showCall
	my mixinStrategy ::Send=PlainString
	my registerPlace
	my mixinStrategy ::Persistent=Eager
	my persistenceMgr [my place]::agentPersistenceMgr
	next
    }

    WebObject instproc registerPlace {} {
	my set place [Place getInstance]
	my set agentInfo [[my place]::agentMgr register [my selfName]]
    }

    WebObject instproc deregisterPlace {} {
	[my place]::agentMgr deregister [my selfName]
    }

    #
    # seek for the HTTP worker object that has invoked
    # the current call
    #
    WebObject instproc getWorker {} {
	for {set level 1} {1} {incr level} {
	    if {[catch {set worker [uplevel $level self]}]} {
		return ""
	    } elseif {[$worker istype Place::HttpdWrk]} {
		return $worker
	    }
	}
    }
    WebObject instproc getFormData {} {
	[my getWorker] formData
    }

    #
    # code a call for an action on self;
    # action is "proc args"
    #
    WebObject instproc selfAction {action} {
	return [url encodeItem "[string trimleft [self] :] $action"]
    }
    WebObject instproc action {o action} {
	return [url encodeItem "[string trimleft $o :] $action"]
    }
    WebObject instproc echo {} {
	return [self]
    }

    WebObject instproc error args {
	return "Error on [self]: Invocation '$args' failed."
    }

    WebObject instproc default {} {
	return "No default behaviour on [self]."
    }

    WebObject instproc exportProcs args {
	my instvar exportedProcs
	foreach a $args {
	    if {[lsearch $exportedProcs $a] == -1} {
		lappend exportedProcs $a
	    }
	}
    }

    WebObject instproc isExportedProc p {
	expr {[lsearch [my set exportedProcs] $p] != -1}
    }

    WebObject instproc selfName {} {
	return [string trimleft [self] :]
    }

    WebObject instproc objName {obj} {
	return [string trimleft $obj :]
    }

    WebObject instproc buildAdress {} {
	my instvar place
	set a http://[$place host]
	if {[set p [$place port]]} {
	    append a :$p
	}
    }

    WebObject instproc destroy args {
	my deregisterPlace
	next
    }

    #
    # simple class, to be inherited before WebObject, if
    # every remote method should reach the object
    #
    Class ExportAll
    ExportAll instproc isExportedProc p {
	return 1
    }

    namespace export WebObject ExportAll
}

namespace import ::xotcl::actiweb::webObject::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































Deleted assets/xotcl1.6.7/actiweb/cacert.pem.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
-----BEGIN CERTIFICATE-----
MIIDKjCCApOgAwIBAgIBADANBgkqhkiG9w0BAQQFADCBwDELMAkGA1UEBhMCQVQx
DzANBgNVBAgTBlZpZW5uYTEPMA0GA1UEBxMGVmllbm5hMR0wGwYDVQQKExRNeSBU
ZXN0IE9yZ2FuaXphdGlvbjETMBEGA1UECxMKTXkgRGVtbyBDQTErMCkGA1UEAxMi
TXkgRGVtbyBDQSBhdCBNeSBUZXN0IE9yZ2FuaXphdGlvbjEuMCwGCSqGSIb3DQEJ
ARYfa2xhdXMua29sb3dyYXRuaWtAd3Utd2llbi5hYy5hdDAeFw0wMzA5MDUxMTEw
MDFaFw0xMzA5MDIxMTEwMDFaMIHAMQswCQYDVQQGEwJBVDEPMA0GA1UECBMGVmll
bm5hMQ8wDQYDVQQHEwZWaWVubmExHTAbBgNVBAoTFE15IFRlc3QgT3JnYW5pemF0
aW9uMRMwEQYDVQQLEwpNeSBEZW1vIENBMSswKQYDVQQDEyJNeSBEZW1vIENBIGF0
IE15IFRlc3QgT3JnYW5pemF0aW9uMS4wLAYJKoZIhvcNAQkBFh9rbGF1cy5rb2xv
d3JhdG5pa0B3dS13aWVuLmFjLmF0MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB
gQDIKhCgkG/rSDc8NjDGtJBKW1+fQsoPoBSnMeWOjRQ0YiYomHLZo2XHxsfHsDHj
xXE69GkY9SuwYX/UiF7C0H5LhVew5GTACZsZTbqUWR3D0+R4RQTNJRhQzHq4HE0o
cWjKRiQWWMqNE6S/M4Eri4SJyoaXzhkXjkboYTf/+Dks1wIDAQABozIwMDAPBgNV
HRMBAf8EBTADAQH/MB0GA1UdDgQWBBT5lsU8wZ72pP5lB5ezzqxi5mk4KTANBgkq
hkiG9w0BAQQFAAOBgQA8pZPqoSDBduMtKzNP5A6TerIc7Whm/mwBmiMq0sRHFPWe
sCHJkBxF+ryJT6WDsm1RuCdueHgoppnJ6epdqxmtOAcNcn+OQDU5lzSATBu60B5m
bH4zRsxwn4L9ts+Q1IbjWXc0P1G+2oQSNfvduS7esrs1RM64h6gUJErzxU5cfg==
-----END CERTIFICATE-----
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































Deleted assets/xotcl1.6.7/actiweb/pageTemplate.xotcl.

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
package provide xotcl::actiweb::pageTemplate 0.8

package require xotcl::actiweb::webObject
package require xotcl::actiweb::invoker
package require xotcl::mixinStrategy

package require XOTcl

namespace eval ::xotcl::actiweb::pageTemplate {
    namespace import ::xotcl::*

    Class PageTemplate -superclass WebObject
    PageTemplate instproc init args {
	next
	my mixinStrategy ::Send=TypedString
    }

    PageTemplate abstract instproc listExportedProcs args
    PageTemplate abstract instproc simplePage args

    Class PageTemplateHtml -superclass PageTemplate

    PageTemplateHtml instproc init args {
	my contentType text/html
	next
    }

    PageTemplateHtml instproc listExportedProcs args {
	#
	# place must be a Html place!
	#
	set place [HtmlPlace getInstance]
	set c "
  The following options are avaiable on $n:
  "

	foreach i [my exportedProcs] {
	    set href [my selfAction "[self] $i"]
	    set app {
		<p> <a href= "$href">$i</a>
	    }
	    append c [subst -nobackslashes $app]
	}
	return [my simplePage $place [self] $c]
    }

    PageTemplateHtml instproc simplePage {title heading content {closing ""}}  {
      set place [Place getInstance]
	set c {<html>
<head>
<title>$title</title>
</head>
<body>
<h1>$heading</h1>
<hr>
<p> 
    
$content
	    
<p> $closing

<p><hr><p>
</body>
</html>
}
	return [subst -nobackslashes -nocommands $c] 
    }

    #
    # builds a simple Form -- args are tupels of the form
    # {text, name, type, default, size}
    #
    #
    PageTemplateHtml instproc simpleForm {action args} {
	set action [my selfAction $action]
	set c {
	    <form method="get" action="$action">
	    <TABLE>
	}
	foreach {text name type def size} $args {
	    append c "
      <TR>
        <TD>$text: </TD>
        <TD><input name=\"$name\" type=\"$type\" size=\"$size\" value=\"$def\"></TD>
      </TR>
    "
	}
	append c {
	    <TR>
	    <td><input type=submit value="Submit"></td>
	    <td><input type=reset value="Reset"></td>
	    </TR>
	    </TABLE>

	    </FORM>
	}
	return [subst -nobackslashes -nocommands $c]
    }

    namespace export PageTemplate PageTemplateHtml
}

namespace import ::xotcl::actiweb::pageTemplate::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































Deleted assets/xotcl1.6.7/actiweb/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded xotcl::actiweb::agent 0.8 [list source [file join $dir Agent.xotcl]]
package ifneeded xotcl::actiweb::agentManagement 0.8 [list source [file join $dir AgentManagement.xotcl]]
package ifneeded xotcl::actiweb::htmlPlace 0.8 [list source [file join $dir HtmlPlace.xotcl]]
package ifneeded xotcl::actiweb::httpPlace 0.8 [list source [file join $dir HttpPlace.xotcl]]
package ifneeded xotcl::actiweb::invoker 0.8 [list source [file join $dir Invoker.xotcl]]
package ifneeded xotcl::actiweb::pageTemplate 0.8 [list source [file join $dir pageTemplate.xotcl]]
package ifneeded xotcl::actiweb::placeAccessControl 0.8 [list source [file join $dir PlaceAccessControl.xotcl]]
package ifneeded xotcl::actiweb::secureHtmlPlace 0.8 [list source [file join $dir SecureHtmlPlace.xotcl]]
package ifneeded xotcl::actiweb::secureHttpPlace 0.8 [list source [file join $dir SecureHttpPlace.xotcl]]
package ifneeded xotcl::actiweb::sendStrategy 0.8 [list source [file join $dir SendStrategy.xotcl]]
package ifneeded xotcl::actiweb::userMgt 0.8 [list source [file join $dir UserMgt.xotcl]]
package ifneeded xotcl::actiweb::webAgent 0.8 [list source [file join $dir WebAgent.xotcl]]
package ifneeded xotcl::actiweb::webDocument 0.8 [list source [file join $dir WebDocument.xotcl]]
package ifneeded xotcl::actiweb::webObject 0.8 [list source [file join $dir WebObject.xotcl]]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































Deleted assets/xotcl1.6.7/comm/Access.xotcl.

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
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
# -*- tcl -*- $Id: Access.xotcl,v 1.9 2007/08/14 16:38:26 neumann Exp $

set httpAccessVersion 0.91
package provide xotcl::comm::httpAccess $httpAccessVersion

package require -exact xotcl::comm::pcache 0.9
package require -exact xotcl::comm::mime 0.9
package require -exact xotcl::comm::connection 1.0
package require -exact xotcl::trace 0.91

package require XOTcl

namespace eval ::xotcl::comm::httpAccess {
    namespace import ::xotcl::*

    variable os
    variable VERSION

    if {[catch {set os [exec uname -sr]}]} {
	if {[catch {set os [exec uname -a]}]} { set os unknownOS }
    }
    if {![info exists VERSION]} { set VERSION 1.0 }


    # assert is used only for invariants in the source
    proc assert {f r} {
	set got [eval $f]
	if {$got != $r} {
	    puts stderr "assertion failed: \[$f\] == $r (got $got)"
	}
    }


    # resolve and checkUrl implement URL handling (primarily completion)
    proc checkUrl {url} {
	#puts stderr "checkUrl: <$url>"
	if {![regexp {^([^:]+:/)/([^/]+)(/.*)?$} $url _ scheme network path]} {
	    regexp {^([^:]+:)(/.*)?$} $url _ scheme path
	}
	if {![info exists path]} {
	    # no access scheme provided, try some heuristics...
	    if {[regexp {^[./]} $url]} {
		# expand leading "." to pwd
		if {[regexp {^\.(.*)$} $url _ url]} { set url [pwd]$url }
		return file:$url
	    } else {
		set url http://$url
		regsub {///$} $url // url
		return $url
	    }
	}
	if {$path eq ""} {set path /}
	return [expr {[info exists network] ?
		      "$scheme/$network$path" : "$scheme$path"}]
    }

    # resolving a relative url with respect to a base url (based on rfc 1808)
    proc resolve {rel base {childTagName ""}} {
	if {$base eq ""}    { return [checkUrl $rel] }
	if {$rel eq ""}     { return $base }
	if {[regexp {^[^:]+:/} $rel _]} { return [checkUrl $rel] }
	if {![regexp {^([^:]+:/)/([^/]+)(/.*)$} $base _ baseScheme baseNetwork basePath]} {
	    regexp {^([^:]+:)(/.*)$} $base _ baseScheme basePath
	} elseif {[regexp {^[^:/]+:} $rel]} {
	    return $rel
	}
	regexp {^(.*)\#.*$} $basePath _ basePath
	regexp {^(.*)[?].*$} $basePath _ basePath
	if {[regexp {^//([^/]+)/(.*)$} $rel _ relNetwork relPath]} {
	    return $baseScheme/$relNetwork/$relPath
	}
	if {[info exists baseNetwork]} {
	    append baseScheme /$baseNetwork
	}
	#puts stderr rel=<$rel>
	if {![string match "/*" $rel]} {
	    #puts stderr rel<$rel>base<$basePath>
	    if {[string match \#* $rel]} {
		set r $basePath$rel
	    } elseif {![regsub {/([^/]*)$} $basePath /$rel r]} {
		set r /$rel
	    }
	    while {[regsub -all {/\./} $r / r]} {}
	    regsub {/\.$} $r / r
	    while {[regsub -all {/[^/.]+/\.\./} $r / r]} {}
	    # remove leading /../ (netscapes navigator does this)
	    while {[regsub {^/\.\./} $r / r]} {}
	    set rel $r
	    #puts stderr finalrel<$r>
	}
	#if {$childTagName ne ""} 
	if {1} {
	    upvar 1 $childTagName childTag 
	    catch {unset childTag}
	    if {[regexp {^(.+)\#(.+)$} $rel _ rel childTag]} {
		#puts stderr childTag=$childTag,url=$baseScheme$rel.
	    }
	}
	return $baseScheme$rel
    }

    assert {resolve "" http://mohegan/} http://mohegan/
    assert {resolve http://mohegan/ ""} http://mohegan/
    assert {resolve http://mohegan ""} http://mohegan/
    assert {resolve http://mohegan/ http://nestroy} http://mohegan/
    assert {resolve test.html http://127.0.0.1/} http://127.0.0.1/test.html
    assert {resolve test http://nestroy/} http://nestroy/test
    assert {resolve test file:/u/neumann/old} file:/u/neumann/test
    assert {resolve /test http://nestroy/} http://nestroy/test
    assert {resolve //mohegan/index.html http://nestroy/} http://mohegan/index.html
    assert {resolve //mohegan/index.html http://nestroy/} http://mohegan/index.html
    assert {resolve index.html http://nestroy/dir/} http://nestroy/dir/index.html
    assert {resolve ./index.html http://nestroy/dir/} http://nestroy/dir/index.html
    assert {resolve ././index.html http://nestroy/dir/} http://nestroy/dir/index.html
    assert {resolve ../index.html http://nestroy/dir/} http://nestroy/index.html
    assert {resolve ../../index.html http://nestroy/dir/} http://nestroy/index.html
    assert {resolve ../../../test file:/u/neumann/old} file:/test
    assert {resolve newdir/  http://nestroy/dir/} http://nestroy/dir/newdir/
    assert {resolve /newdir/  http://nestroy/dir/} http://nestroy/newdir/
    assert {resolve file:/u/neumann/ice.html ""} file:/u/neumann/ice.html
    assert {resolve \#label http://nestroy/h.html} http://nestroy/h.html
    assert {resolve mailto:user@host http://nestroy/h.html} mailto:user@host
    assert {resolve ../../../../mis2001/folien/081101.ppt  http://wwwi.wu-wien.ac.at/Studium/Abschnitt_2/LVA_ws01/IT/index.html} http://wwwi.wu-wien.ac.at/mis2001/folien/081101.ppt


    ##############################################################
    # Every object of class Access informs the (possibly empty) list of 
    # informObjects during its lifecycle with the following messages
    #   
    #   startCb:   when the request for the object is created
    #              and was classified and initialized
    #
    #   notifyCb:  when the type of the incming data is dertermined
    #              (typically after parsing the http header)
    #
    #   incCb:     when new data is available
    #
    #   endCb:     when the request is finished sucessfully and the object
    #              is going to be destroyed
    #
    #   cancelCb:  when the request is finished nonsucessfully and the object
    #              is going to be destroyed
    #
    # All these messages receive the name of the Access object
    # as first parameter, incCb has two more arguments (totalsize 
    # and currentsize) 

    # caching:
    # 0 no caching
    # 1 volatile cache (does not check cache, keeps spool file for back button)
    # 2 persistent cache

    Class Access -parameter {
	{method GET} {blocking 0} {httpVersion 1.1} {headers {}} 
	url query data contentType path caching sinkClass parentUrl
    }
    Access instproc informObject x {
	foreach i $x { my lappend informObjects $i }
    }
    Access instproc method x {
			      my set method [string toupper $x]
			  }
    Access instproc unknown {m args} {
	error "Method '$m' with args '$args' is unknown for [self class]"
    }

    Access proc checkRunning {} {
	foreach u [my array names running] {
	    puts stderr "... running: $u"
	}
	puts stderr "... -----------"
    }
    Access proc createRequest args {
	#my showCall
	set informobject {}
	set allowJoin 1
	set nargs {}
	foreach {a v} $args {
	    switch -exact -- $a {
		-url           {set url $v;          lappend nargs $a $v}
		-informObject  {set informobject $v; lappend nargs $a $v}
		-parentRequest {set parentRequest $v}
		-allowJoin     {set allowJoin $v}
		default        {lappend nargs $a $v}
	    }
	}
	#if {[my array exists running]} {parray [self]::running}
	if {[my exists running($url)] && $allowJoin} {
	    my showMsg "we can join running($url)=[my set running($url)]"
	    # we can join the request.
	    # requests are joined by adding the informobjects to
	    # the existing request
	    set token [my set running($url)]
	    # delegation to a different request works only so easy
	    # when loading to a file...
	    $token informObject $informobject
	    return $token
	} else {
	    set token [my autoname ::req]
	    if {[info exists parentRequest]} {
		set token ${parentRequest}$token
	    } 
	    #my showMsg "TOKEN = $token $url"
	    return [eval my create $token $nargs]
	}
    }
    Access instproc running {} {
	#my showCall
	[self class] set running([my url]) [self]
    }
    Access instproc stop {} {
	#showCall
	my instvar url
	if {[[self class] exists running($url)]} {
	    #puts stderr "my unset [[self class] set running($url)]
	    [self class] unset running($url)
	    #if {[my array exists running]} { parray [self class]::running }
	} else {
	    #puts stderr "not running($url)"
	    #if {[my array exists running]} { parray [self class]::running }
	}
    }
    #Access instproc destroy args {
    #  my showCall
    #  next
    #}
    Access instproc init args {
	#my showCall
	my instvar method url
	if {![my exists informObjects]} {
	    my set informObjects {}
	}
	next
	if {![my exists caching]} { 
	    if {$method eq "GET"} {
		set defaultCaching 2
	    } else {
		set defaultCaching 1
	    }
	    my caching $defaultCaching
	}
	#my showVars

	set url [string trim $url]
	my initialize
	if {[my classify $url]} {
	    #my showVars
	    # now inform all interested objects that we have the object
	    my doCallbacks startCb
	    #my showVars blocking
	    # trigger the transfer... (might be blocking or not)
	    my $method
	    if {![my exists finished]} {
		# the request is not finished
		if {[my blocking]} {
		    #my showMsg "waiting"
		    my vwait finished
		    #my showMsg "waiting DONE"
		}
	    }
	}
    }
    Access instproc getContent {} {
	[my set sink] content
    }

    #########################################
    Access instproc timeout t {
	my set timeout [::after $t [self] timeoutOccured]
    }
    Access instproc timeoutOccured {} {
	#my showCall
	my unset timeout
	my abort "timeout exceeded"
    }
    Access instproc timeoutFinish {} {
	if {[my exists timeout]} {
	    after cancel [my set timeout]
	    my unset timeout
	}
    }
    #########################################

    Access instproc initialize {} {
	#my showCall
	my set state           0
	my set meta            {}
	my set currentsize     0
	my set totalsize       0
    }
    Access instproc classify {url} {
	my instvar host path port method
	#my showVars caching
	if {[my caching] > 1 && [persistentCache isValidated $url]} {
	    #puts stderr "*** cacheable && validated"
	    #showVars
	    #persistentCache dump
	    set access CacheAccess
	} elseif {[regexp -nocase {^http://([^/:]+)(:([0-9]+))?(/.*)?$} $url \
		       _ host y givenPort path]} {
	    if {$givenPort ne ""} {set port $givenPort } {set port 80}
	    switch -exact $method {
		PROPFIND -
		PROPPATCH -
		COPY -
		MKCOL -
		MOVE -
		LOCK -
		UNLOCK {
		    package require xotcl::comm::dav
		    set access Dav
		}
		default {set access Http}
	    }
	} elseif {[regexp -nocase {^https://([^/:]+)(:([0-9]+))?(/.*)$} $url \
		       _ host y givenPort path]} {
	    if {$givenPort ne ""} {set port $givenPort } {set port 443}
	    set access Https
	} elseif {[regexp -nocase {^file:(.*)$} $url _ path]} {
	    set access File
	} elseif {[regexp -nocase {^ftp://([^/]+)/(.*)$} $url _ host path]} {
	    package require -exact xotcl::comm::ftp 0.9
	    set access Ftp
	} elseif {[regexp -nocase {^imap://([^/]+)/(.*)$} $url _ host path]} {
	    package require xotcl::comm::imap
	    set access Imap
	} elseif {[regexp -nocase {^cmd:/(.*)$} $url _ path]} {
	    set access xotcl::Cmd    
	} elseif {[regexp -nocase {^ldap://([^/:]+)?(:([0-9]+))?(/.*)$} \
		       $url _ host y givenPort path]} {
	    if {$givenPort ne ""} { set port $givenPort }
	    my showMsg "*** ldap://<$host>:<$port>/<$path>"
	    package require xotcl::comm::ldap
	    set access Ldap  
	} else {
	    #my set state 0
	    my abort "Unsupported URL: '$url'"
	    return 0
	}
	my class $access
	#my showMsg "class of request = $access"
	return 1
    }
    Access instproc revisit {} {
	my class ReAccess
	my initialize
	my [my set method]
    }
    ### dummy stubs for 'close' and 'GET' for error cases
    Access instproc close {} {
    }
    Access instproc GET {} {
	if {[my exists errormsg]} { ;# the error was already reportet
	    my finish
	} else {
	    my abort "unknown error"
	}
    }

    Access instproc headerDone {} {
	my instvar caching sink
	if {[my exists ignoreBody]} return
	if {[my exists sinkClass] && $caching>0 } {
	    error "can┬┤t set both sinkclass and caching"
	}
	switch $caching {
	    2 {
		set sink [CacheFileSink create [self]::cfs]
		#my showMsg "[self class] result goes to cache"
		$sink notifyCb [self]
	    }
	    1 {
		set sink [CacheFileSink create [self]::cfs -persistent 0]
		#my showMsg "result goes to volatile cache"
		$sink notifyCb [self]
	    }
	    0 {
		if {[my exists sinkClass]} {
		    set sink [[my sinkClass] create [self]::s]
		}
	    }
	}
	my doCallbacks notifyCb
    }
    Access instproc mkSpoolFile {{name ""}} {
	if {![my exists fileName]} {
	    my set fileName [persistentCache newEntry [my url] [self] [my caching] $name]
	}
    }
    Access instproc block {} {
	my set block
    }
    Access instproc kill {} {
	my showCall
	my set state -1; #interrupted
	my finish
    }
    Access instproc abort {msg} {
	#my showCall
	#my showVars
	my instvar state errormsg
	if {[catch {::printError "[self] ($state): $msg"} err]} {
	    puts stderr "\n$err\nERROR [self] ($state): $msg\n"
	}
	#my set error [list $msg $::errorInfo $::errorCode]
	my caching 0
	if {[my exists ignoreBody]} {
	    my unset ignoreBody
	}
	set state -2 ;# error
	set errormsg $msg
	my finish
    }
    Access instproc finish {} {
	#my showCall
	my timeoutFinish
	my close
	#my showVars state ignoreBody
	# state is "interrupted" or "error"
	if {[my set state] < 0} {
	    set action cancelCb
	    set success 0
	} else {
	    set action endCb
	    #set state ok
	    set success 1
	}
	if {[my exists ignoreBody]} {
	    my stop
	    #my set finished $success
	    set cmd [my set ignoreBody]
	    my unset ignoreBody
	    #my showMsg "executing... <$cmd>"
	    eval my $cmd
	} else {
	    if {[my exists sink]} {
		[my set sink] $action [self]
	    }
	    #catch {after cancel $after} ;# ????
	    my doCallbacks $action
	    my stop
	    my set finished $success
	}
    }
    Access instproc eof {} {
	#my showCall
	#my showMsg "c [my set currentsize]== t [[self set totalsize]]"
	#my set state eof
	my finish
    }
    Access instproc doCallbacks {cb} {
	#my showCall
	if {[my exists ignoreBody]} {
	    my showMsg "ignoring callback"
	} else {
	    foreach obj [my set informObjects] {
		#my showMsg "*** $obj $cb [self]"
		#puts stderr "------------ calling: $obj $cb [self]"
		if {[catch {$obj $cb [self]} errormsg]} {
		    puts stderr "--------------$cb:errormsg=$errormsg, \
		     errorInfo=$::errorInfo, \
		     errorCode=$::errorCode."
		}
		#puts stderr "------------ calling DONE: $obj $cb [self]"
	    }
	}
    }
    Access instproc shutdown {} {
	#my showMsg "state=[my set state] > 3"
	if {[my set state] > 3} {
	    my set mustDestroy 1
	} else {
	    #my showVars
	    #my showStack
	    #my showMsg "DESTROY !!!"
	    if {[my set state] > -2} {
		my destroy
	    }
	}
    }


    Class FileAccess -superclass Access
    FileAccess instproc initialize args {
	my caching 0
	next
    }
    FileAccess instproc close {} {
    }
    FileAccess instproc block {} {
	my showTimeStart
	set S [open [my set fileName] r]
	fconfigure $S -translation binary
	set block [::read $S]
	::close $S
	my showTimeEnd
	return $block
    }
    FileAccess instproc GET {} {
	my instvar path response totalsize currentsize \
	    fileName informObjects
	set fileName $path
	set totalsize [file size $path]
	set response "file 200 OK"
	my headerDone
	my set state 4
	set currentsize $totalsize
	#my showVars informObjects 
	foreach obj $informObjects {
	    $obj incCb [self] $totalsize $currentsize
	}
	my eof
    }


    Class File -superclass FileAccess
    File instproc GET {} {
	my instvar path
	#puts stderr path=$path,exists=[file exists $path]
	if {![file exists $path]} {
	    my abort "No such file '$path'"
	    return
	}
	if {![my exists contentType]} {
	    my contentType [Mime guessContentType $path]
	}
	my set sink [FileSink create [self]::fas -fileName $path]
	#puts stderr ****sink=$sink,[$sink info class]
	#puts stderr "*** before next ([self class])"
	next
	#puts stderr "*** after next ([self class])"
    }

    Class CacheAccess -superclass File
    CacheAccess instproc GET {} {
	my instvar url
	my path         [persistentCache cacheFileName $url]
	my contentType  [persistentCache contentType $url]
	my set meta     [persistentCache meta $url]
	next
    }

    Class ReAccess -superclass File
    ReAccess instproc GET {} {
	my instvar fileName sink
	my set block       ""
	my set currentsize 0
	my caching     0
	if {![info exists fileName]} {
	    set fileName [$sink set fileName]
	}
	my set path $fileName
	next
    }



    Class Cmd -superclass Access
    Cmd instproc init args {
	if {![my exists caching]} {
	    my caching 0
	}
	next
    }
    Cmd instproc GET {} {
	my instvar path block totalsize currentsize \
	    response informObjects state
	if {[catch {set block [eval $path]} error]} {
	    my contentType text/plain
	    set block $error
	} else {
	    my contentType text/html
	}
	set totalsize [string length $block]
	set response "cmd 200 OK"
	my headerDone
	my set state 4
	set currentsize $totalsize
	foreach obj $informObjects {
	    $obj incCb [self] $totalsize $currentsize
	    #$obj endCb [self]
	}
	#set state eof
	my finish
    }
    Cmd instproc block args {
	my instvar block
	return $block
    }


    #Class NetAccess -superclass Access -parameter {host port}
    Class NetAccess -superclass Access
    NetAccess instproc initialize args {
	if {![my exists blocksize]} {my set blocksize 512}
	my set readMethod read
	next
    }
    NetAccess instproc read {} {
	#my instvar S blocksize block
	#set block [::read $S $blocksize]
	my instvar S block blocksize
	set block [::read $S $blocksize]
    }
    NetAccess instproc gzread {} {
	my instvar S Z blocksize block
	puts -nonewline $Z [::read $S $blocksize]
	set block [::read $Z]
	#puts stderr len=[string length $block],block=<$block>
    }
    NetAccess instproc gzopen {} {
	my instvar Z S readMethod
	requireModules {zipchan libzipchan.so}
	fconfigure $S -translation binary
	set Z [zipchan]
	set readMethod gzread
    }
    NetAccess instproc close {} {
	#my showMsg "**** close persistent=[my exists persistent]"
	if {![my exists persistent]} {
	    foreach stream {S Z} {
		if {[my exists $stream]} {
		    ::close [my set $stream]
		    my unset $stream
		}
	    }
	}
	my stop
    }
    NetAccess instproc hold {} {
	my instvar S
	$S hold
    }
    NetAccess instproc resume {} {
	my instvar S
	$S resume
    }
    NetAccess instproc readData {} {
	#my showCall
	if {[catch {
	    #puts stderr "??????????????readMethod=[my set readMethod]"
	    my [my set readMethod]
	    my pushBlock
	} err]} {
	    puts stderr ERR=$err
	    my set block ""
	    my abort $err
	}
    }
    NetAccess instproc pushBlock {} {
	#my showCall
	my instvar block
	if {[set n [string length $block]]} {
	    my instvar currentsize totalsize informObjects sink
	    #my showVars n currentsize totalsize
	    incr currentsize $n
	    if {$currentsize > $totalsize} {
		set totalsize $currentsize
	    }
	    #my showMsg "total=$totalsize current=$currentsize"
	    if {[my exists ignoreBody]} {
		#puts stderr "ignoring: <$block>"
	    } else {
		if {[info exists sink]} {
		    $sink incCb [self] $totalsize $currentsize
		}
		foreach obj $informObjects {
		    #my showMsg "call incbCb $totalsize $currentsize $obj [$obj info class]"
		    $obj incCb [self] $totalsize $currentsize
		    #my showMsg "done incbCb $totalsize $currentsize"
		}
	    }
	} else {
	    #my showVars n
	    return [my eof]
	}
    }

    Class Http -superclass NetAccess  ;###  -parameter {query {httpVersion 1.0}}
    Http set proxyfilter  httpProxyRequired
    Http set proxyhost    {}
    Http set proxyport    {}
    Http set accept       */*
    if {[info exists argv0]} {
	Http set useragent    "[file tail $argv0] httpAccess/$httpAccessVersion xotcl/$::xotcl::version ($os)"
    }
    Http proc proxyfilter {host phostv pportv} {
	my instvar proxyfilter proxyhost proxyport
	upvar \#1 $phostv phost $pportv pport
	switch -- $proxyfilter {
	    httpProxyRequired {
		if {[string length $proxyhost]} {
		    if {![string length $proxyport]} { set proxyport 8080 }
		    set phost $proxyhost
		    set pport $proxyport
		}
	    }
	}
    }

    Http instproc initialize args {
	if {![my exists port]}        {my set port 80}
	if {![my exists httpVersion]} {my set httpVersion 1.1}
	next
	#my showMsg "result queried from net"
    }
    Http instproc GET {} {
	#my showCall
	if {[my exists query]} {
	    my instvar query caching
	    my append url ?$query
	    my append path ?$query
	    if {$caching == 2} {set caching 1}
	    my showVars caching $query
	}
	my open
    }
    Http instproc HEAD {} {
	my open
    }
    Http instproc POST {} {
	# we have query and data only for a uniform interface for
	# forms that cann pass the attribute value pairs always via
	# query.
	if {[my exists query]} {
	    my data [my query]
	}
	my open
    }
    Http instproc PUT {} {  
	my open
    }
    # Http1.1
    Http instproc OPTIONS {} {
	my showCall
	my open  
    }
    # Http1.1
    Http instproc TRACE {} {
	my showCall
    }
    # Http1.1
    Http instproc DELETE {} {
	#my showCall
	my open  
    }
    Http instproc openConnection {host port reuse} {
	return [Connection make [self] $host $port $reuse _]
    }
    Http instproc open {} {
	#my showCall
	my instvar url S state host port path
	if {$state > 0} {
	    puts stderr "... [self]:$proc ignoring request in state $state"
	    return
	}
	Http proxyfilter $host phost pport
	if {[info exists phost] && [string length $phost]} {
	    set usePort $pport
	    set useHost $phost
	    set path $url
	} else {
	    set usePort $port
	    set useHost $host
	}

	set S [my openConnection $useHost $usePort [expr {[my httpVersion]>1.0}]]
	if {[$S exists error]} {
	    my abort [$S set error]
	    return
	}
	set state 2
	my running
	$S event writable [self] ask
    }

    Http instproc ask {} {
	my instvar url S state host port path \
	    method headers data caching

	$S event writable [self] {}

	if {[pwdManager checkAvailableCredentials $url credentials]} {
	    eval lappend headers $credentials
	    #my showMsg "*** new headers = <$headers>"
	}
	if {$caching==2 && [persistentCache ifModifiedHeader $url ifModified]} {
	    eval lappend headers $ifModified
	    #puts stderr "new headers = <$headers>"
	}
	# Send data in cr-lf format, but accept any line terminators
	$S translation {auto crlf}

	#my showMsg "'$method $path HTTP/[my httpVersion]' headers {$headers}"
	$S puts "$method $path HTTP/[my httpVersion]"
	if {[$S  exists error]} {
	    my abort "Connection refused by host '$host' port '$port'\n\
    	[$S set error]"
	    return
	}

	$S puts "Accept: [Http set accept]"
	$S puts "Host: $host"
	$S puts "User-Agent: [Http set useragent]"
	foreach {tag value} $headers {
	    regsub -all \[\n\r\] $value {} value
	    set tag [string trim $tag]
	    if {[string length $tag]} {
		#my showMsg "+++ <$tag: $value>"
		$S puts "$tag: $value"
	    }
	}
	if {[my exists data]} {
	    $S puts "Content-Length: [string length $data]"
	    $S puts "Content-Type: [my contentType]"
	    $S puts ""
	    $S translation {auto binary}
	    $S puts-nonewline $data
	} else {
	    $S puts ""
	}
	$S flush
	if {[$S  exists error]} {
	    my instvar host port
	    my abort "Connection refused by host '$host' port '$port'\n\
		[$S set error]"
	} else {
	    set state 3
	    $S event readable [self] headerStart
	}
    }

    Http instproc headerStart {} {
	#my showCall
	my instvar S response
	set n [$S gets response]
	#my showVars n response
	if {[$S  exists error]} {
	    my instvar host port
	    my abort "Error on connection to host '$host' port '$port'\n\
		[$S set error]"
	    return
	}
	#my showMsg "n=$n, eof=[$S eof]"
	if {$n == -1 && ![$S eof]} {
	    #my showMsg "******************************input pending, no full line"
	    return
	}
	my instvar responseCode responseHttpVersion
	if {[regexp {^HTTP/([0-9.]+) +([0-9]+) *} $response _ \
		 responseHttpVersion responseCode]} {
	    #my showMsg "response valid: '$response'"
	    $S event readable [self] header
	} else {
	    my instvar host port
	    my abort "Unexpected response from $host:$port\n    $n: '$response'"
	}
    }
    Http instproc header {} {
	my instvar S meta totalsize
	if {[$S gets line]} {
	    #my showMsg "line=$line"
	    if {[regexp -nocase {^content-type:(.+)$} $line _ type]} {
		my contentType [string trim $type]
	    } elseif {[regexp -nocase {^content-length:(.+)$} $line _ length]} {
		set totalsize [string trim $length]
	    }
	    if {[regexp -nocase {^([^:]+): *(.+)$} $line _ key value]} {
		lappend meta [string tolower $key] $value
	    }
	} else {
	    my headerDone
	}
    }
    Http array set expectsBody \
	{GET 1 HEAD 0 POST 1 PUT 0 DELETE 1 OPTIONS 0 TRACE 1}
    Http instproc headerDone {} {
	#my showVars meta
	my instvar S meta method responseCode responseHttpVersion
	[self class] instvar expectsBody
	set expectBody $expectsBody($method)

	array set v [my set meta]
	if {([info exists v(connection)] && $v(connection) eq "close") || \
		$responseHttpVersion < 1.1} {
	    $S makePersistent 0
	} else {
	    $S makePersistent 1
	}
	
	switch $responseCode {
	    200 {}
	    204 {
		#set state empty
		my finish
		set block ""
		set expectBody 0
		return
	    }
	    301 -
	    302 {
		# the request is redirected to another server
		my set ignoreBody [list redirect $v(location)]
		
		# RFC2068 Note: When automatically redirecting a POST request after
		# receiving a 302 status code, some existing HTTP/1.0 user agents
		# will erroneously change it into a GET request.
		#my method GET 
		
		my showMsg "redirect '[my url]' --> '$v(location)'"
	    }
	    304 { ;#  Not Modified, use cached version
		my set ignoreBody cacheAccess
		set expectBody 1
		#my showMsg "result comes from cache"
	    }
	    401 {
		my set ignoreBody \
		    [list resubmitAuthenticated $v(www-authenticate)]
		#my showMsg "resubmitAuthenticated $v(www-authenticate)"
		if {[my exists resubmitAuthenticated]} {
		    if {[my set resubmitAuthenticated] > 5} {
			my abort "Too many wrong passwords given"
		    } else {
			my incr resubmitAuthenticated
		    }
		} else {
		    my set resubmitAuthenticated 1
		}
		set expectBody 1
	    }
	    404 {
		my instvar url
		#my showVars
		my set ignoreBody [list abort "File Not Found on Server '$url'"]
		set expectBody 1
	    }
	    default {
		#my showVars responseCode
	    }
	}
	next
	if {![my exists S]} {;# this request was already canceled
	    return
	}
	if {[info exists v(transfer-encoding)]} {
	    if {$v(transfer-encoding) == "chunked"} {
		$S translation {auto binary}
		my set state 4
		$S event readable [self] readChunkedLength
	    } else {
		my abort "Unexpected Transfer encoding '$v(transfer-encoding)'"
	    }
	} else {
	    # yahoo does not send a content length for a get request
	    #if {$totalsize == 0 && ($responseCode > 300 || !$expectsBody($method) )} 
	    #my showVars method totalsize expectsBody($method) expectBody
	    # the following is used currently for Actiweb-Agents:
	    # the reponse of a PUTS contains a BODY!
	    if {!$expectBody && 
		[::info exists v(content-length)] &&
		$v(content-length) > 0} {
		set expectBody 1
		#my showMsg "setting expectBody 1"
	    }

	    if {!$expectBody} {
		#$S event readable [self] ""
		#set state eof
		my finish
		set block ""
	    } else {
		### To avoid CRLF problmes we set the translation for 
		### the body entity  to binary
		$S translation binary
		my set state 4
		$S event readable [self] readData
	    }
	}
    }

    Http instproc cacheAccess {} {
	# there is an actual version of the document in the cache
	#showCall
	persistentCache validated [my url]
	#my close
	my class CacheAccess
	#my showMsg "result comes from cache [persistentCache cacheFileName $url]"
	my caching 0 ;# should be really: toCache 0
	my GET
    }

    Http instproc redirect location {
	# the request is redirected to another server
	if {$location ne [my url] } {
	    #my showVars
	    my url $location
	    my initialize
	    my classify $location
	    my [my set method]
	}
    }
    Http instproc resubmitAuthenticated headerField {
	#my showCall
	# the server requires authentification
	my instvar path method
	if {[pwdManager checkRequestedAuthentification $method $path $headerField \
		 type realm]} {
	    my instvar url caching method headers
	    array set v $headers
	    #my showVars
	    catch {unset v(Authorization)}
	    set headers [array get v]
	    pwdManager removePasswd $realm
	    my close
	    if {[pwdManager requireCredentials $realm $url]} {
		my initialize
		if {$caching == 2} {set caching 1}
		my $method
	    }
	} else {
	    my abort "unknown authentication method '$headerField'"
	}
    }
    Http instproc readChunkedLength {} {
	#my showCall
	my instvar S chunkLength totalsize
	set length [$S gets lengthString]
	if {$length > 0} {
	    set chunkLength [expr 0x$lengthString]
	    #my showVars lengthString chunkLength
	    if {$chunkLength == 0} {
		$S event readable [self] readChunkedTrailer
	    } else {
		incr totalsize $chunkLength
		$S translation {binary}
		$S event readable [self] readChunkedData
	    }
	}
    }
    Http instproc readChunkedTrailer {} {
	#my showCall
	my instvar S state block
	set size [$S gets line]
	if {$size != 0} {
	    showObj [self]
	    my abort "expected trailer size 0, got size $size"
	} else {
	    #set state eof
	    my finish
	    set block ""
	    #showObj [self]
	}
    }
    Http instproc readChunkedData {} {
	#my showCall
	my instvar S block totalsize currentsize chunkLength
	set block [$S readSize $chunkLength]
	set received [string length $block]
	#my showVars block
	#my showVars currentsize totalsize chunkLength received
	if {$chunkLength == $received} {
	    $S translation {auto binary}
	    $S event readable [self] readChunkedLength
	} else {
	    incr chunkLength -$received
	}
	my pushBlock
    }

    Http instproc readData {} {
	#my showCall
	my instvar S block totalsize currentsize
	set block [$S read]
	#puts stderr "????? bl=[string length $block]"
	if {[$S exists error]} {
	    set block ""
	    my abort [$S set error]
	    return
	}
	my pushBlock
	#my showMsg "c [my set currentsize]== t [[self set totalsize]]"
	if {$currentsize == $totalsize && 
	    [my exists S] && [$S exists persistent]} {
	    #my showMsg "PERSITENT, end of entity reached"
	    #my set state eof
	    my finish
	    set block ""
	    #showObj [self]
	}
	if {[my exists mustDestroy]} {
	    #my showMsg "mustDestroy was set"
	    my destroy
	}
    }
    Http instproc close {} {
	#my showCall
	if {[my exists S]} {
	    [my set S] close
	    #unset S
	}
	#next
    }
    Http instproc freeConnection {} {
	#showCall
	my instvar S
	#::puts stderr "[self] freeing $S !!!!!!!!!!!!!!!!!!!!!!!"
	unset S
    }


    #Access instproc makeZombie {} {
    #  my showMsg "procs= [my info procs], i [Object info instcommands]"
    #  my class Zombie
    #}
    #Class Zombie
    #Zombie instproc unknown {m args} {
    #  my showMsg "+++ zombie method '$m' called"
    #}


    Class Https -superclass Http
    Https instproc initialize args {
	#my showCall
	package require tls 
	if {![my exists port]} { my set port 443}
	next
	### temporary solution, FIXME: 
	### zur zeit muss man den secure-webserver.xotcl und 
	### secure-webclient.xotcl jedenfalls aus dem xotcl/apps/xocomm-apps
	### verzeichnis starten, da haben wir mal die cfg files in unserem
	### baum....
	source .ssl/ssl-configuration.xotcl
	###
    }
    Https instproc openConnection {host port reuse} {
	set S [Connection make [self] $host $port $reuse reused]
	if {$reused} {
	    #my showMsg "reusing $S"
	} else {
	    my showMsg "make the socket ([$S socket]) secure ..."    
	    set cmd [list $S importSSL]
	    foreach attr {cafile cadir certfile cipher command keyfile \
			      model request require ssl2 ssl3 tls1} {
		if {[sslClientConfig exists $attr]} {
		    lappend cmd -$attr [sslClientConfig set $attr]
		}
	    }
	    my showMsg "the assembled command is... ┬┤$cmd┬┤"    
	    eval $cmd
	    puts stderr "CHANNELS= [file channels]"
	}
	return $S
    }



    #######################################################################
    Object pwdManager
    pwdManager proc requirePasswd {realm username password} {
	# used by ftp and imap
	my instvar user area
	upvar [self callinglevel] $password passwd
	if {[my exists pwd($realm)]} {
	    #my showMsg "*** reusing password for $realm"
	    set passwd [my set pwd($realm)]
	    return 1
	} else {
	    userPwd user $username
	    if {[userPwd show $realm user($realm) passwd]} {
		set area($realm/$username) $realm
		return 1
	    }
	}
	return 0
    }
    pwdManager proc storePasswd {realm username password} {
	# used by ftp and imap
	my instvar pwd user
	set pwd($realm) $password
	set user($realm) $username
    }
    pwdManager proc removePasswd {realm} {
	if {[my exists pwd($realm)]} {
	    my unset pwd($realm) 
	    my unset user($realm) 
	}
    }
    pwdManager proc requireCredentials {realm url} {
	regexp {^(.*/)[^/]*$} $url _ path
	if {[my exists pwd($realm)]} {
	    #my showMsg "*** register url=$url for ther realm=$realm"
	    my set area($path) $realm
	    return 1
	} else {
	    my instvar pwd user
	    if {[info exists ::env(USER)]} {
		set USER $::env(USER)
	    } elseif {[info exists ::env(USERNAME)]} {
		set USER $::env(USERNAME)
	    } else {
		set USER unknown
	    }

	    userPwd user $USER
	    if {[userPwd show $realm user($realm) pwd($realm)]} {
		#my showMsg "*** setting password for realm '$realm' url=$path"
		my set area($path) $realm
		return 1
	    }
	}
	return 0
    }
    pwdManager proc encodeCredentials {authMethod realm} {
	#my showCall
	switch $authMethod {
	    basic  {set credential [my encodeCredentialsBasic $realm]}
	    digest {set credential [my encodeCredentialsDigest $realm]}
	}
	return $credential
    }
    pwdManager proc encodeCredentialsBasic {realm} {
	my instvar pwd user
	return [list Authorization \
		    "Basic [base64 encode $user($realm):$pwd($realm)]"]
    }
    pwdManager proc encodeCredentialsDigest {realm} {
	#my showCall
	package require tcu;        #FIXME: noch nicht in distribution
	my instvar digestResponseData
	my mkDigestResponseData $realm
	set digestResponse {}
	foreach {t v} [array get digestResponseData] {
	    append digestResponse " $t = \"$v\","
	}
	return [list Authorization "Digest [string trimright $digestResponse ,]"] 
    }
    pwdManager proc mkDigestResponseData {realm} {
	#my showCall
	my instvar pwd user digestResponseData requestUri
	# RFC 2617
	#   credentials      = "Digest" digest-response
	#   digest-response  = 1#( username | realm | nonce | digest-uri
	#                                | response | [ algorithm ] | [cnonce] |
	#                                [opaque] | [message-qop] |
	#                                    [nonce-count]  | [auth-param] )
	#   username         = "username" "=" username-value
	#   username-value   = quoted-string
	#   digest-uri       = "uri" "=" digest-uri-value
	#   digest-uri-value = request-uri   ; As specified by HTTP/1.1
	#   message-qop      = "qop" "=" qop-value
	#   cnonce           = "cnonce" "=" cnonce-value
	#   cnonce-value     = nonce-value
	#   nonce-count      = "nc" "=" nc-value
	#   nc-value         = 8LHEX
	#   response         = "response" "=" request-digest
	#   request-digest = <"> 32LHEX <">
	#   LHEX             =  "0" | "1"| ...| "e" | "f"  
	set digestResponseData(username) $user($realm)
	set digestResponseData(uri) $requestUri
	set digestResponseData(cnonce) "TEST"
	set digestResponseData(nc) 00000001
	set digestResponseData(response) [my mkRequestDigest]
	#parray digestResponseData
    }
    pwdManager proc mkRequestDigest {} {
	# returns a string of 32 hex digits, which proves that the user
	# knows a password
	
	#A1 = unq(username-value) ":" unq(realm-value) ":" passwd
	my instvar digestResponseData pwd requestMethod requestUri
	append A1 $digestResponseData(username)\
	    : $digestResponseData(realm) : $pwd($digestResponseData(realm))
	if {![my exists digestResponseData(qop)] || 
	    $digestResponseData(qop) eq "auth"} {
	    append A2 $requestMethod : $requestUri
	} elseif {$digestResponseData(qop) eq "auth-int"} {
	    #A2 = Method ":" digest-uri-value ":" H(entity-body)
	    append A2 $requestMethod : $requestUri: ""
	}
	if {[my exists digestResponseData(qop)]} {
	    append reqDigest $digestResponseData(nonce) : \
		$digestResponseData(nc) : \
		$digestResponseData(cnonce): \
		$digestResponseData(qop)
	    set reqDigest [md5 [md5 $A1]:$reqDigest:[md5 $A2]]
	} else {    
	    set reqDigest [md5 [md5 $A1]:$digestResponseData(nonce):[md5 $A2]]
	}  
	return $reqDigest 
    }

    pwdManager proc checkAvailableCredentials {url returnCredentials} {
	# we start a fresh request and check, whether we have sent for this url
	# (directory) already some credentials in an earlier reqhest.
	my instvar authMethod
	regexp {^(.*/)[^/]*$} $url _ path
	if {[my exists area($path)]} {
	    set realm [my set area($path)]
	    upvar [self callinglevel] $returnCredentials credentials
	    #my showMsg "*** adding credentials for realm=$realm and $path"
	    set credentials [my encodeCredentials $authMethod $realm]
	    return 1
	}
	return 0
    }
    pwdManager proc checkRequestedAuthentification {reqMethod path headerField 
						    typeVar realmVar} {
	# check for which realm with which authentification method the
	# server wants an authentification
	#my showCall
	upvar [self callinglevel] $typeVar type $realmVar realm
	my instvar authMethod digestResponseData requestUri requestMethod
	set requestUri $path
	set requestMethod $reqMethod
	if {[regexp {^Basic realm="(.*)"$} $headerField _ realm]} {
	    set type basic;#    FD: musste da lassen wg. call by reference
	    set authMethod $type
	    return 1
	} elseif {[regsub {^Digest } $headerField _ headerField]} {
	    set type digest ;# FD: musste da lassen wg. call by reference
	    set authMethod $type
	    foreach pair [split $headerField ,] {      
		if {[regexp {^(.*) *= *(".*")$} $pair _ n v]} {
		    set digestResponseData([string trim $n]) [string trim [string trim $v] \"]
		}
	    }
	    set realm $digestResponseData(realm)
	    return 1
	}
	return 0
    }

    #######################################################################
    # test classes
    Class Sink
    Sink instproc startCb         {r}   {
	my set contentLength 0
	next
    }
    Sink instproc notifyCb      {r}     {
	next
    }
    Sink instproc incCb         {r t c} {
	my set contentLength $t
	next
    }
    Sink instproc endCb         {r}     {
	next
	#showCall
    }
    Sink instproc cancelCb      {r}     {
	next
	#showCall
    }
    Sink instproc content       {}      {
	next
	#showCall
    }
    Sink instproc contentLength {}      {
	my set contentLength
	#showCall
    }


    Class TimeSink -superclass Sink
    TimeSink instproc startCb         {r}   {
	my set startTime [clock clicks]
	next
    }
    TimeSink instproc notifyCb      {r}     {
	my set notifyTime [clock clicks]
	next
    }
    TimeSink instproc endCb         {r}     {
	my set endTime [clock clicks]
	next
	my reportTimes
    }
    TimeSink instproc cancelCb      {r}     {
	my set endTime [clock clicks]
	next
    }
    TimeSink instproc reportTimes {}     {
	my instvar startTime endTime notifyTime
	set bytes [my contentLength]
	set grossSecs		[expr {($endTime-$startTime)/1000000.0}]
	set grossKbps		[expr {($bytes/1000.0)/$grossSecs}]
	set netSecs		[expr {($endTime-$notifyTime)/1000000.0}]
	set netKbps [expr {($bytes/1000.0)/$netSecs}]
	#if {[catch {set netKbps [expr {($bytes/1000.0)/$netSecs}]}]} {
	#  set netKbps 0
	#}
	set headSecs		[expr {$grossSecs-$netSecs}]
	foreach v {grossSecs grossKbps netSecs netKbps headSecs} {
	    set $v [format %.2f [set $v]]
	}
	my showMsg "got $bytes bytes in $grossSecs ($headSecs+$netSecs) seconds,\
	$grossKbps ($netKbps) KB/S"
    }


    Class ParallelSink -superclass Sink -parameter {
	{httpVersion 1.1}
	{sinkClass TimeSink}
	{maxsimultaneous 20}
    }
    ParallelSink instproc init args {
	next
	my set running 1
	my set numrequests 0
	my set sumbytes 0
	my set blocked {}
    }
    ParallelSink instproc startCb r {
	#my showCall
	my incr running
	my incr numrequests
	#puts stderr "... running++ [my set running]"
    }
    ParallelSink instproc endCb r {
	#my showCall
	my incr sumbytes [$r set currentsize]
	my done $r
    }
    ParallelSink instproc cancelCb r {
	#my showCall
	my done $r
    }
    ParallelSink instproc done r {
	#my showCall
	my instvar blocked
	$r shutdown
	my incr running -1
	#puts stderr "... running-- [my set running] [llength [Http info instances]]"
	#puts stderr [Http info instances]
	#foreach i [Http info instances] {puts stderr "\t$i: [$i set method] [$i set url]"}
	#puts stderr RUNNING=[my set running]
	if {[llength $blocked] > 0} {
	    set newreq [lindex $blocked 0]
	    set blocked [lrange $blocked 1 end]
	    my scheduleRequest [lindex $newreq 0] [lindex $newreq 1] [lindex $newreq 2]
	} elseif {[my set running] < 1} {
	    my set done 1
	}
    }


    ParallelSink instproc scheduleRequest {method url {parentUrl ""}} {
	my instvar requests blocked running maxsimultaneous
	if {$running > $maxsimultaneous} {
	    lappend blocked [list $method $url $parentUrl]
	} else {
	    set cmd [list Access createRequest -url $url \
			 -sinkClass [my sinkClass] \
			 -informObject [self] \
			 -method $method \
			 -timeout 25000 \
			 -caching 0 -allowJoin 0 -httpVersion [my httpVersion]]
	    if {$parentUrl ne ""} {
		lappend cmd -parentUrl $parentUrl
	    }
	    set r [eval $cmd]
	}
    }

    ParallelSink instproc requests {urls} {
	my showTimeStart
	foreach url $urls { my scheduleRequest GET $url }
	my wait
	my showTimeEnd
    }

    ParallelSink instproc wait {} {
	my instvar running
	if {$running > 0} {
	    set savedValue $running
	    #my showMsg ".......... waiting for initially $running requests"
	    if {[catch {my vwait done} err]} {
		my showMsg "vwait returned: $err "
	    }
	    #my showMsg "$savedValue requests FINISHED "
	}
    }

    Class MemorySink -superclass Sink
    MemorySink instproc incCb         {r t c} {
	my append d [$r block]
	next
    }
    MemorySink instproc content       {}      {
	return [my set d]
    }
    MemorySink instproc contentLength {}      {
	if {[my exists d]} {
	    return [string length [my set d]]
	} else {
	    return 0
	}
    }

    Class FileSink  -superclass Sink -parameter fileName
    ### write methods
    #FileSink instproc startCb         {r}   {
    #  next
    #}
    FileSink instproc notifyCb      {r}     {
	#my showVars
	next
	my instvar file fileName
	if {[info exists fileName]} {
	    set file [::open $fileName w]
	    fconfigure $file -translation binary
	} else {
	    # we have no filename; we assume the sink must be a dummy sink
	    # that deletgates its work to some other FileSink
	    my class ShadowFileSink
	    my notifyCb $r
	}
    }
    FileSink instproc incCb {r t c} {
	next
	if {[my exists file]} {
	    if {$r == "req0"} {
		puts stderr "*******************************************************"
		puts stderr [$r block]
		puts stderr "*******************************************************"
	    }
	    puts -nonewline [my set file] [$r block]
	}
    }
    FileSink instproc endCb  {r} {
	#my showCall
	next
	my close
    }
    FileSink instproc cancelCb  {r} {
	next
	my close
    }
    FileSink instproc close {} {
	if {[my exists file]} {
	    ::close [my set file]
	    my unset file
	}
    }
    ### read methods
    FileSink instproc content {} {
	next
	my instvar file fileName
	set file [::open $fileName r]
	fconfigure $file -translation binary
	set d [read [my set file]]
	my close
	return $d
    }
    FileSink instproc contentLength {}      {
	next
	if {[my exists fileName]} {
	    return [file size [my set fileName]]
	} else {
	    return 0
	}
    }


    Class ShadowFileSink -superclass Sink
    ShadowFileSink instproc notifyCb      {r} {
	next
	my set token $r
    }
    ShadowFileSink instproc content       {} {
	my instvar token
	next
	return [[$token set sink] content]
    }
    ShadowFileSink instproc contentLength {} {
	my instvar token
	next
	return [[$token set sink] contentLength]
    }


    Class CacheFileSink -superclass FileSink -parameter {{persistent 1}}
    CacheFileSink instproc notifyCb req {
	#my showCall
	if {![my exists fileName]} {
	    my instvar persistent
	    set url [$req set url]
	    my set fileName [persistentCache newEntry $url $req $persistent ""]
	}
	# it is important to execute next after setting the fileName...
	next
    }
    CacheFileSink instproc endCb req {
	#my showCall
	my instvar persistent
	next
	if {$persistent} {
	    persistentCache entryDone [$req set url]
	}
    }
    CacheFileSink instproc cancelCb req {
	next
	if {[my exists fileName]} {
	    file delete [my set fileName]
	    my unset fileName
	}
    }
    CacheFileSink instproc destroy {} {
	#my showCall
	if {[my exists fileName] && ![my set persistent]} {
	    #my showMsg "file delete $fileName"
	    file delete [my set fileName]
	    my unset fileName
	}
	next
    }


    #===========================================================

    Class SimpleRequest -parameter {
	{caching 0} 
	{useFileSink 0} 
	{blocking 1} 
	{timing 0} 
	url fileName 
	timeout httpVersion method headers data query contentType informObject
    }
    SimpleRequest instproc fileName x {
	my set fileName $x
	my set useFileSink 1
    }
    SimpleRequest instproc init args {
	my instvar useFileSink fileName sink caching token  
	#my showMsg "Starting Request"
	next
	if {[info exists fileName]} {
	    set sink [FileSink create [self]::sink -fileName $fileName]
	} elseif {$useFileSink || $caching > 0} {
	    set sink [FileSink create [self]::sink]
	} else {
	    set sink [MemorySink create [self]::sink]
	}
	#my showMsg "class of sink = [$sink info class]"
	if {[my set timing]} {
	    $sink mixin TimeSink
	}
	set cmd [list Access createRequest \
		     -url [my url] \
		     -informObject $sink \
		     -blocking [my blocking] \
		     -caching $caching]
	foreach optionalParameter {
	    timeout httpVersion method headers data query  
	    contentType informObject
	} {
	    if {[my exists $optionalParameter]} {
		lappend cmd -$optionalParameter [my set $optionalParameter]
	    }
	}
	#my showMsg "cmd=$cmd"
	set token [eval $cmd]
	#if {[my success]} {
	#  $sink reportTimes
	#  #puts stderr <[$sink content]>
	#}
    }
    SimpleRequest instproc success {} {
	if {[my exists token]} {
	    return [expr {[[my set token] set finished] == 1}]
	} 
	return 0
    }
    SimpleRequest instproc destroy {} {
	if {[my exists token]} {
	    [my set token] destroy
	}
	next
    }
    SimpleRequest instproc getContent {} {
	[my set sink] content
    }
    SimpleRequest instproc getContentLength {} {
	[my set sink] contentLength
    }
    #SimpleRequest instproc destroy args { next }

    #######################################################################

    namespace export \
	Access FileAccess File CacheAccess ReAccess \
	Cmd NetAccess Http Https Sink TimeSink \
	ParallelSink MemorySink FileSink \
	ShadowFileSink CacheFileSink SimpleRequest
}

namespace import ::xotcl::comm::httpAccess::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/comm/COPYRIGHT.

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
 *  XOTcl - Extended OTcl
 *
 *  Copyright (C) 1999-2008 Gustaf Neumann (a), Uwe Zdun (b)
 *
 * (a) Vienna University of Economics and Business Administration
 *     Dept. of Information Systems / New Media
 *     A-1090, Augasse 2-6
 *     Vienna, Austria
 *
 * (b) University of Essen
 *     Specification of Software Systems
 *     Altendorferstra▀e 97-101
 *     D-45143 Essen, Germany
 *     
 *  Permission to use, copy, modify, distribute, and sell this
 *  software and its documentation for any purpose is hereby granted
 *  without fee, provided that the above copyright notice appear in
 *  all copies and that both that copyright notice and this permission
 *  notice appear in supporting documentation. We make no
 *  representations about the suitability of this software for any
 *  purpose.  It is provided "as is" without express or implied
 *  warranty.
 *
 *
 *  This software is based upon MIT Object Tcl by David Wetherall and
 *  Christopher J. Lindblad, that contains the following copyright
 *  message:
 *
 *   "Copyright 1993 Massachusetts Institute of Technology
 *
 *    Permission to use, copy, modify, distribute, and sell this
 *    software and its documentation for any purpose is hereby granted
 *    without fee, provided that the above copyright notice appear in
 *    all copies and that both that copyright notice and this
 *    permission notice appear in supporting documentation, and that
 *    the name of M.I.T. not be used in advertising or publicity
 *    pertaining to distribution of the software without specific,
 *    written prior permission.  M.I.T. makes no representations about
 *    the suitability of this software for any purpose.  It is
 *    provided "as is" without express or implied warranty."

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































Deleted assets/xotcl1.6.7/comm/Connection.xotcl.

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
# -*- tcl -*- $Id: Connection.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::comm::connection 1.0

package require XOTcl

namespace eval ::xotcl::comm::connection {
    namespace import ::xotcl::*

    Class Connection -parameter {host port req socket handle}

    Connection proc make {r host port reuse reusedVar} {
	#my showCall
	my instvar openConnections
	upvar [self callinglevel] $reusedVar reused
	if {$reuse} {
	    set handle $host:$port-[$r set blocking]
	    #if {[array exists openConnections]} {parray openConnections}
	    if {![info exists openConnections($handle)]} {
		# there is no persistent connection, we create a new one
		set reused 0
		set openConnections($handle) \
		    [Connection new -host $host -port $port -req $r -handle $handle]
		#my showMsg "$openConnections($handle) CONNECTION add for $handle added"
	    } else {
		# there is a persistent connection
		set reused 1
		set c $openConnections($handle)
		$c instvar req
		#::puts stderr "$c CONNECTION reuse for $handle ($c) new req=$r"
		if {[info exists req]} {
		    # the persistent connection is active with some request $req
		    #::puts stderr "$c CONNECTION req $req already active"
		} else {
		    # the persistent connection is currently not active
		    $c set req $r
		}
	    }
	    return $openConnections($handle)
	} else {
	    set reused 0
	    return [Connection new -host $host -port $port -req $r]
	}
    }
    Connection proc removeHandle handle {
	#my showVars
	#puts stderr "***************** unsetting $handle ***************"
	if {[my exists openConnections($handle)]} {
	    my unset openConnections($handle)
	}
    }
    Connection instproc init args {  ;# the constructor creates the socket
	my set blocked {}
	next
	if {[my exists socket]} {
	    my set keepOpen 1
	} else {
	    my set keepOpen 0
	    if {[catch {my socket [socket -async [my host] [my port]]} msg]} {
		my set error $msg
		return
	    }
	}
	::fconfigure [my socket] -blocking false -buffersize 16384
    }
    #Connection instproc STATUS {ctx} {
    #  my instvar socket
    #  ::puts stderr "*** $ctx: $socket blocking=[::fconfigure $socket -blocking]"
    #}
    Connection instproc destroy {} { ;# the destructor closes the socket
	#my showCall
	if {[my exists handle]} {
	    #my showVars handle
	    # the connection was created via make
	    [self class] removeHandle [my handle]
	    #::puts stderr "my CONNECTION close and destroy [my handle]"
	} else {
	    #::puts stderr "my CONNECTION close and destroy"
	}
	# in cases of errors we might not have a socket yet
	if {[my exists socket]} {
	    close [my socket]
	}
	next
    }
    Connection instproc translation {translation} {
	#showCall
	::fconfigure [my socket] -translation $translation
    }    
    Connection instproc importSSL args {
	#my showCall
	package require tls
	eval tls::import [my socket] $args
    }
    Connection instproc fconfigure args {
	#my showCall
	eval ::fconfigure [my socket] $args
    }    
    Connection instproc event {type r method} {
	#my showCall
	my instvar req blocked
	# is the request in the argument list the currently active request?
	if {[info exists req] && $r == $req} {
	    # a request can overwrite its active request
	    if {$method eq ""} {
		::fileevent [my socket] $type ""
		#my showMsg "CONNECTION clear for [my socket]"
	    } else {
		#my showMsg "CONNECTION register for [my socket]"
		::fileevent [my socket] $type [list $r $method]
	    }
	} else {
	    #my showMsg "event BLOCKING current request=$req, new=$r $method"
	    #my showMsg "event BLOCKING rd=[::fileevent [my socket] readable]"
	    #my showMsg "event BLOCKING wr=[::fileevent [my socket] writable]"
	    #my showMsg "event BLOCKING bl=$blocked"
	    ::lappend blocked $r $type $method
	}
    }
    Connection instproc hold {} {
	my set continueCmd [list ::fileevent [my socket] readable \
				[::fileevent [my socket] readable]]
	::fileevent $socket readable {}
	#my showVars continueCmd
    }
    Connection instproc resume {} {
	#my showCall
	if {[my exists continueCmd]} {
	    eval [my set continueCmd]
	    my unset continueCmd
	}
    }

    Connection instproc puts {string} {
	#my showCall
	if {[catch {::puts [my socket] $string} msg]} {
	    ::puts stderr message=$msg
	}
    }
    Connection instproc puts-nonewline {string} {
	#my showCall
	if {[catch {::puts -nonewline [my socket] $string} msg]} {
	    ::puts stderr message=$msg
	}
    }
    Connection instproc gets {var} {
	#my showCall
	upvar [self callinglevel] $var result
	if {[catch {set n [::gets [my socket] result]} msg]} {
	    my set error $msg 
	    #my showMsg "CONNECTION error"
	    return 0
	}
	#my showMsg "n=$n, result=<$result>"
	return $n
    }
    Connection instproc read {} {
	#my showCall
	my instvar socket
	if {[catch {set result [::read $socket [::fconfigure $socket -buffersize]]} msg]} {
	    my set error $msg 
	    return ""
	}
	#my showMsg Done
	return $result
    }
    Connection instproc readSize {length} {
	if {[catch {set result [::read [my socket] $length]} msg]} {
	    my set error $msg 
	    return 0
	}
	return $result
    }
    Connection instproc flush {} {
	#my showCall
	if {[catch {::flush [my socket]} msg]} {
	    my set error $msg 
	}
    }
    Connection instproc eof {} {
	#my showCall
	if {[my exists error]} {
	    return 1
	} else {
	    return [::eof [my socket]]
	}
    }
    Connection instproc close {} {
	#my showCall
	my instvar req socket blocked
	if {![info exists socket]} return ;# error during connection open
	::fileevent $socket readable ""
	::fileevent $socket writable ""
	$req freeConnection
	if {[my exists persistent]} {
	    my flush
	    #::puts stderr "[self] PERSISTENT CONNECTION wanna close"
	    if {$blocked eq ""} {
		::fileevent $socket readable [list [self] destroy]
		unset req
	    } else {
		#my showVars blocked
		set req [lindex $blocked 0]
		set type [lindex $blocked 1]
		set method [lindex $blocked 2]
		set blocked [lrange $blocked 3 end]
		#my showMsg "in persistent connection unblock $type [list $req $method]"
		::fileevent $socket $type [list $req $method]
	    }
	} else {
	    #my showMsg "in nonpersistent connection blocked=$blocked"
	    if {$blocked ne ""} {
		set req [lindex $blocked 0]
		set type [lindex $blocked 1]
		set method [lindex $blocked 2]
		set nblocked [lrange $blocked 3 end]
		close $socket
		unset socket
		if {[my exists handle]} {
		    [self class] removeHandle [my handle]
		}
		if {[my exists error]} {
		    #my showMsg "UNSETTING ERROR -----------"
		    my unset error
		}
		my init
		set blocked $nblocked
		::fileevent $socket $type [list $req $method]
		#my showMsg "REANIMATE $socket $type [list $req $method]"
		#my showVars
	    } else {
		#my showMsg "Nothing blocked: readable=[::fileevent $socket readable]"

		my destroy
	    }
	}
    }
    Connection instproc makePersistent {p} {
	if {$p} {
	    my set persistent 1
	} else {
	    if {[my exists persistent]} {
		my unset persistent
		#my showMsg "no longer persistent"
	    }
	}
    }

    namespace export Connection
}

namespace import ::xotcl::comm::connection::*

if {[info command bgerror] eq ""} {
    proc bgerror {msg} { puts stderr "******* bgerror $msg $::errorInfo*****"}
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/comm/Dav.xotcl.

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
# $Id: Dav.xotcl,v 1.4 2006/02/18 22:17:33 neumann Exp $

package provide xotcl::comm::dav 0.9

package require XOTcl

namespace eval ::xotcl::comm::dav {
  package require xotcl::comm::httpAccess
  namespace import ::xotcl::*

  Class Dav -superclass Http
  Dav instproc initialize args {
    my instvar contentType 
    #showCall
    set contentType text/xml
    next
  }

  Dav instproc PROPFIND {} {
    #showCall
    # extra dav headers
    # Depth: ("0" | "1" | "infinity") [infinity is the default]
    
    # body is a propfind XML-Element
    # <!ELEMENT propfind (allprop | propname | prop) >
    #     <!ELEMENT allprop EMPTY >
    #     <!ELEMENT propname EMPTY >
    #     <!ELEMENT prop ANY>

    # this should be set by the clients
    #<?xml version="1.0" encoding="utf-8" ?>
    #             <D:propfind xmlns:D='DAV:'>
    #                  <D:allprop/>
    #             </D:propfind>
    my open
  }
  Dav instproc PROPPATCH {} {
    #showCall
    # body is a propertyupdate XML-Element
    # <!ELEMENT propertyupdate (remove | set)+ >
    #     <!ELEMENT remove (prop) >
    #     <!ELEMENT set (prop) >
    
    #   set xmlReqBody($method) "<?xml version=\"1.0\" encoding=\"utf-8\" ?>
    #             <D:propertyupdate xmlns:D=\"DAV:\">
    #                 <D:remove>
    #                    <D:prop> 
    #                        <D:displayname/>
    #                    </D:prop>                    
    #                  </D:remove>
    #             </D:propertyupdate>"
    my open
  }
  Dav instproc MKCOL {} {
    #showCall
    # invoked without a request body (may contain a message body?)
    my open
  }
  Dav instproc GET {} {
    #showCall
    # invoked without a request body and without extra header
    # back to HTTP class
    next
  }
  Dav instproc HEAD {} {
    #showCall
    # invoked without a request bodyand without extra header
    # back to HTTP class
    next
  }
  Dav instproc POST {} {
    #showCall
    # the same as in  RFC2068
    # back to HTTP class
    next
  }
  Dav instproc DELETE {} {
    #showCall
    # extra dav headers
    # Depth: ("0" | "1" | "infinity")

    # invoked without a request body
    my open
  }
  Dav instproc PUT {} {
    #showCall
    # PUT for Non-Collection Resources --> RFC2068
    # PUT for Collections --> MKCOL
    # next
  }
  Dav instproc COPY {} {
    #showCall
    # extra dav headers
    # If: [see 9.4 WebDAV]
    # Destination: <absolutURI> [see RFC2396 for the definition of absolutURI]
    # Depth: ("0" | "1" | "infinity")
    # Overwrite: ("T" | "F")
    

    # body is a propertybehavior XML-Element
    # <!ELEMENT propertybehavior (omit | keepalive) >
    #     <!ELEMENT omit EMPTY >
    #     <!ELEMENT keepalive (#PCDATA | href+) >
    #         <!ELEMENT href (#PCDATA) >
    my open
  }
  Dav instproc MOVE {} {
    #showCall
    # extra dav headers
    # If: [see 9.4 WebDAV]
    # Destination: <absolutURI> [see RFC2396 for the definition of absolutURI]
    # Depth: "infinity" [see 8.9.2]
    # Overwrite: ("T" | "F")

    # body is a propertybehavior XML-Element
    # see COPY
    my open
  }
  Dav instproc LOCK {} {
    #showCall
    # extra dav headers
    # If: [see 9.4 WebDAV]
    # Destination: <absolutURI> [see RFC2396 for the definition of absolutURI]
    # Depth: ("0" | "1" | "infinity")
    # Timeout: [see 9.8 WebDAV]
    # Authorization: (defined in HTTP1.1 in 14.8)

    # body is a lockinfo XML-Element
    # <!ELEMENT lockinfo (lockscope, locktype, owner?) >
    #    <!ELEMENT lockscope (exclusive | shared) >
    #        <!ELEMENT exclusive EMPTY >
    #        <!ELEMENT shared EMPTY >
    #    <!ELEMENT locktype (write) >
    #        <!ELEMENT write EMPTY >
    #    <!ELEMENT owner ANY>
    my open
  }

  # The Lock-Token request header is used with the UNLOCK method to
  # identify the lock to be removed.
  Dav instproc UNLOCK {} {
    my instvar headers 
    #showCall
    # extra dav headers
    # Lock-Token: <Coded-URL> [see 8.11 in WebDAV]

    # invoked without a request body
    my open
  }

  #---------------------
  # Utility            #
  #---------------------

  #?
  Object xmlReqBodyManager 
  xmlReqBodyManager proc requireXmlReqBody {request} {
  }

  #? 
  Object davHeaderManager 
  davHeaderManager proc requireDavHeader {request} {
  }



  #LOCK /DAV/welcome.html HTTP/1.1  
  #Host: wawog
  #Connection: close

  namespace export Dav \
      xmlReqBodyManager davHeaderManager 
}

namespace import ::xotcl::comm::dav::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































Deleted assets/xotcl1.6.7/comm/Ftp.xotcl.

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
# $Id: Ftp.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::comm::ftp 0.9
package require xotcl::comm::httpAccess

package require XOTcl

namespace eval ::xotcl::comm::ftp {
    namespace import ::xotcl::*

    Class Ftp -superclass NetAccess -parameter {user passwd}
    Ftp instproc initialize args {
	#my showCall
	my instvar port caching user passwd loginMsg resp blocksize
	set port 21
	set blocksize 1024
	set caching 0
	set user ftp
	set passwd cineast@
	set loginMsg {}
	set resp(connect)       {220 provideUser}
	set resp(provideUser)   {331 providePasswd}
	set resp(providePasswd) {230 loginFinished}
	set resp(loginFinished) {227 pasv}
	set resp(pasv)          {200 type}
	set resp(type-list)     {150 list}
	set resp(type-retr)     {150 retr 550 retry-retrieve}
	set resp(transfer)      {226 transferDone}
	next
    }
    Ftp instproc err {state reply} {
	my abort "Error in $state: $reply"
    }
    Ftp instproc queryServer {query state} {
	my instvar S
	puts $S $query
	flush $S
	fileevent $S readable [::list [self] response $state]
    }
    Ftp instproc response {state} {
	#my showCall
	my instvar S code msg
	set reply [gets $S]
	#my showVars reply
	if {[regexp {^([0-9]+)[-](.*)$} $reply _ code msg]} {
	    fileevent $S readable [::list [self] responseMulti $state]
	} else {
	    regexp {^([0-9]+) (.*)$} $reply _ code msg 
	    my responseEnd $state
	}
    }
    Ftp instproc responseMulti {state} {
	# multi line response
	my instvar S code msg 
	set m [gets $S]
	if {[regexp "^$code " $m]} { 
	    my responseEnd $state
	} else {
	    # try to strip code and dash
	    regexp "^$code-(.*)\$" $m _ m
	    append msg \n$m
	}
    }
    Ftp instproc responseEnd {state} {
	my instvar S code msg resp
	fileevent $S readable {}
	#puts stderr "code=$code, msg=<$msg>"
	foreach {c newState} $resp($state) {
	    if {$c == $code} { return [my $newState] }
	}
	my err $state "expected=$resp($state), got $code $msg"
    }
    Ftp instproc GET {} {
	my instvar S  host port url
	regexp {^(.*):([0-9]+)$} $host _ host port
	my running
	# rb running my $url ;# ???
	# proxy ?
	set S [socket -async $host $port]
	fconfigure $S -blocking false -translation {auto crlf}
	fileevent $S readable [::list [self] response connect]
    }
    Ftp instproc provideUser {} {
	my instvar user msg loginMsg
	set loginMsg $msg
	my queryServer "USER $user" provideUser
    }
    Ftp instproc providePasswd {} {
	my instvar passwd
	#  if {[pwdManager requirePasswd "Ftp $user\@$host" $user password]} {
	#    my queryServer "PASS $password" providePasswd
	#  }
	my queryServer "PASS $passwd" providePasswd
    }
    Ftp instproc loginFinished {} {  
	my instvar msg loginMsg
	append  loginMsg \n$msg
	my queryServer "PASV" loginFinished
    }
    Ftp instproc pasv {} {
	my instvar S D msg
	set d {([0-9]+)}
	if {[regexp "\[(]$d,$d,$d,$d,$d,$d" $msg _ 1 2 3 4 p1 p2]} {
	    if {[catch {set D [socket -async $1.$2.$3.$4 [expr {$p1*256 + $p2}]]} err
		]} {
		return [my err $proc $err] 
	    }
	    fconfigure $D -blocking no -translation binary
	} else {
	    return [my err $proc $msg] 
	}
	my queryServer "TYPE I" pasv
    }
    Ftp instproc type {} {
	my instvar path
	if {$path=={}} {
	    my queryServer "LIST" type-list
	} elseif {[regexp /$ $path]} { 
	    my queryServer "LIST $path" type-list
	} else {
	    my queryServer "RETR $path" type-retr
	}
    }
    Ftp instproc retry-retrieve {} {
	my instvar path url
	append url /
	my queryServer "LIST $path/" type-list
    }
    Ftp instproc list {} {
	my instvar S D contentType
	set contentType text/dirlist
	my headerDone
	fileevent $S readable [::list [self] response transfer]
	fileevent $D readable [::list [self] readData]
    }
    Ftp instproc read {} {
	# the method read is called by the more general method readData
	my instvar D block blocksize
	if {[::eof $D]} {
	    set block ""
	    close $D
	    unset D
	} else {
	    #puts stderr blocksize=$blocksize
	    set block [::read $D $blocksize]
	    #puts stderr read:[string length $block]bytes
	}
    }
    Ftp instproc transferDone {} {
	my instvar D S
	if {[info exists D]} {
	    fileevent $S readable {}
	    set block ""
	    close $D
	    unset D
	} 
	my finish
    }
    Ftp instproc retr {} {
	my instvar S D msg totalsize contentType path
	regexp {[(]([0-9]+)[ ]+[Bb]ytes} $msg _ totalsize
	set contentType [Mime guessContentType $path]
	my headerDone
	if {[info exists S]} {
	    # file dialog was not canceled
	    fileevent $S readable [::list [self] response transfer]
	    fileevent $D readable [::list [self] readData]
	    fconfigure $D -translation binary
	}
    }

    namespace export Ftp
}

namespace import ::xotcl::comm::ftp::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































Deleted assets/xotcl1.6.7/comm/Httpd.xotcl.

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
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
# -*- tcl -*- $Id: Httpd.xotcl,v 1.9 2007/08/14 16:38:26 neumann Exp $
#
# The XOTcl class Httpd implements an HTTP/1.0 and HTTP/1.1 server with  
# basic functionality.
#
#  Gustaf Neumann (neumann@wu-wien.ac.at)

set VERSION 1.1
package provide xotcl::comm::httpd $VERSION

package require XOTcl

#package require xotcl::comm::httpAccess

package require -exact xotcl::comm::connection 1.0
package require -exact xotcl::trace 0.91
package require -exact xotcl::comm::mime 0.9

namespace eval ::xotcl::comm::httpd {
  namespace import ::xotcl::*

  Class Httpd -parameter {
    {port 80} 
    ipaddr 
    {root ./} 
    {logdir $::xotcl::logdir} 
    {httpdWrk Httpd::Wrk}
    {redirects [list]}
    {workerTimeout 10000}
  }
  Httpd proc Date seconds {clock format $seconds -format {%a, %d %b %Y %T %Z}}
  Httpd instproc checkRoot {} {
    my instvar root
    set root [string trimright $root /]
    if {![file isdir $root]} {
      puts stderr "Warning: create root directory '$root'"
      file mkdir $root
    } 
    # make directory absolute
    set currentdir [pwd]
    cd $root
    set root [pwd]
    #puts stderr "[self] root=$root"
    cd $currentdir
  }

  proc ! string {
    set f [open [::xotcl::tmpdir]log w+]; 
    puts $f "[clock format [clock seconds]] $string"
    close $f}

  Httpd instproc init args {
    my instvar port logdir logfile redirects
    if {![my exists workerMixins]} {
      my set workerMixins {}
      #puts stderr "resetting workermixins of [self]"
    }
    next
    set proto [string trim [namespace tail [my info class]] :d]
    puts stderr "Starting XOTcl [string toupper $proto] server $::VERSION\
	[string tolower $proto]://[info hostname]:$port/"

    # Start a server by listening on the port
    if {[my exists ipaddr]} {set ip "-myaddr [my set ipaddr]"} {set ip ""}
    my set listen [eval [list socket -server [list [self] accept]] $ip $port]
    #my set listen [socket -server [list [self] accept] $port]

    my checkRoot
    if {![file isdir $logdir]} {file mkdir $logdir}
    set logfile [open $logdir/serverlog-$port a+]
    my array set requiresBody \
	{GET 0 HEAD 0 POST 1 PUT 1 DELETE 0 OPTIONS 0 TRACE 0}
  }
  Httpd instproc destroy {} {			# destructor
    catch {close [my set listen]}
    catch {close [my set logfile]}
    next
  }
  Httpd instproc accept {socket ipaddr port} {	# Accept a new connection and set up a handler
    #puts stderr "using workermixins of [self] {[my set workerMixins]}"

    [my set httpdWrk] new -childof [self] -socket $socket -ipaddr $ipaddr \
	-port $port -mixin [my set workerMixins]
  }
  Httpd instproc redirect list {
    foreach {pattern hostport} $list {
      my lappend redirects $pattern $hostport
    }
  }


  Class Httpd::Wrk -parameter {socket port ipaddr}
  Httpd::Wrk array set codes {
    200 {Data follows}          201 {Created}         204 {No Content}
    302 {Moved Temporarily}     304 {Not Modified}
    400 {Bad Request}           401 {Unauthorized}    402 {Payment Required}
    403 {Forbidden}             404 {Not Found}       405 {Method Not Allowed}
    406 {Not Acceptable}        408 {Request Timeout} 411 {Length Required}
    500 {Internal Server Error} 503 {Service Unavailable}  504 {Service Temporarily Unavailable}
  }
  Httpd::Wrk instproc formData {} {my set formData}
  Httpd::Wrk instproc init args {		# Constructor 
    my instvar socket port ipaddr
    my set formData [list]
    my set replyHeaderFields [list]
    next
    my makeConnection $socket
    my log Connect "$ipaddr $port"
    my connection translation {auto crlf}
    my connection event readable [self] firstLine
  }
  Httpd::Wrk instproc makeConnection {socket} {
    Connection create [self]::connection -socket $socket -req [self]
  }
  Httpd::Wrk instproc close {} {		# logical close of a single request
    #my showCall
    my instvar version timeout meta
    set eof [my connection eof]
    if {$version > 1.0 && !$eof} {
      #my showMsg "!EOF in http/$version"
      my connection flush
      set timeout [after [[my info parent] workerTimeout] [self] destroy]
      ### reset parameters, worker will be potentially reused
      if {[array exists meta]} {
	unset meta
	array set meta {}
      }
      unset version
      if {[my exists user]} {
	my unset user
	my unset realm
      }
      foreach c [my set formData] { $c destroy }
      my set replyHeaderFields [list]
      my set formData {}
      #my showVars
      my connection translation {auto crlf}
      my connection event readable [self] firstLine
    } elseif {$eof} {
      #my showMsg "Destroy in http/$version"
      # the client side has closed the connection
      my destroy
    } else {
      #my showMsg "!EOF in http/$version ???"
      # we close the conneciton actively (e.g. forced by an error)
      my connection flush
      #puts stderr "DESTROY----this line should never show up"
      my destroy
    }
  }
  Httpd::Wrk instproc destroy {} {
    #my showCall
    if {[my isobject [self]::connection]} {
      my connection close
    }
    next
  }
  Httpd::Wrk instproc freeConnection {} {
  }
  Httpd::Wrk instproc firstLine {} {	# Read the first line of the request
    #my showCall
    my instvar method resourceName hasFormData query fileName \
	version timeout 
    if {[info exists timeout]} {
      after cancel $timeout
      unset timeout
    }
    my lappend replyHeaderFields Date [Httpd Date [clock seconds]]
    set n [my connection gets firstLine]
    if {$n > 0} {
      #::puts stderr "[self] firstline=<$firstLine>"
      # parse request line, ignore HTTP version for now
      if {[regexp {^(POST|GET|PUT|HEAD|OPTIONS) ([^?]+)(\??)([^ ]*) *HTTP/(.*)$} \
	       $firstLine _ method resourceName hasFormData query version]} {
	set resourceName [string trimright [string trimleft $resourceName ./] " "]
	# construct filename
	[my info parent] instvar root
	set fileName $root/[url decodeName $resourceName]
	#puts stderr ---[encoding convertfrom utf-8 $fileName]----
	set fileName [encoding convertfrom utf-8 $fileName]
	#
	my decode-formData $query
	my log Query $firstLine
	if {[my exists forceVersion1.0]} {
	  set version 1.0
	}
	my connection makePersistent [expr {$version > 1.0}]
	my connection event readable [self] header
      } else {
	set version 1.0
	set resourceName ???
	set method ???
	my log Error "bad first line:$firstLine"
	my replyCode 400
	my replyErrorMsg
      }
    } elseif {![my connection eof]} {
      #my showMsg "+++ not completed EOF=[my connection eof]"
    } else {
      set version 1.0
      #my showMsg "+++ n=negative ($n) EOF=[my connection eof] version set to 1.0"
      my close
    }
  }
  Httpd::Wrk instproc header {} {			# Read the header
    #my showCall
    my instvar method data
    if {[my connection gets line] > 0} {
      #puts stderr line=$line
      if {[regexp -nocase {^([^:]+): *(.+)$} $line _ key value]} {
	my set meta([string tolower $key]) $value
      }
    } else {
      #puts stderr line-EMPTY
      if {[my exists meta(content-length)] && [my set meta(content-length)]>0} {
	#puts stderr "we have content-length [my set meta(content-length)]"
	set data ""
	my connection translation binary
	my connection event readable [self] receive-body
      } elseif {[my exists meta(content-type)] &&
		[regexp -nocase {multipart/form-data; *boundary=} \
		     [my set meta(content-type)]]} {
	#puts stderr "formdata"
	set data ""
	my connection event readable [self] receive-body
      } else {
	#puts stderr "no-content-length, triggering respond"
	my connection event readable [self] ""
	[my info parent] instvar requiresBody
	if {$requiresBody($method)} {
	  my replyCode 411
	  my replyErrorMsg
	} else {
	  my check-redirect
	}
      }
    }
  }
  Httpd::Wrk instproc receive-body {} {	;# ... now we have to read the body
    #my showCall
    my instvar method data meta
    set d [my connection read]
    if {$d ne ""} {
      append data $d
      #my showMsg "datal=[string length $data], cl=$meta(content-length)"
      if {[string length $data] >= $meta(content-length)} {
	my connection event readable [self] ""
	if {$method eq "POST"} { my decode-POST-query  }
	my check-redirect
      }
    } else {   ;# 0 byte, must be eof...
      my showMsg "received 0 bytes"
      my connection event readable [self] ""
      if {[string length $data] < $meta(content-length)} {
	my replyCode 404
	my replyErrorMsg
      } else {
	my check-redirect
      }
    }
  }
  Httpd::Wrk instproc unmodified mtime {
    my instvar meta
    if {[info exists meta(if-modified-since)]} {
      set ms $meta(if-modified-since)
      regexp {^([^;]+);(.*)$} $ms _ ms options
      if {[catch {set mss [clock scan $ms]}]} {
	regsub -all -- {-} $ms " " ms
	if {[catch {set mss [clock scan $ms]}]} {
	  set ms [lreplace $ms end end]
	  set mss [clock scan $ms]
	}
      }
      return [expr {$mtime <= $mss}]
    }
    return 0
  }
  Httpd::Wrk instproc check-redirect {} {	
    [my info parent] instvar redirects
    my instvar resourceName hasFormData query
    set resource $resourceName$hasFormData$query
    foreach {pattern hostport} $redirects {
      #puts stderr "match <$pattern> <$resource> [regexp $pattern $resource]"
      if {[regexp $pattern $resource]} {
	#puts stderr "do redirect to $hostport/$resource"
	my replyCode 302 location $hostport/$resource
	my replyErrorMsg
	return
      }
    }
    my respond
  }
  Httpd::Wrk instproc respond {} {			# Respond to the query
    # the request was read completely...   This method is wellsuited for mixins!
    my respond-[my set method]
  }

  Httpd::Wrk instproc respond-GET {} {
    #my showCall
    my instvar fileName
    my sendFile $fileName
  }
  Httpd::Wrk instproc respond-HEAD {} {			# Respond to the query
    my instvar fileName
    if {[file readable $fileName]} {
      my replyCode 200 \
	  Last-Modified [Httpd Date [file mtime $fileName]] \
	  Content-Type [Mime guessContentType $fileName] \
	  Content-Length [file size $fileName]
      my connection puts ""
      #my log Done "$fileName [Mime guessContentType $fileName]"
      my close
    } else {
      my replyCode 404
      my replyErrorMsg
    }
  }
  Httpd::Wrk instproc respond-OPTIONS {} {			# Respond to the query
    my replyCode 200 \
	Allow "OPTIONS, GET, HEAD, POST" \
	Public "OPTIONS, GET, HEAD, POST"
    my connection puts ""
    my close
  }
  Httpd::Wrk instproc respond-PUT {} {
    my instvar data method fileName
    my replyCode [expr {[file writable $fileName] ? 200 : 201}]
    my connection puts ""
    set out [open $fileName w]
    fconfigure $out -translation binary
    puts -nonewline $out $data
    my log Done "$fileName [Mime guessContentType $fileName]"
    close $out
    my close
  }
  Httpd::Wrk instproc respond-CGI {} {
    my instvar fileName
    if {[file executable $fileName]} {
      my replyCode 200
      my connection puts [exec $fileName]      ;# no parameter handling yet
      my close
    } else {
      my replyCode 403
      my replyErrorMsg
    }
  }
  Httpd::Wrk instproc new-formData {} {
    set arg [Object create [self]::[my autoname formData]]
    my lappend formData $arg
    return $arg
  }
  Httpd::Wrk instproc decode-formData {query} {
    #my showCall
    foreach pair [split [string trimleft $query \n] &] {
      set arg [my new-formData]
      if {[regexp {^(.+)=(.*)$} $pair _ name content]} {
	$arg set name [url decodeItem $name]
	$arg set content [url decodeItem $content]
      } else {
	$arg set content [url decodeItem $pair]
      }
    }
  }
  Httpd::Wrk instproc decode-POST-query {} {
    if {[my exists meta(content-type)]} {
      set ct [my set meta(content-type)]
      if {[regexp -nocase {application/x-www-form-urlencoded} $ct]} {
	#my showMsg "ordinary FORM"
	my decode-formData [my set data]
	return
      } elseif {[regexp -nocase {multipart/form-data; *boundary=(.*)$} $ct \
		     _ boundary]} {
	#my showMsg "multipart FORM"
	set parts [my set data]
	set bl [expr {[string length $boundary]+2}]
	while {[set endIDX [string first --$boundary $parts]] > -1} {
	  set part [string range $parts $bl [expr {$endIDX-1}]]
	  if {[set endHD [string first \r\n\r\n $part]] > -1} {
	    set arg [my new-formData]
	    if {[catch {Mime multipart-decode-header \
			    [string range $part 0 [expr {$endHD-1}]] \
			    $arg} msg]} {
	      my replyCode 406
	      my replyErrorMsg $msg
	      return 0
	    }
	    $arg set content [string range $part \
				  [expr {$endHD + 4}] \
				  [expr {[string length $part] -3}]]
	    #$arg showVars
	  }
	  set parts [string range $parts [expr {$endIDX+2}] end]
	}
      }
    }
  }
  Httpd::Wrk instproc respond-POST {} {
    my replyCode 405
    my replyErrorMsg
    #my respond-CGI
  }

  Httpd::Wrk instproc replyErrorMsg {{msg ""} args} {
    my instvar replyCode
    [self class] instvar codes
    foreach {tag value} $args {my connection puts "$tag: $value"}
    my sendText "\n<HTML><title>Status Code: $replyCode</title>\n\
      <BODY>$msg<p>\n\
      Status Code $replyCode: <b>$codes($replyCode)</b><br>\n\
      Resource Name: [my set resourceName]</BODY></HTML>\n"
    my close  ;# close must be last call
  }
  Httpd::Wrk instproc replyCode {code args} {
    #my showCall
    my instvar version
    [self class] instvar codes
    my set replyCode $code
    my connection puts "HTTP/$version $code $codes($code)"
    foreach {tag value} [my set replyHeaderFields] {my connection puts "$tag: $value"}
    foreach {tag value} $args {my connection puts "$tag: $value"}
    if {$code >= 400} {
      my log Error "$code $codes($code)\tmeta: [my array get meta]"
    }  else {
      my log Done "$code $codes($code)"
    }
  }
  Httpd::Wrk instproc sendText {response {type text/html}} {
    #my showCall
    my connection puts "Content-Type: $type"
    # bei einer leeren Responses blockieren Klienten und melden Fehler
    if {$response eq ""} { set response " " }
    my connection puts "Content-Length: [string length $response]\n"
    if {[my set method] ne "HEAD"} {
      my connection fconfigure -translation {auto binary}
      my connection puts-nonewline $response
    } else {
      my showMsg HEAD!
    }
  }
  Httpd::Wrk instproc sendMsg {response {type text/html}} {
    # my showCall
    my replyCode 200
    my sendText $response $type 
    my close
  }
  Httpd::Wrk instproc sendDir {dirName} {
    [my info parent] instvar root
    set title "Directory listing"
    set reply "<HTML><TITLE>$title</TITLE><BODY><H1>$title</H1>\n<TABLE>\n"
    set oldpwd [pwd]
    cd $root
    set dirs ""; set files ""
    foreach f [lsort -dictionary [glob -nocomplain ./$dirName/*]] {
      set full [file join $root $f]
      set pname [string trimleft $f ./]
      if {[file isdir $full]} {
	append pname /
      }
      if {![catch {set size [file size $full]}]} {
	# it is not a broken link
	set entry ""
	append entry <tr> \
	    <td> "<A href='/$pname'>$pname</a>"    </td> \
	    "<td align='right'>" $size </td> \
	    "<td align='right'>" [clock format [file mtime $full]] </td> \
	    </tr>\n
	if {[string match */ $pname]} {append dirs $entry} else {append files $entry}
      }
    }
    append reply $dirs $files "</TABLE></HTML>\n"
    cd $oldpwd
    my sendMsg $reply
    return
  }

  Httpd::Wrk instproc sendFile {fn {type ""}} {
    #my showCall
    if {[file isdirectory $fn]} {
      set full [file join $fn index.html]
      if {[file readable $full]} {
	set fn $full
      } else {
	my sendDir [my set resourceName]
	return
      }
    }
    #puts stderr "readable '$fn' [file readable $fn]"
    if {[file readable $fn]} {
      set mtime [file mtime $fn]
      if {[my unmodified $mtime]} { 
	my replyCode 304
	my replyErrorMsg
	return 
      }
      if {$type eq ""} {set type [Mime guessContentType $fn]}
      my replyCode 200 \
	  Last-Modified [Httpd Date $mtime] \
	  Content-Type $type \
	  Content-Length [file size $fn]
      my connection puts ""
      my connection fconfigure -translation binary ;#-buffersize 65536
      set localFile [open $fn]
      fconfigure $localFile -translation binary -buffersize 65536
      fcopy $localFile [my connection set socket] \
	  -command [list [self] fcopy-end $localFile]
    } else {
      my replyCode 404
      my replyErrorMsg
    }
  }
  Httpd::Wrk instproc fcopy-end {localFile args} {	# End of fcopy
    close $localFile
    my connection fconfigure -blocking false ;# fconfigure changes blocking in 8.3.2!
    my close
  }
  Httpd::Wrk instproc log {reason arg} {			# trivial logging
    my instvar port ipaddr
    if {[my exists user]} {
      set user [my set user]/[my set realm]
    } {set user -}
    [my info parent] instvar logfile
    puts $logfile "[clock format [clock seconds]] $user $ipaddr:$port\t$reason\t$arg"
    flush $logfile
  }


  #########################################################################
  Class Httpsd -superclass Httpd -parameter {
    {port 443}
    {httpdWrk Httpsd::Wrk}
    {requestCert 0}
    {requireValidCert 0}
    {certfile filename.crt}
    {keyfile filename.key}
    {cafile cacert.pem}
    {infoCb {}}
  }
  Httpsd instproc init args {
    package require tls
    proc tls::password {} {
      puts stderr "getting passwd"
      return pemp
    }
    next
  }

  Class Httpsd::Wrk -superclass Httpd::Wrk
  Httpsd::Wrk instproc firstLine {} {
    my set forceVersion1.0 1
    my lappend replyHeaderFields Connection close
    next
  }
  Httpsd::Wrk instproc makeConnection {socket} {
    Connection create [self]::connection -socket $socket -req [self]
    [my info parent] instvar \
	keyfile certfile cafile infoCb requestCert requireValidCert
    # SSL-enable a regular Tcl channel - it need not be a socket, but
    # must provide bi-directional flow. Also setting session parameters
    # for SSL handshake. www.sensus.org/tcl/tls.htm
    
    # -request bool --> Request a certificate from peer during SSL
    # handshake. (default: true)
    
    # -require bool --> Require a valid certificate from peer during SSL
    # handshake. If this is set to true then -request must also be set
    # to true. (default: false)
    
    # -server bool --> Handshake as server if true, else handshake as
    # client.(default: false)
    my connection importSSL -server 1 \
	-certfile  $certfile \
	-keyfile  $keyfile \
	-cafile    $cafile \
	-request   $requestCert \
	-require   $requireValidCert \
	-command   $infoCb
  }
  #########################################################################



  ###
  ### Mixin-Classes for respond patterns
  ### mixes into Http and Httpd::Wrk 
  ###
  Class Httpd::Responder
  Httpd::Responder instproc init args {
    next
    my lappend workerMixins Httpd::Responder::Wrk
    my set respondpatterns {}
    # Example how to register new methods: regexp is matched with the triple
    # (HTTP-METHOD URL HASFORMDATA) where HASFORMDATA is empty when no
    # parameters are given. The parsed components of the url etc. are
    # available as instvars
    my actions {^GET cgi[-]bin [?]} respond-CGI
  }
  Httpd::Responder instproc actions {regexp method} {
    my lappend respondpatterns $regexp $method
  }
  Class Httpd::Responder::Wrk
  Httpd::Responder::Wrk instproc respond {} {
    my instvar fileName method resourceName hasFormData
    [my info parent] instvar respondpatterns
    ### auch das ist ein kandidat fuer eine chain of responsibility
    foreach {pattern action} $respondpatterns {
      if {[regexp $pattern "$method $resourceName $hasFormData"]} {
	my $action
	return
      }
    }
    next
  }

  ###
  ### Mixin-Classes for Access Control
  ### mixes into Http and Httpd::Wrk
  ###
  Class Httpd::AccessControl
  Httpd::AccessControl abstract instproc protectedResource {fn method varAuthMethod varRealm}
  Httpd::AccessControl abstract instproc credentialsNotOk {wrk credentials authMethod realm}
  Httpd::AccessControl abstract instproc addRealmFile {realm authFile}
  Httpd::AccessControl abstract instproc addRealmEntry {realm passwds}
  Httpd::AccessControl abstract instproc protectDir {realm path methods}

  Class Httpd::AccessControl::Wrk
  Httpd::AccessControl::Wrk instproc respond {} {
    my instvar fileName method digestChallengeData
    set controller [my info parent]
    if {[$controller protectedResource $fileName $method authMethod realm]} {
      #my showMsg "*** Protected resource: $fileName $method"
      if {![my exists meta(authorization)] ||
	  [$controller credentialsNotOk [self] \
	       [my set meta(authorization)] $authMethod $realm]} {
	my unauthorizedAccess $realm
	return
      }
    }
    next
  }

  ###########################################################################
  ## Basic Access Control
  ###########################################################################
  Class Httpd::BasicAccessControl -superclass Httpd::AccessControl

  Httpd::BasicAccessControl instproc initWorkerMixins {} {
    my lappend workerMixins [self class]::Wrk
  }

  Httpd::BasicAccessControl instproc init args {
    next
    my initWorkerMixins
  }

  Httpd::BasicAccessControl instproc protectedResource {fn method varAuthMethod varRealm} {
    #my showCall
    # check whether access to $fn via $method is protected
    upvar [self callinglevel] $varAuthMethod authMethod $varRealm realm
    # we check only the current directory, not the parent directories
    if {[string match */ $fn]} {
      set path $fn
    } else {
      set path [file dirname $fn]/
    } 
    foreach i [list $path $path:$method] {
      if {[my exists protected($i)]} {
	set realm [my set protected($i)]
	set authMethod Basic
	return 1
      }
    }
    return 0
  }

  Httpd::BasicAccessControl instproc credentialsNotOk {wrk credentials authMethod realm} {
    # check whether $credentials are sufficient for $realm
    regexp {^(.*):(.*)$} [base64 decode [lindex $credentials 1]] _ user pwd
    #puts stderr "passwd($realm:$user)=[my exists passwd($realm:$user)]"
    $wrk set user $user
    $wrk set realm $realm
    if {[my exists passwd($realm:$user)]} {
      return [expr {[my set passwd($realm:$user)] != $pwd}]
    }
    return 1
  }

  Httpd::BasicAccessControl instproc addRealmEntry {realm passwds} {
    if {[llength $passwds] == 1} {
      my addRealmFile [lindex $passwds 0]
    } else {
      foreach {name pwd} $passwds {
	#puts stderr "realm='$realm' adding user: $name pw: $pwd"
	my set passwd($realm:$name) $pwd
      }
    }
  }
  Httpd::BasicAccessControl instproc addRealmFile {realm authFile} {
    set FILE [open $authFile r]
    while {![eof $FILE]} {
      foreach {name pwd} [split [gets $FILE] :] {
	my addRealmEntry $realm [list $name $pwd]
      }
    }
    close $FILE
  }

  Httpd::BasicAccessControl instproc protectDir {realm path methods} {
    my instvar root
    my checkRoot
    set resource $root/$path      ;# resources are currently directories
    if {$methods == {}} {
      my set protected($resource) $realm       ;#for every method
    } else {
      foreach m $methods {
	my set protected($resource:$m) $realm  ;#for selected methods
      }
    }
  }
  Class Httpd::BasicAccessControl::Wrk -superclass Httpd::AccessControl::Wrk
  Httpd::BasicAccessControl::Wrk instproc unauthorizedAccess {realm} {
    my set digestChallengeData(realm) $realm
    my replyCode 401 www-authenticate "Basic realm=\"$realm\""
    my replyErrorMsg "Unauthorized request for realm '$realm'" 
  }



  ###########################################################################
  ## Digest Access Control
  ###########################################################################
  Class Httpd::DigestAccessControl -superclass Httpd::BasicAccessControl
  Httpd::DigestAccessControl instproc init args {
    package require tcu
    next
    my lappend workerMixins [self class]::Wrk
  }
  Httpd::DigestAccessControl instproc credentialsNotOk {wrk credentials authMethod realm} {
    # check whether $credentials are sufficient for $realm
    my showMsg "Digest Authentication ..."
    # HELP FD: hier muss ich noch ├╝berpr├╝fen, ob die digest-header
    # (credentials) ok sind. Hier habe ich probleme auf die sachen,
    # die der worker gesendet (bspw. nonce) hat zu kommen. Ich
    # wei├č, man kann mit [my info children] daran kommen. Aber,
    # was ist, wenn man mehrere Worker hat?

    ## Fredj, das sollte kein Problem sein: das credentialsNotOk wird
    ## vom aktuellen worker (respond) aufgerufen. man kann dem *NotOk
    ## den worker mitgeben, oder die beiden Methoden etwas umorganisieren.
    return
  }
  Class Httpd::DigestAccessControl::Wrk -superclass Httpd::BasicAccessControl::Wrk
  Httpd::DigestAccessControl::Wrk instproc unauthorizedAccess {realm} {
    my set digestChallengeData(realm) $realm
    my replyCode 401 www-authenticate "Digest [my digestChallenge]"
    my replyErrorMsg "Unauthorized request for realm '$realm'"
  }
  Httpd::DigestAccessControl::Wrk instproc digestChallenge {} {
    my showCall
    my instvar digestChallengeData
    my mkDigestChallengeData
    set digestResponse {}
    foreach {t v} [array get digestChallengeData] {
      append digestResponse "$t = \"$v\", "
    }
    regsub {, $} $digestResponse {} digestResponse
    return $digestResponse
  }
  Httpd::DigestAccessControl::Wrk instproc mkDigestChallengeData {} {
    my showCall
    my instvar digestChallengeData

    # RFC 2617
    #   challenge         =  "Digest" digest-challenge
    #   digest-challenge  = 1#( realm | [ domain ] | nonce |
    #                       [ opaque ] |[ stale ] | [ algorithm ] |
    #                       [ qop-options ] | [auth-param] )
    #   domain            = "domain" "=" <"> URI ( 1*SP URI ) <">
    #   URI               = absoluteURI | abs_path
    #   nonce             = "nonce" "=" nonce-value
    #   nonce-value       = quoted-string
    #   opaque            = "opaque" "=" quoted-string
    #   stale             = "stale" "=" ( "true" | "false" )
    #   algorithm         = "algorithm" "=" ( "MD5" | "MD5-sess" | token )
    #   qop-options       = "qop" "=" <"> 1#qop-value <">
    #   qop-value         = "auth" | "auth-int" | token

    # FD: hier w├╝rde man die n├Âtigen parametern (nonce,domain,opaque,
    # etc.) berechnen und in dem asso. Array speichern.
    # FD: minimale Anforderung
    set digestChallengeData(nonce)  [my genNonce]
    set digestChallengeData(opaque) [base64 encode [self]:my-self-spcified-string]
    set digestChallengeData(algorithm) "MD5" ;#default
    set digestChallengeData(qop) "auth"
    set digestChallengeData(domain) [array names [my info parent]::protected]
  }

  Httpd::DigestAccessControl::Wrk instproc genNonce {} {
    my showCall
    my instvar digestChallengeData
    set timeStamp [clock seconds]
    set nonce [base64 encode [md5 $timeStamp:[self]]]
    return $nonce
  }


  #
  # example usage:

  #Httpd h1 -port 8081 -root [glob ~/wafe]
  #Httpd h2 -port 9086 -root $root \
      -mixin {Httpd::Responder Httdp::BasicAccessControl} \
      -addRealmEntry test {test test} -protectDir test "" {} \
      -redirect {^(mailman|pipermail|cgi-bin) http://alice.wu-wien.ac.at:80}


  namespace export Httpd Httpsd 
  namespace eval Httpd               {
    namespace export Wrk \
	AccessControl BasicAccessControl DigestAccessControl \
	Responder
  }
  namespace eval Httpsd              {
    namespace export Wrk
  }
  #namespace eval Responder           {namespace export Wrk}
  #namespace eval AccessControl       {namespace export Wrk}
  #namespace eval BasicAccessControl  {namespace export Wrk}
  #namespace eval DigestAccessControl {namespace export Wrk}
}

namespace import ::xotcl::comm::httpd::*
namespace eval Httpd               {namespace import ::xotcl::comm::httpd::Httpd::*}
namespace eval Httpsd              {namespace import ::xotcl::comm::httpd::Httpsd::*}
#namespace eval Responder           {namespace import ::xotcl::comm::httpd::Responder::*}
#namespace eval AccessControl       {namespace import ::xotcl::comm::httpd::AccessControl::*}
#namespace eval BasicAccessControl  {namespace import ::xotcl::comm::httpd::BasicAccessControl::*}
#namespace eval DigestAccessControl {namespace import ::xotcl::comm::httpd::DigestAccessControl::*}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/comm/Imap.xotcl.

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
# $Id: Imap.xotcl,v 1.4 2006/02/18 22:17:33 neumann Exp $

package provide xotcl::comm::imap 0.9

package require XOTcl

namespace eval ::xotcl::comm::imap {
  package require xotcl::comm::httpAccess
  namespace import ::xotcl::*

  Class Imap -superclass NetAccess -parameter {user}
  Imap instproc initialize args {
    my instvar port caching tokenCounter resp token
    set port 143
    set caching 1
    set resp(connect)       {"[*] OK" login}
    set resp(login)         {"A[0-9]+ OK" loginFinished  "A[0-9]+ NO" login}
    set resp(loginFinished) {"[*] [0-9]+" inboxSize "[*] OK" inboxSelected}
    set resp(mailSelected)  {"[*] [0-9]+ FETCH" fetchBody 
      "A[0-9]+ OK " ignoreLine
      "[*] " ignoreLine}
    set resp(heads)         {"[*] [0-9]+ FETCH" fetchHeaders 
      "A[0-9]+ OK " ignoreLine
      "[*] " ignoreLine}
    set tokenCounter 0
    next
    set token NONE
  }
  Imap instproc err {state reply} {
    my abort "Error in $state: $reply"
  }
  Imap instproc token {} {
    my instvar tokenCounter
    return [format {A%.4d} [incr tokenCounter]]
  }
  Imap instproc imapString {input} {
    regsub -all {(["\])} $input {\\\1} output ;#"
		   return \"$output\"
		 }
		  Imap instproc queryServer {query state} {
		    #my showCall
		    my instvar S token
		    set token [my token]
		    puts $S "$token $query"
		    #puts stderr "$token $query"
		    flush $S
		    fileevent $S readable [list [self] response $state]
		  }
		  Imap instproc response {state} {
		    my instvar S resp msg token
		    set msg [gets $S]
		    #my showVars msg token
		    foreach {c newState} $resp($state) {
		      if {![regexp {^[*]} $msg] && ![regexp ^$token $msg]} {
			my showMsg "$state: token=$token IGNORING $msg"
			return
		      }
		      if {[regexp ^$c $msg]} {
			#my showMsg "$state NEWSTATE $newState"
			return [my $newState] 
		      }
		    }
		    my err $state "expected=$resp($state), got $msg"
		  }
		  Imap instproc GET {} {
		    my instvar state S path host port user inbox mailNr
		    # number at end of path is the message number in the mailbox
		    if {[regexp {^([^/]+)/([^/]+)/([0-9]+)$} $path _ user inbox mailNr]} {
		    } elseif {[regexp {^([^/]+)/([^/]+)/?$} $path _ user inbox]} {
		    } else {
		      my abort "invalid imap path $path"
		    }
		    regexp {^(.*):([0-9]+)$} $host _ host port
		    # proxy ?
		    if {[catch {set S [socket -async $host $port]} err]} {
		      my abort "Could not open connection to host '$host:$port'\n    $err"
		    } else {
		      fconfigure $S -blocking false 
		      fileevent $S readable [list [self] response connect]
		    }
		  }
		  Imap instproc login {} {
		    my instvar user host password
		    if {[pwdManager requirePasswd "Imap $user\@$host" $user password]} {
		      my queryServer "login $user [my imapString $password]" login
		    } else {
		      what now?
		    }
		  }
		  Imap instproc loginFinished {} {
		    my instvar user host password inbox
		    pwdManager storePasswd "Imap $user\@$host" $user $password
		    my queryServer "select $inbox" loginFinished
		  }
		  Imap instproc inboxSize {} {
		    my instvar msg nrMails
		    regexp {^[*] ([0-9]+) EXISTS} $msg _ nrMails
		  }
		  Imap instproc inboxSelected {} {
		    my instvar msg contentType nrMails mailNr
		    if {[info exists mailNr]} {
		      set contentType text/plain
		      my body-state
		      my queryServer "fetch $mailNr rfc822" mailSelected
		    } else {
		      my instvar header inbox block host user block
		      set contentType text/html
		      my body-state
		      set what "Mailbox $inbox of $user@$host"
		      set block "<HTML><HEAD><TITLE>$what</TITLE></HEAD>\n"
		      append block "<BODY><H1>$what</H1>\n" \
			  "The following <i>$nrMails</i> messages are in this mailbox:" \
			  "<p>\n<UL>\n"
		      my pushBlock
		      catch {unset header}
		      set mailNr $nrMails
		      my queryServer "fetch $nrMails body\[header\]" heads
		    }
		  }
		  Imap instproc ignoreLine {} {;}
		  Imap instproc fetchBody {} {
		    my instvar S
		    fileevent $S readable [list [self] bodyContent]
		  }
		  Imap instproc bodyContent {} {
		    my instvar S block msg
		    set msg [gets $S]
		    if {$msg == ")"} {
		      my set state 4
		      my finish
		    } else {
		      set block $msg\n
		      my pushBlock
		    }
		  }
		  Imap instproc fetchHeaders {} {
		    my instvar S
		    fileevent $S readable [list [self] headContent]
		  }
		  Imap instproc headContent {} {
		    my instvar S token header nrMails mailNr block host user inbox
		    set msg [gets $S]
		    if {[regexp -nocase {^([^:]+): *(.+)$} $msg _ key value]} {
		      set key [string tolower $key]
		      set header($mailNr,$key) $value
		    } elseif {$msg == ")"} {
		      # mail header finished
		      set block "<LI> Message $mailNr from $header($mailNr,date)<br>\ 
	<A HREF=\"imap://$host/$user/$inbox/$mailNr\">"
		      if {[catch {set from $header($mailNr,from)}]} {
			if {[catch {set from $header($mailNr,sender)}]} {	set from UNKNOWN }
		      }
		      if {[regexp {[(](.*)[)]} $from _ x]} { 
		      } elseif {[regexp {[<](.*)[>]} $from _ x]} { 
		      } else  { set x $from }
		      append block $x ": "
		      if {[info exists header($mailNr,subject)]} { append block $header($mailNr,subject) }
		      append block </A><P>
		      my pushBlock
		      if {$mailNr > 1} {
			incr mailNr -1
			my queryServer "fetch $mailNr body\[header\]" heads
		      } else {
			set block "</UL></BODY></HTML>\n"
			my pushBlock
			my set state 4
			my finish
		      }
		    }
		  }

		  namespace export Imap
		}

      namespace import ::xotcl::comm::imap::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































Deleted assets/xotcl1.6.7/comm/Ldap.xotcl.

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
package provide xotcl::comm::ldap 0.9

package require xotcl::wafecompat ; # Get 'requireModules'.

package require XOTcl

namespace eval ::xotcl::comm::ldap {
    namespace import ::xotcl::*

    requireModules { ldapOpen ldaplibGen.so }

    Class Ldap -superclass NetAccess -parameter {host port dn attributes scope filter}
    Ldap instproc initialize args {
	my instvar port mapToC useCache
	my set port 389
	my set useCache 0
	set mapToC(one) onelevel
	set mapToC(sub) subtree
	set mapToC(base) base
	next
    }
    Ldap proc urlDecode string {
	set toParse $string
	set parsed ""
	while {1} {
	    if {[regexp {^([^%]*)%(..)(.*)$} $toParse _ front hex toParse]} {
		append parsed $front [binary format c 0x$hex]
	    } else {
		append parsed $toParse
		break
	    }
	}
	return $parsed
    }
    Ldap instproc getUrlcomponents {} { 
	showCall
	my instvar path dn attributes scope filter url
	set path [Ldap urlDecode $path]
	puts stderr "___ path=<$path>"
	if {[regexp -nocase {^/([^?]*)(\?([^?]*)(\?([^?]*)(\?([^?]*))?)?)?$} \
		 $path _ dn a attributes s scope f filter]} {
	    if {$scope eq ""} { set scope "base" }
	    if {$filter eq ""} { set filter "(objectClass=*)" }
	} else {
	    set errmsg    "*** Ldap Url trail=<$path> does not  match!\n"      
	    append errmsg "___ RFC 1959 says:\n"
	    append errmsg "    ldap://<host>:<port>/<dn>\[?<attributes>\[?<scope>?<filter>\]\]\n"    
	    append errmsg "___ Cineast and Netscape uses:\n"
	    append errmsg "    ldap://<host>:<port>/<dn>\[?<attributes>\[?<scope>\[?<filter>\]\]\]"
	    my abort "Unsupported URL: '$url' \n $errmsg"
	}    
    }
    Ldap instproc GET {} {
	my instvar  contentType totalsize state currentsize informObjects block
	showCall
	set contentType text/html
	my getUrlcomponents
	if {"start" ne $state } {
	    puts stderr "... [self]:$proc ignoring request in state $state"
	    return
	}
	my open
	my search
	my body-state
	set totalsize [string length $block]
	set currentsize $totalsize
	foreach obj $informObjects {
	    $obj incCb [self] $totalsize $currentsize
	}
	my eof
    }
    Ldap instproc open {} {
	showCall
	my instvar port host  ldapHandle
	set ldapHandle [ldapOpen $host $port]
    }
    Ldap instproc bind {} {
	my instvar ldapHandle
	showCall
    }
    Ldap instproc search {} {
	showVars
	my instvar url ldapHandle searchHandle dn attributes scope filter results mapToC path
	set searchHandle [ldapSearch $ldapHandle $dn \
			      $mapToC($scope) $filter [split $attributes ,] false results]
	set nentries [ldapCountEntries $ldapHandle $searchHandle]
	puts stderr "*** nentries = $nentries"
	if {!$nentries} {set results ""}
	my response 
    }
    Ldap instproc getAttrs {dn} {
    }
    Ldap instproc makeUrl {dn} {
	showCall
	my instvar port host scope filter attributes
	set tmpUrl ldap://$host:$port/$dn?$attributes?$scope?$filter
	return "<a href=\"$tmpUrl\">$dn</a>"  
    }
    Ldap instproc  response {} { 
	showCall
	my  instvar block results attrsVals ldapHandle searchHandle
	set block "
<HTML>
 <HEAD><TITLE>LDAP searching result!!</TITLE></HEAD>
 <BODY bgcolor=FFFFFF>
   <H1>Result</H1>\n  <ul>\n"
	foreach {resDN}  $results {
	    append block "   <li>  [my makeUrl $resDN] <p>\n    <ul>\n"   
	    ldapAttributes $ldapHandle $searchHandle $resDN attrsVals
	    foreach {a v} [array get attrsVals] {      
		append block "     <li> <FONT COLOR=\"\#cc0000\" face=\"Arial,Helvetica\" size=4><b> $a </b></FONT> = $v <p>\n"    
	    }
	    append block "    </ul>\n" 
	}
	append block "  </ul>\n </BODY>\n</HTML>"
    }

    # destructor: Close Connection to LDAP-Server and unbind 
    Ldap instproc destroy {} {
	showCall
	my  instvar ldapHandle
	if {[catch {ldapUnbind $ldapHandle} error]} {
	    return $error
	}
	my freeSearchHandle
    }
    Ldap instproc close {} {
	showCall
	my destroy
	next
    }
    Ldap instproc freeSearchHandle {} { 
	showCall
	my instvar searchHandle 
	if {[info exists searchHandle]} {
	    ldapFreeSearch $searchHandle  
	}
    }

    namespace export Ldap
}

namespace import ::xotcl::comm::ldap::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































Deleted assets/xotcl1.6.7/comm/Mime.xotcl.

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
# $Id: Mime.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::comm::mime 0.9

package require XOTcl

namespace eval ::xotcl::comm::mime {
  namespace import ::xotcl::*

  #######################################################################
  Class MimeTypeLoader
  MimeTypeLoader instproc loadMimeTypes {file} {
    if {![file exists $file]} return

    puts stderr "Loading Mime types from $file"
    set f [open $file r]
    set content [read $f]
    close $f
    regsub -all "\\\\ *\n" $content " " content
    foreach line [split $content \n] {
      set line [string trim $line]
      if {[regexp ^\# $line]} continue
      if {$line eq ""} continue
      regsub -all "  +" $line " " line
      #puts stderr <$line>
      while {$line ne ""} {
	if {[regexp {^ *([^ ]+)=\"([^\"]+)\" *(.*)$} $line _ key value line]} {
	  set v([string tolower $key]) $value
	} elseif {[regexp {^ *([^ ]+)=([^ ]+) *(.*)$} $line _ key value line]} {
	  set v([string tolower $key]) $value
	} else {
	  set tokens [split $line]
	  if {![regexp / [lindex $line 0]]} {
	    puts stderr "Mime: cannot parse line '$line' in $file"
	  } else {
	    set v(exts) [join [lrange $tokens 1 end] ,]
	    set v(type) [lindex $tokens 0]
	  }
	  break
	}
      }
      if {[info exists v(exts)] && [info exists v(type)]} {
	set v(exts) [string tolower $v(exts)]
	set v(type) [string tolower $v(type)]
	foreach ext [split $v(exts) ,] {
	  set ext [string trimleft $ext .]
	  #puts stderr "ext '$ext', contentType = '$v(type)'"
	  my set extTable($ext) $v(type)
	}
	unset v(exts) v(type)
      } else {
	puts stderr "invalid mime entry in $file"
      }
    } 
  }
  MimeTypeLoader instproc guessContentType {name} {
    my loadMimeTypes ~/.mime.types
    my mixin {}
    return [next]
  }

  Class MIME
  MIME instproc guessContentType {name} {
    my instvar extTable nameTable
    if {[regexp {\.([a-zA-Z0-9]+)$} $name _ ext]} {
      catch {set contentType $extTable([string tolower $ext])}
    }
    if {![info exists contentType]} {
      foreach namePattern [array names nameTable] {
	if {[regexp $namePattern $name]} {
	  set contentType text/plain
	  break
	}
      }
    }
    if {![info exists contentType]} {
      set contentType unknown/unknown
    }
    return $contentType
  }
  MIME instproc multipart-decode-header {header obj} {
    $obj instvar name filename contentType
    foreach line [split $header \r] {
      set line [string trim $line \n]
      #puts stderr line=$line
      if {[regexp -nocase {^Content-Disposition: *([^;]+);(.*)$} $line _ \
	       dispo detail]} {
	if {$dispo ne "form-data"} {
	  error "Unknown Content Disposition '$line'"
	}
	if {![regexp -nocase { name *= *"([^\"]+)"} $line _ name]} {
	  error "can't parse form-data name '$line'"
	}
	regexp -nocase {filename *= *"([^\"]+)"} $line _ filename
      } elseif {[regexp -nocase {^Content-Type: *([^; ]+)} $line _ contentType]} {
      } else {
	my showMsg "ignoring '$line'"
      }
    }
  }

  MIME create Mime -mixin MimeTypeLoader
  Mime array set nameTable {
    README text/plain
  }
  Mime array set extTable {
    gif  image/gif
    xpm  image/x-xpixmap
    xbm  image/x-xbitmap
    jpg  image/jpeg
    png  image/x-png
    html text/html
    htm  text/html
    xml  text/xml
    css  text/css
    ps   application/postscript
    pdf  application/pdf
    doc  application/msword
    xls  application/msexel
  }


  ##################################################################
  Class FormData
  FormData instproc encode list {;#RFC 1867
    my showCall
  }
  FormData formData
  ##################################################################
  Class Base64
  Base64 instproc init args {
    my instvar base64 base64_en
    # Emit base64 encoding for a string
    set i 0
    foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \
		      a b c d e f g h i j k l m n o p q r s t u v w x y z \
		      0 1 2 3 4 5 6 7 8 9 + /} {
      set base64($char) $i
      set base64_en($i) $char
      incr i
    }
    next
  }
  Base64 instproc encode string {
    my instvar base64_en
    set result {}
    set length 0
    foreach {a b c} [split $string {}] {
      scan $a %c x
      if {$c ne ""} {
	scan $b %c y
	scan $c %c z
	append result \
	    $base64_en([expr {($x>>2) & 0x3F}]) \
	    $base64_en([expr {(($x<<4) & 0x30) | (($y>>4) & 0xF)}]) \
	    $base64_en([expr {(($y<<2) & 0x3C) | (($z>>6) & 0x3)}]) \
	    $base64_en([expr {$z & 0x3F}])
      } elseif {$b ne ""} {
	scan $b %c y
	append result \
	    $base64_en([expr {($x>>2) & 0x3F}]) \
	    $base64_en([expr {(($x<<4) & 0x30) | (($y>>4) & 0xF)}]) \
	    $base64_en([expr {($y<<2) & 0x3C}]) \
	    =
      } else {
	append result \
	    $base64_en([expr {($x>>2) & 0x3F}]) \
	    $base64_en([expr {($x<<4) & 0x30}]) \
	    ==
      }
      if {[incr length 4] >= 72} {
	append result \n
	set length 0
      }
    }
    return $result
  }
  Base64 instproc decode string {
    my instvar base64
    set output {}
    set group 0
    set j 18
    foreach char [split $string {}] {
      if {$char != "="} {
	set group [expr {$group | ($base64($char) << $j)}]
	if {[incr j -6] < 0} {
	  scan [format %06x $group] %2x%2x%2x a b c
	  append output [format %c%c%c $a $b $c]
	  set group 0
	  set j 18
	}
      } else {
	scan [format %04x $group] %2x%2x a b
	if {$j==6} {
	  append output [format %c $a]
	} else {
	  append output [format %c%c $a $b]
	}
	break
      }
    }
    return $output
  }
  Base64 base64
  ##################################################################
  Class Url
  Url instproc encode list {
    set result ""
    set sep ""
    foreach i $list {
      append result $sep [my encodeItem $i]
      if {$sep != "="} {
	set sep =
      } else {
	set sep &
      }
    }
    return $result
  }
  Url instproc encodeItem string {
    my instvar httpFormMap
    set alphanumeric    a-zA-Z0-9.
    if {![info exists httpFormMap]} {
      for {set i 1} {$i <= 256} {incr i} {
	set c [format %c $i]
	if {![string match \[$alphanumeric\] $c]} {
	  set httpFormMap($c) %[format %.2x $i]
	}
      }
      # these are handled specially
      array set httpFormMap { " " +   \n %0d%0a }
    }
    regsub -all \[^$alphanumeric\] $string {$httpFormMap(&)} string
    regsub -all \n $string {\\n} string
    regsub -all \t $string {\\t} string
    regsub -all {[][{})\\]\)} $string {\\&} string
  return [subst $string]
}
Url instproc hexToChar hex {
  ::scan $hex %x h
  #my showMsg "::scan $hex %x h -> $h"
  format %c $h
}
Url instproc decodeItem string {
  #my showCall
  set result ""  
  regsub -all {\+} $string " " string
  regsub -all {%0d%0a} $string "\n" string
  regsub -all {%([a-fA-F0-9][a-fA-F0-9])} $string {[my hexToChar \1]} string
  return [subst -novariables -nobackslashes $string]
}
Url instproc decodeName string {
  #my showCall
  set result ""  
  regsub -all {%0d%0a} $string "\n" string
  regsub -all {%([a-fA-F0-9][a-fA-F0-9])} $string {[my hexToChar \1]} string
  return [subst -novariables -nobackslashes $string]
}
Url instproc decode string {
  #my showCall
  set result ""
  foreach i [split $string &=] {
    lappend result [decodeItem $i]
  }
  #my showVars result
  return $result
}
Url url

namespace export Mime url base64
}

namespace import ::xotcl::comm::mime::*
#puts stderr "importing ::xotcl::comm::mime::* to [namespace current]"
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/comm/PCache.xotcl.

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
# -*- Tcl -*- $Id: PCache.xotcl,v 1.9 2007/08/14 16:38:26 neumann Exp $
# Persistent Cache object, using gdbm

# Configuration:
# The persistent cache is kept in a directory which is determined by
# the following three rules.
#
# 1) the global variable "CACHE_DIR", which has to be set,
#    before this file is loaded
# 2) If "CACHE_DIR" is not set, the global variable "homedir"
#    is checked, which is assumed to be the home directory
#    of the Cineast browser
# 3) As a last resource the tmp directory is used as the cache directory
#
# Additionally, the cache directory can be specified after loading of this
# file (before the first open) through the instance variable "dir"
# in the object persistentCache.

package provide xotcl::comm::pcache 0.9
#package require xotcl::package

package require XOTcl

namespace eval ::xotcl::comm::pcache {
    namespace import ::xotcl::*

    variable CACHE_DIR
    variable homeDir

    if {![info exists CACHE_DIR]} {
	if {![info exists homeDir]} {
	    set homeDir [::xotcl::tmpdir]
	}
	set CACHE_DIR $homeDir/cache2
    }

    Object persistentCache
    persistentCache set dir $CACHE_DIR
    persistentCache proc flush { {cmd {}} } {
	my instvar DBID
	if {[info exists DBID]} { $DBID close }
	if {{} ne $cmd } {
	    if {[catch {eval $cmd} err]} {puts stderr err=$err}
	}
	my open  ;# UZ: wenn hier das self weggenommen wird, crashed das lintFilter
	#open  ;# UZ: wenn hier das self weggenommen wird, crashed das lintFilter

    }
    # the open method for the first invocation
    persistentCache proc open {} {
	my instvar dir DBID 
	package require xotcl::store
	set DBID [Storage someNewChildStore]
	if {![file isdirectory $dir]} {
	    # if the cache directory does not exist, create it..
	    file mkdir $dir
	}
	# the open method for later invocations, doing the real work
	my proc open {} {
	    my instvar dir DBID
	    $DBID open $dir/index
	}
	# invoke the method
	open
    }
    persistentCache proc clear {} {
	my instvar cacheFileName contentType meta entry validated dir
	my flush [list eval file delete -force  $dir/index \
		      [glob -nocomplain $dir/\[0-9\]*::*]]
	foreach var {cacheFileName contentType meta entry validated} {
	    catch {unset $var}
	}
    }
    persistentCache proc clearEntry {url} {
	my instvar DBID cacheFileName contentType meta entry validated
	my inCache $url
	if {[info exists cacheFileName($url)]} {
	    my flush [list eval file delete -force $cacheFileName($url)]
	    foreach var {cacheFileName contentType meta entry validated} {
		my showMsg "unset ${var}($url)"
		catch {unset ${var}($url)}
	    }
	    catch {$DBID unset $url}
	}
    }
    persistentCache proc lazyFlush {} {
	my instvar flushPending
	if {[info exists flushPending]} { after cancel $flushPending }
	set flushPending [after 100 [self] flush]
    }
    persistentCache proc newEntry {url access doCache name} {
	my instvar cacheFileName contentType meta dir
	if {$name ne ""} {
	    #$access set caching 0
	    return $name
	} elseif {$doCache} {
	    set cacheFileName($url) $dir/[pid]-$access
	    set contentType($url)   [$access set contentType]
	    set meta($url)          [$access set meta]
	    return $cacheFileName($url)
	} else {
	    # we use the Memory cache only for non-persistent cache entries
	    # which are deleted when the program terminates
	    set fileName $dir/v[pid]-$access
	    MemoryCache + $url $fileName
	    return $fileName
	}
    }
    persistentCache proc entryDone {url} {
	my instvar entry cacheFileName contentType DBID meta
	if {![info exists DBID]} { open }
	$DBID set $url [list \
			    cacheFileName $cacheFileName($url) \
			    contentType   $contentType($url)   \
			    meta          $meta($url)          ]
	my lazyFlush
	#my showMsg "size=[file size $cacheFileName($url)]"
	set entry($url) 1
	my set validated($url) 1
    }
    persistentCache proc inCache {url} {
	my instvar entry
	if {[info exists entry($url)]} {
	    set result 1
	} else {
	    my instvar cacheFileName contentType meta DBID
	    if {![info exists DBID]} { open }
	    set result [$DBID set $url]
	    my lazyFlush
	    if {$result ne ""} {
		set entry($url) 1
		array set r $result
		set cacheFileName($url) $r(cacheFileName)
		set contentType($url)   $r(contentType)
		set meta($url)          $r(meta)
		set result 1
	    } else {
		set result 0
	    }
	}
	return $result
    }
    persistentCache proc validated {url} {
	my set validated($url) 1
    }
    persistentCache proc invalidate {url} {
	if {[my exists validated($url)]} {
	    my unset validated($url)
	}
    }
    persistentCache proc isValidated {url} {
	if {[my exists validated($url)]} {
	    return 1
	}
	return 0
    }
    persistentCache proc ifModifiedHeader {url ifModVar} {
	set result 0
	if {[my inCache $url]} {
	    #puts stderr inCache:$url
	    upvar [self callinglevel] $ifModVar ifModifiedHeader
	    my instvar meta
	    array set m $meta($url)
	    if {[info exists m(last-modified)]} {
		set ifModifiedHeader [list If-Modified-Since $m(last-modified)]
		set result 1
	    }
	} else {
	    #puts stderr "url=$url is not in cache"
	}
	return $result
    }
    persistentCache proc dump {} {
	my instvar DBID
	puts stderr DUMP:
	foreach k [$DBID names] {
	    puts stderr $k
	    puts stderr "    [$DBID set $k]"
	}
    }
    persistentCache proc cacheFileName {url} {
	my instvar cacheFileName
	return $cacheFileName($url)
    }
    persistentCache proc contentType {url} {
	my instvar contentType
	return $contentType($url)
    }
    persistentCache proc meta {url} {
	my instvar meta
	return $meta($url)
    }
    persistentCache proc destroy {} {
	#my showCall
	next
    }
    #persistentCache flush



    ########################################################### Cache
    Object MemoryCache
    MemoryCache proc query {url entry} {
	my instvar cache
	if {[info exists cache($url)]} {
	    upvar [self callinglevel] $entry e
	    #puts stderr "-->[self] [self proc] finds: $url"
	    set e $cache($url)
	    return 1
	}
	return 0
    }
    MemoryCache proc + {url entry} {
	#puts stderr "-->[self class]:[self] [self proc] $url"
	my set cache($url) $entry
    }
    MemoryCache proc - {url} {
	#puts stderr "-->[self class]:[self] [self proc] $url"
	catch {my unset cache($url)}
    }
    MemoryCache proc destroy {} {
	my instvar cache
	foreach url [array names cache] {
	    set f $cache($url)
	    if {[regexp ^/ $f]} {
		#my showMsg "trying to remove $f [file exists $f]"
		file delete -force $f
	    }
	}
	next
    }


    Object instproc allInstances {} {
	# Diese Methode ermittelt rekursiv alle direkten und indirekten
	# Instanzen einer Klasse
	::set inst [my info instances]
	foreach s [my info subclass] {
	    foreach i [$s allInstances] { ::lappend inst $i }
	}
	return $inst
    }

    # onExit is automatically called when wafe terminates
    proc onExit {} {
	#puts stderr "allinstances of Access: [Access allInstances]"
	#foreach i [Access allInstances] {
	#  if {[info command $i] eq ""} continue
	#  $i destroy
	#}
	#MemoryCache clear
	persistentCache flush
	#Trace statReport
    }

    namespace export persistentCache MemoryCache
}

namespace import ::xotcl::comm::pcache::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/comm/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded xotcl::comm::connection 1.0 [list source [file join $dir Connection.xotcl]]
package ifneeded xotcl::comm::dav 0.9 [list source [file join $dir Dav.xotcl]]
package ifneeded xotcl::comm::ftp 0.9 [list source [file join $dir Ftp.xotcl]]
package ifneeded xotcl::comm::httpAccess 0.91 [list source [file join $dir Access.xotcl]]
package ifneeded xotcl::comm::httpd 1.1 [list source [file join $dir Httpd.xotcl]]
package ifneeded xotcl::comm::imap 0.9 [list source [file join $dir Imap.xotcl]]
package ifneeded xotcl::comm::ldap 0.9 [list source [file join $dir Ldap.xotcl]]
package ifneeded xotcl::comm::mime 0.9 [list source [file join $dir Mime.xotcl]]
package ifneeded xotcl::comm::pcache 0.9 [list source [file join $dir PCache.xotcl]]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































Deleted assets/xotcl1.6.7/lib/COPYRIGHT.

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
 *  XOTcl - Extended OTcl
 *
 *  Copyright (C) 1999-2008 Gustaf Neumann (a), Uwe Zdun (b)
 *
 * (a) Vienna University of Economics and Business Administration
 *     Dept. of Information Systems / New Media
 *     A-1090, Augasse 2-6
 *     Vienna, Austria
 *
 * (b) University of Essen
 *     Specification of Software Systems
 *     Altendorferstra▀e 97-101
 *     D-45143 Essen, Germany
 *     
 *  Permission to use, copy, modify, distribute, and sell this
 *  software and its documentation for any purpose is hereby granted
 *  without fee, provided that the above copyright notice appear in
 *  all copies and that both that copyright notice and this permission
 *  notice appear in supporting documentation. We make no
 *  representations about the suitability of this software for any
 *  purpose.  It is provided "as is" without express or implied
 *  warranty.
 *
 *
 *  This software is based upon MIT Object Tcl by David Wetherall and
 *  Christopher J. Lindblad, that contains the following copyright
 *  message:
 *
 *   "Copyright 1993 Massachusetts Institute of Technology
 *
 *    Permission to use, copy, modify, distribute, and sell this
 *    software and its documentation for any purpose is hereby granted
 *    without fee, provided that the above copyright notice appear in
 *    all copies and that both that copyright notice and this
 *    permission notice appear in supporting documentation, and that
 *    the name of M.I.T. not be used in advertising or publicity
 *    pertaining to distribution of the software without specific,
 *    written prior permission.  M.I.T. makes no representations about
 *    the suitability of this software for any purpose.  It is
 *    provided "as is" without express or implied warranty."

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































Deleted assets/xotcl1.6.7/lib/Script.xotcl.

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
#$Id: Script.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::script 0.9
package require XOTcl

namespace eval ::xotcl::script {
    namespace import ::xotcl::*

    @ @File {description {
	A small package to instantiate an object, that 
	represents a script.
    }
    }
    @ Class Script {
	description {
	    An object of type Script becomes automatically the command
	    line arguments evaluated as "-" method calls during creation, e.g.
	    <@pre>
	    Script s -set r 5
	    </@pre>
	    and a call with cmd-line "-set v 6" of the script, results in an
	    object s with two vars set: r to 5, and v to 6.
	}
    }



    Class Script
    Script proc create args {
	eval lappend args $::argv
	eval next $args
    }
    Script instproc unknown args {
	puts stderr "$::argv0: Unknown option ┤-$args┤ provided"
    }

    namespace export Script
}

namespace import ::xotcl::script::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































Deleted assets/xotcl1.6.7/lib/changeXOTclVersion.xotcl.

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
#
# this is a maintenance program for XOTcl that allows us to change the 
# version information across the whole distribution automatically.
# 
# this program assumes that pwd is in xotcl-full-X.X* directory or subdir
#
set XOTCL_MAJOR_VERSION 1
set XOTCL_MINOR_VERSION 6
set XOTCL_RELEASE_LEVEL .6

# example settings: 
# 1.0
#set XOTCL_MAJOR_VERSION 1
#set XOTCL_MINOR_VERSION 0
#set XOTCL_RELEASE_LEVEL .3
#
# 0.9.3
#set XOTCL_MAJOR_VERSION 0
#set XOTCL_MINOR_VERSION 9
#set XOTCL_RELEASE_LEVEL .3

#set XOTCL_MAJOR_VERSION 0
#set XOTCL_MINOR_VERSION 9
#set XOTCL_RELEASE_LEVEL .3
#set XOTCL_RELEASE_LEVEL .4
#set XOTCL_RELEASE_LEVEL .5


set XOTCL_VERSION $XOTCL_MAJOR_VERSION.$XOTCL_MINOR_VERSION
set FULL_VERSION $XOTCL_VERSION$XOTCL_RELEASE_LEVEL

if {![regexp {((^.*/xotcl-)([0-9.]*))/?} [pwd] _ topdirname topdirprefix oldversion]} {
  error "this program assumes that pwd is in xotcl-X.X* directory"
}

puts "Prior version is: $oldversion"
puts "New version is:   $FULL_VERSION"
puts "Working in:       $topdirname"

cd $topdirname

puts "... make clean first"
if {[file exists Makefile]} {
  exec make clean
}

foreach file [exec find . -name configure.in] {
  puts "... updating $file"
  set F [open $file]; set c [read $F]; close $F
  set newFile ""
  foreach line [split $c \n] {
    set newLine $line
    if {[regexp {^XOTCL_MAJOR_VERSION=[0-9]} $line]} {
      set line "XOTCL_MAJOR_VERSION=$XOTCL_MAJOR_VERSION"
    } elseif {[regexp {^XOTCL_MINOR_VERSION=[0-9]} $line]} {
      set line "XOTCL_MINOR_VERSION=$XOTCL_MINOR_VERSION"
    } elseif {[regexp {^XOTCL_RELEASE_LEVEL=} $line]} {
      set line "XOTCL_RELEASE_LEVEL=$XOTCL_RELEASE_LEVEL"
    } elseif {[regexp {^define\(XOTclVersion, .*$} $line]} {
      set line "define(XOTclVersion, $XOTCL_MAJOR_VERSION.$XOTCL_MINOR_VERSION$XOTCL_RELEASE_LEVEL)"
    }
    append newFile $line\n
  }
  set F [open $file w]; puts $F $newFile; close $F
}

set newtopdirname $topdirprefix$FULL_VERSION
if {$oldversion != $FULL_VERSION} {
  puts "topdir:               $topdirname->$newtopdirname"
  file rename -force $topdirname $newtopdirname
} 
cd $newtopdirname

foreach file [exec find . -name configure.in] {
  set dir [file dirname $file]
  set oldpwd [pwd]
  cd $dir
  exec autoconf
  cd $oldpwd
}

# determine last configure command
cd $newtopdirname
if {[catch {set configurecmd [exec fgrep {$ ./configure} config.log]}]} {
  set configurecmd "./configure"
} else {
  regsub {^ +\$ } $configurecmd "" configurecmd
}
#puts $configurecmd

cd $newtopdirname/
puts "Configuring in [pwd]"
eval exec $configurecmd

puts "ok ... version is now $FULL_VERSION"
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































Deleted assets/xotcl1.6.7/lib/htmllib.xotcl.

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
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
## $Header: /home/neumann/cvs/xotcl/xotcl/library/lib/htmllib.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

#
# htmllib.xotcl
#
# Author: Antti Salonen, as@fishpool.fi
#
# Copyright:
#
# This software is copyrighted by Fishpool Creations Oy Ltd.  The following 
# terms apply to all files associated with the software unless explicitly 
# disclaimed in individual files.
#
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
# 
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
# 
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
# 

package provide xotcl::htmllib 0.1
package require XOTcl

namespace eval ::xotcl::htmllib {
    namespace import ::xotcl::*

    @ @File {
	description {
	    This package provides the class HtmlBuilder, which can be used to 
	    generate HTML documents, or a part of a document.
	}
	authors {
	    Antti Salonen, as@fishpool.fi
	}
	date {
	    $Date: 2006/09/27 08:12:40 $
	}
    }
    
    #
    # the compressed parameter means that minimal HTML page are created
    # i.e. that space indentation is turned off
    #
    Class HtmlBuilder -parameter {
	{compressed 0}
    }

    ## The constructor.
    ##
    ## The HtmlBuilder object has two instance variables. The document Tcl list
    ## contains the document as a list of strings. The document is stored as a list
    ## rather than a single string to allow further indentation of the whole
    ## document when necessary.
    ##   The indentLevel variable is the level of indentation, which is generally
    ## increased for the contents of any HTML element that may contain block-level
    ## elements. Typical examples would be <ul>, <li>, <td> and so forth.

    HtmlBuilder instproc init {} {
	my instvar document indentLevel
	set document [list] 
	set indentLevel 0
	return
    }


    HtmlBuilder instproc clear {} {
	my instvar document indentLevel

	set document [list]
	set indentLevel 0
	return
    }


    HtmlBuilder instproc getDocument {} {
	my instvar document
	return $document
    }


    HtmlBuilder instproc toString {} {
	my instvar document compressed
	set rvalue ""
	foreach line $document {
	    if {$compressed == "0"} {
		append rvalue "$line\n"
	    } else {
		## only new line for closing tags at the beginnig 
		## of a document element
		if {[string equal -length 2 "</" $line]} {
		    append rvalue "$line\n"
		} else {
		    append rvalue "$line "
		}
	    }
	}
	return $rvalue
    }


    ## parseArguments - Parses the arguments in argList as described in the two
    ## additional Tcl lists. In addition to the arguments listed in the two 
    ## additional lists, the procedure also accepts arguments common to all
    ## HTML elements.
    ## Arguments:
    ##   argList - List of arguments to be parsed
    ##   argParamList - List of arguments that take a parameter
    ##   argNoParamList - List of arguments that don't take a parameter
    ## Returns:
    ##   A string with arguments to an HTML element.

    HtmlBuilder proc parseArguments {argList argParamList argNoParamList} {
	set rvalue ""
	set argParamList [concat $argParamList [list "ID" "CLASS" "STYLE" "TITLE" "LANG" "DIR"]]
	set param 0
	foreach arg $argList {
	    if {$param} {
		append rvalue "=\"$arg\""
		set param 0
	    } else {
		set arg2 [string toupper [string trimleft $arg "-"]]
		if {[lsearch -exact $argParamList $arg2] != -1} {
		    append rvalue " $arg2"
		    set param 1
		} elseif {[lsearch -exact $argNoParamList $arg2] != -1} {
		    append rvalue " $arg2"
		} else {
		    error "HTML syntax error: Invalid argument $arg2 to element"
		}
	    }
	}
	if {$param} {
	    error "HTML syntax error: Missing parameter to argument $arg2"
	}
	return $rvalue
    }


    ##############################################################################
    ## Low-level modification methods:
    ##
    ## The efficiency of these is of utmost importance if efficiency is an issue
    ## in the first place.
    ##
    ## addString
    ## addStringIncr
    ## addStringDecr
    ## addWhiteSpace
    ## addDocument
    ## mergeDocument


    ## Add a new arbitrary string to the document. This method is used by other
    ## modification methods, as well as the user directly to add content other than
    ## HTML elements. The string str is appended to the document with proper
    ## indentation.

    HtmlBuilder instproc addString {str} {
	my instvar document indentLevel compressed
	
	if {$compressed == "0"} {
	    for {set n 0} {$n < $indentLevel} {incr n} {
		append newLine "  "
	    }
	}
	append newLine $str
	lappend document $newLine
	
	return
    }

    ## Add a string to the document and increase the indentation level.

    HtmlBuilder instproc addStringIncr {str} {
	my instvar indentLevel
	my addString $str
	incr indentLevel
	return
    }


    ## Decrease the indentation level and add a string to the document.

    HtmlBuilder instproc addStringDecr {str} {
	my instvar indentLevel
	incr indentLevel -1
	my addString $str
	return
    }

    #
    # add the string and replace all line breaks in the
    # string with addLineBreak calls so that given plain text 
    # appears similar in HTML output

    HtmlBuilder instproc addStringWithLineBreaks {str} {
	while {[set idx [string first "\n" $str]] != -1} {
	    my addString [string range $str 0 [expr {$idx - 1}]]
	    my addLineBreak
	    set str [string range $str [expr {$idx + 1}] end]
	}
	my addString $str
    }
    
    ## Add a single line of white space to the HTML document.
    
    HtmlBuilder instproc addWhiteSpace {} {
	my addString ""
	return
    }

    ## Add the content of the document given as parameter.

    HtmlBuilder instproc addDocument {document} {
	set documentList [$document getDocument]
	
	foreach line $documentList {
	    my addString $line
	}
	return
    }

    ## Merge the content of the document given as a parameter. The difference
    ## to addDocument is that the document merged is destroyed.

    HtmlBuilder instproc mergeDocument {document} {
	set documentList [$document getDocument]
	
	foreach line $documentList {
	    my addString $line
	}
	$document destroy
	return
    }




    ##############################################################################
    ## HTML generation methods:                                                
    ##              
    ## The methods for generating various HTML structures are either a pair of 
    ## start and end methods, such as startParagraph and endParagraph, or a single
    ## method such as addListItem. Even if the the closing tag for <p>, for
    ## example, is not required by the HTML specification, using the closing method
    ## is necessary to have the document properly indented.


    # Add a string to the document within <strong>...</strong>

    HtmlBuilder instproc addStringStrong {str} {
	my addString "<STRONG>$str</STRONG>"
	return
    }

    # Add a string to the document within <em>...</em>

    HtmlBuilder instproc addStringEmphasized {str} {
	my addString "<EM>$str</EM>"
	return
    }

    # Add a comment to the document <!-- ... -->

    HtmlBuilder instproc addComment {str} {
	my addString "<!-- $str -->"
	return
    }

    HtmlBuilder instproc addLineBreak {} {
	my addString "<BR>"
	return
    }

    ## startDocument - Start an HTML document. Currently all documents are HTML 4.0
    ## Transitional. HTML, BODY, HEAD and TITLE elements are added/started here.
    ## Optional arguments:
    ##   -title documentTitle (empty if not given)
    ##   -stylesheet externalStyleSheet
    ##   -bgcolor backgroundColour (deprecated in HTML 4.0)

    HtmlBuilder instproc startDocument {args} {
	set title ""
	foreach {name value} $args {
	    switch -- $name {
		-title {
		    set title $value
		}
		-stylesheet {
		    set stylesheet $value
		}
		-bgcolor {
		    set bgcolor $value
		}
	    }
	}
	my addString {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/frameset.dtd">}
	my addWhiteSpace
	my addString {<HTML>}
	my addStringIncr {<HEAD>}
	my addString "<TITLE>$title</TITLE>"
	if {[info exists stylesheet]} {
	    my addString "<LINK REL=\"StyleSheet\" HREF=\"$stylesheet\" TYPE=\"text/css\">"
	}
	my addStringDecr {</HEAD>}
	my addWhiteSpace
	if {[info exists bgcolor]} {
	    my addStringIncr "<BODY BGCOLOR=\"$bgcolor\">"
	} else {
	    my addStringIncr {<BODY>}
	}
	return
    }

    ## endDocument - end an HTML document

    HtmlBuilder instproc endDocument {} {
	my addStringDecr {</BODY>}
	my addString {</HTML>}
	return
    }

    ## startParagraph - start a P element
    ## Optional arguments:
    ##   Common HTML arguments

    HtmlBuilder instproc startParagraph {args} {
	set attributes [HtmlBuilder parseArguments $args [list] [list]]
	my addStringIncr "<P$attributes>"
	return
    }

    ## endParagraph - end a P element

    HtmlBuilder instproc endParagraph {} {
	my addStringDecr {</P>}
	return
    }

    ## startAnchor - start an A element
    ## Optional arguments:
    ##   -href URI
    ##   -name cdata
    ##   -target frameTarget
    ##   Common HTML arguments

    HtmlBuilder instproc startAnchor {args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "HREF" "NAME" "TARGET"] [list]]
	my addStringIncr "<A$attributes>"
	return
    }

    ## endAnchor - end an A element

    HtmlBuilder instproc endAnchor {args} {
	my addStringDecr {</A>}
	return
    }

    ## addAnchor - add an A element, using content as the visible link.
    ## Optional arguments:
    ##   -href URI
    ##   -name cdata
    ##   -target frameTarget
    ##   Common HTML arguments

    HtmlBuilder instproc addAnchor {content args} {
	eval my startAnchor $args
	my addString $content
	my endAnchor
	return
    }

    ## startUnorderedList - start a UL element
    ## Optional arguments:
    ##   Commmon HTML arguments

    HtmlBuilder instproc startUnorderedList {args} {
	set attributes [HtmlBuilder parseArguments $args [list] [list]]
	my addStringIncr "<UL$attributes>"
	return
    }

    ## endUnorderedList - end a UL element

    HtmlBuilder instproc endUnorderedList {} {
	my addStringDecr {</UL>}
	return
    }

    ## startListItem - start an LI element
    ## Optional arguments:
    ##   Common HTML arguments

    HtmlBuilder instproc startListItem {args} {
	set attributes [HtmlBuilder parseArguments $args [list] [list]]
	my addStringIncr "<LI$attributes>"
	return
    }

    ## endListItem - end an LI element

    HtmlBuilder instproc endListItem {} {
	my addStringDecr {</LI>}
	return
    }

    ## add a simple list item
    HtmlBuilder instproc addListItem {content} {
	my startListItem
	my addString $content
	my endListItem
    }

    ## startTable - start a TABLE element. Note that if the -border argument isn't
    ## used, by default the table are created with borders (<TABLE BORDER>).

    ## Optional arguments:
    ##   -border pixels
    ##   -cellpadding length
    ##   -cellspacing length
    ##   -summary text
    ##   -width length
    ##   -bgcolor  color spec
    ##   Common HTML arguments

    HtmlBuilder instproc startTable {args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "BORDER" "CELLPADDING" "CELLSPACING" "SUMMARY" \
				 "WIDTH" "BGCOLOR"] [list]]
	if {[lsearch $args "-border"] == -1} {
	    append attributes " BORDER"
	}
	my addStringIncr "<TABLE$attributes>"
	return
    }

    ## endTable - end a TABLE element

    HtmlBuilder instproc endTable {} {
	my addStringDecr {</TABLE>}
	return
    }

    ## startTableRow - start a TR element
    ## Optional arguments:
    ##   Common HTML arguments
    HtmlBuilder instproc startTableRow {args} {
	set attributes [HtmlBuilder parseArguments $args [list "VALIGN"] [list]]
	my addStringIncr "<TR$attributes>"
	return
    }

    ## endTableRow - end a TR element

    HtmlBuilder instproc endTableRow {} {
	my addStringDecr {</TR>}
	return
    }

    ## startTableCell - start a TD element
    ## Optional arguments:
    ##   -colspan number
    ##   -rowspan number
    ##   -align left|center|right|justify|char
    ##   -valign top|middle|bottom|baseline
    ##   -bgcolor
    ##   -width
    ##   Common HTML arguments

    HtmlBuilder instproc startTableCell {args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "COLSPAN" "ROWSPAN" "ALIGN" "VALIGN" \
				 "BGCOLOR" "WIDTH"] [list]]
	my addStringIncr "<TD$attributes>"
	return
    }

    ## endTableCell - end a TD element

    HtmlBuilder instproc endTableCell {} {
	my addStringDecr {</TD>}
	return
    }

    #
    # add a simple table cell which just contains a string
    #
    HtmlBuilder instproc addTableCell {{string ""} args} {
	eval my startTableCell $args
	my addString $string
	my endTableCell
    }

    ## startTableHeaderCell - start a TH element
    ## Optional arguments:
    ##   -colspan number
    ##   -rowspan number
    ##   -align left|center|right|justify|char
    ##   -valign top|middle|bottom|baseline
    ##   Common HTML arguments

    HtmlBuilder instproc startTableHeaderCell {args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "COLSPAN" "ROWSPAN" "ALIGN" "VALIGN"] [list]]
	my addStringIncr "<TH$attributes>"
	return
    }

    ## endTableHeaderCell - end a TH element

    HtmlBuilder instproc endTableHeaderCell {} {
	my addStringDecr {</TH>}
	return
    }

    ## startForm - start a FORM element
    ## Required arguments:
    ##   -action URI
    ## Optional arguments:
    ##   -method get|post
    ##   Common HTML arguments

    HtmlBuilder instproc startForm {args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "ACTION" "METHOD" "ENCTYPE"] [list]]
	my addStringIncr "<FORM$attributes>"
	return
    }

    ## endForm - end a FORM element

    HtmlBuilder instproc endForm {} {
	my addStringDecr {</FORM>}
	return
    }

    ## addInput - add in INPUT element
    ## Required arguments:
    ##   -type <input type>
    ##   -name <control name>
    ## Optional arguments:
    ##   -value <initial value>
    ##   -size <width of input, in pixels of characters>
    ##   -maxlength <max number of characters for text input>
    ##   -checked
    ##   Common HTML arguments
    
    HtmlBuilder instproc addInput {args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "TYPE" "NAME" "VALUE" "SIZE" "MAXLENGTH"] \
			    [list "CHECKED"]]
	my addString "<INPUT$attributes>"
	return
    }

    ## addTextArea - start a TEXTAREA element
    ## First parameter: value - Default value of the text area
    ## Required arguments:
    ##   -rows <number of rows>
    ##   -cols <number of columns>
    ## Optional arguments:
    ##   -name <control name>
    ##   Common HTML Arguments

    HtmlBuilder instproc addTextArea {value args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "ROWS" "COLS" "NAME"] [list]]
	my addString "<TEXTAREA$attributes>$value</TEXTAREA>"
	return
    }

    ## startOptionSelector - start a SELECT element
    ## Optional arguments:
    ##   -name <control name>
    ##   -size <number of visible items>
    ##   -multiple
    ##   Common HTML arguments

    HtmlBuilder instproc startOptionSelector {args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "NAME" "SIZE"] [list "MULTIPLE"]]
	my addStringIncr "<SELECT$attributes>"
	return
    }    

    ## endOptionSelector - end a SELECT element

    HtmlBuilder instproc endOptionSelector {} {
	my addStringDecr "</SELECT>"
	return
    }

    ## startOption - start an OPTION element
    ## Optional arguments:
    ##   -value <value of option>
    ##   -selected
    ##   Common HTML arguments

    HtmlBuilder instproc startOption {args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "VALUE"] [list "SELECTED"]]
	my addStringIncr "<OPTION$attributes>"
	return
    }

    ## endOption - end an OPTION element

    HtmlBuilder instproc endOption {} {
	my addStringDecr "</OPTION>"
	return
    }

    ## addImage - add an IMG element
    ## Required arguments:
    ##   -src <url>
    ##   -alt <alternate text>
    ##   -align <alignment> (deprecated in HTML 4.0)
    ## Optional arguments:
    ##   Common HTML arguments

    HtmlBuilder instproc addImage {args} {
	set attributes [HtmlBuilder parseArguments $args \
			    [list "SRC" "ALT" "ALIGN"] [list]]
	my addString "<IMG$attributes>"
	return
    }

    ## startBlock - start a DIV element (a generic block-level container)
    ## Optional arguments:
    ##   Common HTML attributes

    HtmlBuilder instproc startBlock {args} {
	set attributes [HtmlBuilder parseArguments $args [list] [list]]
	my addStringIncr "<DIV$attributes>"
	return
    }

    ## endBlock - end a DIV element

    HtmlBuilder instproc endBlock {} {
	my addStringDecr "</DIV>"
	return
    }

    ## addHorizontalRule - add an HR element
    ## Optional arguments:
    ##   Common HTML arguments

    HtmlBuilder instproc addHorizontalRule {args} {
	set attributes [HtmlBuilder parseArguments $args [list] [list]]
	my addString "<HR$attributes>"
	return
    }

    namespace export HtmlBuilder
}

namespace import ::xotcl::htmllib::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/lib/make.xotcl.

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
# $Id: make.xotcl,v 1.4 2006/09/27 08:12:40 neumann Exp $ 
### inEachDir changes now to each directory
### install clears tgarget directory before installing
### Object file added (for better -n processing)
#lappend auto_path ..

package require XOTcl 1
namespace import -force ::xotcl::*

###
Object make
#
# shared lib add files for pkgIndex.tcl
#
make proc mkIndex {name} {
  #puts stderr "+++ mkIndex in [pwd]"
  set fls {}
  foreach f [glob -nocomplain *tcl] {
    if {![file isdirectory $f]} {
      set F [open $f]; set c [read $F]; close $F
      if {[string match "*package provide*" $c]} { lappend fls $f }
    }
  }

  set so [glob -nocomplain *[info sharedlibextension]]
  # loading libxotcl into xotclsh crashes on some systems
  foreach lib [list libxotcl$::xotcl::version[info sharedlibextension] \
		   xotcl$::xotcl::version.dll] {
    set p [lsearch -exact $so $lib]
    if {$p != -1} {
      set so [lreplace $so $p $p]
      #puts stderr "new so=<$so>"
    }
  }
  #puts stderr "[pwd]: call so=<$so>"
  set fls [concat $fls $so]
  
  if {$fls ne ""} {
    if {[file exists pkgIndex.tcl]} {
      file delete -force pkgIndex.tcl
    }
    #puts stderr "callinglevel <[self callinglevel]> $fls"
    #puts stderr "[pwd]:\n\tcall eval pkg_mkIndex -direct . $fls"
    if {[catch {eval pkg_mkIndex -direct . $fls} errs]} {
      puts stderr "!!! $errs"
    }
    #puts stderr "[pwd] done"
  }

  foreach addFile [glob -nocomplain *.add] {
    if {[file exists $addFile]} {
      puts stderr "Appending $addFile to pkgIndex.tcl in [pwd]"
      set OUT [file open pkgIndex.tcl a]
      set IN [file open $addFile]
      puts -nonewline $OUT [read $IN]
      close $IN; close $OUT
    }
  }
  #puts stderr "+++ mkIndex name=$name, pwd=[pwd] DONE"
}
make proc inEachDir {path cmd} {
  #puts stderr "[pwd] inEachDir $path  [file isdirectory $path]"
  if { [file isdirectory $path] 
       && ![string match *CVS $path]
       && ![string match *SCCS $path]
       && ![string match *Attic $path]
       && ![string match *dbm* $path]
    } {
    set olddir [pwd]
    cd $path
    eval make $cmd $path
    set files [glob -nocomplain *]
    cd $olddir
    foreach p $files { my inEachDir $path/$p $cmd }
    #puts stderr "+++ change back to $olddir"
  }
}
make proc in {path cmd} {
  if {[file isdirectory $path] && ![string match *CVS $path]} {
    set olddir [pwd]
    cd $path
    eval make $cmd $path
    cd $olddir
  }
}
### tcl file-command
rename file tcl_file
Object file -requireNamespace

rename open file::open
proc open {f {mode r}} { file open $f $mode }
#file proc open {f {mode r}} { ::open $f $mode }


file array set destructive {
  atime 0       attributes 0  copy 1       delete 1      dirname 0
  executable 0  exists 0      extension 0  isdirectory 0 isfile 0
  join 0        lstat 0       mkdir 1      mtime 0       nativename 0
  owned 0       pathtype 0    readable 0   readlink 0    rename 1
  rootname 0    size 0        split 0      stat 0        tail 0
  type 0        volumes 0     writable 0
}
foreach subcmd [file array names destructive] {
  file proc $subcmd args {
    #puts stderr " [pwd] call: '::tcl_file [self proc] $args'"
    eval ::tcl_file [self proc] $args
  }
}
### minus n option
Class make::-n
foreach f [file info commands] {
  if {$f eq "unknown" || $f eq "next" || $f eq "self"} continue
  if {![file exists destructive($f)] || [file set destructive($f)]} {
    #puts stderr destruct=$f
    make::-n instproc $f args {
	puts "--- [pwd]:\t[self proc] $args"
    }
  } else {
    #puts stderr nondestruct=$f
    make::-n instproc $f args {
      set r [next]
      #puts "??? [self proc] $args -> {$r}"
      return $r
    }
  }
}

### command line parameters
if {![info exists argv] || $argv eq ""} {set argv -all}
if {$argv eq "-n"} {set argv "-n -all"}

Class Script
Script proc create args {
  eval lappend args $::argv
  eval next $args
}
Script instproc unknown args {
  puts stderr "$::argv0: Unknown option ┬┤-$args┬┤ provided"
}

Script instproc n {} {file mixin make::-n}
Script instproc all {} {
  make inEachDir . mkIndex
}
Script instproc dir {dirName} {
  cd $dirName
}
Script instproc target {path} {
  make set target $path
}
Script create main

#puts stderr "+++ make.xotcl finished."
#if {[set ::tcl_platform(platform)] eq "windows"} {
#  exit
#}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































Deleted assets/xotcl1.6.7/lib/makeDoc.xotcl.

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
#$Id: makeDoc.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $
package require XOTcl 1.6
namespace import ::xotcl::*
@ @File {
  description {
    Documentation tool for the XOTcl distribution.<br>
    Usage: 'makeDoc docdir filename ?filename ...?'<br>
    Called by Makefile.
  }
}
lappend auto_path [file dirname [info script]]

#package require xotcl::package
#package verbose 1
package require -exact xotcl::xodoc 0.84
set fileList ""

puts "XOTcl Documentation Tool"
puts "------------------------"
if {$argc > 1} {
  set DOCDIR [lindex $argv 0]
  puts "Documenting to directory $DOCDIR:"
  if {![file isdirectory $DOCDIR]} {
    file mkdir $DOCDIR
  }
  set files [lrange $argv 1 end]
  foreach file $files {
      puts "...$file"
      if {[catch {XODoc documentFileAsHTML $file $DOCDIR} fb]} {
	  puts stderr "\terror processing $file:\n[string replace $::errorInfo 400 end ...]"
      } else {
	  lappend fileList $file $fb
      }
  }
} else {
  error "usage: xodoc docdir filename ?filename ...?"
}

set filesHtml ""
set filesDir ""
## write index page
foreach {f fb} $fileList {
  set dir .
  regexp {^(.*)/[^/]*$} $f _ dir
  if {$fb ne "langRef-xotcl"} {
    set tail ", "
    if {$dir != $filesDir} {
      append filesHtml "<li> <b>Directory '$dir': </b><br>"
      set filesDir $dir
      set tail ""
    }
    append filesHtml "$tail<a HREF=\"./${fb}.html\">[file tail $f]</a>"
  }
}

#  <html>
#  <head>
#  <title>XOTcl - Documentation</title>
#  </head>
#  <body bgcolor=FFFFFF>
#  <h1><IMG ALIGN=MIDDLE SRC = "./logo-100.jpg">Lanuage Reference - Index</h1>

set content {

The <EM>Extended Object Tcl (XOTcl)</EM> Documentation contains the
following parts: 

<h2> XOTcl Language Documentation </h2>
  <UL>
  <LI>XOTcl Tutorial (<a href="tutorial.html">HTML</a>, 
		      <a href="tutorial.pdf">PDF</a>)
  <LI>Language Reference (<a href="langRef-xotcl.html">HTML</a>,
		      <a href="langRef-xotcl.pdf">PDF</a>)
  <LI>If you have question, problems etc. you might check the
      <a href="http://alice.wu-wien.ac.at/mailman/listinfo/xotcl">XOTcl 
         mailing list</a> (<a href="http://alice.wu-wien.ac.at:8000/xotcl-mailing-list/">archive 1</a>,
      <a href="http://alice.wu-wien.ac.at/pipermail/xotcl/">archive 2</a>)
      or you might check the XOTcl section of the  
         <a href="http://wiki.tcl.tk/XOTcl">Tcl wiki</a>.
   </UL>

<h2>Package and Script Documentation</h2>
<center>
  This section of the documentation is under work...
</center>

  <ul>
    $filesHtml
  </ul>
  <p>

<h2>Tcl Online Information </h2>
  <ul>
   <li>Online information for <a href="http://www.tcl.tk/man/">
      Tcl manual pages</a>
  </ul>
 
}


set content [subst -nobackslashes -nocommands $content]
set f [open $DOCDIR/index.html w]
puts $f $content
close $f

puts "Documentation finished"
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































Deleted assets/xotcl1.6.7/lib/metadataAnalyzer.xotcl.

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
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
package provide xotcl::metadataAnalyzer 0.84 
package require XOTcl

namespace eval ::xotcl::metadataAnalyzer {
    namespace import ::xotcl::*

    @ @File {
	description {
	    XOTcl file analyzer for @ metadata. E.g.\ used for 
	    doumentation with xoDoc (but in the static variant 
				     StaticMetadataAnalyzer which uses the dynamic 
				     variant in this file).
	    <@p>
	    Sample sample usage:
	    <@pre>
	    package require xotcl::metadataAnalyzer

	    # instantiate metadata analyzer object
	    MetadataAnalyzer @::m
	    # make this object be known to @ and turn @ metadata processing on
	    @ analyzerObj @::m
	    @ onOff 1

	    # read in some metadata tags (in sample file) & execute the file
	    source lib/testx.xotcl

	    # turn @ metadata processing off again
	    @ onOff 0

	    # print out all collected metadata
	    puts [@::m print]
	    </@pre>
	}
    }

    @ Class MetadataToken {
	description {
	    Each collected metadata element is stored in a token object.
	    MetadataToken is superclass of token object classes. Each metadata token
	    has two interesting parameters: 
	    <@p>
	    "properties" contains list of all described metadata properties. E.g. can
	    be printed with
	    <@pre>
	    foreach p [my set properties] { 
		if {[my exists $p]} {
		    append c "    $p=[my set $p]\n"
		}
	    }
	    </@pre>
	    "name" contains the method, object, ... name of the metadata element.
	    <@p>
	    All metadata token are aggregated by @. Therefore, 
	    <@pre>
	    foreach mdt [@ info children] { 
		if {[$mdt istype MetadataToken]} {$mdt print}
	    }
	    </@pre>
	    prints all token.

	}
    }
    Class MetadataToken -parameter {
	{name ""}
	{properties ""}
    }

    @ MetadataToken proc sortTokenList {l "token list"} {
	description {Sort a token list with names. Since names are autonames, 
	    this means order of appearance in the program.}
    }
    MetadataToken proc sortTokenList l {
	foreach t $l {
	    set names([$t set name]) $t
	}
	set sortedNames [lsort [array names names]]
	set sortedList ""
	foreach n $sortedNames {
	    lappend sortedList $names($n)
	}
	return $sortedList
    }

    MetadataToken instproc evaluateMetadata md {
	my instvar properties
	foreach {p v} $md {
	    # only append property, if its not already there
	    # otherwise just overwrite the value
	    if {[lsearch $properties $p] == -1} {
		my lappend properties $p
	    }
	    my set $p $v
	}
    }

    @ MetadataToken instproc printProperties {} {
	description {Print metadata properties to stdout.}
    }
    MetadataToken instproc printProperties {} {
	set c ""
	foreach p [my set properties] { 
	    if {[my exists $p]} {
		append c "   [my capitalize $p]=[my set $p]\n"
	    }
	}
	return $c
    }

    MetadataToken instproc capitalize string {
	if {$::tcl_version >= 8.3} {
	    string toupper $string 0 0
	} else {
	    return "[string toupper [string range $string 0 0]][string range $string 1 end]"
	}
    }

    @ MetadataToken abstract instproc print {} {
	description {
	    Abstract method for printing a token to stdout.
	}
    }
    MetadataToken abstract instproc print {}

    @ Class FileToken -superclass MetadataToken {
	description {
	    Token for @File Metadata.
	}
    }
    Class FileToken -superclass MetadataToken
    FileToken instproc print {} {
	set c "FILE=[my set name]\n"
	append c [my printProperties]
	return $c
    }

    @ Class ConstraintToken -superclass MetadataToken {
	description {
	    Token for @Constraint Metadata.
	}
    }
    Class ConstraintToken -superclass MetadataToken
    ConstraintToken instproc print {} {
	set c "CONSTRAINT=[my set name]\n"
	append c [my printProperties]
	return $c
    }

    @ Class PackageToken -superclass MetadataToken {
	description {
	    Token for Package metadata. Contains additional parameters:
	    "version" of the package and "type"= either "require" or "provide".

	}
    }
    Class PackageToken -superclass MetadataToken -parameter {
	{version ""}
	{type ""}
    }

    @ Class ObjToken -superclass MetadataToken {
	description {
	    Token for Object metadata. Contains additional parameters:
	    "procList" = list of all proc token and "cl"= class name.
	}
    }
    Class ObjToken -superclass MetadataToken -parameter {
	{procList ""}
	cl
    }

    ObjToken instproc printProcs {} {
	set c "  PROCS:\n"
	set pl [MetadataToken sortTokenList [my procList]]
	if {[my istype ClassToken]} {
	    set pl [concat [MetadataToken sortTokenList [my instprocList]] $pl]
	}
	foreach p $pl {
	    append c "    [$p set name]\n"
	}
	return $c
    }

    ObjToken instproc print {} {
	set c "OBJECT=[my set name]\n"
	if {[my exists cl]} {append c "  CLASS=[my set cl]\n"}
	if {[my exists heritage]} {append c "  HERITAGE=[my set heritage]\n"}
	append c [my printProperties]

	set pl [MetadataToken sortTokenList [my procList]]
	if {[my istype ClassToken]} {
	    set pl [concat [MetadataToken sortTokenList [my instprocList]] $pl]
	}
	foreach p $pl {
	    append c [$p print]
	}

	return $c
    }

    @ Class ClassToken -superclass ObjToken {
	description {
	    Token for Class metadata. Contains additional parameters:
	    "instprocList" = list of all instproc token.
	}
    }
    Class ClassToken -superclass ObjToken -parameter {
	{instprocList ""}
    }
    ClassToken instproc print {} {
	regsub "^OBJECT=" [next] "CLASS=" r
	return $r
    }

    @ Class MetaClassToken -superclass ClassToken {
	description {
	    Token for Meta-Class metadata.
	}
    }
    Class MetaClassToken -superclass ClassToken
    MetaClassToken instproc print {} {
	regsub "^CLASS=" [next] "META-CLASS=" r
	return $r
    }

    @ Class MethodToken -superclass MetadataToken {
	description {
	    Token for Method metadata. Contains additional parameters:
	    "arguments" of the method, "returnValue"  of the method, 
	    "obj" name, "abstract" = 0 or 1 (whether its an abstract method or not).
	}
    }
    Class MethodToken -superclass MetadataToken -parameter {
	arguments
	returnValue
	obj
	{abstract 0}
    }

    # Prints out method information
    MethodToken instproc print {} {
	set c "  METHOD=[my set name], ARGUMENTS= "

	if {[my exists arguments]} {
	    foreach {arg argDescription} [my set arguments] {
		# ignore argDescription and default values
		if {[llength $arg] > 1} {set arg [lindex $arg 0]}
		append c $arg " "
	    }
	}
	append c "\n [my printProperties]"
	return $c
    }

    @ Class ProcToken -superclass MethodToken {
	description {
	    Token for Proc metadata
	}
    }
    Class ProcToken -superclass MethodToken
    ProcToken instproc print {} {
	regsub "^  METHOD=" [next] "  PROC=" r
	return $r
    }

    @ Class InstprocToken -superclass MethodToken {
	description {
	    Token for Instproc metadata.
	}
    }
    Class InstprocToken -superclass MethodToken
    InstprocToken instproc print {} {
	regsub "^  METHOD=" [next] "  INSTPROC=" r
	return $r
    }

    @ Class MetadataAnalyzer { 
	description "Handler class for building a metadata runtime structure"
    }

    Class MetadataAnalyzer -parameter {
	{objList ""}
	{packageList ""}
	{knownMetaclasses "Class"}
	{ns ""}
	fileToken
	{constraintList ""}
    }

    MetadataAnalyzer instproc init args {
	next
    }

    MetadataAnalyzer instproc handleMethod {obj type name {argList ""} {doc ""}} {
	#puts stderr "+++Method $type $name $argList $doc"
	set procClass ProcToken
	set objCl ObjToken
	if {$type eq "instproc"} {
	    set procCl InstprocToken
	    set objCl ClassToken
	}
	set t [$procClass create [my autoname ::xotcl::@::t]]
	
	set n [$t set name [string trimleft $name :]]
	$t set obj $obj

	set objFound 0
	foreach o [my set objList] {
	    if {[$o set name] == $obj} {
		set objFound 1
		if {$type eq "instproc" && ![$o istype ClassToken]} {
		    $o class ClassToken
		}
		break
	    }
	}
	if {$objFound == 0} {
	    set o [$objCl create [my autoname ::xotcl::@::t]]
	    $o set name $obj
	    my lappend objList $o
	}
	$o lappend ${type}List $t

	$t set arguments $argList 

	$t evaluateMetadata $doc
	return $t
    }

    MetadataAnalyzer instproc handleObj {class name args} {
	my instvar knownMetaclasses objList extensions
	set objCl ObjToken
	if {[lsearch $class $knownMetaclasses] != -1} {
	    set objCl ClassToken
	}
	# if an instproc/proc has created an entry for this obj/class
	# -> use it and overwrite it with new info
	if {[set idx [lsearch $name $objList]] != -1} {
	    set t [lindex $objList $idx]
	    $t class $objCl
	} else {
	    set t [$objCl create [my autoname ::xotcl::@::t]]
	    my lappend objList $t
	}

	$t set name $name

	set la [llength $args]

	# evaluate -superclass argument
	if {($la == 3 || $la == 2) && [lindex $args 0] eq "-superclass"} {
	    set heritage [$t set heritage [lindex $args 1]]
	    foreach h $heritage {
		if {[lsearch $h $knownMetaclasses] != -1} {
		    # A new metaclass was defined
		    lappend knownMetaclasses $name
		    $t class MetaClassToken
		}
	    }
	}

	# evaluate documentation
	set doc ""
	if {$la == 1} {
	    set doc [lindex $args 0]
	} elseif {$la == 3} {
	    set doc [lindex $args 2]
	}
	$t evaluateMetadata $doc
	$t set cl $class

	#puts stderr "+++Obj $name $args"
    }

    MetadataAnalyzer instproc handleFile doc {
	if {[my exists fileToken]} {
	    [my set fileToken] evaluateMetadata $doc
	}
    }

    MetadataAnalyzer instproc handleConstraint {constraint name args} {
	set t [ConstraintToken create [my autoname ::xotcl::@::t]]
	my lappend constraintList $t
	$t set name $name
	set doc [lindex $args 0]
	$t evaluateMetadata $doc
    }

    MetadataAnalyzer instproc handlePackage args {
	#puts "$args"
	if {[llength $args] > 2} {
	    set type [lindex $args 1]
	    if {$type eq "provide" || $type eq "require"} {
		set t [PackageToken create [my autoname ::xotcl::@::t]]
		my lappend packageList $t
		$t set name [lindex $args 2]
		$t set type $type
		if {[llength $args] > 3} {
		    $t set version [lindex $args 3]
		}
	    }
	}
    }

    @ MetadataAnalyzer instproc print {} {
	description "Print all collected token information to stdout. 
   This method is also an exmaple how the tokens can be used."
    }
    MetadataAnalyzer instproc print {} {
	my instvar extensions packageList
	set c ""
	if {[llength $packageList] > 0} {
	    append c "PACKAGES:"
	    foreach t $packageList {
		if {[$t type] eq "provide"} {
		    append c "  Package provided: [$t name] [$t version]\n"
		} elseif {[$t type] eq "require"} {
		    append c "  Package required: [$t name] [$t version]\n"
		}
	    }
	}

	if {[my exists fileToken]} {
	    append c [[my set fileToken] print]
	}

	if {[my exists constraintToken]} {
	    append c [[my set constraintToken] print]
	}

	if {[info exists extensions]} {
	    # Add list of extensions.
	    foreach extension $extensions {
		append c "\nExtensions: [$extension name], " \
		    "Description: [$extension description]"
	    }
	}

	set objList [MetadataToken sortTokenList [my objList]]

	if {[llength $objList]>0} {
	    foreach obj $objList {append c [$obj print]}
	}
	return $c
    }

    @ Class AnalyzerCmd {
	description {Class that overload the unknown mechanism of @ to provide metadata analysis.}
    }
    Class AnalyzerCmd -parameter {
	{analyzerObj ""}
	{onOff 0}
    } 
    AnalyzerCmd instproc unknown args {
	my instvar analyzerObj onOff

	if {!$onOff} {return [next]}

	if {[llength $args] > 1} {
	    set abstract 0
	    if {[lindex $args 1] eq "abstract"} {
		if {[llength $args] > 2} {
		    set p [lindex $args 2]
		    if {$p eq "proc" || $p eq "instproc"} {
			set args [lreplace $args 1 1]
			set abstract 1
		    }
		}
	    }
	    switch [lindex $args 1] {
		proc - instproc {
		    set r [eval $analyzerObj handleMethod $args]
		    if {$abstract} {$r abstract 1}
		    return $r
		}
		default {
		    switch [lindex $args 0] {
			@File {
			    return [$analyzerObj handleFile [lindex $args 1]]
			}
			@Constraint {
			    return [eval $analyzerObj handleConstraint $args]
			}
			default {
			    return [eval $analyzerObj handleObj $args]
			}
		    }
		}
	    }
	}
	puts stderr "Unknown @ metadata: '$args'"
    }
    @ AnalyzerCmd @ {
	description {Recreate @ with metadata analyis funtionality.}
    }
    AnalyzerCmd @

    namespace export \
	MetadataToken FileToken ConstraintToken PackageToken ObjToken \
	ClassToken MetaClassToken MethodToken ProcToken InstprocToken \
	MetadataAnalyzer AnalyzerCmd
}

namespace import ::xotcl::metadataAnalyzer::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/lib/mixinStrategy.xotcl.

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
#$Id: mixinStrategy.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $
package provide xotcl::mixinStrategy 0.9

package require XOTcl

namespace eval ::xotcl::mixinStrategy {
  namespace import ::xotcl::*

  @ @File { description {
    These methods provide support for managing "strategies",  i.e. 
    mixin-classes, where only one kind of a family of conformant 
    mixins should be registered.
    <@p>
    Naming convertions for strategies:
    All strategies must follow the naming convention 'kind=implementation'. 
    Examples are the persistency strategy 'eager' specfied as 
    'persistent=eager' or the persistency strategy 'lazy' (specified as
    'persistent=lazy')
  }}

  @ Object instproc mixinStrategy {strategy "Strategy to be added" } {
    description {
      This method adds or replaces a new strategy from the mixin
      list. Strategies are named following the convention mentioned 
      above.
    }
    return "old strategy"
  }

  Object instproc mixinStrategy {strategy} {
    regexp {:?([^:=]+)=} $strategy _ kind
    set mixins ""
    set oldStrategy ""
    foreach mixin [my info mixin] {
      if {[string match *${kind}=* $mixin]} {
	lappend mixins $strategy
	set oldStrategy $mixin
      } else {
	lappend mixins $mixin
      }
    }
    if {$oldStrategy eq ""} {
      lappend mixins $strategy
    }
    my mixin $mixins
    return $oldStrategy
  }

  @ Object instproc mixinQueryStrategy {kind "strategy kind"} {
    description {
      This method searches the mixin list for a mixin of this
      kind (starting with $kind=)
    }
    return "returns the maching strategy"
  }

  Object instproc mixinQueryStrategy {kind} {
    set m [my info mixin]
    return [::lindex $m [::lsearch -glob $m $kind=*]]
  }

  @ Object instproc add {construct "(inst) 'filter' or 'mixin'" args "to be added"} {
    description "add the specified (inst) 'filters' or 'mixins'"
    return "empty"
  }

  Object instproc add {kind args} {
    if {$kind != {instfilter} && $kind != {instmixin} &&
	$kind != {filter} && $kind != {mixin}} {
      error "Usage: <object> [self proc] <instfilter|instmixin|filter|mixin> ..."
    }
    ::set classes [my info $kind]
    eval ::lappend classes $args
    my $kind $classes
    #puts stderr "$kind of [self] are now: ┬┤[my info $kind]┬┤"
  }
  @ Object instproc remove {construct "(inst) 'filter' or 'mixin'" args "to be removed"} {
    description "remove the specified (inst) 'filters' or 'mixins'"
    return "empty"
  }
  Object instproc remove {kind args} {
    if {$kind != {instfilter} && $kind != {instmixin} &&
	$kind != {filter} && $kind != {mixin}} {
      error "Usage: <object> [self proc] <instfilter|instmixin|filter|mixin> ..."
    }
    ::set classes [my info $kind]
    foreach c $args {
      ::set pos [::lsearch $classes $c]
      if {$pos == -1} { 
	error "$kind ┬┤$c┬┤ could not be removed" 
      } else {
	set $classes [::lreplace $classes $pos $pos]
      }
    } 
    my $kind $classes
    # puts stderr "$kind of [self] are now: ┬┤[my info $kind]┬┤"
  }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































Deleted assets/xotcl1.6.7/lib/package.xotcl.

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
#$Id: package.xotcl,v 1.7 2006/09/27 08:12:40 neumann Exp $
package provide xotcl::package 0.91

package require xotcl::mixinStrategy
package require XOTcl

rename package tcl_package

namespace eval ::xotcl::package {
    namespace import ::xotcl::*

    @ @File {description {
	Represent Tcl package loading command by an XOTcl
	object. Enables tracking, tracing, and verbose output
	of package loading
    }
    }
    @ Object package {
	description {
	    Supports all Tcl package options plus present and verbose.
	}
    }
    @ package proc present {args "packageName or -exact packageName"} {
	description {
	    Check whether a package is present or not. Similar to Tcl's 
	    package present, but works with Tcl < 8.3
	}
    }
    @ package proc verbose {v  "1 or 0"} {
	description {
	    Toggle verbose output on/off. If on, package prints the locations
	    from where packages are loaded to the screen. Default is off.
	}
    } 

    Object package
    package set component .
    package set verbose 0
    package proc unknown args {
      #puts stderr "unknown: package $args"
      namespace eval :: tcl_package $args
    }
    package proc verbose value {
	my set verbose $value
    }
    package proc present args {
	if {$::tcl_version<8.3} {
	    my instvar loaded
	    switch -exact -- [lindex $args 0] {
		-exact  {set pkg [lindex $args 1]}
		default {set pkg [lindex $args 0]}
	    }
	    if {[info exists loaded($pkg)]} {
		return $loaded($pkg)
	    } else {
		error "not found"
	    }
	} else {
	  namespace eval :: tcl_package present $args
	}
    }

    package proc require args {
	my instvar component verbose uses loaded
	set prevComponent $component
	if {[catch {set v [eval package present $args]} msg]} {
	    #puts stderr "we have to load $msg"
	    switch -exact -- [lindex $args 0] {
		-exact  {set pkg [lindex $args 1]}
		default {set pkg [lindex $args 0]}
	    }
	    set component $pkg
	    lappend uses($prevComponent) $component
	    set v [namespace eval :: tcl_package require $args]
	    if {$v ne "" && $verbose} {
		set path [lindex [tcl_package ifneeded $pkg $v] 1]
		puts "... $pkg $v loaded from '$path'"
		set loaded($pkg) $v   ;# loaded stuff needed for Tcl 8.0
	    }
	}
	set component $prevComponent
	return $v
    }

    Object package::tracker
    package::tracker set verbose 0
    package::tracker proc storeEntry {table index} {
	my instvar verbose $table
	set ${table}($index) "[package set component] [info script]"
	if {$verbose} {
	    puts  "... $table $index loaded from [info script]"
	}
    }
    package::tracker proc dump {} {
	my instvar class object instproc proc
	if {[info exist class]}    { parray class }
	if {[info exist object]}   { parray object }
	if {[info exist instproc]} { parray instproc }
	if {[info exist proc]}     { parray proc }
    }
    package::tracker proc start {} {
	::Class  add mixin [self]::M
	::Object add mixin [self]::M
    }

    Class package::tracker::M
    package::tracker::M instproc create {cls args} {
	set table [string tolower [string trimleft [self] :]]
	package::tracker storeEntry $table [lindex $args 0]
	next
	$cls add mixin [self class]
    }
    package::tracker::M instproc instproc args {
	package::tracker storeEntry instproc [self]->[lindex $args 0]
	next
    }
    package::tracker::M instproc proc args {
					    package::tracker storeEntry proc [self]->[lindex $args 0]
					    next
					}

    #package::tracker set verbose 1
    #package::tracker start
    #
    #Class A
    #A instproc p args {
    #    puts A
    #}
    #A proc pp args {
    #    a call 
    #}
    #Object o
    #o proc ppp args {
    #    another call
    #}
    #puts stderr ====================================================
    #package::tracker dump

    #puts stderr AUTO_PATH=$auto_path.

    namespace export package
    namespace eval package {
	namespace export tracker
	namespace eval tracker {
	    namespace export M
	}
    }
}

namespace import ::xotcl::package::*
namespace eval package {
    namespace import ::xotcl::package::package::*
    namespace eval tracker {
	namespace import ::xotcl::package::package::tracker::*
    }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































Deleted assets/xotcl1.6.7/lib/pkgIndex-package.add.

1
package ifneeded xotcl::package 0.91 [list source [file join $dir package.xotcl]]
<


Deleted assets/xotcl1.6.7/lib/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded xotcl::htmllib 0.1 [list source [file join $dir htmllib.xotcl]]
package ifneeded xotcl::metadataAnalyzer 0.84 [list source [file join $dir metadataAnalyzer.xotcl]]
package ifneeded xotcl::mixinStrategy 0.9 [list source [file join $dir mixinStrategy.xotcl]]
package ifneeded xotcl::script 0.9 [list source [file join $dir Script.xotcl]]
package ifneeded xotcl::staticMetadataAnalyzer 0.84 [list source [file join $dir staticMetadata.xotcl]]
package ifneeded xotcl::test 1.38 [list source [file join $dir test.xotcl]]
package ifneeded xotcl::trace 0.91 [list source [file join $dir trace.xotcl]]
package ifneeded xotcl::upvar-compat 1.0 [list source [file join $dir upvarcompat.xotcl]]
package ifneeded xotcl::wafecompat 0.9 [list source [file join $dir wafecompat.tcl]]
package ifneeded xotcl::xodoc 0.84 [list source [file join $dir xodoc.xotcl]]
package ifneeded xotcl::package 0.91 [list source [file join $dir package.xotcl]]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































Deleted assets/xotcl1.6.7/lib/staticMetadata.xotcl.

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
package require -exact xotcl::metadataAnalyzer 0.84
package provide xotcl::staticMetadataAnalyzer 0.84
package require XOTcl

namespace eval ::xotcl::staticMetadataAnalyzer {
  namespace import ::xotcl::*

  @ @File {
    description {
      XOTcl file static analyzer for @ metadata. E.g. used for 
      doumentation with xoDoc. I.e. allows for reading in a 
      file and evaluating the metadata-related info only.
    }
  }

  @ Class StaticMetadataAnalyzer -superclass MetadataAnalyzer {
    description {
      Metadata analyzer class that allows for reading in files
      and  evaluation of the metadata content in the file.
    }
  }

  Class StaticMetadataAnalyzer -superclass MetadataAnalyzer \
      -parameter {{namespace ::}}
  StaticMetadataAnalyzer instproc cmdsplit {cmd} {
    # from Jeffrey's tkcon
    set inc {}
    set cmds {}
    foreach cmd [split [string trimleft $cmd] \n] {
      if {{} ne $inc } {
	append inc \n$cmd
      } else {
	append inc [string trimleft $cmd]
      }
      if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} {
	if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc}
	set inc {}
      }
    }
    if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc}
    return $cmds
  }
  StaticMetadataAnalyzer instproc evaluateCommands {c} {
    my instvar namespace
    foreach command [my cmdsplit $c] {
      #puts stderr "$command==========================="
      if {[regexp "^ *:*@ " $command]} {
	#puts stderr "$command==========================="
	namespace eval $namespace $command
      } elseif {[regexp "^ *package " $command]} {
	#puts stderr "$command==========================="
	namespace eval $namespace [list my handlePackage $command]
      } elseif {[regexp "^ *namespace *eval *(\[^\{\]*) *\{(.*)\}\[^\}\]*$" $command _ namespace nsc]} {
	#puts stderr "$command==========================="
	namespace eval $namespace [list my evaluateCommands $nsc]
      } 
    }
  }


  @ StaticMetadataAnalyzer instproc analyzeFile {name "File name"} {
    description "Analyze a file and build up a token structure for each metadata token in the file."
  }
  StaticMetadataAnalyzer instproc analyzeFile name {
    my set cmd ""

    set t [FileToken create [my autoname t]]  
    $t set name $name
    my set fileToken $t

    set f [open $name r]
    set c [read $f]
    close $f
    ::@ onOff 1
    my evaluateCommands $c
    ::@ onOff 0
  }

  namespace export StaticMetadataAnalyzer
}

namespace import ::xotcl::staticMetadataAnalyzer::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































Deleted assets/xotcl1.6.7/lib/test.xotcl.

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
package provide xotcl::test 1.38
package require XOTcl

namespace eval ::xotcl::test {
  namespace import ::xotcl::*

  @ @File {description {
    Simple regression test support.
  }}

  @ Class Test {
    description {
      Class Test is used to configure test instances, which can 
      be configured by the following parameters:
      <@ul>
      <@li>cmd: the command to be executed</@li>
      <@li>expected: the expected result</@li>
      <@li>count: number of executions of cmd</@li>
      <@li>pre: a command to be executed at the begin of the test (before cmd)</@li>
      <@li>post: a command to be executed after the test (after all cmds)</@li>
      <@li>namespace in which pre, post and cmd are evaluated; default ::</@li>
      </@ul>
      The defined tests can be executed by <@tt>Test run</@tt>
    }
  }

  Class Test -parameter {
    {name ""}
    cmd 
    {namespace ::}
    {verbose 0} 
    {expected 1} 
    {count 1000} 
    msg setResult errorReport
    pre post
  }
  Test set count 0 
  Test proc new args {
    my instvar case ccount name
    if {[my exists case]} {
      if {![info exists ccount($case)]} {set ccount($case) 0}
      set name $case.[format %.3d [incr ccount($case)]]
    } else {
      set name t.[format %.3d [my incr count]]
    }
    eval my create $name -name $name $args
  }
  Test proc run {} {
    set startTime [clock clicks -milliseconds]
    foreach example [lsort [my allInstances]] {
      $example run
    }
    puts stderr "Total Time: [expr {[clock clicks -milliseconds]-$startTime}] ms"
  }
  Test proc _allInstances {C} {
    set set [$C info instances]
    foreach sc [$C info subclass] {
      eval lappend set [my _allInstances $sc]
    }
    return $set
  }
  Test proc allInstances {} {
    return [my _allInstances Test]
  }

  Test instproc call {msg cmd} {
    if {[my verbose]} {puts stderr "$msg: $cmd"}
    namespace eval [my namespace] $cmd
  }
  Test instproc run args {
    my instvar cmd expected pre post count msg
    if {[info exists pre]} {my call "pre" $pre}
    if {![info exists msg]} {set msg $cmd}
    set r [my call "run" $cmd]
    if {[my exists setResult]} {set r [eval [my set setResult]]}
    if {$r == $expected} {
      if {[info exists count]} {set c $count} {set c 1000}
      if {[my verbose]} {
	puts stderr "running test $c times"
      }
      if {$c > 1} {
	#set r0 [time $cmd $c]
	#puts stderr "time {time $cmd $c}"
	set r1 [time {time {namespace eval [my namespace] $cmd} $c}]
	#regexp {^(-?[0-9]+) +} $r0 _ mS0
	regexp {^(-?[0-9]+) +} $r1 _ mS1
	set ms [expr {$mS1*1.0/$c}]
	puts stderr "[my name]:\t[format %6.1f $ms] mms, $msg"
      } else {
	puts stderr "[my name]: $msg ok"
      }
    } else {
      puts stderr "[my name]:\tincorrect result for '$msg'"
      puts stderr "\texpected: '$expected', got '$r' [my exists errorReport]"
      if {[my exists errorReport]} {eval [my set errorReport]}
      exit -1
    }
    if {[info exists post]} {my call "post" $post}
  }
  proc case name {::xotcl::test::Test set case $name}
  namespace export Test
}

namespace import ::xotcl::test::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































Deleted assets/xotcl1.6.7/lib/trace.xotcl.

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
# -*- Tcl -*- $Id: trace.xotcl,v 1.12 2007/08/14 16:38:26 neumann Exp $
package provide xotcl::trace 0.91
package require XOTcl

namespace eval ::xotcl::trace {
  namespace import ::xotcl::*

  @ @File {description {
    Various tracing tools for the XOTcl language.
  }
  }
  @ Object instproc traceFilter {
    args "arbitrary args"
  } {
    Description {
      Filter to trace every method call on an object or class hierarchy.
      Outputs a message befora and after each call of the traced object.
    }
    return "empty string"
  }
  @ Object Trace { 
    Description {
      Write trace outputs and produce statistics. Variable traceStream
      defines where to write trace output (default: stderr).
    }
  }
  @ Trace proc puts {line "output line"} {
    Description {
      Define how traceFilter writes to the output stream. Default:
      write to trace stream.
    }
  }
  @ Trace proc openTraceFile {name "file name"} {
    Description {
      Redirect trace output to file.
    }
  }
  @ Trace proc closeTraceFile {name "file name"} {
    Description {
      Close trace  file and redirect output to stderr.
    }
  }
  @ Object instproc lintFilter {} {
    Description {Experimental lint filter}
  }
  @ Object instproc statFilter {} {
    Description {Experimental statistics filter}
  }
  @ Object instproc showVars {args "ist of variables"} {
    Description {Show the values of the specified variables (or of all variables)
      of an object on stderr.}
  }
  @ Object instproc showMsg {msg "optional output"} {
    Description {Show a message msg with the form "[self] $cls->$method $msg" on stderr.}
  }
  @ Object instproc showClass {} { Description {Show classes and mixins of the object}}
  @ Object instproc showStack {maxDepth "max stack depth, default=100"} { 
    Description {Show callstack up to the specified calldepth.}}
  @ Object instproc showCall {} { Description {Show the current call with the form "[self] $cls->$method $args" on stderr.}}
  @ Object instproc showTimeStart {"?handle?" "Handle object name, optional"} {Description {start a timer}}
  @ Object instproc showTimeEnd {"?handle?" "Handle object name, optional"} {Description {end a timer and show result}}

  ##########################################################################

  proc showCall {} { Trace deprecated-function showCall}
  proc showVars {} { Trace deprecated-function showVars}
  proc showObj {o {printObjectName 1}} { Trace deprecated-function showObj}
  proc showStack {{m 100}} { Trace deprecated-function showStack}


  Object Trace
  Trace set traceStream stderr
  Trace proc openTraceFile name {
    my set traceStream [open $name w]
  }
  Trace proc closeTraceFile {} {
    close $Trace::traceStream
    my set traceStream stderr
  }
  Trace proc puts line {
    puts $Trace::traceStream $line
  }
  Trace proc add {type obj} {
    if {[my isclass $obj]} {
      $obj instfilter add ${type}Filter
    } else {
      $obj filter add ${type}Filter
    }
  }
  Trace proc delete {type obj} {
    if {[my isclass $obj]} {
      $obj instfilter delete ${type}Filter
    } else {
      $obj filter delete ${type}Filter
    }
  }
  Trace proc statReset {} {
    catch {my unset stat}
  }
  Trace proc statReportClass c {
    if {[my exists stat($c)]} {
      puts "\nClass $c: [my set stat($c)] references"
      foreach method [$c info instprocs] {
         set key $c->$method			       
         if {[info exists stat($key)]} {
           puts "\t$key: [my set stat($key)] references"
         } else {
           puts "\t$key: not used"
         }
       }
    } else {
      puts "\nClass $c: not used"
    }
    foreach subclass [lsort [$c info subclass]] {
      my [self proc] $subclass
    }
  }
  Trace proc statReport {} {
    my statReportClass Object
  }
  Trace proc statCount key {
    if {[my exists stat($key)]} {
      my incr stat($key)
    } else {
      my incr set stat($key) 1
    }
  }
  Trace proc deprecated-function {name} {
    puts stderr "Function <$name> is deprecated. Use method with same name instead."
  }



  Object instproc traceFilter args {
    # don't trace the Trace object
    if {[self] eq "::Trace"} {return [next]}
    set context "[self callingclass]->[self callingproc]"
    set method [self calledproc]
    switch -- $method {
      proc -
      instproc {set dargs [list [lindex $args 0] [lindex $args 1] ...] }
      default  {set dargs $args }
    }
    #my showStack
    Trace puts "CALL $context>  [self]->$method $dargs (next=[self next])"
    set result [next]
    Trace puts "EXIT $context>  [self]->$method ($result)"
    return $result
  }

  Object instproc lintFilter args {
    #puts stderr c=[self class],ic[my info class],p=[self calledproc]
    #puts stderr " =====================METHOD='[self calledproc]'"
    my instvar __reported
    switch -exact -- [self calledproc] {
      instvar {
        set ccls [self callingclass]
        set method [self callingproc]

        #puts stderr ccls=$ccls.
        if {$ccls eq ""} { ;## instvar in proc
          set bod [my info body $method]
          set context "proc [self]->$method"
        } else { ;## instvar in instproc
          set bod [$ccls info instbody $method]
          set context "instproc $ccls->$method"
        }
        foreach v $args {
          set vpattern "$v\[^a-zA-Z0-9\]"
          if {[regexp "\[\$\]$vpattern" $bod]} continue
          if {[regexp " *$vpattern" $bod]}  continue
          #if {[regexp "info *exists *$vpattern" $bod]}  continue
          #if {[regexp "append *$vpattern" $bod]}  continue
          #if {[regexp "array.*$vpattern" $bod]}  continue
          if {[info exists __reported($v,$context)]} continue
          set __reported($v,$context) 1
          puts stderr "'$v' of 'instvar $args' is NOT used in\n\
	$context ... {$bod}"
        }
      }
    }
    next
  }
  Object instproc statFilter args {
    # don't return statistics from the Trace object
    #puts stderr "self=[self]"
    if {[self] eq "::Trace"} {return [next]}
    set ccls [self callingclass]
    set cmet [self callingproc]
    set met [self calledproc]
    #::puts stderr "cls=$ccls->$cmet, [self]->$met"
    Trace statCount $ccls
    Trace statCount $ccls->$cmet
    next
  }



  ######################################################################
  # show**** methods
  #
  Object instproc showVars args {
    set msg {}
    if {$args == {}} {
      foreach var [lsort [my info vars]] {
        if {[my array exists $var]} {
          append msg "\n\t$var: "
          #puts stderr "ARRAY $var"
          #puts stderr "ARRAY names <[[self]array names $var]>"
          foreach i [lsort [my array names $var]] {
            append msg $i=[my set ${var}($i)] ", "
          }
        } elseif {[my exists $var]} {
          append msg "\n\t$var: " [list [my set $var]]
        } else {
          append msg "\n\t$var: " UNKNOWN
        }
      }
    } else {
      foreach var $args {
        if {[my array exists $var]} {
          lappend msg $var: ARRAY
        } elseif {[my exists $var]} {
          lappend msg $var: [my set $var]
        } else {
          lappend msg $var: UNKNOWN
        }
      }
    }
    set method [self callingproc]
    set cls [self callingclass]
    puts stderr "[self] $cls->$method $msg"
    #puts stderr "        MIXINS: [my info mixin]"
  }
  Object instproc showMsg msg {
    set method [self callingproc]
    set cls [self callingclass]
    puts stderr "[self] $cls->$method $msg"
  }
  Object instproc showClass {} {
    set method [self callingproc]
    set cls [self callingclass]
    puts stderr "[self] $cls->$method class [my info class]\
	mixins {[my info mixin]}"
  }
  Object instproc showStack {{m 100}} {
    set max [info level]  
    if {$m<$max} {set max $m}
    puts stderr "Call Stack (level: command)"
    for {set i 0} {$i < $max} {incr i} {
      if {[catch {set s [uplevel $i self]} msg]} {
        set s ""
      }
      puts stderr "[format %5d -$i]:\t$s [info level [expr {-$i}]]"
    }
  }
  Object instproc showCall {} {
    set method [self callingproc]
    set cls [self callingclass]
    set args [lreplace [info level -1] 0 0]
    puts stderr "[self] $cls->$method $args"
  }
  Object instproc showTimeStart {{handle __h}} {
    upvar [self callinglevel] $handle obj
    set obj [Object [self]::[my autoname __time]]
    $obj set clicks [clock clicks]
    return
  }
  Object instproc showTimeEnd {{handle __h}} {
    upvar [self callinglevel] $handle obj
    set method [self callingproc]
    set cls [self callingclass]
    set elapsed [expr {([clock clicks]-[$obj set clicks])/1000000.0}]
    puts stderr "[self] $cls->$method: elapsed [format %.2f $elapsed]secs"
    $obj destroy
  }


  ######################################################################


  namespace export showCall showVars showObj showStack Trace
}

namespace import ::xotcl::trace::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/lib/upvarcompat.xotcl.

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
#$Id: upvarcompat.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::upvar-compat 1.0
package require XOTcl

namespace eval ::xotcl::upvar-compat {
    namespace import ::xotcl::*

    @ @File {description {
	Provide a version of upvar and uplevel that provide 
	backward compatibility such that these commands 
	ignore inactive filter and mixin frames (upvar behaves
	 the same whether or not a filter is installed). Newer
	scripts should use <@TT>upvar/uplevel [self callinglevel] var/command</@TT>
	instead.
    } }
}

# Define upvar and uplevel; use the level, if given explizitely:
# otherwise point to the callinglevel from XOTcl
rename ::uplevel ::xotcl::tcl_uplevel
proc ::uplevel {lvl args} {
  set cl [::xotcl::tcl_uplevel 1 ::xotcl::self callinglevel]
  if {[string match #* $cl]} {
    # we were called from XOTcl, use the XOTcl method
    set cmd [concat [list my uplevel $lvl] $args]
  } else {
    # no XOTcl in sight, use tcl variant
    set cmd [concat [list ::xotcl::tcl_uplevel $lvl] $args]
  }
  #puts stderr cmd=$cmd
  set code [catch [list ::xotcl::tcl_uplevel 1 $cmd] msg]
  return -code $code $msg
}

rename ::upvar ::xotcl::tcl_upvar
proc ::upvar {lvl args} {
  set cl [::xotcl::tcl_uplevel 1 ::xotcl::self callinglevel]
  if {[string match #* $cl]} {
    # we were called from XOTcl, use the XOTcl method
    set cmd [concat [list my upvar $lvl] $args]
    #set code [catch {my uplevel $lvl $args} msg]
  } else {
    # no XOTcl in sight, use tcl variant
    set cmd [concat [list ::xotcl::tcl_upvar $lvl] $args]
  }
  set code [catch [list ::xotcl::tcl_uplevel 1 $cmd] msg]
  return -code $code $msg
}

puts stderr HU

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































Deleted assets/xotcl1.6.7/lib/wafecompat.tcl.

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
# $Id: wafecompat.tcl,v 1.4 2006/09/27 08:12:40 neumann Exp $
package provide xotcl::wafecompat 0.9

set WAFELIB        /usr/lib/X11/wafe/
set MODULE_PATH    "$WAFELIB $auto_path" 
set COMPONENT_PATH $WAFELIB/otcl-classes
proc MOTIFPREFIX {} {return {}}
proc requireModules modules {
  global MODULE_PATH 
  foreach {cmd module} $modules {
    if {{} ne [info command $cmd] } continue
    if {[regexp {([A-Za-z1-9]+)Gen} $module _ n] ||
	[regexp {lib([a-z]+)} $module _ n] ||
	[regexp {^(.+)[.]so} $module _ n]
      } {
      set name [string toupper $n]
    }
    foreach path $MODULE_PATH {
      set f $path/tcllib/bin/$module
      if {[set found [file exists $f]]} {
	puts stderr "Loading module $name from $f"
	load $f $name
	break
      }
    }
    if {!$found} { error "Could not find module $module in {$MODULE_PATH}"}
}}
proc requireTclComponents {files} {
  global COMPONENT_PATH _componentLoaded
  foreach component $files {
    if {[info exists _componentLoaded($component)]} continue
    foreach path $COMPONENT_PATH {
      set f $path/$component
      if {[file exists $f]} {
	puts stderr "Loading source file $f"
	uplevel \#0 source $f
	set _componentLoaded($component) $f
	break
      }
    }
    if {![info exists _componentLoaded($component)]} {
      error "Could not find component $component in {$COMPONENT_PATH}"
    }
}}
proc addTimeOut {n cmd} {
  after $n $cmd
}
proc removeTimeOut {n} {
  after cancel $n
}
proc quit {} { exit }
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































Deleted assets/xotcl1.6.7/lib/xodoc.xotcl.

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
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
# $Id: xodoc.xotcl,v 1.7 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::xodoc 0.84
package require -exact xotcl::staticMetadataAnalyzer 0.84
package require xotcl::htmllib
#package require xotcl::trace
package require XOTcl

namespace eval ::xotcl::xodoc {
    namespace import ::xotcl::*

    @ @File {
	description {
	    XOTcl documentation tool. Overloads the command @, which is used
	    as a documentation token. 
	}
    }

    @ Class MetadataTokenHTML {
	description {Instmixin to provide HTML printing. Such instmixins
	    are registered for all token types.
	}
    }
    Class MetadataTokenHTML
    @ MetadataTokenHTML abstract instproc printHTML {} {
	description {Print token to HTML document object}
    }
    MetadataTokenHTML abstract instproc printHTML {}

    @ MetadataTokenHTML instproc getDocPropertiesHTML {} {
	description {
	    Returns list of properties as HTML.
	}
    }

    MetadataTokenHTML instproc getDocPropertiesHTML {htmlDoc} {
	foreach p [my set properties] { 
	    $htmlDoc startTableRow -valign top
	    if {[my exists $p]} {
		$htmlDoc startTableCell -valign top
		$htmlDoc addString "<em> [my capitalize $p]:</em>" 
		$htmlDoc endTableCell

		$htmlDoc startTableCell -valign top
		if {$p eq "errorCodes"} {
		    # Build table cell with list of error codes.
		    foreach {code desc} [my set $p] {
			set code [string map [list < &lt\; > &gt\;] $code]
			set desc [string map [list < &lt\; > &gt\;] $desc]
			$htmlDoc addString "<b>$code</b>: $desc\n<p>"
		    }
		} else {
		    $htmlDoc addString [my set $p]
		}
		$htmlDoc endTableCell
	    }
	    $htmlDoc endTableRow
	}
    }

    MetadataTokenHTML instproc reflowHTML {left paragraph} {
	#set result ""
	#foreach line [split $paragraph \n] {
	#  if {![regexp {^ *$} $line]} {
	#    append result "$left$line<br>\n"
	#  }
	#}
	#return $result
	return $paragraph
    }

    MetadataToken instmixin [concat [MetadataToken info instmixin] MetadataTokenHTML]

    @ Class FileTokenHTML -superclass MetadataTokenHTML
    Class FileTokenHTML -superclass MetadataTokenHTML
    FileTokenHTML instproc printHTML {htmlDoc} {
	$htmlDoc addLineBreak
	$htmlDoc addString "<b> Filename: </b>"
	$htmlDoc addAnchor [my set name] -href [my set name]
	$htmlDoc addLineBreak
	$htmlDoc addLineBreak
	$htmlDoc startTable -border 0
	my getDocPropertiesHTML $htmlDoc
	$htmlDoc endTable
    }

    FileToken instmixin [concat [FileToken info instmixin] FileTokenHTML]

    @ Class ConstraintTokenHTML -superclass MetadataTokenHTML
    Class ConstraintTokenHTML -superclass MetadataTokenHTML
    ConstraintTokenHTML instproc printHTML {htmlDoc} {
	$htmlDoc addAnchor "" -name [my set name]
	$htmlDoc addString "<h2> Constraint: <em> [my set name] </em> </h2>"
	$htmlDoc addLineBreak
	$htmlDoc startTable -border 0
	my getDocPropertiesHTML $htmlDoc
	$htmlDoc endTable
    }

    ConstraintToken instmixin [concat [ConstraintToken info instmixin] ConstraintTokenHTML]

    @ Class ObjTokenHTML -superclass MetadataTokenHTML
    Class ObjTokenHTML -superclass MetadataTokenHTML
    ObjTokenHTML instproc getProcsHTML {htmlDoc} {
	set c ""
	set pl [MetadataToken sortTokenList [my procList]]
	if {[my istype ClassToken]} {
	    set pl [concat [MetadataToken sortTokenList [my instprocList]] $pl]
	}
	foreach p $pl {
	    set pn [$p set name]
	    set label($pn) "<a href=\"#[my set name]-$pn\">$pn</a>"
	}
	foreach l [lsort [array names label]] {
	    if {$c ne ""} {append c ", "}
	    append c $label($l)
	}
	if {$c ne ""} {append c "."}
	$htmlDoc addString "$c"
    }
    
    ObjTokenHTML instproc printHTML {htmlDoc} {
	$htmlDoc addAnchor "" -name [my set name]
	if {[my istype MetaClassToken]} {
	    set start "<h2> MetaClass:"
	} elseif {[my istype ClassToken]} {
	    set start "<h2> Class:"
	} else {
	    set start "<h2> Object:"
	}
	$htmlDoc addString "$start <em> [my set name] </em> </h2>"
	if {[my exists cl]} {
	    $htmlDoc addString "<b>Class</b>: [my set cl]"
	    $htmlDoc addLineBreak
	}
	if {[my exists heritage]} {
	    $htmlDoc addString "<b>Heritage</b>: [my set heritage]"
	    $htmlDoc addLineBreak
	}

	set head ""
	if {[my procList] ne ""} {set head "<b> Procs </b> "}
	if {[my istype ClassToken]} {
	    if {[my instprocList] ne ""} {set head "<b> Procs/Instprocs: </b> "}
	}
	$htmlDoc addString $head
	my getProcsHTML $htmlDoc

	$htmlDoc startTable -border 0
	my getDocPropertiesHTML $htmlDoc
	$htmlDoc endTable
    }

    ObjToken instmixin [concat [ObjToken info instmixin] ObjTokenHTML]

    @ Class MethodTokenHTML -superclass MetadataTokenHTML
    Class MethodTokenHTML -superclass MetadataTokenHTML

    # Prints out method information as HTML.
    MethodTokenHTML instproc printHTML {htmlDoc} {
	#my showVars
	set argText "\n"

	HtmlBuilder args

	set a  "<em>Arguments:</em>"

	set anchor [my set obj]-[my set name]
	$htmlDoc addAnchor "" -name $anchor

	if {[my abstract]} {$htmlDoc addString  "<b><em>abstract</em></b>"}
	$htmlDoc addString  "<b>[my set name] </b>"

	args set indentLevel [$htmlDoc set indentLevel]

	if {[my exists arguments]} {
	    #set argText "<table>\n"
	    foreach {arg argDescription} [my set arguments] {
		if {[llength $arg] > 1} {
		    # A default value was given to the argument.
		    $htmlDoc addString "<em>?[lindex $arg 0]?</em>"
		    set at "<b>?[lindex $arg 0]?</b>:$argDescription Default: \"[lindex $arg 1]\"."
		} else {
		    $htmlDoc addString "<em>$arg</em>"
		    set at "<b>$arg</b>: $argDescription"
		}
		args startTableRow -valign top
		args startTableCell -valign top
		args addString $a
		set a ""
		args endTableCell
		args startTableCell -valign top
		args addString $at
		args endTableCell
		args endTableRow
	    }
	}
	$htmlDoc startTable -border 0
	
	$htmlDoc addString [args toString]
	args destroy

	my getDocPropertiesHTML $htmlDoc

	$htmlDoc endTable

	#$htmlDoc endListItem
    }

    MethodToken instmixin [concat [MethodToken info instmixin] MethodTokenHTML]

    @ Class XODoc { description "Handler class for building a documentation database" }

    Class XODoc -superclass StaticMetadataAnalyzer

    @ XODoc proc documentFileAsHTML {
				     file "filename of the xotcl file to be documented"
				     docdir "directory to which the html file is written"
				 } {
	description "Uses the xoDoc package to produce an HTML documentation of
               a specified file ***.xotcl. The file is written to ***.html
               in docdir"
	return "file basename without suffix"
    }

    XODoc proc documentFileAsHTML {file docdir} {
	set docdb [XODoc [XODoc autoname docdb]]
	::@ set analyzerObj $docdb
	$docdb analyzeFile $file
	set ext [file extension $file]
	if {$ext ne ""} {set ext -[string trimleft $ext .]}
	set docfilename [file rootname [file tail $file]]$ext
	$docdb writeFile ${docdir}/$docfilename.html $file
	$docdb destroy
	return $docfilename
    }

    XODoc instproc printPackages {htmlDoc} {
	my instvar packageList
	$htmlDoc addString "<h2> Package/File Information </h2>"
	if {[llength $packageList] > 0} {
	    foreach t $packageList {
		if {[$t type] eq "provide"} {
		    $htmlDoc addString "<b> Package provided: </b> [$t name] [$t version]"
		} elseif {[$t type] eq "require"} {
		    $htmlDoc addString "<b> Package required: </b> [$t name] [$t version]"
		}
		$htmlDoc addLineBreak
	    }
	} else {
	    $htmlDoc addString "<b> No package provided/required </b>"
	    $htmlDoc addLineBreak
	}
    }

    XODoc instproc printExtensions {htmlDoc} {
	my instvar extensions
	if {[info exists extensions]} {
	    # Add list of extensions.
	    foreach extension $extensions {
		$htmlDoc addLineBreak
		$htmlDoc addString "<h2>Document extension: <em>[$extension name]</em>"
		$htmlDoc addString "<em>Description:</em> [$extension description]"
		$htmlDoc addLineBreak
	    }
	}
    }

    XODoc instproc printObjList {htmlDoc} {
	set objList [MetadataToken sortTokenList [my objList]]

	if {[llength $objList]>0} {
	    $htmlDoc addLineBreak
	    $htmlDoc addString "<b>Defined Objects/Classes: </b>"
	    $htmlDoc startUnorderedList
	    foreach obj $objList {
		set on [$obj set name]
		$htmlDoc startListItem
		$htmlDoc addAnchor "<em>$on</em>:" -href "#$on"
		$obj getProcsHTML $htmlDoc
		$htmlDoc addLineBreak
		$htmlDoc endListItem
	    }
	    $htmlDoc endUnorderedList
	}
    }

    XODoc instproc printFileToken {htmlDoc} {
	if {[my exists fileToken]} {
	    [my set fileToken] printHTML $htmlDoc
	} else {
	    $htmlDoc addString "<b> No file information. </b>\n"
	}
	$htmlDoc addLineBreak
    }

    XODoc instproc printConstraintsList {htmlDoc} {
	set constraintList [MetadataToken sortTokenList [my constraintList]]

	if {[llength $constraintList]>0} {
	    $htmlDoc addLineBreak
	    $htmlDoc addString "<b>Defined Constraints: </b>"
	    $htmlDoc startUnorderedList
	    foreach c $constraintList {
		set cn [$c set name]
		$htmlDoc startListItem
		$htmlDoc addAnchor "<em>$cn</em>:" -href "#$cn"
		$htmlDoc addLineBreak
		$htmlDoc endListItem
	    }
	    $htmlDoc endUnorderedList
	}
    }

    XODoc instproc printConstraints {htmlDoc} {
	foreach c [my set constraintList] {
	    $htmlDoc addHorizontalRule
	    $htmlDoc startParagraph
	    $c printHTML $htmlDoc
	    $htmlDoc endParagraph
	}
	$htmlDoc addLineBreak
    }

    XODoc instproc printProcsList {htmlDoc list string} {
	if {[llength $list] > 0} {
	    $htmlDoc addString "<h3>$string</h3>"
	    $htmlDoc startUnorderedList
	    foreach s $list {
		$htmlDoc startListItem
		$s printHTML $htmlDoc
		$htmlDoc endListItem
	    }
	    $htmlDoc endUnorderedList
	}
    }
    XODoc instproc printObjs {htmlDoc} {
	set objList [MetadataToken sortTokenList [my objList]]

	foreach t $objList {
	    $htmlDoc addHorizontalRule
	    $htmlDoc startParagraph
	    $t printHTML $htmlDoc
	    if {[$t istype ClassToken]} {
		my printProcsList $htmlDoc [$t set instprocList] Instprocs
	    }
	    my printProcsList $htmlDoc [$t set procList] Procs
	    $htmlDoc endParagraph
	}
    }

    XODoc instproc replaceFormatTags {fc} {
	regsub -all <@ $fc < fc
	regsub -all </@ $fc </ fc
	return $fc
    }

    @ XODoc instproc printHTML {
	name "name of the html document"
    } {
	description "Create HTML documentation object from metadata token"
    }
    XODoc instproc printHTML {name} {
	HtmlBuilder htmlDoc
	htmlDoc startDocument -title "XOTcl - Documentation -- $name" \
	    -bgcolor FFFFFF -stylesheet xotcl-doc.css
	htmlDoc addStringIncr "<h1>"
	htmlDoc addImage -src "./logo-100.jpg" -alt "$name" -align MIDDLE 
	htmlDoc addStringDecr "$name</h1>"
	htmlDoc addHorizontalRule
	htmlDoc startParagraph

	my printPackages htmlDoc
	my printExtensions htmlDoc
	my printObjList htmlDoc
	my printConstraintsList htmlDoc
	my printFileToken htmlDoc
	my printObjs htmlDoc
	my printConstraints htmlDoc
	htmlDoc endParagraph
	htmlDoc addHorizontalRule
	htmlDoc startParagraph
	htmlDoc endParagraph
	htmlDoc addAnchor "Back to index page." -href "./index.html"
	htmlDoc addLineBreak
	htmlDoc addHorizontalRule 
	htmlDoc startParagraph 
	htmlDoc endParagraph
	htmlDoc endDocument
	set r [my replaceFormatTags [htmlDoc toString]]
	htmlDoc destroy
	return $r
    }

    @ XODoc instproc writeFile {
	filename "file name destination" name "name of the html document"
    } {
	description "Create HTML docuemntation from metadata token and write to file <filename>"
    }
    XODoc instproc writeFile {filename name} {
	set content [my printHTML $name]
	set f [open $filename w]
	puts $f $content
	close $f
    }

    namespace export \
	MetadataTokenHTML FileTokenHTML ConstraintTokenHTML ObjTokenHTML \
	MethodTokenHTML XODoc
}

namespace import ::xotcl::xodoc::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/patterns/COPYRIGHT.

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
 *  XOTcl - Extended OTcl
 *
 *  Copyright (C) 1999-2008 Gustaf Neumann (a), Uwe Zdun (b)
 *
 * (a) Vienna University of Economics and Business Administration
 *     Dept. of Information Systems / New Media
 *     A-1090, Augasse 2-6
 *     Vienna, Austria
 *
 * (b) University of Essen
 *     Specification of Software Systems
 *     Altendorferstra▀e 97-101
 *     D-45143 Essen, Germany
 *     
 *  Permission to use, copy, modify, distribute, and sell this
 *  software and its documentation for any purpose is hereby granted
 *  without fee, provided that the above copyright notice appear in
 *  all copies and that both that copyright notice and this permission
 *  notice appear in supporting documentation. We make no
 *  representations about the suitability of this software for any
 *  purpose.  It is provided "as is" without express or implied
 *  warranty.
 *
 *
 *  This software is based upon MIT Object Tcl by David Wetherall and
 *  Christopher J. Lindblad, that contains the following copyright
 *  message:
 *
 *   "Copyright 1993 Massachusetts Institute of Technology
 *
 *    Permission to use, copy, modify, distribute, and sell this
 *    software and its documentation for any purpose is hereby granted
 *    without fee, provided that the above copyright notice appear in
 *    all copies and that both that copyright notice and this
 *    permission notice appear in supporting documentation, and that
 *    the name of M.I.T. not be used in advertising or publicity
 *    pertaining to distribution of the software without specific,
 *    written prior permission.  M.I.T. makes no representations about
 *    the suitability of this software for any purpose.  It is
 *    provided "as is" without express or implied warranty."

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































Deleted assets/xotcl1.6.7/patterns/ChainOfResponsibility.xotcl.

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
# $Id: ChainOfResponsibility.xotcl,v 1.4 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::pattern::chainOfResponsibility 0.9
package require XOTcl

namespace eval ::xotcl::pattern::chainOfResponsibility {
    namespace import ::xotcl::*

    Class ChainOfResponsibility -superclass Class

    ChainOfResponsibility instproc chainingFilter args {
	set cp [self calledproc]
	set registrationclass [lindex [self filterreg] 0]
	$registrationclass instvar operations
	#puts stderr "CHAIN [array names [self regclass]::chainedOperations ]---$cp"
	if {[$registrationclass exists chainedOperations($cp)]} {
	    #
	    # a value is found on the chain, if it differs from the failure value !
	    #
	    set failureValue [$registrationclass set chainedOperations($cp)]
	    set r [my $cp $args]
	    if {$r == $failureValue} {
		if {[my exists successor] &&
		    [set s [my set successor]] != ""} {
		    #puts stderr "CHAIN: forwarding to $s"
		    set r [$s $cp $args]
		}
	    }
	    set r ;# return $r
	} else {
	    next ;# return [next]
	}
    }

    ChainOfResponsibility instproc init args {
	my instfilter add chainingFilter
	my parameter {successor}
	# chained operations hold their value of failure
	my array set chainedOperations {}
    }

    ChainOfResponsibility instproc addChainedOperation {name {failureValue ""}} {
	my set chainedOperations($name) $failureValue
    }

    ChainOfResponsibility instproc removeChainedOperation {name} {
	my unset chainedOperations($name)
    }

    namespace export ChainOfResponsibility
}

namespace import ::xotcl::pattern::chainOfResponsibility::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































Deleted assets/xotcl1.6.7/patterns/OnCalleeProxy.xotcl.

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
# $Id: OnCalleeProxy.xotcl,v 1.4 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::pattern::onCalleeProxy 0.8
package require XOTcl

namespace eval ::xotcl::pattern::onCalleeProxy {
    namespace import ::xotcl::*

    Class OnCalleeProxy -superclass Class  

    @ @File {
	description {
	    Simple proxy pattern implementation enhanced with the ability to adapt
	    calls solely for specified calling objects
	    for each calling obj there may be a different delegator obj
	}
    }

    OnCalleeProxy instproc onCalleeProxyFilter args { 
	set o [string trimleft [self callingobject] :]
	my instvar callee
	#puts stderr "[self class]: checking $o -- [self] -- [self calledproc] "
	if {[info exists callee($o)]} {
	    return [::eval [set callee($o)] [self calledproc] $args]
	} else {
	    next
	}
    }

    OnCalleeProxy instproc init args {
	my instfilter add onCalleeProxyFilter
	next
	my instproc setCallee {callingObj a} {
	    my set callee([string trimleft $callingObj :]) $a
	}
    }

    namespace export OnCalleeProxy
}

namespace import ::xotcl::pattern::onCalleeProxy::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































Deleted assets/xotcl1.6.7/patterns/Singleton.xotcl.

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
# $Id: Singleton.xotcl,v 1.7 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::pattern::singleton 0.8
package require XOTcl

namespace eval ::xotcl::pattern::singleton {
    namespace import ::xotcl::*

    Class SingletonBase
    SingletonBase instproc getInstance args {
	my instvar _instance 
	if {[info exists _instance]} {
	    return $_instance
	}
	return ""
    } 


    #
    # A simple pattern mixin that makes a class to a non-specializable singleton
    #
    Class NonSpecializableSingleton -superclass SingletonBase

    NonSpecializableSingleton instproc create args {
	my instvar _instance
	if {![info exists _instance]} {
	    set _instance [self]
	    next
	}
	return $_instance
    }

    NonSpecializableSingleton instproc getInstance {} {
	if {[info exists _instance]} {
	    my instvar _instance
	    return $_instance
	}
	return ""
    }

    #
    # Specializable Singleton 
    #
    Class Singleton -superclass {SingletonBase Class}
    Singleton instproc singletonFilter args {
	switch -exact [self calledproc] {
	    init {
		set registrationclass [lindex [self filterreg] 0]
		$registrationclass instvar _instance
		if {![info exists _instance]} {
		    set _instance [self]
		    next
		} else {
		    my destroy
		}
		return $_instance
	    }
	    default {
		return [next]
	    }
	}
    }

    Singleton instproc init args {
	my instfilter add singletonFilter
	#
	# specialized singletons have to look up the singleton class
	# first
	Class instproc getInstance {} {
	    foreach sc [my info superclass] {
		if {[$sc info class] eq "::Singleton"} {
		    return [$sc getInstance]
		} else {
		    return ""
		}
	    }
	}
	next
    }

    namespace export SingletonBase NonSpecializableSingleton Singleton
}

namespace import ::xotcl::pattern::singleton::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































Deleted assets/xotcl1.6.7/patterns/SortedComposite.xotcl.

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
# $Id: SortedComposite.xotcl,v 1.4 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::pattern::sortedCompositeWithAfter 0.9
package require XOTcl

namespace eval ::xotcl::pattern::sortedCompositeWithAfter {
    namespace import ::xotcl::*

    Class SortedComposite -superclass Class

    @ @File {
	description {
	    Composite pattern enhanced with sorting 
	}
    }

    SortedComposite instproc remove {array element} {
	if {[my exists ${array}($element)]} {
	    my unset ${array}($element)
	}
    }

    SortedComposite instproc addOperations args {
	foreach pair $args {
	    foreach {proc op} $pair {my set operations($proc) $op}
	}
    } 

    SortedComposite instproc removeOperations args {
	foreach op $args {my remove operations $op}
    }

    SortedComposite instproc addAfterOperations args {
	foreach pair $args {
	    foreach {proc op} $pair {my set afterOperations($proc) $op}
	}
    } 
    SortedComposite instproc removeAfterOperations args {
	foreach op $args {my remove afterOperations $op}
    }

    SortedComposite instproc compositeFilter args {
	set registrationclass [lindex [self filterreg] 0]
	set r [self calledproc]
	set result [next]
	if {[$registrationclass exists operations($r)] && [my exists children]} {
	    set method [$registrationclass set operations($r)]
	    foreach object [my set children] {
		eval [self]::$object $method $args
	    }
	}
	if {[$registrationclass exists afterOperations($r)]} {
	    eval my [$registrationclass set afterOperations($r)] $args
	}
	set result
    }

    SortedComposite instproc init args {
	my array set operations {}
	my array set afterOperations {}

	my instproc setChildren args {
	    switch [llength $args] {
		0 { return [my set children] }
		1 { return [my set children [lindex $args 0]] }
		default {error "wrong # args: [self] setChildren ?children?"}
	    }
	}
	my instproc appendChildren args {
	    eval my lappend children $args
	}

	next
	my instfilter add compositeFilter 
    }

    namespace export SortedComposite
}

namespace import ::xotcl::pattern::sortedCompositeWithAfter::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































Deleted assets/xotcl1.6.7/patterns/adapter.xotcl.

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
# $Id: adapter.xotcl,v 1.4 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::pattern::adapter 0.9

package require XOTcl

namespace eval ::xotcl::pattern::adapter {
    namespace import ::xotcl::*

    Class Adapter -superclass Class  

    @ @File {
	description {
	    Simple adapter pattern meta-class taken from the paper 
	    'Filters as a Language Support for Design Patterns in
	    Object-Oriented Scripting Languages'. 
	}
    }

    Adapter instproc adapterFilter args { 
	set r [self calledproc]
	my instvar specificRequest adaptee \
	    [list specificRequest($r) sr]
	if {[info exists sr]} {
	    return [eval $adaptee $sr $args]
	}
	next
    }

    Adapter instproc init args {
	my instfilter add adapterFilter
	next
	my instproc setRequest {r sr} {
	    my set specificRequest($r) $sr
	}
	my instproc setAdaptee {a} {
	    my set adaptee $a
	}
    }

    namespace export Adapter
}

namespace import ::xotcl::pattern::adapter::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































Deleted assets/xotcl1.6.7/patterns/composite.xotcl.

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
# $Id: composite.xotcl,v 1.4 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::pattern::composite  0.9
package require XOTcl

namespace eval ::xotcl::pattern::composite {
    namespace import ::xotcl::*

    Class Composite -superclass Class

    @ @File {
	description {
	    Simple composite pattern meta-class taken from the paper 
	    'Filters as a Language Support for Design Patterns in
	    Object-Oriented Scripting Languages'. 
	}
    }

    Composite instproc addOperations args {
	foreach op $args {
	    if {![my exists operations($op)]} {
		my set operations($op) $op
	    }
	}
    } 

    Composite instproc removeOperations args {
	foreach op $args {
	    if {![my exists operations($op)]} {
		my unset operations($op)
	    }
	}
    }

    Composite instproc compositeFilter args {
	# get the operations class variable from the object's class
	set registrationclass [lindex [self filterreg] 0]
	$registrationclass instvar operations
	# get the request
	set r [self calledproc]

	# check if the request is a registered operation 
	if {[info exists operations($r)]} {
	    foreach object [my info children] {
		# forward request
		eval $object $r $args
	    }
	}
	return [next]    
    }


    Composite instproc init {args} {
	my array set operations {}
	next
	my instfilter add compositeFilter 
    }

    namespace export Composite
}

namespace import ::xotcl::pattern::composite::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































Deleted assets/xotcl1.6.7/patterns/link.xotcl.

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
# $Id: link.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::pattern::link 0.9
package require XOTcl

namespace eval ::xotcl::pattern::link {
    namespace import ::xotcl::*

    #
    # establish/introspect 'link' through link-instproc
    #
    Class Link -parameter {
	{link ""}
    }

    Link instproc adapterFilter args {
	set l [my set link]
	set m [self calledproc]

	# let link/destroy requests go through to the link
	if {$m eq "link" || $m eq "destroy"} {
	    return [next]
	}

	if {[Object isobject $l]} {
	    puts stderr "adapting $m on link [self] -> $l"
	    eval $l $m $args
	} else {
	    # if there is currently no link establish -> return
	    if {$l eq ""} {return}
	    error "Link: object $l is no xotcl object"
	}
    }

    Link instfilter adapterFilter

    # Link L
    # Class A

    # L link A

    # L w

    # w set a 45

    # puts [w set a]

    # puts [L link]

    # #A destroy
    # puts ----1
    # L set r 45
    # puts ----2

    namespace export Link
}

namespace import ::xotcl::pattern::link::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































Deleted assets/xotcl1.6.7/patterns/manager.xotcl.

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
# $Id: manager.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::pattern::manager 0.8
package require XOTcl

namespace eval ::xotcl::pattern::manager {
    namespace import ::xotcl::*

    #
    # a simle manager pattern following buschmann (164) 
    # based on dynamic object aggregation and using dynamic code
    # for supplier creation (instead of loading)
    #
    # it shares the suppliers !
    #

    #
    # abstract supplier, init starts dynamic code creation
    #
    Class Supplier
    Supplier abstract instproc init args
    Supplier abstract instproc m args


    Class Manager -parameter {
	{supplierClass Supplier}
    } 

    Manager instproc getSupplier {name} {
	if {[my info children [namespace tail $name]] != ""} {
	    return [self]::[namespace tail $name]
	} else {
	    return [my [my supplierClass] [namespace tail $name]]
	}
    }

    namespace export Supplier Manager
}

namespace import ::xotcl::pattern::manager::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































Deleted assets/xotcl1.6.7/patterns/observer.xotcl.

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
# $Id: observer.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::pattern::observer 0.8
package require XOTcl

namespace eval ::xotcl::pattern::observer {
    namespace import ::xotcl::*

    Class Observer -superclass Class

    @ @File {
	description {
	    Simple observer pattern meta-class taken from the paper 
	    'Filters as a Language Support for Design Patterns in
	    Object-Oriented Scripting Languages'. 
	}
    }

    Class Observer::Subject -superclass Class

    Observer::Subject instproc notificationFilter {args} {
	set procName [self calledproc]
	my instvar \
	    preObservers  [list preObservers($procName)  preObs] \
	    postObservers [list postObservers($procName) postObs]

	if {[info exists preObs]} {
	    foreach obj $preObs { $obj update [self] $args }
	}
	set result [next]

	if {[info exists postObs]} {
	    foreach obj $postObs { $obj update [self] $args }
	}
	return $result
    }

    Class Observer::SubjectMgt
    Observer::SubjectMgt instproc attach {hook objs} {
	upvar [self callinglevel] $hook observers
	foreach obj $objs {
	    if {![info exists observers] || [lsearch $observers $obj] == -1} {
		lappend observers $obj
	    }
	}
    }
    Observer::SubjectMgt instproc detach {hook objs} {
	upvar [self callinglevel] $hook observers
	if {[info exists observers]} {
	    foreach obj $objs {
		set p [lsearch $observers $obj]
		set observers [lreplace $observers $p $p]
	    }
	}
    }

    Observer::SubjectMgt instproc attachPre {procName args} {
	my instvar preObservers 
	my attach  preObservers($procName) $args
    } 
    Observer::SubjectMgt instproc attachPost {procName args} {
	my instvar postObservers 
	my attach  postObservers($procName) $args
    } 
    Observer::SubjectMgt instproc detachPre {procName args} {
	my instvar preObservers
	my detach  preObservers($procName) $args
    }
    Observer::SubjectMgt instproc detachPost {procName args} {
	my instvar postObservers
	my detach  postObservers($procName) $args
    }

    Observer::Subject instproc init args {
	next
	my superclass [list Observer::SubjectMgt [my info superclass]]
	my instfilter notificationFilter
    }

    Observer instproc timeout t {
	my set timeout $t
    }

    Observer instproc update {subject args} {
	#addTimeOut [my set timeout] "my update $subject $args"
	#$subject getResponse
	# do something with the response
	puts [self]---update
    }

    namespace export Observer
    namespace eval Observer {
	namespace export Subject SubjectMgt
    }
}

namespace import ::xotcl::pattern::observer::*
namespace eval Observer {
    namespace import ::xotcl::pattern::observer::Observer::*
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































Deleted assets/xotcl1.6.7/patterns/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded xotcl::pattern::adapter 0.9 [list source [file join $dir adapter.xotcl]]
package ifneeded xotcl::pattern::chainOfResponsibility 0.9 [list source [file join $dir ChainOfResponsibility.xotcl]]
package ifneeded xotcl::pattern::composite 0.9 [list source [file join $dir composite.xotcl]]
package ifneeded xotcl::pattern::link 0.9 [list source [file join $dir link.xotcl]]
package ifneeded xotcl::pattern::manager 0.8 [list source [file join $dir manager.xotcl]]
package ifneeded xotcl::pattern::observer 0.8 [list source [file join $dir observer.xotcl]]
package ifneeded xotcl::pattern::onCalleeProxy 0.8 [list source [file join $dir OnCalleeProxy.xotcl]]
package ifneeded xotcl::pattern::singleton 0.8 [list source [file join $dir Singleton.xotcl]]
package ifneeded xotcl::pattern::sortedCompositeWithAfter 0.9 [list source [file join $dir SortedComposite.xotcl]]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































Deleted assets/xotcl1.6.7/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
package ifneeded XOTcl 1.6.7 [subst -nocommands {
  load libxotcl[info sharedlibextension] Xotcl
  set __dir__ $dir 
  foreach index [concat \
    [glob -nocomplain [file join $dir * pkgIndex.tcl]] \
    [glob -nocomplain [file join $dir * * pkgIndex.tcl]]] {
    set dir [file dirname \$index]
    source \$index
  }
  set dir \$__dir__ 
  unset __dir__ 
}]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted assets/xotcl1.6.7/rdf/COPYRIGHT.

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
 *  XOTcl - Extended OTcl
 *
 *  Copyright (C) 1999-2008 Gustaf Neumann (a), Uwe Zdun (b)
 *
 * (a) Vienna University of Economics and Business Administration
 *     Dept. of Information Systems / New Media
 *     A-1090, Augasse 2-6
 *     Vienna, Austria
 *
 * (b) University of Essen
 *     Specification of Software Systems
 *     Altendorferstra▀e 97-101
 *     D-45143 Essen, Germany
 *     
 *  Permission to use, copy, modify, distribute, and sell this
 *  software and its documentation for any purpose is hereby granted
 *  without fee, provided that the above copyright notice appear in
 *  all copies and that both that copyright notice and this permission
 *  notice appear in supporting documentation. We make no
 *  representations about the suitability of this software for any
 *  purpose.  It is provided "as is" without express or implied
 *  warranty.
 *
 *
 *  This software is based upon MIT Object Tcl by David Wetherall and
 *  Christopher J. Lindblad, that contains the following copyright
 *  message:
 *
 *   "Copyright 1993 Massachusetts Institute of Technology
 *
 *    Permission to use, copy, modify, distribute, and sell this
 *    software and its documentation for any purpose is hereby granted
 *    without fee, provided that the above copyright notice appear in
 *    all copies and that both that copyright notice and this
 *    permission notice appear in supporting documentation, and that
 *    the name of M.I.T. not be used in advertising or publicity
 *    pertaining to distribution of the software without specific,
 *    written prior permission.  M.I.T. makes no representations about
 *    the suitability of this software for any purpose.  It is
 *    provided "as is" without express or implied warranty."

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































Deleted assets/xotcl1.6.7/rdf/RDFCreator.xotcl.

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
# $Id: RDFCreator.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::rdf::tripleRecreator 0.9
package require XOTcl
package require xotcl::rdf::parser

namespace eval ::xotcl::rdf::tripleRecreator {
    namespace import ::xotcl::*

    Class RDFCreator -parameter {
	{rdfNS "http://www.w3.org/1999/02/22-rdf-syntax-ns#"}
	{openExprs ""}
    }

    Class OpenExpr -parameter {
	{type ""}
	{subject ""}
	{closing ""}
    } 

    RDFCreator instproc init args {
	next
    }

    RDFCreator instproc free {} {
	my instvar openExprs
	while {$openExprs ne ""} {
	    set o [lindex $openExprs 0]
	    set openExprs [lrange $openExprs 1 end]
	    $o destroy
	}
    }

    RDFCreator instproc sort {tl} {
	#
	# this assumes that the triples are created and named in node tree order, e.g. 
	# through autonames like triple0, triple1, ... (as in rdfTripleCreator)
	#
	# => bag types defs are before bag's _1, _2 -- etc.
	#
	# otherwise overload sorting method !
	#
	return [lsort $tl]
    }

    RDFCreator instproc createFromTriples {tripleList} {
	my instvar openExprs
	set heading "<?xml version=\"1.0\"?>\n<RDF
  xmlns:rdf=\"[my set rdfNS]\""
	set body ""
	XMLNamespace [self]::ns
	[self]::ns add rdf [set rdfNS [my rdfNS]]
	my free

	foreach t [my sort $tripleList] {
	    set p [$t predicate]
	    set o [$t object]
	    set s [$t subject]

	    
	    set opening ""
	    set closing ""
	    if {[regexp "(^.*://.*/(\[^/\]+)(/|\#))(\[^/\]+)\$" $p _ ns prefix __ name]} {
		
		if {[string match $rdfNS $ns]} {
		    if {"type" eq $name} {
			if {[regexp "${rdfNS}(RDFAlt|RDFBag|RDFSeq)" $o _ type]} {
			    set opening "\n<rdf:$type ID=\"$s\">"
			    set closing "\n</rdf:$type>"
			}
		    }
		}

		if {[set nsPrefix [[self]::ns searchFullName $ns]] == ""} {
		    [self]::ns add [set nsPrefix [my autoname $prefix]] $ns
		    append heading "\n  xmlns:${nsPrefix}=\"$ns\""
		}
		
		set oe [lindex [my set openExprs] 0]

		if {$oe eq "" || [$oe subject] != $s} {
		    if {$oe ne ""} {
			append body [$oe closing]
			[lindex [set openExprs] 0] destroy
			set openExprs [lrange $openExprs 1 end]
		    }
		    if {$opening eq ""} {
			append body "\n<rdf:Description about=\"$s\">"
			set closing "\n</rdf:Description>"
			set type "Description"
		    } else {
			append body $opening
		    }
		    set noe [my OpenExpr [my autoname oe]]
		    set openExprs [concat $noe $openExprs]
		    
		    $noe subject $s
		    $noe closing $closing
		    $noe type $type
		    set oe $noe
		}
		set tn ${nsPrefix}:$name

		switch -exact [$oe type] {
		    RDFDescription {
			#puts DESCRIPTION
			append body "\n<$tn> [$t object] </$tn>"
		    }
		    RDFAlt - RDFSeq {
			#puts ALT---$tn
			if {[regexp {rdf:_([0-9]*)} $tn _ __]} {
			    append body "\n<rdf:li resource=\"[$t object]\"/>"
			}
		    } 
		    RDFBag {
			if {[regexp {rdf:_([0-9]*)} $tn _ __]} {
			    append body "\n<$tn resource=\"[$t object]\"/>"
			}
		    }
		}
	    } else { 
		puts "Predicate '$p' not matched"
		# hier als xmlns behandeln ...
	    } 
	}
	append heading ">"
	set r $heading
	while {$openExprs ne ""} {
	    set oe [lindex $openExprs 0]
	    set openExprs [lrange $openExprs 1 end]
	    append body [$oe closing]
	    $oe destroy
	}
	append r $body
	append r "\n</RDF>"
	return $r
    }

    namespace export RDFCreator OpenExpr
}

namespace import ::xotcl::rdf::tripleRecreator::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































Deleted assets/xotcl1.6.7/rdf/RDFTriple.xotcl.

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
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
# $Id: RDFTriple.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $
package provide xotcl::rdf::triple 1.0

package require XOTcl
package require xotcl::rdf::parser

namespace eval ::xotcl::rdf::triple {
  namespace import ::xotcl::*

  Class RDFTriple -parameter {
    predicate
    subject
    object
  }

  RDFTriple instproc dump {} {
    #set o [my object]; if {[info command $o] ne ""} { $o showVars  }
    #return "P: [my predicate] S: [my subject] O: [my object]\n"
    return "[my subject] -[my predicate]-> '[my object]'\n"
  }

  Class NodeInfo -parameter {
    lastCurrentNode
    {aboutEach 0}
    {aboutEachPrefix 0}
    topID
    {statements ""}
  }

  Class DescriptionInfo -superclass NodeInfo -parameter {
    {bagID 0}
  }

  Class PropertyInfo -superclass NodeInfo -parameter {
    {reify 0}
    generatedParentID
  }

  Class AboutEachMgr

  AboutEachMgr instproc init args {
    my array set entries {}
    next
  }

  AboutEachMgr instproc reset {} {
    foreach c [my info children] {$c destroy}
    my init
  }

  AboutEachMgr instproc addEntry {name} {
    my set entries($name) ""
  }

  AboutEachMgr instproc isEntry {name} {
    my exists entries($name)
  }

  AboutEachMgr instproc addTriple {name p s o} {
    if {[my exists entries($name)]} {
      set r [RDFTriple create [self]::[my autoname name%08d]]
      $r set predicate $p
      $r set subject $s
      $r set object $o
      my lappend entries($name) $r
      return $r
    }
    return ""
  }

  AboutEachMgr instproc getTriples {name} {
    if {[my exists entries($name)]} {
      my set entries($name)
    } else {return ""}
  }

  Class RDFTripleDB
  RDFTripleDB instproc add {p s o} {
    #my showCall
    set r [RDFTriple create [self]::[my autoname triple%08d]]
    $r set predicate $p
    $r set subject $s
    $r set object $o
    return $r
  }
  RDFTripleDB instproc dump {} {
    #my showCall
    set r ""
    foreach fact [my info children] {append r [$fact dump]}
    return $r
  }
  RDFTripleDB instproc getTriples {} {
    # for the time being: return only children of type RDFTriple
    set ch {}
    foreach c [my info children] {if {[$c istype "RDFTriple"]} {lappend ch $c}}
    return $ch
    #my info children
  }
  RDFTripleDB instproc reset {} {
    #my showCall
    foreach c [my info children] {$c destroy}
    my autoname -reset triple
    #my showMsg "children after reset: <[my info children]>'"
  }
  # return all triples that match the subject
  RDFTripleDB instproc querySubject {s} {
    #my showCall
    set r ""
    foreach t [my info children] {
      if {[string match $s [$t subject]]} {
	lappend r $t
      }
    }
    return $r
  }

  RDFTripleDB instproc queryPredicate {p} {
    #my showCall
    set r ""
    foreach t [my info children] {
      if {[string match $p [$t predicate]]} {
	lappend r $t
      }
    }
    return $r
  }

  RDFTripleDB instproc queryPredicateOnSubject {p s} {
    #my showCall
    foreach t [my querySubject $s] {
      if {[string match $p [$t predicate]]} {
	# there may be only one matching P on a S
	# return the triple
	return $t
      }
    }
    return ""
  }
  RDFTripleDB instproc prettyTriples {} {
    my instvar result
    if {[my exists table]} {my unset table}
    if {[my exists subjectPrinted]} {my unset subjectPrinted}
    set result ""

    foreach triple [lsort [my getTriples]] {
      set subject [$triple set subject]
      set predicate [$triple set predicate]
      set object [$triple set object]

      regexp {^http.*w3[.]org.*(\#.*)$} $predicate _ predicate
      regexp {^http.*w3[.]org.*(\#.*)$} $object _ object
      my lappend table($subject) $predicate $object
    }
    foreach subject [lsort [my array names table]] {
      if {![regexp {^rdfdoc\#} $subject]} { my prettyStatements "" $subject }
    }
    set r $result; set result ""
    foreach subject [lsort [my array names table]] {
      if {![my exists subjectPrinted($subject)]} { 
	my prettyStatements "" $subject 
      }
    }
    if {$result ne ""} {
      append r "\n=================== unreferenced:\n$result"
      
    }
    return $r
  }
  RDFTripleDB instproc prettyStatement {space subject predicate object} {
    my append result "$space   [format %-35s $subject] [format %-25s $predicate] $object\n"
  }
  RDFTripleDB instproc prettyStatements {space subject} {
    if {![my exists table($subject)]} {
      my append result "$space NO VALUE FOR $subject\n"
    } else {
      if {![my exists subjectPrinted($subject)]} {
	my set subjectPrinted($subject) 1
	foreach {predicate object} [my set table($subject)] {
	  my prettyStatement $space $subject $predicate $object
	  if {[regexp {^rdfdoc\#} $object]} {
	    my prettyStatements "$space  " $object
	  }
	}
      }
    }
  }


  Class TripleVisitor -superclass NodeTreeVisitor -parameter {
    {descriptionAsBag 0}
    {currentNode ""}
    parser
    rdfNS
  }

  TripleVisitor instproc getInfo {} {
    my set openNode([my set currentNode])
  }

  TripleVisitor instproc getLastInfo {info} {
    my set openNode([$info set lastCurrentNode])
  }

  TripleVisitor instproc popInfo {objName} {
    set i [my getInfo]
    my set currentNode [$i set lastCurrentNode]
    my unset openNode($objName)
    return $i
  }

  TripleVisitor instproc pushInfo {objName ei} {
    set lce [$ei set lastCurrentNode [my set currentNode]]
    if {$lce ne ""} {
      set lastInfo [my set openNode($lce)]
      $ei aboutEach [$lastInfo aboutEach]
      $ei aboutEachPrefix [$lastInfo aboutEachPrefix]
    }
    my set openNode($objName) $ei
    my set currentNode $objName
  }

  TripleVisitor instproc qualify {obj var} {
    [$obj resolveNS] getFullName $var
  }

  TripleVisitor instproc init args {
    my array set openNode {{} {}}
    RDFTripleDB create [self]::db
    AboutEachMgr create [self]::aboutEach
    AboutEachMgr create [self]::aboutEachPrefix
    next
  }

  TripleVisitor instproc resetWithoutDB args {
    [self]::aboutEach reset
    [self]::aboutEachPrefix reset
    next
  }

  TripleVisitor instproc reset args {
    [self]::db reset
    my resetWithoutDB
    next
  }

  TripleVisitor instproc addDB {p s o} {
    #puts "ADDDB: P<$p> S<$s> O<$o>"
    set info [my getInfo]
    if {$info ne ""} {
      set topID [$info set topID]
      if {[$info aboutEach]} {
	return [[self]::aboutEach addTriple $topID $p $s $o]
      } elseif {[$info aboutEachPrefix]} {
	return [[self]::aboutEachPrefix addTriple $topID $p $s $o]
      }
    }
    return [[self]::db add $p $s $o]
  }

  TripleVisitor instproc checkReification {triple node} {
    # for statements that nest inside a description/property, we remember
    # the statement to be able to reify them
    # (e.g., bag created for description)
    if {$triple ne "" && $node ne ""} {
      set info [my set openNode($node)]
      if {[my isobject $info] && [$info istype NodeInfo]} {
	${info} lappend statements $triple
      }
    }
  }

  TripleVisitor instproc qualifyWithBaseURL v {
    if {[string match "\#*" $v]} {
      return [[my set parser] baseURL]$v
    }
    return $v
  }

  TripleVisitor instproc RDFTag {objName} {
    set ns [$objName resolveNS]
    set rdfNS [$ns searchNamespaceByPrefix rdf]
    if {$rdfNS eq ""} {
      set rdfNS [$ns searchNamespaceByPrefix xmlns]
    }
    my set rdfNS $rdfNS
  }
  TripleVisitor instproc DescriptionNode objName {
    set di [DescriptionInfo create [self]::[my autoname di]]
    $di topID [my qualifyWithBaseURL [$objName getSubject]]
    my pushInfo $objName $di
    #
    # if a description nests inside a Member, we need a triple
    # for the member index (connected to the Description topId)
    #
    if {[namespace tail [[set member [$objName info parent]] info class]] \
	    == "RDFMember"} {
      set bag_ID [[$member info parent] set ID]
      my addDB [my qualify $objName [$member set memberIndex]] \
	  $bag_ID [$di set topID] 
    }
  }

  TripleVisitor instproc handlePCData {objName pcdata} {
    set info [my getInfo]

    if {[set lcn [$info set lastCurrentNode]] == ""} {
      #puts stderr "cannot determine lastCurrentNode from $info"
      #$info showVars
      set selector ""
    } else {
      set selector [namespace tail [$lcn info class]]
    }
    
    switch -exact $selector {
      RDFDescription {
	set triple [my addDB \
			[my qualify $objName [$objName set content]] \
			[$info set topID] $pcdata]
	my checkReification $triple $lcn
      }
      RDFProperty {
	if {[set rAttr [$lcn getRDFAttribute resource]] != ""} {
	  set triple [my addDB \
			  [my qualify $objName [$objName set content]] \
			  [$lcn set $rAttr] $pcdata]
	  #$lcn showVars
	} else {
	  set lastInfo [my getLastInfo $info]
	  if {[$lastInfo exists generatedParentID]} {
	    set parentID [$lastInfo set generatedParentID]
	  } else {
	    set parentID [[$objName info parent] set ID]
	  }
	  #set parentID [$lastInfo set generatedParentID]
	  set triple [my addDB \
			  [my qualify $objName [$objName set content]] \
			  $parentID $pcdata]
	}
      }
      default {
	#puts stderr "create a generatedParentID for reification"
	$info set generatedParentID [[my set parser] makeID]
	set triple [my addDB \
			[my qualify $objName [$objName set content]] \
			[$info set generatedParentID] $pcdata]
	my checkReification $triple [my set currentNode]
      }
    }
    $info set tripleWritten 1
  }

  TripleVisitor instproc Property objName {
    set info [PropertyInfo create [self]::[my autoname pi]]
    ## if we find no subject and are in Container ->
    ## reifiy over generatedParentID
    set propSubject [$objName getSubject]

    $info topID [my qualifyWithBaseURL $propSubject]
    my pushInfo $objName $info
    
    if {[$objName exists pcdata]} {
      my handlePCData $objName [$objName getFirstPCData]
    } 
  }

  TripleVisitor instproc ContainerNode objName {
    set ID [my qualifyWithBaseURL [$objName set ID]]
    foreach t [$objName array names rdfTypes] {
      my addDB [my qualify $objName \
		    [$objName qualifyWithRdfNsPrefix type]] $ID $t
    }
  }

  TripleVisitor instproc Member objName {
    set container [$objName info parent]
    set resource [$objName qualifyWithRdfNsPrefix resource]
    set parseType [$objName qualifyWithRdfNsPrefix parseType]
    if {[$objName exists pcdata]} {
      set co [$objName getFirstPCData]
    } elseif {[$objName exists attributes(resource)]} {
      set co [$objName set attributes(resource)]
    } elseif {[$objName exists attributes($resource)]} {
      set co [$objName set attributes($resource)]
    }
    #puts stderr "CONTAINER = [info exists co]"
    if {[info exists co]} {
      my addDB \
	  [my qualify $container [$objName set memberIndex]] \
	  [$container set ID] $co
    } else {
      #$objName showVars
    }
  }

  TripleVisitor instproc visit objName {
    set cl [namespace tail [$objName info class]]
    $objName instvar attributes
    set triple ""

    #puts "********Visit $objName -- $cl"

    switch -exact $cl {
      RDFTag 		{my RDFTag $objName}
      RDFDescription 	{my DescriptionNode $objName}
      RDFProperty 	{my Property $objName}
      RDFBag - RDFSeq - RDFAlt {my ContainerNode $objName}
      RDFMember 	{my Member $objName}
    }

    foreach a [array names attributes] {
      regexp "^([$objName set rdfNSPrefix]:|)(.*)" $a _ __ an
      switch -exact $an {
	bagID {
	  set info [my getInfo]
	  $info set bagID 1
	}
	aboutEach {
	  set info [my getInfo]
	  if {[DescriptionInfo info instances $info] eq ""} {
	    error "AboutEach not in description"
	  }
	  $info aboutEach 1
	  [self]::aboutEach addEntry [my qualifyWithBaseURL [$objName getSubject]]
	}
	aboutEachPrefix {
	  set info [my getInfo]
	  if {[DescriptionInfo info instances $info] eq ""} {
	    error "AboutEachPrefix not in description"
	  }
	  $info aboutEachPrefix 1
	  [self]::aboutEachPrefix addEntry [my qualifyWithBaseURL [$objName getSubject]]
	}
	resource {
	  if {$cl eq "RDFProperty"} {
	    my handlePCData $objName [set attributes($a)]
	  }
	}
      }
    }
  }

  TripleVisitor instproc reificate {objName p s o} {
    set memberID [[my set parser] makeID]
    my addDB [my qualify $objName \
		  [$objName qualifyWithRdfNsPrefix predicate]] $memberID $p
    my addDB [my qualify $objName \
		  [$objName qualifyWithRdfNsPrefix subject]] $memberID $s
    my addDB [my qualify $objName \
		  [$objName qualifyWithRdfNsPrefix object]] $memberID $o
    my addDB [my qualify $objName \
		  [$objName qualifyWithRdfNsPrefix type]] $memberID \
	[my qualify $objName [$objName qualifyWithRdfNsPrefix Statement]]
    return $memberID
  }

  TripleVisitor instproc visitEnd objName {
    switch -exact [namespace tail [$objName info class]] {
      RDFDescription {
	set di [my popInfo $objName]
	if {[my descriptionAsBag] || [$di set bagID]} {
	  set bagID [$objName set bagID]
	  my addDB [my qualify $objName [$objName qualifyWithRdfNsPrefix type]] \
	      $bagID [my qualify $objName [$objName qualifyWithRdfNsPrefix Bag]]
	  
	  set bagCount 0
	  
	  foreach s [$di set statements] {
	    set memberID [my reificate $objName \
			      [$s set predicate] [$s set subject] [$s set object]]
	    my addDB [my qualify $objName \
			  [$objName qualifyWithRdfNsPrefix _[incr bagCount]]] \
		$bagID $memberID
	  }
	}
	foreach t [$objName array names rdfTypes] {
	  my addDB [my qualify $objName [$objName qualifyWithRdfNsPrefix "type"]] \
	      [$objName getSubject] $t
	}
	$di destroy
      }
      RDFProperty {
	set info [my popInfo $objName]
	if {![$info exists tripleWritten]} {
	  set triple ""
	  foreach fc [$objName info children] {
	    switch -exact [namespace tail [$fc info class]] {
	      RDFDescription {
		set triple [my addDB \
				[my qualify $objName [$objName set content]] \
				[my qualifyWithBaseURL [$objName getSubject]] [$fc getSubject]]
		break
	      }
	      RDFBag - RDFSeq - RDFAlt {
		set triple [my addDB \
				[my qualify $objName [$objName set content]] \
				[my qualifyWithBaseURL [$objName getSubject]] [$fc set ID]]
		break
	      }
	    }
	  }
	  if {$triple ne ""} {
	    my checkReification $triple [my set currentNode]
	  }
	}
	$info destroy
      }
    }
  }

  TripleVisitor instproc evaluateAboutEach {} {
    set triplesWritten ""
    set rdfNSFullName [[my rdfNS] searchPrefix rdf]

    foreach entry [[self]::aboutEach array names entries] {
      # matching entry triples should be bag types and their
      # members -> duplication of aboutEach statements for the
      # members
      foreach entryTriple [lsort [[self]::db querySubject $entry]] {
	if {[regexp "^${rdfNSFullName}_\[0-9\]*$" [$entryTriple predicate]]} {
	  foreach t [[self]::aboutEach getTriples $entry] {
	    set subject [$t subject]
	    # if this is a toplevel elt of an about each tree -> its
	    # subject is the object of the container member
	    if {$subject eq $entry} {
	      [self]::db add [$t predicate] [$entryTriple object] [$t object]
	    } elseif {[lsearch $triplesWritten $t] == -1} {
	      [self]::db add [$t predicate] $subject [$t object]
	      lappend triplesWritten $t
	    }
	  }
	}
      }
    }
  }

  TripleVisitor instproc interpretNodeTree {node} {
    my set parser [$node set parser]
    $node accept [self]
    my evaluateAboutEach
  }

  namespace export RDFTriple NodeInfo DescriptionInfo PropertyInfo \
      AboutEachMgr RDFTripleDB TripleVisitor
}
namespace import ::xotcl::rdf::triple::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/rdf/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded xotcl::rdf::parser 1.0 [list source [file join $dir xoRDF.xotcl]]
package ifneeded xotcl::rdf::recreatorVisitor 0.9 [list source [file join $dir rdfRecreatorVisitor.xotcl]]
package ifneeded xotcl::rdf::triple 1.0 [list source [file join $dir RDFTriple.xotcl]]
package ifneeded xotcl::rdf::tripleRecreator 0.9 [list source [file join $dir RDFCreator.xotcl]]
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























Deleted assets/xotcl1.6.7/rdf/rdfRecreatorVisitor.xotcl.

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
#$Id: rdfRecreatorVisitor.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::rdf::recreatorVisitor 0.9
package require xotcl::rdf::parser
package require xotcl::xml::recreatorVisitor
package require XOTcl

namespace eval ::xotcl::rdf::recreatorVisitor {
    namespace import ::xotcl::*

    ##############################################################################
    #
    # a visitor that recreates an RDF representation from a
    # node tree
    #
    #############################################################################
    Class RDFRecreatorVisitor -superclass XMLRecreatorVisitor
    
    RDFRecreatorVisitor instproc appendLineFeed obj {
	if {[set parseType [$obj getRDFAttribute parseType]] != ""} {
	    if {$parseType ne "Resource"} {
		# we have parseType == Literal 
		# -> don't append "\n"
		return ""
	    } 
	}
	return "\n"
    }

    RDFRecreatorVisitor instproc visit objName {
	next
	my instvar result
	if {[$objName istype RDFResource]} {
	    foreach t [$objName array names rdfTypes] {
		set ts [$objName prependRDFPrefix type]
		append result "  [my insertIndent $objName]<$ts resource=\"$t\"/>\n"
	    }
	}
	return $result
    }

    namespace export RDFRecreatorVisitor
}

namespace import ::xotcl::rdf::recreatorVisitor::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































Deleted assets/xotcl1.6.7/rdf/xoRDF.xotcl.

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
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
# $Id: xoRDF.xotcl,v 1.4 2005/09/09 21:09:01 neumann Exp $
package provide xotcl::rdf::parser 1.0

package require XOTcl
package require xotcl::xml::parser
#package require xotcl::pattern::link
package require xotcl::trace

namespace eval ::xotcl::rdf::parser {
  namespace import ::xotcl::*

  ##############################################################################
  #
  #  RDF Parse Type Handling for RDF Node Class and RDF Parser class
  #  to be used as mixin. Here, we have decomposed the parse type handling
  #
  ##############################################################################

  #
  #  Nodes just call "isParseLiteral", "isParseResource", and "handleParseType"
  #  by their template methods -> mixins concretizes implementation
  #
  Class RDFNodeParseTypeHandling

  #
  # parseType=literal nodes are not parsed, but handled as literals
  # -> the XML parser should parse these nodes -> we have cut them off
  # if we encounter "parseType = literal" nextParsedLiterals searches the
  # parseLiterals array and returns the content
  #
  RDFNodeParseTypeHandling instproc nextParsedLiterals {} {
    set parser [my set parser]
    $parser set parseLiterals([$parser incr parseLiteralsCount])
  }

  #
  # handle attributes that determine the parse type
  #
  RDFNodeParseTypeHandling instproc handleParseType value {
    if {$value eq "Resource"} {
      my set parseResource 1
    } else {
      # with RDF 1.0 all values other than Resource are treated
      # as parseType = literal
      my set pcdata [list "" [my nextParsedLiterals]]
      my set parseLiteral 1
    }
  }

  #
  # two convinience methods that tell us whether the parse type is literal/resource
  #
  RDFNodeParseTypeHandling instproc isParseLiteral {} {
    #
    # if the parse literal var is set -> one child
    # is of type ParseTypeLiteral !
    #
    my exists parseLiteral
  }
  RDFNodeParseTypeHandling instproc isParseResource {} {
    #
    # if the parseResource var is set -> one child
    # is of type ParseTypeResource !
    #
    my exists parseResource
  }

  #
  # and we overload the Parser's parse method in order to cut off
  # all parseType = "Literal", because we have to hinder the XML
  # parser to parse RDF text that is marked as parseType = literal
  # we store the result in an array "parseLiterals" that is used
  # by the RDFNodeParseTypeHandling Mixin
  #
  Class RDFParserParseTypeHandling
  RDFParserParseTypeHandling instproc parse data {
    my array set parseLiterals {}
    my set parseLiteralsCount 0
    set count 0

    set dt $data

    while {[set pt [string first "parseType" $dt]] != -1} {
      # we cut the string off manually, because a regexp is slower
      if {$::tcl_version > 8.0} {
	set last [string first "=" $dt $pt]
      } else {
	set last [string first "=" [string range $dt $pt end]]
	incr last $pt
      }
      set ptStart [expr {[string last "<" [string range $dt 0 $pt]] + 1}]
      set propName [string range $dt $ptStart $pt]
      set blank [string first " " $propName]
      if {$blank != -1} {
	set propName [string range $propName 0 [expr {$blank -1}]]
      }
      set dt [string range $dt $last end]
      # All parse types != Resource treated as literals
      if {![regexp {^= *[\"']Resource} $dt]} {
	regexp -indices ">" $dt idx
	set start [lindex $idx 1]
	if {[regexp -indices "</$propName>" $dt idx]} {
	  set endTagLeft [lindex $idx 0]
	  set literal [string range $dt [expr {$start + 1}] [expr {$endTagLeft - 1}]]
	  set dt [string range $dt $endTagLeft end]
	  my set parseLiterals([incr count]) $literal
	} else {
	  error "end tag for $propName missing"
	}
      }
    }
    next $data
  }

  ##############################################################################
  #
  #  RDFNode Node Class
  #
  ##############################################################################

  Class RDFNode -superclass XMLNode -parameter {
    subject
    {rdfNSPrefix ""}
  }
  @ Class RDFNode -superclass XMLNode {
    description {
      general superclass for RDF nodes
      common properties
    }
  }

  #
  # add mixins for parse type handling
  #
  RDFNode instproc init args {
    next
    my mixin add RDFNodeParseTypeHandling
    set p [my info parent]
    if {[$p exists rdfNSPrefix]} {
      my set rdfNSPrefix [$p set rdfNSPrefix]
      #puts stderr "RDF Prefix defined in [self]->init to [$p set rdfNSPrefix]" 
    }
  }

  RDFNode instproc parseData {text} {
    if {[my isParseLiteral]} {return}
    next
  }

  #
  # try to find the "subject" of the RDF statement ->
  # if it not found on the actual node search the parents
  #
  # per default subject is ""; subclasses add subjects,
  # when they encounter ID, about, ... attrs
  #
  RDFNode instproc getSubject {} {
    for {set o [self]} {![$o istype RDFTag]} {set o [$o info parent]} {
      if {[$o exists subject]} {return [$o set subject]}
    }
    return ""
  }


  #
  # lets the parser construct an unique ID in the parser
  #
  RDFNode instproc makeID {} {
    [my set parser] makeID
  }

  #
  # abstract methods that have to be concretized with parse type handling
  # by a parse type mixin (or in subclass)
  #
  RDFNode abstract instproc isParseLiteral {}
  RDFNode abstract instproc isParseResource {}
  RDFNode abstract instproc handleParseType value

  RDFNode instproc appendRDFType t {
    set t [[my resolveNS] getFullName $t]
    my set rdfTypes($t) 1
  }

  #
  # get a typed node abbreviation -> convert it to
  # a description + a nested rdf:type property
  #
  RDFNode instproc getTypedNode {name attrList} {
    set r [my getNestingNode RDFDescription \
	       [my qualifyWithRdfNsPrefix Description] $attrList]
    $r appendRDFType $name
    set r
  }

  #
  # try to parse children corresponding to parse type or if none is given
  # try to parse a child of type obj -> Description or Container
  #
  RDFNode instproc parseNestedChild {name attrList} {
    if {[my isParseResource]} {
      if {![my exists resourceDescription]} {
	my set resourceDescription \
	    [my getNestingNode RDFDescription \
		 [my qualifyWithRdfNsPrefix Description] {}]
	# we have resolved parseType="resource" with a description
	# -> remove parse type attribute info ... it is not correct anymore,
	# but remember parseResource flag
	if {[my exists attributes(parseType)]} {
	  my unset attributes(parseType)
	}
	if {[my exists attributes([set parseType [my qualifyWithRdfNsPrefix parseType]])]} {
	  my unset attributes($parseType)
	}
      }
      
      set r [[my set resourceDescription] getPropertyNodeChild $name $attrList]
    } elseif {[my isParseLiteral]} {
      set r [self]
      # literal -> do nothing
    } else {
      if {[set node [my isNestingNode $name]] ne ""} {
	set r [my getNestingNode $node $name $attrList]
      } else {
	set r [my getTypedNode $name $attrList]
      }
    }
    return $r
  }

  #
  # step forward in the attrList
  #
  RDFNode instproc nextAttrNode {node attrList index} {
    upvar [self callinglevel] $index i $attrList a
    if {$node ne ""} {
      set a [lreplace $a $i [expr {$i + 1}]]
    } else {
      incr i 2
    }
  }

  #
  # create a child node of Property type and return it
  #
  # don't build a node for "type" properties, but append them to
  # the list
  #
  RDFNode instproc getPropertyNodeChild {name attrList} {
    regexp "^[my set rdfNSPrefix]:(.*)" $name _ name
    set parser [my set parser]
    if {$name eq "type" && [my istype RDFResource]} {
      # seek for resource attribute and append type to list
      set rp [my prependRDFPrefix resource]
      set rdfns [$parser set rdfNamespace]
      foreach {n v} $attrList {
	if {![my istype RDFContainerNodeClass]} {
	  if {$n eq $rp || $n eq "resource"} {
	    foreach c {Bag Alt Seq} {
	      if {$v eq "$rdfns$c"} {
		my class RDF$c
		my set memberNr 0
		my set ID [my set bagID]
		my unset bagID
		my set content [my prependRDFPrefix $c]
		# reclass existing li props to member
		set li [my prependRDFPrefix li]
		foreach child [lsort [my info children]] {
		  if {[namespace tail [$child info class]] eq "RDFProperty"} {
		    if {[$child set content] eq $li || 
			[$child set content] eq "li"} {
		      $child class RDFMember
		      my giveMemberNr $child
		      $child set content $li
		    }
		  }
		}
	      }
	    }
	  }
	}
	my appendRDFType $v
      }
      return [self]
    } else {
      set nf [$parser set nodeFactory]
      set r [$nf getNode RDFProperty [self]::[my nextChild prop] $parser]
      $r set content $name
      $r parseAttributes $name $attrList
      set r
    }
  }

  #
  # property in abbr syntax (as attribute)
  #
  RDFNode instproc propertyAttribute {n v} {
    set r [my getPropertyNodeChild $n ""]
    $r parseData $v
    set r
  }

  #
  # check whether an attribute name matches an attributed RDFNode
  # of this class or not
  # return the corresponding node class
  #
  RDFNode instproc isAttribute {n} {
    regexp "^[my set rdfNSPrefix]:(.*)" $n _ n
    if {[lsearch [[my info class] set attributeList] $n] != -1} {
      return $n
    } elseif {$n eq "xml:lang"} {
      # we create attribute for xml_lang (for recreation purposes)
      return $n
    }
    return ""
  }

  #
  # check if name matches an node class that may be nested in [self]
  #
  RDFNode instproc isNestingNode {n} {
    regexp "^[my set rdfNSPrefix]:(.*)" $n _ n
    set cl [my info class]
    if {[$cl exists nestingList($n)]} {
      return [$cl set nestingList($n)]
    }
    return ""
  }

  RDFNode instproc getNestingNode {node name attrList} {
    set parser [my set parser]
    set nf [$parser set nodeFactory]
    switch [namespace tail $node] {
      "RDFMember" - "RDFProperty" {set objName prop} 
      default {set objName res}
    }
    set r [$nf getNode $node [self]::[my nextChild $objName] $parser]
    $r set content $name
    $r parseAttributes $name $attrList
    set r
  }

  #
  # check whether the RDF namespace is redefined to another prefix
  #
  RDFNode instproc makeIndividualNSEntry {prefix entry} {
    if {$entry eq [[my set parser] rdfNamespace]} {
      if {[my set rdfNSPrefix] eq "" || $prefix ne "xmlns"} {
	my set rdfNSPrefix $prefix
      }
      #puts stderr "RDF Prefix redefined in [self] to $prefix"
    }
    next
  }

  RDFNode instproc qualifyWithRdfNsPrefix t {
    set ns [my set rdfNSPrefix]
    if {$ns eq "xmlns"} {return $t}
    return $ns:$t
  }

  #
  # checks whether a given attribute is part of the attributes array
  # and returns the varname, otherwise ""
  #
  RDFNode instproc getAttribute {n nsFullName} {
    set ns [my resolveNS]
    set xmlns [$ns searchPrefix xmlns]
    if {$xmlns eq $nsFullName && [my exists attributes($n)]} {
      return attributes($n)
    }
    set prefix [$ns searchFullName $nsFullName]
    if {$prefix ne "" &&
	[my exists attributes($prefix:$n)]} {
      return attributes($prefix:$n)
    }
    return ""
  }

  #
  # searches for attribute "n" with rdf namespace prefix
  #
  RDFNode instproc getRDFAttribute {n} {
    if {[my exists attributes($n)]} {
      return [my set attributes($n)]
    }
    set rdfNSPrefix [my set rdfNSPrefix]
    if {$rdfNSPrefix ne "xmlns"} {
      set n $rdfNSPrefix:$n
      if {[my exists attributes($n)]} {
	return [my set attributes($n)]
      }
    }
    return ""
  }

  RDFNode instproc prependRDFPrefix ts {
    set rdfNSPrefix [my set rdfNSPrefix]
    if {$rdfNSPrefix ne "xmlns"} {set ts $rdfNSPrefix:$ts}
    return $ts
  }

  ##############################################################################
  #
  # superclass for all resources (like Description, Alt, Seq, Beg)
  # used directly in the parse tree ... resource nodes are mixed in
  #
  ##############################################################################

  Class RDFResource -superclass RDFNode

  RDFResource instproc print {} {
    set t [my array names rdfTypes]
    if {$t eq ""} {return [next]} else {return "[next]\nTYPES: $t"}
  }


  ##############################################################################
  #
  # superclasses for container node classes (alt seq bag)
  #
  ##############################################################################
  Class RDFContainerNodeClass -superclass RDFResource

  RDFContainerNodeClass instproc init args {
    # cache the member number
    # 0 inidicates, there is currently no member
    next

    my set memberNr 0
    my set ID [my makeID]
    my appendRDFType [my qualifyWithRdfNsPrefix \
			  [[my info class] set content]]
  }

  RDFContainerNodeClass instproc parseAttributes {name attrList} {
    #set index 0
    foreach {n v} $attrList {
      if {[set an [my isAttribute $n]] ne ""} {
	my set attributes($n) $v
	if {$an eq "ID"} {	
	  my set subject $v
	  my set ID [[my set parser] set baseURL]\#$v
	}
      }
      #set attrList [my nextAttrNode $an attrList index]
    }
  }

  RDFContainerNodeClass instproc giveMemberNr {member} {
    set pf [my getContentPrefix]
    if {$pf ne ""} {append pf ":"}
    $member set memberIndex "${pf}_[my incr memberNr]"
  }

  RDFContainerNodeClass instproc parseStart {name attrList} {
    set r [self]
    next
    if {[set node [my isNestingNode $name]] ne ""} {
      set r [my getNestingNode $node $name $attrList]
      if {[namespace tail [$r info class]] eq "RDFMember"} {
	my giveMemberNr $r
      }
    } else {
      set r [my getPropertyNodeChild $name $attrList]
    }
    return $r
  }

  ##############################################################################
  #
  # Concrete Factory for creating RDF-style nodes
  #
  ##############################################################################
  Class RDFNodeClassFactory -superclass XMLNodeClassFactory
  RDFNodeClassFactory instproc content content {
    my set content $content
  }
  RDFNodeClassFactory instproc attributeList attributeList {
    my set attributeList $attributeList
  }
  RDFNodeClassFactory instproc nestingTo nestingTo {
    set name [string trimleft [self] :]
    foreach cl $nestingTo {
      $cl set nestingList([my set content]) $name
    }
  }

  RDFNodeClassFactory proc create args {
    # create the class
    set name [next]
    switch -exact $name {
      RDFDescription - RDFProperty - RDFMember {
	my array set attributeList {}
      }
      RDFMember - RDFProperty {
	my array set nestingList {}
      }
    }
  }
  ##########################################################################
  #
  # now create a factory and build all the node classes
  # needed for the RDF Parser/Interpreter
  #
  ##########################################################################
  RDFNodeClassFactory proc createFactories {} {
    foreach {name superclasses content attributeList} {
      RDFTag 	  RDFNode		        RDF     {}
      RDFBag 	  RDFContainerNodeClass 	Bag     {ID}
      RDFSeq 	  RDFContainerNodeClass 	Seq     {ID}
      RDFAlt 	  RDFContainerNodeClass 	Alt     {ID}
      RDFProperty RDFNode	    	""      {bagID ID resource parseType}
      RDFMember   RDFProperty           li      {resource parseType}
      RDFDescription  RDFResource	Description {ID bagID about type aboutEach aboutEachPrefix}
    } {
      #puts "Create class: $name -superclass $superclasses"
      RDFNodeClassFactory create $name -superclass $superclasses \
	  -content $content \
	  -attributeList $attributeList
    }
  }
  RDFNodeClassFactory createFactories

  #
  # define nesting constraints
  #
  RDFTag nestingTo {}
  RDFBag nestingTo {RDFTag RDFProperty}
  RDFSeq nestingTo {RDFTag RDFProperty}
  RDFAlt nestingTo {RDFTag RDFProperty}
  RDFMember nestingTo {RDFContainerNodeClass RDFBag RDFSeq RDFAlt}
  RDFProperty nestingTo {}
  RDFDescription nestingTo {RDFTag RDFMember RDFProperty}

  ##############################################################################
  #
  # add some methods to the property node class
  #
  ##############################################################################

  RDFProperty instproc parseAttributes {name attrList} {
    set r [self]
    #set index 0
    foreach {n v} $attrList {
      if {[my checkForXmlNS $n $v]} {continue}
      if {[set an [my isAttribute $n]] ne ""} {
	my set attributes($n) $v
	if {$an eq "parseType"} {my handleParseType $v}
      } else {
	if {![info exists abbrvPropResource]} {
	  set abbrvPropResource \
	      [my getNestingNode RDFDescription \
		   [my qualifyWithRdfNsPrefix Description] {}]
	}
	$abbrvPropResource propertyAttribute $n $v
      }
      #set attrList [my nextAttrNode $an attrList index]
    }

    if {[info exists abbrvPropResource]} {
      # if resource attribute is given -> use it for abbr property 
      # description as about attr  
      if {[my exists attributes(resource)]} {
	set about [my set attributes(resource)]
	my unset attributes(resource)
      }
      if  {[my exists attributes([set resource [my qualifyWithRdfNsPrefix resource]])]} {
	set about [my set attributes($resource)]
	my unset attributes($resource)
      }
      if {[info exists about]} {
	$abbrvPropResource set attributes(about) $about
	$abbrvPropResource set subject $about
      }
    }
  }
  RDFProperty instproc parseStart {name attrList} {
    if {[my isParseLiteral]} {return [self]}
    next
    return [my parseNestedChild $name $attrList]
  }

  ##############################################################################
  #
  # add methods to the member class
  #
  ##############################################################################

  RDFMember parameter {
    memberIndex
  }

  RDFMember instproc parseAttributes {name attrList} {
    #set index 0
    foreach {n v} $attrList {
      if {[set an [my isAttribute $n]] ne ""} {
	my set attributes($n) $v
	if {$an eq "parseType"} {my handleParseType $v}
      }
      #set attrList [my nextAttrNode $an attrList index]
    }
  }

  RDFMember instproc print {} {
    return "[next]\nMEMBER-INDEX: [my set memberIndex]"
  }

  ##############################################################################
  #
  # add methods to the description node class
  #
  ##############################################################################

  RDFDescription instproc init {args} {
    next
    set ID [my makeID]
    my set subject $ID
    my set bagID $ID
  }

  RDFDescription instproc parseAttributes {name attrList} {
    set r [self]

    # if the parent is a property with an ID -> use it
    # as description subject
    set ID [my qualifyWithRdfNsPrefix ID]
    set parent [my info parent]
    if {[$parent exists attributes(ID)]} {
      my set subject [$parent set attributes(ID)]
    } elseif {[$parent exists attributes($ID)]} {
      my set subject [$parent set attributes($ID)]
    }

    foreach {n v} $attrList {
      if {[my checkForXmlNS $n $v]} {continue}
      if {[set an [my isAttribute $n]] ne ""} {
	my set attributes($n) $v
	switch -exact $an {
	  about -
	  ID -
	  aboutEach -
	  aboutEachPrefix {
	    my set subject $v
	  }
	  bagID {
	    my set bagID [[my set parser] set baseURL]\#$v
	  }
	  type {
	    my appendRDFType $v
	  }
	}
      } else {
	set r [my propertyAttribute $n $v]
      }
    }
    return $r
  }

  RDFDescription instproc parseStart {name attrList} {
    next
    return [my getPropertyNodeChild $name $attrList]
  }

  ##############################################################################
  #
  # add some methods to the <RDF> node class
  #
  ##############################################################################

  RDFTag parameter {{startTagOn 0}}

  RDFTag instproc match {c} {
    # the prefix of the topnode determines initially how the RDF 
    # namespace is named ... since several examples don't have a 
    # namespace definition for this ns, we set here a default, which
    # may be overridden by ns definitions in the XML text
    if {[regexp {^([^:]*):(.*)} $c _ pre c]} {
      my makeIndividualNSEntry $pre [[my set parser] rdfNamespace]
      #puts stderr "Making RDF namespace entry for <$pre>"
    }
    #puts "Match for $c --- Content: [[my info class] set content]"
    expr {$c eq [[my info class] set content]}
  }

  RDFTag instproc parseStart {name attrList} {
    set parsed 0
    if {[set node [my isNestingNode $name]] ne ""} {
      set r [my getNestingNode $node $name $attrList]
    } else {
      set r [my getTypedNode $name $attrList]
    }
    next
    return $r
  }

  RDFTag instproc parseEnd content {
    if {!([my startTagOn] && [my match $content])} {
      [my errorChild $content]
    }
    next
    self ;# return [self]
  }

  ##############################################################################
  #
  # RDF Factory for creating node objects
  #
  ##############################################################################
  Class RDFNodeFactory -superclass XMLNodeFactory
  RDFNodeFactory create rdfNodeFactory -sharedNodes {RDFDescription RDFTag}


  ##############################################################################
  #
  # RDF parser class used to access the xml parser and produce the
  # rdf node tree
  #
  ##############################################################################
  Class RDFParser -superclass XMLParser -parameter {
    {baseURL "rdfdoc"}
    {rdfNamespace "http://www.w3.org/1999/02/22-rdf-syntax-ns#"}
  }

  RDFParser instproc init args {
    my mixin add RDFParserParseTypeHandling

    ### this special parser handles rdf:RDF tags
    my topLevelHandlerPattern {^([^:]*):RDF|RDF} RDFTag

    next
    my set nodeFactory "rdfNodeFactory"
  }

  RDFParser instproc makeID {} {
    my autoname [my baseURL]\#id
  }

  RDFParser instproc reset {} {
    next
    set id [my baseURL]\#id
    my autoname -reset $id
  }

  RDFParser instproc createTopLevelNode {name attrList} {
    set tn [next]
    #$tn makeIndividualNSEntry xmlns [my set rdfNamespace]
    ### toplevel node must be of type RDFTag
    if {![$tn istype RDFTag]} {
      error "Top level node must be of type RDFTag"
    }
    if {[$tn match $name]} {
      $tn set content $name
      $tn startTagOn 1

      ### use default values for rdf/default (xmlns) namespace
      #my makeIndividualNSEntry rdfs "http://www.w3.org/TR/1999/PR-rdf-schema-19990303#"

      foreach {n v} $attrList {
	if {[$tn checkForXmlNS $n $v]} {continue}
      }
    }
    return $tn
  }

  #RDFParser instproc parse data {
  #  next
  #}

  namespace export RDFNodeParseTypeHandling RDFParserParseTypeHandling \
      RDFNode RDFResource RDFContainerNodeClass RDFNodeClassFactory \
      RDFNodeFactory RDFParser rdfNodeFactory \
      RDFTag RDFBag RDFSeq RDFAlt RDFProperty  RDFMember RDFDescription
}

namespace import ::xotcl::rdf::parser::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/registry/COPYRIGHT.

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
 *  XOTcl - Extended OTcl
 *
 *  Copyright (C) 1999-2008 Gustaf Neumann (a), Uwe Zdun (b)
 *
 * (a) Vienna University of Economics and Business Administration
 *     Dept. of Information Systems / New Media
 *     A-1090, Augasse 2-6
 *     Vienna, Austria
 *
 * (b) University of Essen
 *     Specification of Software Systems
 *     Altendorferstra▀e 97-101
 *     D-45143 Essen, Germany
 *     
 *  Permission to use, copy, modify, distribute, and sell this
 *  software and its documentation for any purpose is hereby granted
 *  without fee, provided that the above copyright notice appear in
 *  all copies and that both that copyright notice and this permission
 *  notice appear in supporting documentation. We make no
 *  representations about the suitability of this software for any
 *  purpose.  It is provided "as is" without express or implied
 *  warranty.
 *
 *
 *  This software is based upon MIT Object Tcl by David Wetherall and
 *  Christopher J. Lindblad, that contains the following copyright
 *  message:
 *
 *   "Copyright 1993 Massachusetts Institute of Technology
 *
 *    Permission to use, copy, modify, distribute, and sell this
 *    software and its documentation for any purpose is hereby granted
 *    without fee, provided that the above copyright notice appear in
 *    all copies and that both that copyright notice and this
 *    permission notice appear in supporting documentation, and that
 *    the name of M.I.T. not be used in advertising or publicity
 *    pertaining to distribution of the software without specific,
 *    written prior permission.  M.I.T. makes no representations about
 *    the suitability of this software for any purpose.  It is
 *    provided "as is" without express or implied warranty."

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































Deleted assets/xotcl1.6.7/registry/Registry.xotcl.

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
package provide xotcl::registry::registry 0.8

package require xotcl::trace
package require xotcl::rdf::triple
package require xotcl::rdf::tripleRecreator
package require xotcl::actiweb::agent
package require XOTcl

namespace eval ::xotcl::registry::registry {
    namespace import ::xotcl::*

    Class Registry -superclass Agent

    Registry instproc init args {
	next
	my exportProcs register query queryProperty
	RDFParser [self]::parser
	TripleVisitor [self]::tripleVisitor -parser [self]::parser
	[self]::tripleVisitor descriptionAsBag 0
	my array set services {}
    }

    Registry instproc register {rdfScript} {
	#my showCall
	[[self]::tripleVisitor set parser] parse $rdfScript
	[self]::tripleVisitor interpretNodeTree [self]::parser::topNode
	[self]::tripleVisitor resetWithoutDB
	foreach serviceTriple [[self]::tripleVisitor::db queryPredicate \
				   "http://nestroy.wi-inf.uni-essen.de/schema/service#name"] {
	    set service [$serviceTriple object]
	    if {[info exists services($service)]} {
		puts stderr "we have already such a service '$service'"
		# hier koennte man ueberlegen, den service zu loeschen oder nicht
		# zZT: loesche altes service
	    }
	    puts stderr "REGISTRY: registering $service with [$serviceTriple subject]"
	    my set services($service) [$serviceTriple subject];
	}
    }

    Registry instproc query {service} {
	my showCall
	if {[info exists services($service)]} {
	    set s [my set services($service)]
	    return [[Place getInstance]::rdfCreator createFromTriples [[self]::tripleVisitor::db querySubject $s]]
	}
    }

    Registry instproc queryProperty {args} {
	# returns first service with matching properties
	my showCall
	foreach s [my array names services] {
	    set success 1
	    foreach {att value} $args {
		set t [[self]::tripleVisitor::db queryPredicateOnSubject $att [my set services($s)]]
		if {$t eq "" || [$t object] != $value} {
		    set success 0
		    break
		}
	    }
	    if {$success} {
		set r [my query $s]
		return $r
	    } else {
		return ""
	    }
	}
    }

    namespace export Registry
}

namespace import ::xotcl::registry::registry::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































Deleted assets/xotcl1.6.7/registry/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded xotcl::registry::registry 0.8 [list source [file join $dir Registry.xotcl]]
<
<
<
<
<
<
<
<
<
<
<






















Deleted assets/xotcl1.6.7/serialize/COPYRIGHT.

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
 *  XOTcl - Extended OTcl
 *
 *  Copyright (C) 1999-2008 Gustaf Neumann (a), Uwe Zdun (b)
 *
 * (a) Vienna University of Economics and Business Administration
 *     Dept. of Information Systems / New Media
 *     A-1090, Augasse 2-6
 *     Vienna, Austria
 *
 * (b) University of Essen
 *     Specification of Software Systems
 *     Altendorferstra▀e 97-101
 *     D-45143 Essen, Germany
 *     
 *  Permission to use, copy, modify, distribute, and sell this
 *  software and its documentation for any purpose is hereby granted
 *  without fee, provided that the above copyright notice appear in
 *  all copies and that both that copyright notice and this permission
 *  notice appear in supporting documentation. We make no
 *  representations about the suitability of this software for any
 *  purpose.  It is provided "as is" without express or implied
 *  warranty.
 *
 *
 *  This software is based upon MIT Object Tcl by David Wetherall and
 *  Christopher J. Lindblad, that contains the following copyright
 *  message:
 *
 *   "Copyright 1993 Massachusetts Institute of Technology
 *
 *    Permission to use, copy, modify, distribute, and sell this
 *    software and its documentation for any purpose is hereby granted
 *    without fee, provided that the above copyright notice appear in
 *    all copies and that both that copyright notice and this
 *    permission notice appear in supporting documentation, and that
 *    the name of M.I.T. not be used in advertising or publicity
 *    pertaining to distribution of the software without specific,
 *    written prior permission.  M.I.T. makes no representations about
 *    the suitability of this software for any purpose.  It is
 *    provided "as is" without express or implied warranty."

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































Deleted assets/xotcl1.6.7/serialize/RecoveryPoint.xotcl.

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
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
# $Id: RecoveryPoint.xotcl,v 1.4 2006/02/18 22:17:33 neumann Exp $

package provide xotcl::scriptCreation::recoveryPoint 0.8
package require XOTcl

namespace eval ::xotcl::scriptCreation::recoveryPoint {
    namespace import ::xotcl::*

    ## fehlt noch: filter, mixins, metadata, ass, assoption, etc
    ## beim recover Class's,Object's proc instproc vars nicht ueberschreiben
    ## filter dann anhaengen etc ...
    ## der Recovery Filter darf durch Object filter "" nicht gel├Âscht werden

    #
    # filter to ensure that recovering doesn't overwrite 
    # existing objs/classes
    #

    Object instproc recoveryFilter args {
	::set method [self calledproc] 

	switch -- $method {
	    create {
		# don't overwrite objects
		if {![::Object isobject [lindex $args 0]]} {
		    next
		} else {
		    # puts stderr "Recovery Filter: omitting [lindex $args 0]"
		}
	    }
	    proc {
		if {[lsearch [my info procs] [lindex $args 0]] == -1} {
		    next
		} else {
		    # puts stderr "Recovery Filter: omitting proc [self]::[lindex $args 0]"
		}	
	    }
	    instproc {
		if {[lsearch [my info instprocs] [lindex $args 0]] == -1} {
		    next
		} else {
		    # puts stderr "Recovery Filter: omitting instproc [self]::[lindex $args 0]"
		}
	    }
	    set {
		if {[lsearch [my info vars] [lindex $args 0]] == -1} {
		    next
		} else {
		    # puts stderr "Recovery Filter: omitting var [self]::[lindex $args 0]"
		}
	    }
	    default  {next}
	}
    }

    #
    # remove filter from object
    #
    Object instproc filterremove f {
	::set fl [my info filter]
	puts stderr "filterremove on [self] with $f; fullName: [my filtersearch $f]" 
	while {[::set index [lsearch $fl [my filtersearch $f]]] != -1} {
	    ::set fl [lreplace $fl $index $index]
	}
	my filter $fl
    }

    #
    # remove mixin from object
    #
    Object instproc mixinremove m {
	puts stderr "mixinremove on [self] with $m" 
	::set ml [my info mixins]
	while {[::set index [lsearch $ml $m]] != -1} {
	    ::set ml [lreplace $ml $index $index]
	}
	my mixin $ml
    }

    Class RecoveryPoint \
	-parameter {
	    {appendedObjs ""} 
	    {appendedCls ""} 
	    {appendedNamespaces ""} 
	    {withState 0}
	    {appendToFile 0}
	    {definedObjs [list Object \
			      Class \
			      Class::Parameter]}
	    {excludeNames ""}
	}

    #
    # queries the definedObjs variable whether a given object
    # is already defined/predefined or not  
    # -> a way to exclude classes/objs from saving
    #
    RecoveryPoint instproc isDefined {n} {
	my instvar definedObjs
	puts stderr "Checking Defined: $n in $definedObjs"
	if {[lsearch $definedObjs [string trimleft $n :]] == -1} {
	    return 0
	} else {
	    return 1
	}
    }

    RecoveryPoint instproc appendDefined {n} {
	my instvar definedObjs
	lappend definedObjs [string trimleft $n :]
    }

    #
    # check whether an obj/cls/namespace is appended already
    # append obj/cls/namespace 
    #
    foreach method {Obj Cl Namespace} {
				       set r {
					   my instvar {appended${method}s name}}
				       set r [subst -nocommands -nobackslash $r]
				       
				       set s $r
				       append s {
					   if {[lsearch $name [string trimleft $n :]] == -1} {
					       return 0
					   } else {
					       return 1
					   }
				       }

				       RecoveryPoint instproc isAppended$method {n} $s

				       append r {
					   lappend name [string trimleft $n :]
				       }
				       RecoveryPoint instproc append$method {n} $r
				   }
    

    #
    # compare command for lsort  
    #
    RecoveryPoint instproc namespaceDepth {a b} {
	set aCount 0
	set bCount 0
	for {set i 0} {$i < [string length $a]} {incr i} {
	    if {[string index $a $i] eq ":"} {
		incr aCount
	    }
	}
	for {set i 0} {$i < [string length $b]} {incr i} {
	    if {[string index $b $i] eq ":"} {
		incr bCount
	    }
	}
	if {$aCount == $bCount} {
	    return 0
	} elseif {$aCount > $bCount} {
	    return 1
	}
	
	return -1
    } 

    #
    # produces a script containing the current state of 
    # the given obj
    #
    RecoveryPoint instproc stateScript {obj} {
	set script ""
	foreach v [$obj info vars] {
	    if {[lsearch [my set excludeNames] $v] == -1} {
		$obj instvar $v
		if {[array exists $v]} {
		    foreach name [array names $v] {
			set arr ${v}($name)
			set value [$obj set $arr]
			append script "$obj set $arr \"$value\"\n"
		    }
		} else {
		    set value [set $v]
		    append script "$obj set $v \"$value\"\n"
		}
	    }
	}
	return $script
    }

    #
    # produces a script containing the procs of the given obj
    #
    RecoveryPoint instproc procScript {obj} {
	set script ""
	foreach p [$obj info procs] {
	    if {[lsearch [my set excludeNames] $v] == -1} {
		append script \
		    "$obj proc $p \{[$obj info args $p]\} \{[$obj info body $p]\}\n"
	    }
	}
	return $script
    }

    #
    # produces a script containing the instprocs of the given class
    #
    RecoveryPoint instproc instprocScript {cl} {
	set script ""
	foreach p [$cl info instprocs] {
	    if {[lsearch [my set excludeNames] $v] == -1} {
		append script \
		    "$cl instproc $p \{[$cl info instargs $p]\} \{[$cl info instbody $p]\}\n"
	    }
	}
	return $script
    }

    #
    # append parent obj/classes/namespaces of an object completly
    #

    RecoveryPoint instproc appendParents {name} {
	# puts stderr "Recovery -- appendParents $name "
	set p ""
	set script ""

	set n $name
	while {[set np [namespace parent ::$n]] != "::"} {
	    lappend p $np
	    set n $np
	}    
	set p [lsort -command {[self] namespaceDepth} $p]

	foreach n $p {
	    if {[Object isobject $n]} {
		if {[$n isclass]} {
		    append script [my classScript $n]
		} else {
		    append script [my objectScript $n]
		}
	    } else {
		if {![my isAppendedNamespace $n]} {
		    append script "namespace eval $n \{\}\n"
		    # puts stderr "Recovery -- Appending Namespace: $n"
		    my appendedNamespace $n
		}        
	    }
	}
	return $script
    }


    #
    # produces a script recovering the given obj with all children
    # without state
    #
    RecoveryPoint instproc objectScript {obj} {
	# puts stderr "Recovery -- Object Script $obj"
	my instvar withState
	set script ""
	if {![my isDefined $obj] && 
	    ![my isAppendedObj $obj]} {
	    # if the object's class is not yet appended => do it now
	    set objClass [$obj info class]
	    append script [my classScript $objClass]

	    # append all parent namespaces
	    append script [my appendParents $obj]

	    # append the obj
	    append script "$objClass $obj\n"
	    append script [my procScript $obj]
	    if {$withState == 1} {
		append script [my stateScript $obj]
	    }
	    # puts stderr "Recovery -- Appending Object: $obj"
	    my appendObj $obj

	    # append its children
	    foreach o [$obj info children] {
		append script [my objectScript $o]
	    }
	}
	return $script
    }

    #
    # produces a script recovering the given class with all children
    # without state
    #
    RecoveryPoint instproc classScript {cl} {
	# puts stderr "Recovery -- Class Script $cl"
	my instvar withState
	set script ""
	if {![my isDefined $cl] &&
	    ![my isAppendedCl $cl]} { 
	    # if the class's meta-class is not yet appended => do it now
	    set metaClass [$cl info class]
	    append script [my classScript $metaClass]

	    # append all parent namespaces
	    append script [my appendParents $cl]

	    # append the class
	    append script "$metaClass $cl"

	    set sl [$cl info superclass]
	    if {$sl ne ""} {
		append script " -superclass \{$sl\}\n"
	    } else {
		append script "\n"
	    }

	    append script [my instprocScript $cl]
	    append script [my procScript $cl]

	    if {$withState == 1} {
		append script [my stateScript $cl]
	    }

	    # puts stderr "Recovery -- Appending Class: $cl \n $script"
	    my appendCl $cl

	    # append children
	    set children [$cl info children]
	    set classChildren [$cl info classchildren]

	    foreach c $children {
		if {[lsearch $classChildren $c] != -1} {
		    append script [my classScript $c]
		} else {
		    append script [my objectScript $c]
		}
	    }
	}
	return $script
    }

    #
    # produces a script recovering the given class and all subclasses 
    # with all their children and all instances
    #
    #
    RecoveryPoint instproc hierarchyScript {cl} {
	set script [my classScript $cl]
	set sortedInstances \
	    [lsort -command {[self] namespaceDepth} [$cl info instances]]

	foreach o $sortedInstances {
	    append script [my objectScript $o]
	}

	foreach c [$cl info subclass] {
	    append script [my hierarchyScript $c]
	}

	return $script
    }

    #
    # saves a script to a file
    #
    RecoveryPoint instproc saveScript {filename script} {
	my instvar appendToFile
	if {$appendToFile} {
	    set mode a
	} else {
	    set mode w
	}
	set f [open $filename $mode]
	puts $f $script
	close $f
    }

    #
    # load a script from a file
    #
    RecoveryPoint instproc loadScript {filename} {
	set f [open $filename r]
	set r [read $f]
	close $f
	return $r
    }

    #
    # produce methods to save/recover an object script to/from a file 
    # with/without state/only state
    #

    foreach method {
	Object ObjectState ObjectWithState Class ClassWithState \
	    Hierarchy HierarchyWithState
    } {
       set s {
	   my set withState
       }

       if {[regexp {(.*)WithState} $method _ m]} {
	   set call $m
	   append s "1"
       } else {
	   set call $method
	   append s "0"
       }

       scan $call %c l
       set ::low "[format %c [expr {$l + 32}]][string range $call 1 end]"

       append s {
	   my appendedObjs ""
	   my appendedCls ""
	   my appendedNamespaces ""
       }
       append s "
    foreach a \$args \{"
       set r {      
	   set script [my ${low}Script }
	   set r [subst -nocommands -nobackslash $r]
	   append s $r
	   append s {$a] 
	   my saveScript $filename $script}
       append s "
    \}
  "

       RecoveryPoint instproc save$method {filename args} $s
   }

    RecoveryPoint instproc recover {filename} {
	set r [my loadScript $filename]
	Object filterappend recoveryFilter
	# puts stderr "RecoveryFilter appended for $filename" 
	eval $r
	Object filterremove recoveryFilter
	# puts stderr "RecoveryFilter removed for $filename" 
	return
    }

    namespace export RecoveryPoint
}

namespace import ::xotcl::scriptCreation::recoveryPoint::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/serialize/ScriptCreator.xotcl.

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
# $Id: ScriptCreator.xotcl,v 1.4 2006/02/18 22:17:33 neumann Exp $

package provide xotcl::scriptCreation::scriptCreator 0.8
package require XOTcl

namespace eval ::xotcl::scriptCreation::scriptCreator {
    namespace import ::xotcl::*

    Class ScriptCreator \
	-parameter {
	    {excludedObjs {Object Class Class::Parameter}}
	    {excludeNames ""}
	    {dependencyChecking 1}
	}


    #
    # queries the excludedObjs variable whether a given object
    # is already defined/predefined or not  
    # -> a way to exclude classes/objs from saving
    #
    ScriptCreator instproc isExcluded {n} {
	my instvar excludedObjs
	#puts stderr "Checking Excluded: $n in $excludedObjs"
	if {[lsearch $excludedObjs [string trimleft $n :]] == -1} {
	    return 0
	} else {
	    return 1
	}
    }

    ScriptCreator instproc appendExcluded {n} {
	my instvar excludedObjs
	lappend excludedObjs [string trimleft $n :]
    }

    #
    # compare command for lsort  
    #
    ScriptCreator instproc namespaceDepth {a b} {
	set aCount 0
	set bCount 0
	for {set i 0} {$i < [string length $a]} {incr i} {
	    if {[string index $a $i] eq ":"} {
		incr aCount
	    }
	}
	for {set i 0} {$i < [string length $b]} {incr i} {
	    if {[string index $b $i] eq ":"} {
		incr bCount
	    }
	}
	if {$aCount == $bCount} {
	    return 0
	} elseif {$aCount > $bCount} {
	    return 1
	}
	
	return -1
    } 

    #
    # produces a script containing the current state of 
    # the given obj
    #
    ScriptCreator instproc stateScript {obj} {
	set script ""
	foreach v [$obj info vars] {
	    if {[lsearch [my set excludeNames] $v] == -1} {
		if {[$obj array exists $v]} {
		    foreach name [$obj array names $v] {
			set arr ${v}($name)
			set value [$obj set $arr]
			append script "$obj set $arr \"$value\"\n"
		    }
		} else {
		    set value [$obj set $v]
		    append script "$obj set $v \"$value\"\n"
		}
	    }
	}
	return $script
    }

    #
    # produces a script containing the procs of the given obj
    #
    ScriptCreator instproc procScript {obj} {
	set script ""
	foreach p [$obj info procs] {
	    if {[lsearch [my set excludeNames] $p] == -1} {
		append script \
		    "$obj proc $p \{[$obj info args $p]\} \{[$obj info body $p]\}\n"
	    }
	}
	return $script
    }

    #
    # produces a script containing the instprocs of the given class
    #
    ScriptCreator instproc instprocScript {cl} {
	set script ""
	foreach p [$cl info instprocs] {
	    if {[lsearch [my set excludeNames] $p] == -1} {
		append script \
		    "$cl instproc $p \{[$cl info instargs $p]\} \{[$cl info instbody $p]\}\n"
	    }
	}
	return $script
    }



    #
    # saves a script to a file
    #
    ScriptCreator instproc saveScript {filename script} {
	set f [open $filename w]
	puts $f $script
	close $f
    }

    #
    # load a script from a file
    #
    ScriptCreator instproc loadScript {filename} {
	set f [open $filename r]
	set r [read $f]
	close $f
	return $r
    }

    #
    # check parent obj/classes/namespaces of an object completly
    #
    ScriptCreator instproc checkParents {name} {
	set p ""

	set n $name
	while {[set np [namespace parent ::$n]] != "::"} {
	    lappend p $np
	    set n $np
	}    
	set p [lsort -command {my namespaceDepth} $p]

	foreach n $p {
	    if {![my isExcluded $n] &&
		![my isAppended $n]} {
		error "ScriptCreator: $name needs parent $n, neither appended nor excluded yet."
	    }
	}
    }

    ScriptCreator instproc checkClass {obj class} {
	if {![my isExcluded $class] &&
	    ![my isAppended $class]} {
	    error "ScriptCreator: $obj depends on $class, neither appended nor excluded yet."
	}
    }

    ScriptCreator instproc isAppended name {
	set n [string trimleft $name :]
	if {[lsearch [my set appendedNames] $n]!=-1} {
	    return 1
	} else {
	    return 0
	}
    }

    ScriptCreator instproc appendName name {
	set n [string trimleft $name :]
	my lappend appendedNames $n
    }

    ScriptCreator instproc makeScript args {
	my instvar dependencyChecking
	my set appendedNames ""
	set script ""
	foreach name $args {
	    #puts stderr "Script Creator -- $name"
	    if {![my isExcluded $name] && 
		![my isAppended $name]} {
		
		if {$dependencyChecking} {
		    my checkParents $name
		}
		if {[Object isobject $name]} {
		    set class [$name info class]
		    if {$dependencyChecking} {
			my checkClass $name $class
		    }
		    if {[Object isclass $name]} {
			# append the class
			#puts stderr "Appending Class: $name"
			append script "[$name info class] $name"
			set sl [$name info superclass]
			if {$dependencyChecking} {
			    foreach c $sl {
				my checkClass $name $c
			    }
			}
			if {$sl ne ""} {
			    append script " -superclass \{$sl\}\n"
			} else {
			    append script "\n"
			}
			append script [my instprocScript $name]
		    } else {
			# append the obj
			#puts stderr "Appending Object: $name"
			append script "[$name info class] $name\n"
		    }
		    append script [my procScript $name]
		} else {
		    append script "namespace eval $name \{\}\n"
		    #puts stderr "Appending Namespace: $name"
		}
		my appendName $name
	    }
	}
	return $script
    }

    namespace export ScriptCreator
}

namespace import ::xotcl::scriptCreation::scriptCreator::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/serialize/Serializer.xotcl.

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
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
# $Id: Serializer.xotcl,v 1.19 2007/10/05 09:06:00 neumann Exp $
package require XOTcl 1.5
package provide xotcl::serializer 1.0

namespace eval ::xotcl::serializer {

  namespace import -force ::xotcl::*

  @ @File {
    description {
      This package provides the class Serializer, which can be used to
      generate a snapshot of the current state of the workspace
      in the form of XOTcl source code.
    }
    authors {
      Gustaf Neumann, Gustaf.Neumann@wu-wien.ac.at
    }
    date { $Date: 2007/10/05 09:06:00 $ }
  }
  
  @ Serializer proc all {
		 ?-ignoreVarsRE&nbsp;RE? 
		 "provide regular expression; matching vars are ignored"
		 ?-ignore&nbsp;obj1&nbsp;obj2&nbsp;...? 
		 "provide a list of objects to be omitted"} {
    Description {
      Serialize all objects and classes that are currently 
      defined (except the specified omissions and the current
	       Serializer object). 
      <p>Examples:<@br>
      <@pre class='code'>Serializer all -ignoreVarsRE {::b$}</@pre>
      Do not serialize any instance variable named b (of any object).<p>
      <@pre class='code'>Serializer all -ignoreVarsRE {^::o1::.*text.*$|^::o2::x$}</@pre>
      Do not serialize any variable of c1 whose name contains 
      the string "text" and do not serialze the variable x of o2.<p>
      <@pre class='code'>Serializer all -ignore obj1 obj2 ... </@pre>
      do not serizalze the specified objects
    }
    return "script"
  }
  
  @ Serializer proc deepSerialize {
		   objs "Objects to be serialized"
		   ?-ignoreVarsRE&nbsp;RE? 
		   "provide regular expression; matching vars are ignored"
		   ?-ignore&nbsp;obj1&nbsp;obj2&nbsp;...? 
		   "provide a list of objects to be omitted"
		   ?-map&nbsp;list? "translate object names in serialized code"
				 } {
    Description {
      Serialize object with all child objects (deep operation) 
      except the specified omissions. For the description of 
      <@tt>ignore</@tt> and <@tt>igonoreVarsRE</@tt> see 
      <@tt>Serizalizer all</@tt>. <@tt>map</@tt> can be used
      in addition to provide pairs of old-string and new-string
      (like in the tcl command <@tt>string map</@tt>). This option
      can be used to regenerate the serialized object under a different
      object or under an different name, or to translate relative
      object names in the serialized code.<p>
      
      Examples:  
      <@pre class='code'>Serializer deepSerialize ::a::b::c -map {::a::b ::x::y}</@pre>
      Serialize the object <@tt>c</@tt> which is a child of <@tt>a::b</@tt>; 
      the object will be reinitialized as object <@tt>::x::y::c</@tt>,
      all references <@tt>::a::b</@tt> will be replaced by <@tt>::x::y</@tt>.<p>
      
      <@pre class='code'>Serializer deepSerialize ::a::b::c -map {::a::b [self]}</@pre>
      The serizalized object can be reinstantiated under some current object,
      under which the script is evaluated.<p>
      
      <@pre class='code'>Serializer deepSerialize ::a::b::c -map {::a::b::c ${var}}</@pre>
      The serizalized object will be reinstantiated under a name specified
      by the variable <@tt>var<@tt> in the recreation context.
    }
    return "script"
  }
  
  @ Serializer proc methodSerialize {
		     object "object or class"
		     method "name of method"
		     prefix "either empty or 'inst' (latter for instprocs)"
				   } {
    Description {
      Serialize the specified method. In order to serialize 
      an instproc, <@tt>prefix</@tt> should be 'inst'; to serialze
      procs, it should be empty.<p> 
      
      Examples:
      <@pre class='code'>Serializer methodSerialize Serializer deepSerialize ""</@pre>
      This command serializes the proc <@tt>deepSerialize</@tt> 
      of the Class <@tt>Serializer</@tt>.<p>
      
      <@pre class='code'>Serializer methodSerialize Serializer serialize inst</@pre>
      This command serializes the instproc <@tt>serialize</@tt> 
      of the Class <@tt>Serializer</@tt>.<p>
    }
    return {Script, which can be used to recreate the specified method}
  }
  @ Serializer proc exportMethods {
	list "list of methods of the form 'object proc|instproc methodname'" 
      } {
    Description {
      This method can be used to specify methods that should be
      exported in every <@tt>Serializer all<@/tt>. The rationale
      behind this is that the serializer does not serialize objects
      from the ::xotcl:: namespace, which is used for XOTcl internals
      and volatile objects. It is however often useful to define
      methods on ::xotcl::Class or ::xotcl::Objects, which should
      be exported. One can export procs, instprocs, forward and instforward<p>
      Example:
      <@pre class='code'>      Serializer exportMethods {
	::xotcl::Object instproc __split_arguments
	::xotcl::Object instproc __make_doc
	::xotcl::Object instproc ad_proc
	::xotcl::Class  instproc ad_instproc
	::xotcl::Object forward  expr
      }<@/pre>
    }
  }
  
  
  @ Serializer instproc serialize {entity "Object or Class"} {
    Description {
      Serialize the specified object or class.
    }
    return {Object or Class with all currently defined methods, 
      variables, invariants, filters and mixins}
  }
  
  ##################################################################################
  # real clode starts here.....
  # ################################################################################
  Class Serializer -parameter {ignoreVarsRE map}
  namespace export Serializer

  Serializer proc ignore args {
    my set skip $args
  }
  Serializer instproc ignore args {
    foreach i $args { 
      my set skip($i) 1
      # skip children of ignored objects as well
      foreach j [$i info children] {
	my ignore $j
      }
    }
  }
  Serializer instproc init {} {
    my ignore [self] 
    if {[[self class] exists skip]} {
      eval my ignore [[self class] set skip]
    }
  }
  Serializer instproc method-serialize {o m prefix} {
    my pcmd [my unescaped-method-serialize $o $m $prefix]
  }
  Serializer instproc unescaped-method-serialize {o m prefix} {
    set arglist [list]
    foreach v [$o info ${prefix}args $m] {
      if {[$o info ${prefix}default $m $v x]} {
	lappend arglist [list $v $x] } {lappend arglist $v}
    }
    lappend r ${prefix}proc $m \
	[concat [$o info ${prefix}nonposargs $m] $arglist] \
	[$o info ${prefix}body $m]
    foreach p {pre post} {
      if {[$o info ${prefix}$p $m]!=""} {lappend r [$o info ${prefix}$p $m]}
    }
    return $r
  }
  Serializer instproc pcmd list {
    foreach a $list {
      if {[regexp -- {^-[[:alpha:]]} $a]} {
	set mustEscape 1
	break
      }
    }
    if {[info exists mustEscape]} {
      return "\[list -$list\]"
    } else {
      return -$list
    }
  }
  Serializer instproc collect-var-traces o {
    my instvar traces
    foreach v [$o info vars] {
      set t [$o __trace__ info variable $v]
      if {$t ne ""} {
	foreach ops $t { 
	  foreach {op cmd} $ops break
	  # save traces in post_cmds
	  my append post_cmds [list $o trace add variable $v $op $cmd] "\n"
	  # remove trace from object
	  $o trace remove variable $v $op $cmd
	}
      }
    }
  }
  Serializer instproc Object-serialize o {
    my collect-var-traces $o
    append cmd [list [$o info class] create [$o self]]
    # slots needs to be initialized when optimized, since
    # parametercmds are not serialized
    #if {![$o istype ::xotcl::Slot]} {append cmd " -noinit"}
    append cmd " -noinit"
    append cmd " \\\n"
    foreach i [$o info procs] {
      append cmd " " [my method-serialize $o $i ""] " \\\n"
    }
    foreach i [$o info forward] {
      set fwd [concat [list forward $i] [$o info forward -definition $i]]
      append cmd \t [my pcmd $fwd] " \\\n"
    }
    foreach i [$o info parametercmd] {
      append cmd \t [my pcmd [list parametercmd $i]] " \\\n"
    }
    set vset {}
    set nrVars 0
    foreach v [$o info vars] {
      set setcmd [list]
      if {![my exists ignoreVarsRE] || 
	  ![regexp [my set ignoreVarsRE] ${o}::$v]} {
	if {[$o array exists $v]} {
	  lappend setcmd array set $v [$o array get $v]
	} else {
	  lappend setcmd set $v [$o set $v]
	}
	incr nrVars
	append cmd \t [my pcmd $setcmd] " \\\n"
      }
    }
    foreach x {mixin invar} {
      set v [$o info $x]
      if {$v ne ""} {my append post_cmds [list $o $x set $v] "\n"}
    }
    set v [$o info filter -guards]
    if {$v ne ""} {append cmd [my pcmd [list filter $v]] " \\\n"}
    return $cmd
  }
  Serializer instproc Class-serialize o {
    set cmd [my Object-serialize $o]
    #set p [$o info parameter]
    #if {$p ne ""} {
    #  append cmd " " [my pcmd [list parameter $p]] " \\\n"
    #}
    foreach i [$o info instprocs] {
      append cmd " " [my method-serialize $o $i inst] " \\\n"
    }
    foreach i [$o info instforward] {
      set fwd [concat [list instforward $i] [$o info instforward -definition $i]]
      append cmd \t [my pcmd $fwd] " \\\n"
    }
    foreach i [$o info instparametercmd] {
      append cmd \t [my pcmd [list instparametercmd $i]] " \\\n"
    }
    foreach x {superclass instinvar} {
      set v [$o info $x]
      if {$v ne "" && "::xotcl::Object" ne $v } {
	append cmd " " [my pcmd [list $x $v]] " \\\n"
      }
    }
    foreach x {instmixin} {
      set v [$o info $x]
      if {$v ne "" && "::xotcl::Object" ne $v } {
        my append post_cmds [list $o $x set $v] "\n"
	#append cmd " " [my pcmd [list $x $v]] " \\\n"
      }
    }
    set v [$o info instfilter -guards]
    if {$v ne ""} {append cmd [my pcmd [list instfilter $v]] " \\\n"}
    return $cmd\n
  }
  
  Serializer instproc args {o prefix m} {
    foreach v [$o info ${prefix}args $m] {
      if {[$o info ${prefix}default $m $v x]} {
	lappend arglist [list $v $x] } {
	  lappend arglist $v }
    }
    return $arglist
  }
  Serializer instproc category c {
    if {[$c istype ::xotcl::Class]} {return Class} {return Object}
  }
  Serializer instproc allChildren o {
    set set $o
    foreach c [$o info children] {
      foreach c2 [my allChildren $c] {
	lappend set $c2
      }
    }
    return $set
  }
  Serializer instproc allInstances C {
    set set [$C info instances]
    foreach sc [$C info subclass] {
      foreach c2 [my allInstances $sc] {
	lappend set $c2
      }
    }
    return $set
  }
  Serializer instproc exportedObject o {
    # check, whether o is exported. for exported objects.
    # we export the object tree.
    set oo $o
    while {1} {
      if {[[self class] exists exportObjects($o)]} {
        #puts stderr "exported: $o -> exported $oo"
        return 1
      }
      # we do this for object trees without object-less name spaces
      if {![my isobject $o]} {return 0}
      set o [$o info parent]
    }
  }
  
  Serializer instproc topoSort {set all} {
    if {[my array exists s]} {my array unset s}
    if {[my array exists level]} {my array unset level}
    foreach c $set {
      if {!$all &&
	  [string match "::xotcl::*" $c] && 
	  ![my exportedObject $c]} continue
      if {[my exists skip($c)]} continue
      my set s($c) 1
    }
    set stratum 0
    while {1} {
      set set [my array names s]
      if {[llength $set] == 0} break
      incr stratum
      #my warn "$stratum set=$set"
      my set level($stratum) {}
      foreach c $set {
	if {[my [my category $c]-needsNothing $c]} {
	  my lappend level($stratum) $c
	}
      }
      if {[my set level($stratum)] eq ""} {
	my set level($stratum) $set
	my warn "Cyclic dependency in $set"
      }
      foreach i [my set level($stratum)] {my unset s($i)}
    }
  }
  Serializer instproc warn msg {
    if {[info command ns_log] ne ""} {
      ns_log Notice $msg
    } else {
      puts stderr "!!! $msg"
    }
  }
  
  Serializer instproc Class-needsNothing x {
    if {![my Object-needsNothing $x]}         {return 0}
    set scs [$x info superclass]
    if {[my needsOneOf $scs]} {return 0}
    foreach sc $scs {if {[my needsOneOf [$sc info slots]]} {return 0}}
    #if {[my needsOneOf [$x info instmixin ]]} {return 0}
    return 1
  }
  Serializer instproc Object-needsNothing x {
    set p [$x info parent]
    if {$p ne "::"  && [my needsOneOf $p]} {return 0}
    if {[my needsOneOf [$x info class]]}  {return 0}
    if {[my needsOneOf [[$x info class] info slots]]}  {return 0}
    #if {[my needsOneOf [$x info mixin ]]} {return 0}
    return 1
  }
  Serializer instproc needsOneOf list {
    foreach e $list {if {[my exists s($e)]} {
      #upvar x x; puts stderr "$x needs $e"
      return 1
    }}
    return 0
  }
  Serializer instproc serialize {objectOrClass} {
    string trimright [my [my category $objectOrClass]-serialize $objectOrClass] "\\\n"
  }
  Serializer instproc serialize-objects {list all} {
    my instvar post_cmds
    set post_cmds ""
    # register for introspection purposes "trace" under a different name
    ::xotcl::alias ::xotcl::Object __trace__ -objscope ::trace
    my topoSort $list $all
    #foreach i [lsort [my array names level]] {my warn "$i: [my set level($i)]"}
    set result ""
    foreach l [lsort -integer [my array names level]] {
      foreach i [my set level($l)] {
	#my warn "serialize $i"
        #append result "# Stratum $l\n"
	append result [my serialize $i] \n
      }
    }
    foreach e $list {
      set namespace($e) 1
      set namespace([namespace qualifiers $e]) 1
    }
    ::xotcl::Object instproc __trace__ {} {}

    # Handling of variable traces: traces might require a 
    # different topological sort, which is hard to handle.
    # Similar as with filters, we deactivate the variable
    # traces during initialization. This happens by
    # (1) replacing the XOTcl's trace method by a no-op
    # (2) collecting variable traces through collect-var-traces
    # (3) re-activating the traces after variable initialization

    set exports ""
    set pre_cmds ""

    # delete ::xotcl from the namespace list, if it exists...
    catch {unset namespace(::xotcl)}
    foreach ns [array name namespace] {
      if {![namespace exists $ns]} continue
      if {![my isobject $ns]} {
	append pre_cmds "namespace eval $ns {}\n"
      } elseif {$ns ne [namespace origin $ns] } {
	append pre_cmds "namespace eval $ns {}\n"
      }
      set exp [namespace eval $ns {namespace export}]
      if {$exp ne ""} {
	append exports "namespace eval $ns {namespace export $exp}" \n
      }
    }

    #append post_cmds "::xotcl::alias ::xotcl::Object trace -objscope ::trace\n"
    return $pre_cmds$result$post_cmds$exports
  }
  Serializer instproc deepSerialize o {
    # assumes $o to be fully qualified
    my serialize-objects [my allChildren $o] 1
  }
  Serializer instproc serializeMethod {object kind name} {
    set code ""
    switch $kind {
      proc {
	if {[$object info procs $name] ne ""} {
	  set code [my method-serialize $object $name ""]
	}
      }
      instproc {
	if {[$object info instprocs $name] ne ""} {
	  set code [my method-serialize $object $name inst]
	}
      }
      forward - instforward {
	if {[$object info $kind $name] ne ""} {
	  set fwd [concat [list $kind $name] [$object info $kind -definition $name]]
	  set code [my pcmd $fwd]
	}
      }
    }
    return $code
  } 

 
  Serializer proc exportMethods list {
    foreach {o p m} $list {my set exportMethods($o,$p,$m) 1}
  }
  Serializer proc exportObjects list {
    foreach o $list {my set exportObjects($o) 1}
  }

  Serializer proc serializeExportedMethods {s} {
    set r ""
    foreach k [my array names exportMethods] {
      foreach {o p m} [split $k ,] break
      #if {$o ne "::xotcl::Object" && $o ne "::xotcl::Class"} {
	#error "method export only for ::xotcl::Object and\
	#	::xotcl::Class implemented, not for $o"
      #}
      if {![string match "::xotcl::*" $o]} {
        error "method export is only for ::xotcl::* \
          object an classes implemented, not for $o"
      }
      append methods($o) [$s serializeMethod $o $p $m] " \\\n "      
    }
    set objects [array names methods]
    foreach o [list ::xotcl::Object ::xotcl::Class] {
      set p [lsearch $o $objects]
      if {$p == -1} continue
      set objects [lreplace $objects $p $p]
    }
    foreach o [concat ::xotcl::Object ::xotcl::Class $objects] {
      if {![info exists methods($o)]} continue
      append r \n "$o configure \\\n " \
	  [string trimright $methods($o) "\\\n "] 
    }
    #puts stderr "... exportedMethods <$r\n>"
    return "$r\n"
  }

  Serializer proc all {args} {
    # don't filter anything during serialization
    set filterstate [::xotcl::configure filter off]
    set s [eval my new -childof [self] -volatile $args]
    # always export __exitHandler
    my exportMethods [list ::xotcl::Object proc __exitHandler]
    set r {
      set ::xotcl::__filterstate [::xotcl::configure filter off]
      ::xotcl::Object instproc trace args {}
      ::xotcl::Slot instmixin add ::xotcl::Slot::Nocheck
    } 
    append r "::xotcl::configure softrecreate [::xotcl::configure softrecreate]"
    append r \n [my serializeExportedMethods $s]
    # export the objects and classes
    #$s warn "export objects = [my array names exportObjects]"
    #$s warn "export objects = [my array names exportMethods]"
    append r [$s serialize-objects [$s allInstances ::xotcl::Object] 0]    
    foreach o [list ::xotcl::Object ::xotcl::Class] {
      foreach x {mixin instmixin invar instinvar} {
	set v [$o info $x]
	if {$v ne ""  && $v ne "::xotcl::Object"} {
	  append r "$o configure " [$s pcmd [list $x $v]] "\n"
	}
      }
    }
    append r {
      ::xotcl::alias ::xotcl::Object trace -objscope ::trace
      ::xotcl::Slot instmixin delete ::xotcl::Slot::Nocheck
      ::xotcl::configure filter $::xotcl::__filterstate
      unset ::xotcl::__filterstate
    }
    ::xotcl::configure filter $filterstate
    return $r
  }
  Serializer proc methodSerialize {object method prefix} {
    set s [my new -childof [self] -volatile]
    concat $object [$s unescaped-method-serialize $object $method $prefix]
  }
  Serializer proc deepSerialize args {
    set s [my new -childof [self] -volatile]
    set nr [eval $s configure $args]
    foreach o [lrange $args 0 [incr nr -1]] {
      append r [$s deepSerialize [$o]]
  }
    if {[$s exists map]} {return [string map [$s map] $r]}
    return $r
  }

  # register serialize a global method
  ::xotcl::Object instproc serialize {} {
    ::Serializer deepSerialize [self]
  }

  # include this method in the serialized code
  Serializer exportMethods {
    ::xotcl::Object instproc contains
  }

  # include Serializer in the serialized code
  Serializer exportObjects [namespace current]::Serializer

  namespace eval :: "namespace import -force [namespace current]::*"
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/serialize/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded xotcl::scriptCreation::recoveryPoint 0.8 [list source [file join $dir RecoveryPoint.xotcl]]
package ifneeded xotcl::scriptCreation::scriptCreator 0.8 [list source [file join $dir ScriptCreator.xotcl]]
package ifneeded xotcl::serializer 1.0 [list source [file join $dir Serializer.xotcl]]
<
<
<
<
<
<
<
<
<
<
<
<
<


























Deleted assets/xotcl1.6.7/store/COPYRIGHT.

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
 *  XOTcl - Extended OTcl
 *
 *  Copyright (C) 1999-2008 Gustaf Neumann (a), Uwe Zdun (b)
 *
 * (a) Vienna University of Economics and Business Administration
 *     Dept. of Information Systems / New Media
 *     A-1090, Augasse 2-6
 *     Vienna, Austria
 *
 * (b) University of Essen
 *     Specification of Software Systems
 *     Altendorferstra▀e 97-101
 *     D-45143 Essen, Germany
 *     
 *  Permission to use, copy, modify, distribute, and sell this
 *  software and its documentation for any purpose is hereby granted
 *  without fee, provided that the above copyright notice appear in
 *  all copies and that both that copyright notice and this permission
 *  notice appear in supporting documentation. We make no
 *  representations about the suitability of this software for any
 *  purpose.  It is provided "as is" without express or implied
 *  warranty.
 *
 *
 *  This software is based upon MIT Object Tcl by David Wetherall and
 *  Christopher J. Lindblad, that contains the following copyright
 *  message:
 *
 *   "Copyright 1993 Massachusetts Institute of Technology
 *
 *    Permission to use, copy, modify, distribute, and sell this
 *    software and its documentation for any purpose is hereby granted
 *    without fee, provided that the above copyright notice appear in
 *    all copies and that both that copyright notice and this
 *    permission notice appear in supporting documentation, and that
 *    the name of M.I.T. not be used in advertising or publicity
 *    pertaining to distribution of the software without specific,
 *    written prior permission.  M.I.T. makes no representations about
 *    the suitability of this software for any purpose.  It is
 *    provided "as is" without express or implied warranty."

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































Deleted assets/xotcl1.6.7/store/JufGdbmStorage.xotcl.

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
# $Id: JufGdbmStorage.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::store::jufgdbm 0.81

package require xotcl::store::juf_gdbm
package require xotcl::store
package require XOTcl

namespace eval ::xotcl::store::jufgdbm {
    namespace import ::xotcl::*

    #
    # a simple GNU Gdbm DB Store Access
    #
    Class Storage=JufGdbm -superclass Storage
    Storage=JufGdbm instproc open f {
	my set persistenceDB [juf_gdbm open $f rwc]
    }

    Storage=JufGdbm instproc store {k v} {
	#my showCall
	juf_gdbm store [my set persistenceDB] $k $v
    }

    Storage=JufGdbm instproc list {} {
	juf_gdbm list [my set persistenceDB]
    }

    Storage=JufGdbm instproc fetch {k var} {
	my instvar persistenceDB
	if {[juf_gdbm exists $persistenceDB $k]} {
	    upvar [self callinglevel] $var value
	    set value [juf_gdbm fetch $persistenceDB $k]
	    return 1
	}
	return 0
    }

    Storage=JufGdbm instproc close args {
	juf_gdbm close [my set persistenceDB]
    }

    Storage=JufGdbm instproc delete k {
	juf_gdbm delete [my set persistenceDB] $k
    }

    namespace export Storage=JufGdbm
}

namespace import ::xotcl::store::jufgdbm::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































Deleted assets/xotcl1.6.7/store/MemStorage.xotcl.

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
# $Id: MemStorage.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::store::mem 0.84
package require xotcl::store 0.84
package require XOTcl

namespace eval ::xotcl::store::mem {
  namespace import ::xotcl::*

  Object ::xotcl::memStoragePool
  ::xotcl::memStoragePool proc add {filename} {
    my set memStores($filename) [Object new -childof [self]]
  }
  ::xotcl::memStoragePool proc get {filename} {
    if {[my exists memStores($filename)]} {
      return [my set memStores($filename)]
    }
    return ""
  }
  ::xotcl::memStoragePool proc remove {filename} {
    catch {
      set store [my set memStores($filename)]
      $store destroy
      my unset memStores($filename)
    }
  }

  #
  # a class using an XOTcl Object for memory storage
  Class Storage=Mem -superclass Storage
  Storage=Mem instproc init args {
    my instvar searchID
    ::set searchID ""
  }
  Storage=Mem instproc names  {}   {
    my instvar store
    $store array names v
  }
  Storage=Mem instproc exists name {
    my instvar store
    $store exists v($name)
  }
  Storage=Mem instproc unset name  {
    my instvar store
    $store unset v($name)
  }
  Storage=Mem instproc set args {
    my instvar store
    ::set l [llength $args]
    if {$l == 1} {
      $store set v([lindex $args 0])
    } elseif {$l == 2} {
      $store set v([lindex $args 0]) [lindex $args 1]
    } else {
      eval $store set $args
    }
  }
  Storage=Mem instproc close {} {
    my instvar store
    ::unset store
  }
  Storage=Mem instproc open filename {
    my instvar store
    if {[::set store [::xotcl::memStoragePool get $filename]] == ""} {
      ::set store [::xotcl::memStoragePool add $filename]
    }
  }
  Storage=Mem instproc firstkey {} {
    my instvar store
    $store instvar v
    my instvar searchID
    if {$searchID ne ""} {
      array donesearch v $searchID
    }
    ::set searchID [array startsearch v]
    return [array nextelement v $searchID]
  }
  Storage=Mem instproc nextkey {} {
    my instvar store
    $store instvar v
    my instvar searchID
    if {$searchID eq ""} {
      error "[self class]: firstkey was not invoked on storage search"
    }
    
    ::set elt [array nextelement v $searchID]
    if {$elt eq ""} {
      # if array end is reach search is terminated automatically!!
      ::set searchID ""
    }
    return $elt
  }

  ### warum geht eigentlich folgendes nicht:
  ##  Object o; o set a::b::c 1
  ### dann koennte man sich das set und exists schenken...

  namespace export Storage=Mem
}

namespace import ::xotcl::store::mem::*
#namespace eval ::xotcl {namespace import ::xotcl::store::mem::*}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































Deleted assets/xotcl1.6.7/store/MultiStorage.xotcl.

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

package provide xotcl::store::multi 0.9
package require xotcl::store 0.84
package require XOTcl

namespace eval ::xotcl::store::multi {
    namespace import ::xotcl::*

    Class Storage=multi -superclass Storage
    Storage=multi instproc add {dbPackage args} {
	my instvar storages names
	if {$dbPackage eq ""} {
	    set dbPackage [Storage defaultPackage]
	}
	package require xotcl::store::[string tolower $dbPackage]
	lappend storages [eval Storage=$dbPackage new -childof [self] $args]
    }
    Storage=multi instproc init args {
	my instvar storages
	set storages {}
    }
    Storage=multi instproc names  {}   {
	my instvar storages
	[lindex $storages 0] $names
    }
    Storage=multi instproc exists name {
	my instvar storages
	[lindex $storages 0] exists $name
    }
    Storage=multi instproc unset name  {
	my instvar storages
	foreach s $storages {$s [self proc] $name}
    }
    Storage=multi instproc set args {
	my instvar storages
	set l [llength $args]
	set name [lindex $args 0]
	if {$l == 1} {
	    [lindex $storages 0] set $name
	} elseif {$l == 2} {
	    foreach s $storages { $s set $name [lindex $args 1]}
	} else {
	    eval set $args
	}
    }
    Storage=multi instproc close {} {
	my instvar storages
	foreach s $storages {$s [self proc]}
    }
    Storage=multi instproc dbOpen {} {
	my instvar storages
	foreach s $storages {$s [self proc]}
    }
    Storage=multi instproc firstkey {} {
	my instvar storages
	[lindex $storages 0] firstkey
    }
    Storage=multi instproc nextkey {} {
	my instvar storages
	[lindex $storages 0] nextkey
    }
    Storage=multi instproc checkdir {} {
	my instvar storages
	foreach s $storages {$s [self proc]}
    }
    Storage=multi instproc dbOpen {} {
	my instvar storages
	foreach s $storages {$s [self proc]}
    }

    namespace export Storage=multi
}

namespace import ::xotcl::store::multi::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































Deleted assets/xotcl1.6.7/store/Persistence.xotcl.

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
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
# $Id: Persistence.xotcl,v 1.6 2006/09/27 08:12:40 neumann Exp $

package provide xotcl::store::persistence 0.8

package require xotcl::trace
package require xotcl::package
package require xotcl::mixinStrategy
package require xotcl::store
package require XOTcl

namespace eval ::xotcl::store::persistence {
    namespace import ::xotcl::*

    @ @File {
	description {
	    Persistent store for XOTcl objects with Eager and Lazy persistence.
	    Take a look at "persistenceExample.xotcl" for exmaple of usage.
	}
    }

    @ Class PersistenceMgr {
	description {
	    A persistent store requires a persistent manager. The persistent
	    manager implements the Storage interface via storage mixin. With 
	    the parameter "dbPackage" we can specify which storage will be used.
	    The persistent manager than tries to load the package 
	    "xotcl::${dbPackage}Storage". Default is Sdbm.

	    Example:
	    <@pre>
	    PersistenceMgr pmgr -persistenceDir . -persistenceFile example-db
	    </@pre>

	}
    }

    #
    # base class for persistent managers -- just register corresponding 
    # storage mixin and open DB
    #
    Class PersistenceMgr -parameter {
	{fileName {[string trimleft [self] :]}}
	{dbPackage Sdbm}
	trace
	dirName
    }

    PersistenceMgr instproc init args {
	my instvar dbPackage
	package require xotcl::store::[string tolower $dbPackage]

	Storage=$dbPackage [self]::store $args
	foreach v {dirName fileName} {
	    if {[my exists $v]} {
		[self]::store $v [my set $v]
	    }
	}

	if {[my exists trace]} {
	    [self]::store filter traceFilter
	}
	my array set persistentObjs {}
	next
    }
    # delegate methods to the store object
    PersistenceMgr instproc store args {
	eval [self]::store $args
    }


    PersistenceMgr instproc destroy args {
	foreach obj [my array names persistentObjs] {
	    $obj storeall
	    $obj persistenceMgr ""
	}
	[self]::store close
	next
    }
    PersistenceMgr instproc assureOpenDb {} {
	if {![my exists dbOpen]} {
	    [self]::store dbOpen
	    my set dbOpen 1
	}
    }
    PersistenceMgr instproc addPersistentObj {obj} {
	my set persistentObjs($obj) ""
    }
    PersistenceMgr instproc removePersistentObj {obj} {
	if {[my exists persistentObjs($obj)]} {
	    my unset persistentObjs($obj)
	}
    }

    @ Class Persistent {
	description {
	    Superclass or mixin class for all persistent objects. Normally
	    subclasses are used as mixins or instmixins on object, like:
	    <@pre>
	    o mixin Persistent=Eager
	    p mixin Persistent=Lazy
	    </@pre>
	}
    }
    #
    # Persistence (mixin) classes#
    Class Persistent -parameter {
	persistenceMgr
    }

    # can be overloaded by subclasses, that need a cleanup on 
    # persistenceMgr->destroy (like Lazy)
    Persistent instproc storeall {} {;}

    @ Persistent instproc persistenceMgr {args "persistent manager name"} {
	description {
	    Specify which persistence manager to use for [self] object, like:
	    <@pre>
	    o persistenceMgr pmgr
	    </@pre>
	    Each persistent object must have a persistence manager specified, 
	    before vars can be made persistent.
	}
    }

    #
    # turn off persistence with ... persistenceMgr "", but 
    # persistent vars stay persistent
    #
    Persistent instproc persistenceMgr args {
	if {[llength $args] == 0} {
	    return [my set [self proc]]
	} elseif {[llength $args] == 1} {
	    set pmgr [lindex $args 0]
	    if {$pmgr eq "" && [my exists persistenceMgr]} {
		[my set persistenceMgr] removePersistentObj [self]
		my unset persistenceMgr
		return ""
	    }
	    $pmgr addPersistentObj [self]
	    return [my set [self proc] $pmgr]
	} else {
	    error "wrong # args: [self] [self proc] ?value?"
	}
    }

    @ Persistent instproc persistentVars {} {
	description {
	    Returns list of persistent vars.
	}
    }

    Persistent instproc persistentVars {} {
	if {[my exists __persistentVars]} {
	    return [my set __persistentVars]
	}
	return ""
    }

    @ Persistent instproc persistent {list "persistent variables" } {
	description {
	    Make a list of object variables persistent. If a persistent
	    DB exists, the values are read from this DB, overwriting the current value.
	    E.g.:
	    <@pre>
	    o persistent {x y}
	    </@pre>

	}
    }

    Persistent instproc persistent {list} {
	my instvar persistenceMgr
	if {![info exists persistenceMgr]} {return}
	set store ${persistenceMgr}::store

	$persistenceMgr assureOpenDb
	foreach var $list {
	    my lappend __persistentVars $var
	    # try to refetch vars from db
	    if {[$store exists [self]::${var}(_____arraynames)]} {
		#puts stderr array=[self]::${var}
		foreach i [$store set [self]::${var}(_____arraynames)]  {
		    my set ${var}($i) [$store set [self]::${var}($i)]
		}
	    } elseif {[$store exists [self]::$var]} {
		#puts stderr "---store=$store exists [self]::$var"
		#puts stderr "---set [self]::$var <[$store set [self]::$var]>"
		my instvar $var
		#set name [$store set [self]::$var]
		#puts ***name*[set name]--$var
		set $var [$store set [self]::$var]
	    } elseif {[my exists $var]} {
		#
		# first store of the variable in persistent store
		if {[my array exists $var]} {
		    # this variable is an array
		    #puts stderr array=[self]::$var
		    set anames [my array names $var]
		    foreach n $anames {
			$store set [self]::${var}($n) [my set ${var}($n)]
		    }
		    $store set [self]::${var}(_____arraynames) $anames
		} else {
		    #puts stderr "+++set [self]::$var [$store set [self]::$var]"
		    $store set [self]::$var [my set $var]
		}
	    } else {
		error "persistent: $var is not a variable on [self]"
	    }
	}
    }

    @ Persistent instproc persistent+init {list "persistent variables" } {
	description {
	    Initialize all data in the list as empty strings, 
	    if they do not exist yet, and then make them persistent
	    using the 'persistent' method
	}
    }

    Persistent instproc persistent+init {list} {  
	foreach pd $list {
	    if {![my exists $pd]} {
		my set $pd ""
	    }
	}
	my persistent $list
    }


    @ Persistent instproc unPersistent {list "persistent variables" } {
	description {
	    Make a list of object variables not persistent. 
	}
    }

    Persistent instproc unPersistent {list} {
	my instvar __persistentVars
	set pMgr [my set persistenceMgr]
	foreach v $list {
	    set i [lsearch -exact $__persistentVars $v]
	    catch {
		set __persistentVars [lreplace $__persistentVars $i $i]
		${pMgr}::store unset [self]::$v
	    }
	}
    }

    @ Persistent instproc makeVarScript {} {
	description {
	    Build a Tcl script of "set ..." statements reflecting the current situation in the database.
	}
    }
    Persistent instproc makeVarScript {} {
	set script ""
	foreach v [my persistentVars] {
	    set vt [namespace tail $v]
	    append script [list my set $vt [my set $vt]]\n
	}
	#set script [concat [next] $script]
	return $script
    }

    Persistent instproc destroy args {
	if {[my exists persistenceMgr]} {
	    [my set persistenceMgr] removePersistentObj [self]
	    my unset persistenceMgr
	}
	next
	#my showMsg "Persistent object [self] destroyed."
    }

    @ Class Persistent=Eager {
	description {
	    Eager persistence strategy. Store everything at the same moment to the database
	}
    }
    Class Persistent=Eager -superclass Persistent

    #
    # we use 'strange' argument names to avoid name clashes with given 
    # variable names, when we have to instvar "[self] instvar $nametail"
    #
    Persistent=Eager instproc vartrace {__name_vartrace __sub_vartrace __op_vartrace} {
	#my showCall
	if {$__op_vartrace eq "w"} {
	    my instvar persistenceMgr
	    if {![info exists persistenceMgr]} {return}
	    set store ${persistenceMgr}::store

	    set nametail [namespace tail $__name_vartrace]
	    set key [self]::$nametail
	    if {$__sub_vartrace eq ""} {
		my instvar $nametail
		#puts stderr "+++VT: $store set $key [set $nametail]"
		$store set $key [set $nametail]
	    } else {
		if {$__sub_vartrace ne "_____arraynames"} {
		    my instvar "${nametail}($__sub_vartrace) subname"
		    $store set ${key}($__sub_vartrace) $subname
		    $store set ${key}(_____arraynames) [my array names $nametail]
		} else {
		    error "With persistent arrays you may not use '_____arraynames' as index"
		}
	    }
	}
    }

    Persistent=Eager instproc persistent {list} {
	#my showCall
	next
	foreach v $list {
	    #puts stderr "***trace variable [self]::$v w [list my vartrace]"
	    my trace variable $v w [list [self] vartrace]
	}
    }

    Persistent=Eager instproc unPersistent {list} {
	foreach v $list {
	    my trace vdelete $v w [list [self] vartrace]
	}
	next
    }

    @ Class Persistent=Lazy {
	description {
	    Lazy persistence strategy. Store everything on object destroy (or program termination).
	}
    }

    Class Persistent=Lazy -superclass Persistent
    Persistent=Lazy instproc storeall {} {
	my instvar persistenceMgr
	if {![info exists persistenceMgr]} {return}
	set store ${persistenceMgr}::store

	foreach v [my persistentVars] {
	    if {[my array exists $v]} {
		set anames ""
		foreach sub [my array names $v] {
		    if {[my exists ${v}($sub)]} {
			set key [self]::${v}($sub)
			$store set $key [my set ${v}($sub)]
			lappend anames $sub
		    }
		}
		$store set [self]::${v}(_____arraynames) $anames
	    } else {
		if {[my exists $v]} {
		    set key [self]::$v
		    $store set $key [my set $v]
		}
	    }
	}
    }

    Persistent=Lazy instproc destroy args {
	my storeall
	next
    }

    namespace export PersistenceMgr Persistent Persistent=Eager Persistent=Lazy
}

namespace import ::xotcl::store::persistence::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/store/Storage.xotcl.

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
# $Id: Storage.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::store 0.84
package require XOTcl

namespace eval ::xotcl::store {
    namespace import ::xotcl::*

    @ @File {
	description {
	    Simple generic storage interface for hashtable-like (persistent)
	    storages. There are several different existing stores, including
	    a memory storage, a GDBM storage, a SDBM storage, and a 
	    TextFile storage.  
	}
	date { $Date: 2005/09/09 21:09:01 $ }
    }

    #
    # abstract interface for storage access
    #
    @ Class Storage {
	description {
	    Abstract storage interface class (superclass of all storages).
	}
    }
    Class Storage -parameter {{dirName .} fileName}

    ###
    @ Storage instproc open {
	filename "database filename (or filename base, if more 
            than one file has to be created)"
    } {
	Description {
	    Each storage object represents exactly one database table. The db
	    has to be opened, before it can it used. If it is not opened all
	    other methods return errors.
	}
	return "empty string"
    }
    Storage abstract instproc open filename

    ###
    @ Storage instproc close {} {
	Description {
	    Close associated database.
	}
	return "empty string"
    }
    Storage abstract instproc close {}

    ###
    @ Storage instproc exists {
	key {Key to be searched for.}
    } {
	Description {
	    Search for a key whether it exists or not.
	}
	return {1, if key exists in the database, otherwise 0}
    }
    Storage abstract instproc exists key

    ###
    @ Storage instproc set {
	key {Key to be set.}
	?value? {Optional value that might be set}
    } {
	Description {
	    Set or query a database key in the same way as Tcl's set functions.
	}
	return {Key value.}
    }
    Storage abstract instproc set {key ?value?}

    ###
    @ Storage instproc unset {
	key {Key to be unset.}
    } {
	Description {
	    Unset a database key in the same way as Tcl's unset functions.
	}
	return {empty string}
    }
    Storage abstract instproc unset key

    ###
    @ Storage instproc names {} {
	Description {
	    Return a list of keys in the database (functions in the same 
						   way as Tcl's array names)
	}
	return {List of keys in the db.}
    }
    Storage abstract instproc names {}

    ###
    @ Storage instproc firstkey {} {
	Description {
	    Start a traversal of the database, starting with any key.
	}
	return {Name of first key.}
    }
    Storage abstract instproc firstkey {}

    ###
    @ Storage instproc nextkey {} {
	Description {
	    Proceed with the db traversal. Requires a firstkey before
	    first usage, otherwise it returns an error.
	}
	return {Name of next key, if one exists. Otherwise an empty string is returned.}
    }
    Storage abstract instproc nextkey {}

    Storage instproc traceFilter args {
	set context "[self callingclass]->[self callingproc]"
	set method [self calledproc]
	set dargs $args 
	puts "CALL $context>  [self]->$method $dargs"
	set result [next]
	puts "EXIT $context>  [self]->$method ($result)"
	return $result
    }

    ###
    @ Storage proc someNewChildStore {} {
	Description {
	    Create a childStore according to a preference list depending on
	    which storages are available. Currently the preference list has
	    the following order: Gdbm, Sdbm and TextFile.
	}
	return {name of the created storage object.}
    }
    Storage proc someNewChildStore {} {
	foreach store {Gdbm Sdbm TextFile} {
	    if {![catch {package require xotcl::store::[string tolower $store]}]} {
		set s [Storage=$store new -childof [self]]
		break
	    }
	}
	return $s
    }

    Storage instproc checkDir {} {
	my instvar dirName
	if {[info exists dirName]} {
	    if {![file exists $dirName]} {
		file mkdir $dirName
	    } elseif {![file isdirectory $dirName]} {
		error "specified directory $dirName is no directory!"
	    }
	}
    }
    Storage instproc mkFileName {} {
	my instvar dirName fileName
	if {[info exists dirName]} {
	    return [file join $dirName $fileName]
	} else {
	    return $fileName
	}
    }
    Storage instproc dbOpen {} {
	my checkDir
	my open [my mkFileName]
    }


    Storage proc defaultPackage {} {
	return Sdbm
    }

    namespace export Storage
}

namespace import ::xotcl::store::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































Deleted assets/xotcl1.6.7/store/TclGdbmStorage.xotcl.

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
# $Id: TclGdbmStorage.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::store::tclgdbm 0.84

package require xotcl::store::gdbm
package require xotcl::store
package require XOTcl

namespace eval ::xotcl::store::tclgdbm {
    namespace import ::xotcl::*

    #
    # a simple GNU Gdbm DB Store Access based on TclGdbm
    #
    Class Storage=TclGdbm -superclass Storage
    Storage=TclGdbm instproc open f {
	my instvar persistenceDB
	::set persistenceDB [gdbm_open -wrcreat $f]
    }

    Storage=TclGdbm instproc set args {
	my instvar persistenceDB
	::set l [llength $args]
	if {$l == 1} {[::set persistenceDB] fetch [lindex $args 0]
	} elseif {$l == 2} {[::set persistenceDB] -replace store \
				[lindex $args 0] [lindex $args 1]
	} else { next }
    }

    Storage=TclGdbm instproc exists k {
	my instvar persistenceDB
	$persistenceDB exists $k
    }

    Storage=TclGdbm instproc names {} {
	my instvar persistenceDB
	::set list ""
	if {[::set key [$persistenceDB firstkey]] != ""} {
	    lappend list $key
	    while {[::set key [$persistenceDB nextkey $key]] != ""} {
		lappend list $key
	    }
	}
	return $list
    }


    Storage=TclGdbm instproc close args {
	my instvar persistenceDB
	$persistenceDB close
    }

    Storage=TclGdbm instproc unset k {
	my instvar persistenceDB
	$persistenceDB delete $k
    }

    namespace export Storage=TclGdbm
}

namespace import ::xotcl::store::tclgdbm::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































Deleted assets/xotcl1.6.7/store/TextFileStorage.xotcl.

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
package provide xotcl::store::textfile 0.84
package require xotcl::store
package require XOTcl

namespace eval ::xotcl::store::textfile {
    namespace import ::xotcl::*

    Class Storage=TextFile -superclass Storage -parameter {
	filename
	reorgCounter
	reorgMaxValue
    }

    Storage=TextFile instproc init args {
	my instvar reorgCounter reorgMaxValue searchID
	::set reorgCounter 0
	::set reorgMaxValue 1000
	::set searchID ""
	next
    }
    Storage=TextFile instproc reorganizeDB {} {
	my instvar noreorg reorgCounter reorgMaxValue filename keys
	::set reorgCounter -1
	#puts "***reorganizeDB"
	if {[::info exists filename]} {
	    ::set noreorg 1
	    ::array set bkeys [::array get keys]
	    ::array set keys {}
	    #    parray bkeys

	    ::set bak $filename.orig
	    file rename -force $filename $bak
	    foreach k [::array names bkeys] {
		::set bf [::open $bak r]
		seek $bf [lindex $bkeys($k) 0]
		::set c [read $bf [lindex $bkeys($k) 1]]
		::close $bf
		#puts "***STORING $k [lindex $c 1]"
		my set $k [lindex $c 1]
	    }
	    file delete -force $bak
	    ::unset noreorg
	}
    }
    Storage=TextFile instproc open fn {
	my instvar keys filename
	::array set keys {}
	::set position 0
	::set filename $fn
	if {[file exists $filename]} {
	    ::set f [::open $filename r]
	    ::set c [read $f]
	    ::close $f
	    foreach {k v} $c {
		lappend keyList $k
	    }
	    ::set f [::open $filename r]
	    while {1} {
		set position [tell $f]
		if {!([gets $f line] >= 0)} {		
		    break
		}

		set k [lindex $keyList 0]
		if {[string match $k* $line]} {
		    set lastLength [string length $line]
		    set keys($k) [concat $position $lastLength]
		    set lastKey $k
		    set lastPosition $position
		    set keyList [lreplace $keyList 0 0]
		} elseif {[info exists lastKey]} {
		    set lastLength [expr $lastLength + [string length $line] + 1]
		    set keys($lastKey) [concat $lastPosition $lastLength]
		}
	    }
	    ::close $f

	    #parray keys
	}
    }
    Storage=TextFile instproc exists key {
	my instvar keys
	info exists keys($key)
    }

    Storage=TextFile instproc set args {
	my instvar keys noreorg reorgCounter reorgMaxValue filename
	::set key [lindex $args 0]
	::set l [llength $args]
	if {$l == 1} {     ;# fetch
	    if {[::info exists keys($key)]} {
		::set f [::open $filename r]
		#puts "***fetch -- $keys($key)"
		seek $f [lindex $keys($key) 0]
		::set c [read $f [lindex $keys($key) 1]]
		::close $f
		return [lindex $c 1]
	    } else {
		error "no such variable '$key'"    
	    }
	} elseif {$l == 2} {    ;# store
	    if {![::info exists noreorg] && [::info exists keys($key)]} {
		::incr reorgCounter    
	    }
	    ::set f [::open $filename a+]
	    ::set position [tell $f]
	    #puts "***store -- putting [::list $key [lindex $args 1]] at $position"
	    ::set c [::list $key [lindex $args 1]]
	    puts $f $c
	    ::close $f
	    ::set keys($key) [::list $position [expr {[string length $c] + 1}]]
	    #  parray keys
	    if {$reorgCounter > $reorgMaxValue} {
		my reorganizeDB    
	    }
	} else { next }
    }

    Storage=TextFile instproc names  {} {
	my array names keys
    }
    Storage=TextFile instproc close {} {
	my instvar filename keys
	my reorganizeDB
	::unset filename
	::unset keys
    }
    Storage=TextFile instproc unset key {
	my instvar keys
	if {[::info exists keys($key)]} {
	    ::unset keys($key)
	}
	my reorganizeDB
    }

    Storage=TextFile instproc firstkey {} {
	my instvar keys searchID
	if {$searchID ne ""} {
	    array donesearch keys $searchID
	}
	::set searchID [array startsearch keys]
	return [array nextelement keys $searchID]
    }
    Storage=TextFile instproc nextkey {} {
	my instvar keys searchID
	if {$searchID eq ""} {
	    error "[self class]: firstkey was not invoked on storage search"
	}
	::set elt [array nextelement keys $searchID]
	if {$elt eq ""} {
	    # if array end is reach search is terminated automatically!!
	    ::set searchID ""
	}
	return $elt
    }

    namespace export Storage=TextFile
}

namespace import ::xotcl::store::textfile::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































Deleted assets/xotcl1.6.7/store/persistenceExample.xotcl.

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
#!../../src/xotclsh
# $Id: persistenceExample.xotcl,v 1.2 2006/02/18 22:17:33 neumann Exp $
#
# load the persistence component
package require xotcl::store::persistence

# Two example objects
Object o
# set two variables to default values
o set x 1
o set y 1

Object p
# set two variables to default values
p set x 1
p set y 1

####################################
# now we make these vars persistent
####################################


# 1. we need the PersistenceMgr (for gdbm we have to specify a file
# name). If we want to get rid of the current setting and start again
# we default values, we have to delete this file
PersistenceMgr pmgr -dirName . -fileName example-db

# 2. we have to make the objects persistent. We register the
# persistence strategy as per-object mixin on the two objects
#
# one uses the lazy, one the eager strategy

o mixin Persistent=Eager
p mixin Persistent=Lazy

# 3. tell the objects, which PersistenceMgr to use

o persistenceMgr pmgr
p persistenceMgr pmgr

# 4. make the vars persistent

o persistent {x y}
p persistent {x y}

#####################################

# now the vars are loaded from the persistence store
#
# we incr them to demonstrate the persistency; and print the results

o incr x 2
o append y 1
p incr x 3
p append y 2

puts "Values:"
puts "  o->x: [o set x]"
puts "  o->y: [o set y]"
puts "  p->x: [p set x]"
puts "  p->y: [p set y]"

# now run the program several times to see the results 
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































Deleted assets/xotcl1.6.7/store/pkgIndex-subdir.add.

1
2
3
4
5
6
7
8
9
10
set __store_dir__ $dir
foreach index [glob -nocomplain [file join $dir * pkgIndex.tcl]] {
  set dir [file dirname $index]
  #puts subdir=$dir,index=$index
  source $index
}
set dir $__store_dir__
unset __store_dir__


<
<
<
<
<
<
<
<
<
<




















Deleted assets/xotcl1.6.7/store/pkgIndex.tcl.

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
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded xotcl::store 0.84 [list source [file join $dir Storage.xotcl]]
package ifneeded xotcl::store::jufgdbm 0.81 [list source [file join $dir JufGdbmStorage.xotcl]]
package ifneeded xotcl::store::mem 0.84 [list source [file join $dir MemStorage.xotcl]]
package ifneeded xotcl::store::multi 0.9 [list source [file join $dir MultiStorage.xotcl]]
package ifneeded xotcl::store::persistence 0.8 [list source [file join $dir Persistence.xotcl]]
package ifneeded xotcl::store::tclgdbm 0.84 [list source [file join $dir TclGdbmStorage.xotcl]]
package ifneeded xotcl::store::textfile 0.84 [list source [file join $dir TextFileStorage.xotcl]]
set __store_dir__ $dir
foreach index [glob -nocomplain [file join $dir * pkgIndex.tcl]] {
  set dir [file dirname $index]
  #puts subdir=$dir,index=$index
  source $index
}
set dir $__store_dir__
unset __store_dir__


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































Deleted assets/xotcl1.6.7/xml/COPYRIGHT.

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
 *  XOTcl - Extended OTcl
 *
 *  Copyright (C) 1999-2008 Gustaf Neumann (a), Uwe Zdun (b)
 *
 * (a) Vienna University of Economics and Business Administration
 *     Dept. of Information Systems / New Media
 *     A-1090, Augasse 2-6
 *     Vienna, Austria
 *
 * (b) University of Essen
 *     Specification of Software Systems
 *     Altendorferstra▀e 97-101
 *     D-45143 Essen, Germany
 *     
 *  Permission to use, copy, modify, distribute, and sell this
 *  software and its documentation for any purpose is hereby granted
 *  without fee, provided that the above copyright notice appear in
 *  all copies and that both that copyright notice and this permission
 *  notice appear in supporting documentation. We make no
 *  representations about the suitability of this software for any
 *  purpose.  It is provided "as is" without express or implied
 *  warranty.
 *
 *
 *  This software is based upon MIT Object Tcl by David Wetherall and
 *  Christopher J. Lindblad, that contains the following copyright
 *  message:
 *
 *   "Copyright 1993 Massachusetts Institute of Technology
 *
 *    Permission to use, copy, modify, distribute, and sell this
 *    software and its documentation for any purpose is hereby granted
 *    without fee, provided that the above copyright notice appear in
 *    all copies and that both that copyright notice and this
 *    permission notice appear in supporting documentation, and that
 *    the name of M.I.T. not be used in advertising or publicity
 *    pertaining to distribution of the software without specific,
 *    written prior permission.  M.I.T. makes no representations about
 *    the suitability of this software for any purpose.  It is
 *    provided "as is" without express or implied warranty."

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































Deleted assets/xotcl1.6.7/xml/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded sgml 1.6 [list source [file join $dir sgml.tcl]]
package ifneeded xml 1.8 [list source [file join $dir xml.tcl]]
package ifneeded xotcl::xml::parser 0.94 [list source [file join $dir xoXML.xotcl]]
package ifneeded xotcl::xml::printVisitor 0.9 [list source [file join $dir printVisitor.xotcl]]
package ifneeded xotcl::xml::recreatorVisitor 0.9 [list source [file join $dir xmlRecreatorVisitor.xotcl]]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























Deleted assets/xotcl1.6.7/xml/printVisitor.xotcl.

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
# $Id: printVisitor.xotcl,v 1.3 2005/09/09 21:09:01 neumann Exp $

package provide xotcl::xml::printVisitor 0.9
package require xotcl::xml::parser
package require XOTcl

namespace eval ::xotcl::xml::printVisitor {
    namespace import ::xotcl::*

    ##############################################################################
    #
    # Small debugging visitor that just uses node's print method to print the 
    # node tree
    #
    ##############################################################################

    Class PrintVisitor -superclass NodeTreeVisitor -parameter parser
    PrintVisitor instproc visit objName {
	puts [$objName print]
    }
    PrintVisitor instproc interpretNodeTree node {
	$node accept [self]
    }

    namespace export PrintVisitor
}

namespace import ::xotcl::xml::printVisitor::*
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































Deleted assets/xotcl1.6.7/xml/sgml.tcl.

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
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
# sgml.tcl --
#
#	This file provides generic parsing services for SGML-based
#	languages, namely HTML and XML.
#
#	NB.  It is a misnomer.  There is no support for parsing
#	arbitrary SGML as such.
#
# Copyright (c) 1998,1999 Zveno Pty Ltd
# http://www.zveno.com/
#
# Zveno makes this software available free of charge for any purpose.
# Copies may be made of this software but all of this notice must be included
# on any copy.
#
# The software was developed for research purposes only and Zveno does not
# warrant that it is error free or fit for any purpose.  Zveno disclaims any
# liability for all claims, expenses, losses, damages and costs any user may
# incur as a result of using, copying or modifying this software.
#
# Copyright (c) 1997 ANU and CSIRO on behalf of the
# participants in the CRC for Advanced Computational Systems ('ACSys').
# 
# ACSys makes this software and all associated data and documentation 
# ('Software') available free of charge for any purpose.  You may make copies 
# of the Software but you must include all of this notice on any copy.
# 
# The Software was developed for research purposes and ACSys does not warrant
# that it is error free or fit for any purpose.  ACSys disclaims any
# liability for all claims, expenses, losses, damages and costs any user may
# incur as a result of using, copying or modifying the Software.
#
# $Id: sgml.tcl,v 1.4 2006/09/27 08:12:40 neumann Exp $

package provide sgml 1.6

namespace eval sgml {
    namespace export tokenise parseEvent

    namespace export parseDTD

    # Convenience routine
    proc cl x {
	return "\[$x\]"
    }

    # Define various regular expressions
    # white space
    variable Wsp " \t\r\n"
    variable noWsp [cl ^$Wsp]

    # Various XML names
    variable nmtoken [cl -a-zA-Z0-9._]+
    variable name [cl a-zA-Z_][cl -a-zA-Z0-9._]*

    # Other
    variable ParseEventNum
    if {![info exists ParseEventNum]} {
	set ParseEventNum 0
    }
    variable ParseDTDnum
    if {![info exists ParseDTDNum]} {
	set ParseDTDNum 0
    }

    # table of predefined entities for XML

    variable EntityPredef
    array set EntityPredef {
	lt <   gt >   amp &   quot \"   apos '
    }

}

# sgml::tokenise --
#
#	Transform the given HTML/XML text into a Tcl list.
#
# Arguments:
#	sgml		text to tokenize
#	elemExpr	RE to recognise tags
#	elemSub		transform for matched tags
#	args		options
#
# Valid Options:
#	-final		boolean		True if no more data is to be supplied
#	-statevariable	varName		Name of a variable used to store info
#
# Results:
#	Returns a Tcl list representing the document.

proc sgml::tokenise {sgml elemExpr elemSub args} {
    array set options {-final 1}
    catch {array set options $args}
    set options(-final) [Boolean $options(-final)]

    # If the data is not final then there must be a variable to store
    # unused data.
    if {!$options(-final) && ![info exists options(-statevariable)]} {
	return -code error {option "-statevariable" required if not final}
    }

    # Pre-process stage
    #
    # Extract the internal DTD subset, if any

    catch {upvar #0 $options(-internaldtdvariable) dtd}
    if {[regexp {<!DOCTYPE[^[<]+\[([^]]+)\]} $sgml discard dtd]} {
	regsub {(<!DOCTYPE[^[<]+)(\[[^]]+\])} $sgml {\1\&xml:intdtd;} sgml
    }

    # Protect Tcl special characters
    regsub -all {([{}\\])} $sgml {\\\1} sgml

    # Do the translation

    if {[info exists options(-statevariable)]} {
	upvar #0 $opts(-statevariable) unused
	if {[info exists unused]} {
	    regsub -all $elemExpr $unused$sgml $elemSub sgml
	    unset unused
	} else {
	    regsub -all $elemExpr $sgml $elemSub sgml
	}
	set sgml "{} {} {} {} \{$sgml\}"

	# Performance note (Tcl 8.0):
	#	Use of lindex, lreplace will cause parsing to list object

	if {[regexp {^([^<]*)(<[^>]*$)} [lindex $sgml end] x text unused]} {
	    set sgml [lreplace $sgml end end $text]
	}

    } else {

	# Performance note (Tcl 8.0):
	#	In this case, no conversion to list object is performed

	regsub -all $elemExpr $sgml $elemSub sgml
	set sgml "{} {} {} {} \{$sgml\}"
    }

    return $sgml

}

# sgml::parseEvent --
#
#	Produces an event stream for a XML/HTML document,
#	given the Tcl list format returned by tokenise.
#
#	This procedure checks that the document is well-formed,
#	and throws an error if the document is found to be not
#	well formed.  Warnings are passed via the -warningcommand script.
#
#	The procedure only check for well-formedness,
#	no DTD is required.  However, facilities are provided for entity expansion.
#
# Arguments:
#	sgml		Instance data, as a Tcl list.
#	args		option/value pairs
#
# Valid Options:
#	-final			Indicates end of document data
#	-elementstartcommand	Called when an element starts
#	-elementendcommand	Called when an element ends
#	-characterdatacommand	Called when character data occurs
#	-entityreferencecommand	Called when an entity reference occurs
#	-processinginstructioncommand	Called when a PI occurs
#	-externalentityrefcommand	Called for an external entity reference
#
#	(Not compatible with expat)
#	-xmldeclcommand		Called when the XML declaration occurs
#	-doctypecommand		Called when the document type declaration occurs
#	-commentcommand		Called when a comment occurs
#
#	-errorcommand		Script to evaluate for a fatal error
#	-warningcommand		Script to evaluate for a reportable warning
#	-statevariable		global state variable
#	-normalize		whether to normalize names
#	-reportempty		whether to include an indication of empty elements
#
# Results:
#	The various callback scripts are invoked.
#	Returns empty string.
#
# BUGS:
#	If command options are set to empty string then they should not be invoked.

proc sgml::parseEvent {sgml args} {
    variable Wsp
    variable noWsp
    variable nmtoken
    variable name
    variable ParseEventNum

    array set options [list \
	-elementstartcommand		[namespace current]::noop	\
	-elementendcommand		[namespace current]::noop	\
	-characterdatacommand		[namespace current]::noop	\
	-processinginstructioncommand	[namespace current]::noop	\
	-externalentityrefcommand	[namespace current]::noop	\
	-xmldeclcommand			[namespace current]::noop	\
	-doctypecommand			[namespace current]::noop	\
	-commentcommand			[namespace current]::noop	\
	-entityreferencecommand		{}				\
	-warningcommand			[namespace current]::noop	\
	-errorcommand			[namespace current]::Error	\
	-final				1				\
	-emptyelement			[namespace current]::EmptyElement	\
	-parseattributelistcommand	[namespace current]::noop	\
	-normalize			1				\
	-internaldtd			{}				\
	-reportempty			0				\
	-entityvariable			[namespace current]::EntityPredef	\
    ]
    catch {array set options $args}

    if {![info exists options(-statevariable)]} {
	set options(-statevariable) [namespace current]::ParseEvent[incr ParseEventNum]
    }

    upvar #0 $options(-statevariable) state
    upvar #0 $options(-entityvariable) entities

    if {![info exists state]} {
	# Initialise the state variable
	array set state {
	    mode normal
	    haveXMLDecl 0
	    haveDocElement 0
	    context {}
	    stack {}
	    line 0
	}
    }

    foreach {tag close empty param text} $sgml {

	# Keep track of lines in the input
	incr state(line) [regsub -all \n $param {} discard]
	incr state(line) [regsub -all \n $text {} discard]

	# If the current mode is cdata or comment then we must undo what the
	# regsub has done to reconstitute the data

	switch $state(mode) {
	    comment {
		# This had "[string length $param] && " as a guard -
		# can't remember why :-(
		if {[regexp ([cl ^-]*)--\$ $tag discard comm1]} {
		    # end of comment (in tag)
		    set tag {}
		    set close {}
		    set empty {}
		    set state(mode) normal
		    uplevel #0 $options(-commentcommand) [list $state(commentdata)<$comm1]
		    unset state(commentdata)
		} elseif {[regexp ([cl ^-]*)--\$ $param discard comm1]} {
		    # end of comment (in attributes)
		    uplevel #0 $options(-commentcommand) [list $state(commentdata)<$close$tag$empty>$comm1]
		    unset state(commentdata)
		    set tag {}
		    set param {}
		    set close {}
		    set empty {}
		    set state(mode) normal
		} elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm1 text]} {
		    # end of comment (in text)
		    uplevel #0 $options(-commentcommand) [list $state(commentdata)<$close$tag$param$empty>$comm1]
		    unset state(commentdata)
		    set tag {}
		    set param {}
		    set close {}
		    set empty {}
		    set state(mode) normal
		} else {
		    # comment continues
		    append state(commentdata) <$close$tag$param$empty>$text
		    continue
		}
	    }
	    cdata {
		if {[string length $param] && [regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $tag discard cdata1]} {
		    # end of CDATA (in tag)
		    uplevel #0 $options(-characterdatacommand) [list $state(cdata)<$close$cdata1$text]
		    set text {}
		    set tag {}
		    unset state(cdata)
		    set state(mode) normal
		} elseif {[regexp ([cl ^\]]*)\]\][cl $Wsp]*\$ $param discard cdata1]} {
		    # end of CDATA (in attributes)
		    uplevel #0 $options(-characterdatacommand) [list $state(cdata)<$close$tag$cdata1$text]
		    set text {}
		    set tag {}
		    set param {}
		    unset state(cdata)
		    set state(mode) normal
		} elseif {[regexp ([cl ^\]]*)\]\][cl $Wsp]*>(.*) $text discard cdata1 text]} {
		    # end of CDATA (in text)
		    uplevel #0 $options(-characterdatacommand) [list $state(cdata)<$close$tag$param$empty>$cdata1$text]
		    set text {}
		    set tag {}
		    set param {}
		    set close {}
		    set empty {}
		    unset state(cdata)
		    set state(mode) normal
		} else {
		    # CDATA continues
		    append state(cdata) <$close$tag$param$empty>$text
		    continue
		}
	    }
	}

	# default: normal mode

	# Bug: if the attribute list has a right angle bracket then the empty
	# element marker will not be seen

	set isEmpty [uplevel #0 $options(-emptyelement) [list $tag $param $empty]]
	if {[llength $isEmpty]} {
	    foreach {empty tag param} $isEmpty break
	}

	switch -glob -- [string length $tag],[regexp {^\?|!.*} $tag],$close,$empty {

	    0,0,, {
		# Ignore empty tag - dealt with non-normal mode above
	    }
	    *,0,, {

		# Start tag for an element.

		# Check for a right angle bracket in an attribute value
		# This manifests itself by terminating the value before
		# the delimiter is seen, and the delimiter appearing
		# in the text

		# BUG: If two or more attribute values have right angle
		# brackets then this will fail on the second one.

		if {[regexp [format {=[%s]*"[^"]*$} $Wsp] $param] && \
			[regexp {([^"]*"[^>]*)>(.*)} $text discard attrListRemainder text]} {
		    append param >$attrListRemainder
		} elseif {[regexp [format {=[%s]*'[^']*$} $Wsp] $param] && \
			[regexp {([^']*'[^>]*)>(.*)} $text discard attrListRemainder text]} {
		    append param >$attrListRemainder
		}

		# Check if the internal DTD entity is in an attribute
		# value
		regsub -all &xml:intdtd\; $param \[$options(-internaldtd)\] param

		ParseEvent:ElementOpen $tag $param options
		set state(haveDocElement) 1

	    }

	    *,0,/, {

		# End tag for an element.

		ParseEvent:ElementClose $tag options

	    }

	    *,0,,/ {

		# Empty element

		ParseEvent:ElementOpen $tag $param options -empty 1
		ParseEvent:ElementClose $tag options -empty 1

	    }

	    *,1,* {
		# Processing instructions or XML declaration
		switch -glob -- $tag {

		    {\?xml} {
			# XML Declaration
			if {$state(haveXMLDecl)} {
			    uplevel #0 $options(-errorcommand) "unexpected characters \"<$tag\" around line $state(line)"
			} elseif {![regexp {\?$} $param]} {
			    uplevel #0 $options(-errorcommand) "XML Declaration missing characters \"?>\" around line $state(line)"
			} else {

			    # Get the version number
			    if {[regexp {[ 	]*version="(-+|[a-zA-Z0-9_.:]+)"[ 	]*} $param discard version] || [regexp {[ 	]*version='(-+|[a-zA-Z0-9_.:]+)'[ 	]*} $param discard version]} {
				if {$version ne "1.0" } {
				    # Should we support future versions?
				    # At least 1.X?
				    uplevel #0 $options(-errorcommand) "document XML version \"$version\" is incompatible with XML version 1.0"
				}
			    } else {
				uplevel #0 $options(-errorcommand) "XML Declaration missing version information around line $state(line)"
			    }

			    # Get the encoding declaration
			    set encoding {}
			    regexp {[ 	]*encoding="([A-Za-z]([A-Za-z0-9._]|-)*)"[ 	]*} $param discard encoding
			    regexp {[ 	]*encoding='([A-Za-z]([A-Za-z0-9._]|-)*)'[ 	]*} $param discard encoding

			    # Get the standalone declaration
			    set standalone {}
			    regexp {[ 	]*standalone="(yes|no)"[ 	]*} $param discard standalone
			    regexp {[ 	]*standalone='(yes|no)'[ 	]*} $param discard standalone

			    # Invoke the callback
			    uplevel #0 $options(-xmldeclcommand) [list $version $encoding $standalone]

			}

		    }

		    {\?*} {
			# Processing instruction
			if {![regsub {\?$} $param {} param]} {
			    uplevel #0 $options(-errorcommand) "PI: expected '?' character around line $state(line)"
			} else {
			    uplevel #0 $options(-processinginstructioncommand) [list [string range $tag 1 end] [string trimleft $param]]
			}
		    }

		    !DOCTYPE {
			# External entity reference
			# This should move into xml.tcl
			# Parse the params supplied.  Looking for Name, ExternalID and MarkupDecl
			regexp ^[cl $Wsp]*($name)(.*) $param x state(doc_name) param
			set state(doc_name) [Normalize $state(doc_name) $options(-normalize)]
			set externalID {}
			set pubidlit {}
			set systemlit {}
			set externalID {}
			if {[regexp -nocase ^[cl $Wsp]*(SYSTEM|PUBLIC)(.*) $param x id param]} {
			    switch [string toupper $id] {
				SYSTEM {
				    if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
					set externalID [list SYSTEM $systemlit] ;# "
				    } else {
					uplevel #0 $options(-errorcommand) {{syntax error: SYSTEM identifier not followed by literal}}
				    }
				}
				PUBLIC {
				    if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x pubidlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x pubidlit param]} {
					if {[regexp ^[cl $Wsp]+"([cl ^"]*)"(.*) $param x systemlit param] || [regexp ^[cl $Wsp]+'([cl ^']*)'(.*) $param x systemlit param]} {
					    set externalID [list PUBLIC $pubidlit $systemlit]
					} else {
					    uplevel #0 $options(-errorcommand) "syntax error: PUBLIC identifier not followed by system literal around line $state(line)"
					}
				    } else {
					uplevel #0 $options(-errorcommand) "syntax error: PUBLIC identifier not followed by literal around line $state(line)"
				    }
				}
			    }
			    if {[regexp -nocase ^[cl $Wsp]+NDATA[cl $Wsp]+($name)(.*) $param x notation param]} {
				lappend externalID $notation
			    }
			}

			uplevel #0 $options(-doctypecommand) $state(doc_name) [list $pubidlit $systemlit $options(-internaldtd)]

		    }

		    !--* {

			# Start of a comment
			# See if it ends in the same tag, otherwise change the
			# parsing mode

			regexp {!--(.*)} $tag discard comm1
			if {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $comm1 discard comm1_1]} {
			    # processed comment (end in tag)
			    uplevel #0 $options(-commentcommand) [list $comm1_1]
			} elseif {[regexp ([cl ^-]*)--[cl $Wsp]*\$ $param discard comm2]} {
			    # processed comment (end in attributes)
			    uplevel #0 $options(-commentcommand) [list $comm1$comm2]
			} elseif {[regexp ([cl ^-]*)-->(.*) $text discard comm2 text]} {
			    # processed comment (end in text)
			    uplevel #0 $options(-commentcommand) [list $comm1$param>$comm2]
			} else {
			    # start of comment
			    set state(mode) comment
			    set state(commentdata) "$comm1$param>$text"
			    continue
			}
		    }

		    {!\[CDATA\[*} {

			regexp {!\[CDATA\[(.*)} $tag discard cdata1
			if {[regexp {(.*)]]$} $param discard cdata2]} {
			    # processed CDATA (end in attribute)
			    uplevel #0 $options(-characterdatacommand) [list $cdata1$cdata2$text]
			    set text {}
			} elseif {[regexp {(.*)]]>(.*)} $text discard cdata2 text]} {
			    # processed CDATA (end in text)
			    uplevel #0 $options(-characterdatacommand) [list $cdata1$param$empty>$cdata2$text]
			    set text {}
			} else {
			    # start CDATA
			    set state(cdata) "$cdata1$param>$text"
			    set state(mode) cdata
			    continue
			}

		    }

		    !ELEMENT {
			# Internal DTD declaration
		    }
		    !ATTLIST {
		    }
		    !ENTITY {
		    }
		    !NOTATION {
		    }


		    !* {
			uplevel #0 $options(-processinginstructioncommand) [list $tag $param]
		    }
		    default {
			uplevel #0 $options(-errorcommand) [list "unknown processing instruction \"<$tag>\" around line $state(line)"]
		    }
		}
	    }
	    *,1,* -
	    *,0,/,/ {
		# Syntax error
	    	uplevel #0 $options(-errorcommand) [list [list syntax error: closed/empty tag: tag $tag param $param empty $empty close $close around line $state(line)]]
	    }
	}

	# Process character data

	if {$state(haveDocElement) && [llength $state(stack)]} {

	    # Check if the internal DTD entity is in the text
	    regsub -all &xml:intdtd\; $text \[$options(-internaldtd)\] text

	    # Look for entity references
	    if {([array size entities] || [string length $options(-entityreferencecommand)]) && \
		[regexp {&[^;]+;} $text]} {

		# protect Tcl specials
		regsub -all {([][$\\])} $text {\\\1} text
		# Mark entity references
		regsub -all {&([^;]+);} $text [format {%s; %s {\1} ; %s %s} \}\} [namespace code [list Entity options $options(-entityreferencecommand) $options(-characterdatacommand) $options(-entityvariable)]] [list uplevel #0 $options(-characterdatacommand)] \{\{] text
		set text "uplevel #0 $options(-characterdatacommand) {{$text}}"
		eval $text
	    } else {
		# Restore protected special characters
		regsub -all {\\([{}\\])} $text {\1} text
		uplevel #0 $options(-characterdatacommand) [list $text]
	    }
	} elseif {[string length [string trim $text]]} {
	    uplevel #0 $options(-errorcommand) "unexpected text \"$text\" in document prolog around line $state(line)"
	}

    }

    # If this is the end of the document, close all open containers
    if {$options(-final) && [llength $state(stack)]} {
	eval $options(-errorcommand) [list [list element [lindex $state(stack) end] remains unclosed around line $state(line)]]
    }

    return {}
}

# sgml::ParseEvent:ElementOpen --
#
#	Start of an element.
#
# Arguments:
#	tag	Element name
#	attr	Attribute list
#	opts	Option variable in caller
#	args	further configuration options
#
# Options:
#	-empty boolean
#		indicates whether the element was an empty element
#
# Results:
#	Modify state and invoke callback

proc sgml::ParseEvent:ElementOpen {tag attr opts args} {
    upvar $opts options
    upvar #0 $options(-statevariable) state
    array set cfg {-empty 0}
    array set cfg $args

    if {$options(-normalize)} {
	set tag [string toupper $tag]
    }

    # Update state
    lappend state(stack) $tag

    # Parse attribute list into a key-value representation
    if {[string compare $options(-parseattributelistcommand) {}]} {
	if {[catch {uplevel #0 $options(-parseattributelistcommand) [list $attr]} attr]} {
	    uplevel #0 $options(-errorcommand) [list $attr around line $state(line)]
	    set attr {}
	}
    }

    set empty {}
    if {$cfg(-empty) && $options(-reportempty)} {
	set empty {-empty 1}
    }

    # Invoke callback
    uplevel #0 $options(-elementstartcommand) [list $tag $attr] $empty

    return {}
}

# sgml::ParseEvent:ElementClose --
#
#	End of an element.
#
# Arguments:
#	tag	Element name
#	opts	Option variable in caller
#	args	further configuration options
#
# Options:
#	-empty boolean
#		indicates whether the element as an empty element
#
# Results:
#	Modify state and invoke callback

proc sgml::ParseEvent:ElementClose {tag opts args} {
    upvar $opts options
    upvar #0 $options(-statevariable) state
    array set cfg {-empty 0}
    array set cfg $args

    # WF check
    if {$tag ne [lindex $state(stack) end] } {
	uplevel #0 $options(-errorcommand) [list "end tag \"$tag\" does not match open element \"[lindex $state(stack) end]\" around line $state(line)"]
	return
    }

    # Update state
    set state(stack) [lreplace $state(stack) end end]

    set empty {}
    if {$cfg(-empty) && $options(-reportempty)} {
	set empty {-empty 1}
    }

    # Invoke callback
    uplevel #0 $options(-elementendcommand) [list $tag] $empty

    return {}
}

# sgml::Normalize --
#
#	Perform name normalization if required
#
# Arguments:
#	name	name to normalize
#	req	normalization required
#
# Results:
#	Name returned as upper-case if normalization required

proc sgml::Normalize {name req} {
    if {$req} {
	return [string toupper $name]
    } else {
	return $name
    }
}

# sgml::Entity --
#
#	Resolve XML entity references (syntax: &xxx;).
#
# Arguments:
#	opts		options array variable in caller
#	entityrefcmd	application callback for entity references
#	pcdatacmd	application callback for character data
#	entities	name of array containing entity definitions.
#	ref		entity reference (the "xxx" bit)
#
# Results:
#	Returns substitution text for given entity.

proc sgml::Entity {opts entityrefcmd pcdatacmd entities ref} {
    upvar 2 $opts options
    upvar #0 $options(-statevariable) state

    if {![string length $entities]} {
	set entities [namespace current EntityPredef]
    }

    switch -glob -- $ref {
	%* {
	    # Parameter entity - not recognised outside of a DTD
	}
	#x* {
	    # Character entity - hex
	    if {[catch {format %c [scan [string range $ref 2 end] %x tmp; set tmp]} char]} {
		return -code error "malformed character entity \"$ref\""
	    }
	    uplevel #0 $pcdatacmd [list $char]

	    return {}

	}
	#* {
	    # Character entity - decimal
	    if {[catch {format %c [scan [string range $ref 1 end] %d tmp; set tmp]} char]} {
		return -code error "malformed character entity \"$ref\""
	    }
	    uplevel #0 $pcdatacmd [list $char]

	    return {}

	}
	default {
	    # General entity
	    upvar #0 $entities map
	    if {[info exists map($ref)]} {

		if {![regexp {<|&} $map($ref)]} {

		    # Simple text replacement - optimise

		    uplevel #0 $pcdatacmd [list $map($ref)]

		    return {}

		}

		# Otherwise an additional round of parsing is required.
		# This only applies to XML, since HTML doesn't have general entities

		# Must parse the replacement text for start & end tags, etc
		# This text must be self-contained: balanced closing tags, and so on

		set tokenised [tokenise $map($ref) $::xml::tokExpr $::xml::substExpr]
		set final $options(-final)
		unset options(-final)
		eval parseEvent [list $tokenised] [array get options] -final 0
		set options(-final) $final

		return {}

	    } elseif {[string length $entityrefcmd]} {

		uplevel #0 $entityrefcmd [list $ref]

		return {}

	    }
	}
    }

    # If all else fails leave the entity reference untouched
    uplevel #0 $pcdatacmd [list &$ref\;]

    return {}
}

####################################
#
# DTD parser for SGML (XML).
#
# This DTD actually only handles XML DTDs.  Other language's
# DTD's, such as HTML, must be written in terms of a XML DTD.
#
# A DTD is represented as a three element Tcl list.
# The first element contains the content models for elements,
# the second contains the attribute lists for elements and
# the last element contains the entities for the document.
#
####################################

# sgml::parseDTD --
#
#	Entry point to the SGML DTD parser.
#
# Arguments:
#	dtd	data defining the DTD to be parsed
#	args	configuration options
#
# Results:
#	Returns a three element list, first element is the content model
#	for each element, second element are the attribute lists of the
#	elements and the third element is the entity map.

proc sgml::parseDTD {dtd args} {
    variable Wsp
    variable ParseDTDnum

    array set opts [list \
	-errorcommand		[namespace current]::noop \
	state			[namespace current]::parseDTD[incr ParseDTDnum]
    ]
    array set opts $args

    set exp <!([cl ^$Wsp>]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^>]*)>
    set sub {{\1} {\2} {\3} }
    regsub -all $exp $dtd $sub dtd

    foreach {decl id value} $dtd {
	catch {DTD:[string toupper $decl] $id $value} err
    }

    return [list [array get contentmodel] [array get attributes] [array get entities]]
}

# Procedures for handling the various declarative elements in a DTD.
# New elements may be added by creating a procedure of the form
# parse:DTD:_element_

# For each of these procedures, the various regular expressions they use
# are created outside of the proc to avoid overhead at runtime

# sgml::DTD:ELEMENT --
#
#	<!ELEMENT ...> defines an element.
#
#	The content model for the element is stored in the contentmodel array,
#	indexed by the element name.  The content model is parsed into the
#	following list form:
#
#		{}	Content model is EMPTY.
#			Indicated by an empty list.
#		*	Content model is ANY.
#			Indicated by an asterix.
#		{ELEMENT ...}
#			Content model is element-only.
#		{MIXED {element1 element2 ...}}
#			Content model is mixed (PCDATA and elements).
#			The second element of the list contains the 
#			elements that may occur.  #PCDATA is assumed 
#			(ie. the list is normalised).
#
# Arguments:
#	id	identifier for the element.
#	value	other information in the PI

proc sgml::DTD:ELEMENT {id value} {
    dbgputs DTD_parse [list DTD:ELEMENT $id $value]
    variable Wsp
    upvar opts state
    upvar contentmodel cm

    if {[info exists cm($id)]} {
	eval $state(-errorcommand) element [list "element \"$id\" already declared"]
    } else {
	switch -- $value {
	    EMPTY {
	    	set cm($id) {}
	    }
	    ANY {
	    	set cm($id) *
	    }
	    default {
		if {[regexp [format {^\([%s]*#PCDATA[%s]*(\|([^)]+))?[%s]*\)*[%s]*$} $Wsp $Wsp $Wsp $Wsp] discard discard mtoks]} {
		    set cm($id) [list MIXED [split $mtoks |]]
		} else {
		    if {[catch {CModelParse $state(state) $value} result]} {
			eval $state(-errorcommand) element [list $result]
		    } else {
			set cm($id) [list ELEMENT $result]
		    }
		}
	    }
	}
    }
}

# sgml::CModelParse --
#
#	Parse an element content model (non-mixed).
#	A syntax tree is constructed.
#	A transition table is built next.
#
#	This is going to need alot of work!
#
# Arguments:
#	state	state array variable
#	value	the content model data
#
# Results:
#	A Tcl list representing the content model.

proc sgml::CModelParse {state value} {
    upvar #0 $state var

    # First build syntax tree
    set syntaxTree [CModelMakeSyntaxTree $state $value]

    # Build transition table
    set transitionTable [CModelMakeTransitionTable $state $syntaxTree]

    return [list $syntaxTree $transitionTable]
}

# sgml::CModelMakeSyntaxTree --
#
#	Construct a syntax tree for the regular expression.
#
#	Syntax tree is represented as a Tcl list:
#	rep {:choice|:seq {{rep list1} {rep list2} ...}}
#	where:	rep is repetition character, *, + or ?. {} for no repetition
#		listN is nested expression or Name
#
# Arguments:
#	spec	Element specification
#
# Results:
#	Syntax tree for element spec as nested Tcl list.
#
#	Examples:
#	(memo)
#		{} {:seq {{} memo}}
#	(front, body, back?)
#		{} {:seq {{} front} {{} body} {? back}}
#	(head, (p | list | note)*, div2*)
#		{} {:seq {{} head} {* {:choice {{} p} {{} list} {{} note}}} {* div2}}
#	(p | a | ul)+
#		+ {:choice {{} p} {{} a} {{} ul}}

proc sgml::CModelMakeSyntaxTree {state spec} {
    upvar #0 $state var
    variable Wsp
    variable name

    # Translate the spec into a Tcl list.

    # None of the Tcl special characters are allowed in a content model spec.
    if {[regexp {\$|\[|\]|\{|\}} $spec]} {
	return -code error "illegal characters in specification"
    }

    regsub -all [format {(%s)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $name $Wsp $Wsp] $spec [format {%sCModelSTname %s {\1} {\2} {\3}} \n $state] spec
    regsub -all {\(} $spec "\nCModelSTopenParen $state " spec
    regsub -all [format {\)[%s]*(\?|\*|\+)?[%s]*(,|\|)?} $Wsp $Wsp] $spec [format {%sCModelSTcloseParen %s {\1} {\2}} \n $state] spec

    array set var {stack {} state start}
    eval $spec

    # Peel off the outer seq, its redundant
    return [lindex [lindex $var(stack) 1] 0]
}

# sgml::CModelSTname --
#
#	Processes a name in a content model spec.
#
# Arguments:
#	state	state array variable
#	name	name specified
#	rep	repetition operator
#	cs	choice or sequence delimiter
#
# Results:
#	See CModelSTcp.

proc sgml::CModelSTname {state name rep cs args} {
    if {[llength $args]} {
	return -code error "syntax error in specification: \"$args\""
    }

    CModelSTcp $state $name $rep $cs
}

# sgml::CModelSTcp --
#
#	Process a content particle.
#
# Arguments:
#	state	state array variable
#	name	name specified
#	rep	repetition operator
#	cs	choice or sequence delimiter
#
# Results:
#	The content particle is added to the current group.

proc sgml::CModelSTcp {state cp rep cs} {
    upvar #0 $state var

    switch -glob -- [lindex $var(state) end]=$cs {
	start= {
	    set var(state) [lreplace $var(state) end end end]
	    # Add (dummy) grouping, either choice or sequence will do
	    CModelSTcsSet $state ,
	    CModelSTcpAdd $state $cp $rep
	}
	:choice= -
	:seq= {
	    set var(state) [lreplace $var(state) end end end]
	    CModelSTcpAdd $state $cp $rep
	}
	start=| -
	start=, {
	    set var(state) [lreplace $var(state) end end [expr {$cs eq "," ? ":seq" : ":choice"}]]
	    CModelSTcsSet $state $cs
	    CModelSTcpAdd $state $cp $rep
	}
	:choice=| -
	:seq=, {
	    CModelSTcpAdd $state $cp $rep
	}
	:choice=, -
	:seq=| {
	    return -code error "syntax error in specification: incorrect delimiter after \"$cp\", should be \"[expr {$cs eq "," ? "|" : ","}]\""
	}
	end=* {
	    return -code error "syntax error in specification: no delimiter before \"$cp\""
	}
	default {
	    return -code error "syntax error"
	}
    }
    
}

# sgml::CModelSTcsSet --
#
#	Start a choice or sequence on the stack.
#
# Arguments:
#	state	state array
#	cs	choice oir sequence
#
# Results:
#	state is modified: end element of state is appended.

proc sgml::CModelSTcsSet {state cs} {
    upvar #0 $state var

    set cs [expr {$cs eq "," ? ":seq" : ":choice"}]

    if {[llength $var(stack)]} {
	set var(stack) [lreplace $var(stack) end end $cs]
    } else {
	set var(stack) [list $cs {}]
    }
}

# sgml::CModelSTcpAdd --
#
#	Append a content particle to the top of the stack.
#
# Arguments:
#	state	state array
#	cp	content particle
#	rep	repetition
#
# Results:
#	state is modified: end element of state is appended.

proc sgml::CModelSTcpAdd {state cp rep} {
    upvar #0 $state var

    if {[llength $var(stack)]} {
	set top [lindex $var(stack) end]
    	lappend top [list $rep $cp]
	set var(stack) [lreplace $var(stack) end end $top]
    } else {
	set var(stack) [list $rep $cp]
    }
}

# sgml::CModelSTopenParen --
#
#	Processes a '(' in a content model spec.
#
# Arguments:
#	state	state array
#
# Results:
#	Pushes stack in state array.

proc sgml::CModelSTopenParen {state args} {
    upvar #0 $state var

    if {[llength $args]} {
	return -code error "syntax error in specification: \"$args\""
    }

    lappend var(state) start
    lappend var(stack) [list {} {}]
}

# sgml::CModelSTcloseParen --
#
#	Processes a ')' in a content model spec.
#
# Arguments:
#	state	state array
#	rep	repetition
#	cs	choice or sequence delimiter
#
# Results:
#	Stack is popped, and former top of stack is appended to previous element.

proc sgml::CModelSTcloseParen {state rep cs args} {
    upvar #0 $state var

    if {[llength $args]} {
	return -code error "syntax error in specification: \"$args\""
    }

    set cp [lindex $var(stack) end]
    set var(stack) [lreplace $var(stack) end end]
    set var(state) [lreplace $var(state) end end]
    CModelSTcp $state $cp $rep $cs
}

# sgml::CModelMakeTransitionTable --
#
#	Given a content model's syntax tree, constructs
#	the transition table for the regular expression.
#
#	See "Compilers, Principles, Techniques, and Tools",
#	Aho, Sethi and Ullman.  Section 3.9, algorithm 3.5.
#
# Arguments:
#	state	state array variable
#	st	syntax tree
#
# Results:
#	The transition table is returned, as a key/value Tcl list.

proc sgml::CModelMakeTransitionTable {state st} {
    upvar #0 $state var

    # Construct nullable, firstpos and lastpos functions
    array set var {number 0}
    foreach {nullable firstpos lastpos} [	\
	TraverseDepth1st $state $st {
	    # Evaluated for leaf nodes
	    # Compute nullable(n)
	    # Compute firstpos(n)
	    # Compute lastpos(n)
	    set nullable [nullable leaf $rep $name]
	    set firstpos [list {} $var(number)]
	    set lastpos [list {} $var(number)]
	    set var(pos:$var(number)) $name
	} {
	    # Evaluated for nonterminal nodes
	    # Compute nullable, firstpos, lastpos
	    set firstpos [firstpos $cs $firstpos $nullable]
	    set lastpos  [lastpos  $cs $lastpos  $nullable]
	    set nullable [nullable nonterm $rep $cs $nullable]
	}	\
    ] break

    set accepting [incr var(number)]
    set var(pos:$accepting) #

    # var(pos:N) maps from position to symbol.
    # Construct reverse map for convenience.
    # NB. A symbol may appear in more than one position.
    # var is about to be reset, so use different arrays.

    foreach {pos symbol} [array get var pos:*] {
	set pos [lindex [split $pos :] 1]
	set pos2symbol($pos) $symbol
	lappend sym2pos($symbol) $pos
    }

    # Construct the followpos functions
    catch {unset var}
    followpos $state $st $firstpos $lastpos

    # Construct transition table
    # Dstates is [union $marked $unmarked]
    set unmarked [list [lindex $firstpos 1]]
    while {[llength $unmarked]} {
	set T [lindex $unmarked 0]
	lappend marked $T
	set unmarked [lrange $unmarked 1 end]

	# Find which input symbols occur in T
	set symbols {}
	foreach pos $T {
	    if {$pos != $accepting && [lsearch $symbols $pos2symbol($pos)] < 0} {
		lappend symbols $pos2symbol($pos)
	    }
	}
	foreach a $symbols {
	    set U {}
	    foreach pos $sym2pos($a) {
		if {[lsearch $T $pos] >= 0} {
		    # add followpos($pos)
	    	    if {$var($pos) == {}} {
	    	    	lappend U $accepting
	    	    } else {
	    	    	eval lappend U $var($pos)
	    	    }
		}
	    }
	    set U [makeSet $U]
	    if {[llength $U] && [lsearch $marked $U] < 0 && [lsearch $unmarked $U] < 0} {
		lappend unmarked $U
	    }
	    set Dtran($T,$a) $U
	}
	
    }

    return [list [array get Dtran] [array get sym2pos] $accepting]
}

# sgml::followpos --
#
#	Compute the followpos function, using the already computed
#	firstpos and lastpos.
#
# Arguments:
#	state		array variable to store followpos functions
#	st		syntax tree
#	firstpos	firstpos functions for the syntax tree
#	lastpos		lastpos functions
#
# Results:
#	followpos functions for each leaf node, in name/value format

proc sgml::followpos {state st firstpos lastpos} {
    upvar #0 $state var

    switch -- [lindex [lindex $st 1] 0] {
	:seq {
	    for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
	    	followpos $state [lindex [lindex $st 1] $i]			\
			[lindex [lindex $firstpos 0] [expr {$i - 1}]]	\
			[lindex [lindex $lastpos 0] [expr {$i - 1}]]
	    	foreach pos [lindex [lindex [lindex $lastpos 0] [expr {$i - 1}]] 1] {
		    eval lappend var($pos) [lindex [lindex [lindex $firstpos 0] $i] 1]
		    set var($pos) [makeSet $var($pos)]
	    	}
	    }
	}
	:choice {
	    for {set i 1} {$i < [llength [lindex $st 1]]} {incr i} {
		followpos $state [lindex [lindex $st 1] $i]			\
			[lindex [lindex $firstpos 0] [expr {$i - 1}]]	\
			[lindex [lindex $lastpos 0] [expr {$i - 1}]]
	    }
	}
	default {
	    # No action at leaf nodes
	}
    }

    switch -- [lindex $st 0] {
	? {
	    # We having nothing to do here ! Doing the same as
	    # for * effectively converts this qualifier into the other.
	}
	* {
	    foreach pos [lindex $lastpos 1] {
		eval lappend var($pos) [lindex $firstpos 1]
		set var($pos) [makeSet $var($pos)]
	    }
	}
    }

}

# sgml::TraverseDepth1st --
#
#	Perform depth-first traversal of a tree.
#	A new tree is constructed, with each node computed by f.
#
# Arguments:
#	state	state array variable
#	t	The tree to traverse, a Tcl list
#	leaf	Evaluated at a leaf node
#	nonTerm	Evaluated at a nonterminal node
#
# Results:
#	A new tree is returned.

proc sgml::TraverseDepth1st {state t leaf nonTerm} {
    upvar #0 $state var

    set nullable {}
    set firstpos {}
    set lastpos {}

    switch -- [lindex [lindex $t 1] 0] {
	:seq -
	:choice {
	    set rep [lindex $t 0]
	    set cs [lindex [lindex $t 1] 0]

	    foreach child [lrange [lindex $t 1] 1 end] {
		foreach {childNullable childFirstpos childLastpos} \
			[TraverseDepth1st $state $child $leaf $nonTerm] break
		lappend nullable $childNullable
		lappend firstpos $childFirstpos
		lappend lastpos  $childLastpos
	    }

	    eval $nonTerm
	}
	default {
	    incr var(number)
	    set rep [lindex [lindex $t 0] 0]
	    set name [lindex [lindex $t 1] 0]
	    eval $leaf
	}
    }

    return [list $nullable $firstpos $lastpos]
}

# sgml::firstpos --
#
#	Computes the firstpos function for a nonterminal node.
#
# Arguments:
#	cs		node type, choice or sequence
#	firstpos	firstpos functions for the subtree
#	nullable	nullable functions for the subtree
#
# Results:
#	firstpos function for this node is returned.

proc sgml::firstpos {cs firstpos nullable} {
    switch -- $cs {
	:seq {
	    set result [lindex [lindex $firstpos 0] 1]
	    for {set i 0} {$i < [llength $nullable]} {incr i} {
	    	if {[lindex [lindex $nullable $i] 1]} {
	    	    eval lappend result [lindex [lindex $firstpos [expr {$i + 1}]] 1]
		} else {
		    break
		}
	    }
	}
	:choice {
	    foreach child $firstpos {
		eval lappend result $child
	    }
	}
    }

    return [list $firstpos [makeSet $result]]
}

# sgml::lastpos --
#
#	Computes the lastpos function for a nonterminal node.
#	Same as firstpos, only logic is reversed
#
# Arguments:
#	cs		node type, choice or sequence
#	lastpos		lastpos functions for the subtree
#	nullable	nullable functions forthe subtree
#
# Results:
#	lastpos function for this node is returned.

proc sgml::lastpos {cs lastpos nullable} {
    switch -- $cs {
	:seq {
	    set result [lindex [lindex $lastpos end] 1]
	    for {set i [expr {[llength $nullable] - 1}]} {$i >= 0} {incr i -1} {
		if {[lindex [lindex $nullable $i] 1]} {
		    eval lappend result [lindex [lindex $lastpos $i] 1]
		} else {
		    break
		}
	    }
	}
	:choice {
	    foreach child $lastpos {
		eval lappend result $child
	    }
	}
    }

    return [list $lastpos [makeSet $result]]
}

# sgml::makeSet --
#
#	Turn a list into a set, ie. remove duplicates.
#
# Arguments:
#	s	a list
#
# Results:
#	A set is returned, which is a list with duplicates removed.

proc sgml::makeSet s {
    foreach r $s {
	if {[llength $r]} {
	    set unique($r) {}
	}
    }
    return [array names unique]
}

# sgml::nullable --
#
#	Compute the nullable function for a node.
#
# Arguments:
#	nodeType	leaf or nonterminal
#	rep		repetition applying to this node
#	name		leaf node: symbol for this node, nonterm node: choice or seq node
#	subtree		nonterm node: nullable functions for the subtree
#
# Results:
#	Returns nullable function for this branch of the tree.

proc sgml::nullable {nodeType rep name {subtree {}}} {
    switch -glob -- $rep:$nodeType {
	:leaf -
	+:leaf {
	    return [list {} 0]
	}
	\\*:leaf -
	\\?:leaf {
	    return [list {} 1]
	}
	\\*:nonterm -
	\\?:nonterm {
	    return [list $subtree 1]
	}
	:nonterm -
	+:nonterm {
	    switch -- $name {
		:choice {
		    set result 0
		    foreach child $subtree {
			set result [expr {$result || [lindex $child 1]}]
		    }
		}
		:seq {
		    set result 1
		    foreach child $subtree {
			set result [expr {$result && [lindex $child 1]}]
		    }
		}
	    }
	    return [list $subtree $result]
	}
    }
}

# These regular expressions are defined here once for better performance

namespace eval sgml {
    variable Wsp

    # Watch out for case-sensitivity

    set attlist_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(#REQUIRED|#IMPLIED)
    set attlist_enum_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*\\(([cl ^)]*)\\)[cl $Wsp]*("([cl ^")])")? ;# "
    set attlist_fixed_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(#FIXED)[cl $Wsp]*([cl ^$Wsp]+)

    set param_entity_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*([cl ^"$Wsp]*)[cl $Wsp]*"([cl ^"]*)"

    set notation_exp [cl $Wsp]*([cl ^$Wsp]+)[cl $Wsp]*(.*)

}

# sgml::DTD:ATTLIST --
#
#	<!ATTLIST ...> defines an attribute list.
#
# Arguments:
#	id	Element an attribute list is being defined for.
#	value	data from the PI.
#
# Results:
#	Attribute list variables are modified.

proc sgml::DTD:ATTLIST {id value} {
    variable attlist_exp
    variable attlist_enum_exp
    variable attlist_fixed_exp
    dbgputs DTD_parse [list DTD:ATTLIST $id $value]
    upvar opts state
    upvar attributes am

    if {[info exists am($id)]} {
	eval $state(-errorcommand) attlist [list "attribute list for element \"$id\" already declared"]
    } else {
	# Parse the attribute list.  If it were regular, could just use foreach,
	# but some attributes may have values.
	regsub -all {([][$\\])} $value {\\\1} value
	regsub -all $attlist_exp $value {[DTDAttribute {\1} {\2} {\3}]} value
	regsub -all $attlist_enum_exp $value {[DTDAttribute {\1} {\2} {\3}]} value
	regsub -all $attlist_fixed_exp $value {[DTDAttribute {\1} {\2} {\3} {\4}]} value
	subst $value
	set am($id) [array get attlist]
    }
}

# sgml::DTDAttribute --
#
#	Parse definition of a single attribute.
#
# Arguments:
#	name	attribute name
#	type	type of this attribute
#	default	default value of the attribute
#	value	other information

proc sgml::DTDAttribute {name type default {value {}}} {
    upvar attlist al
    # This needs further work
    set al($name) [list $default $value]
}

# sgml::DTD:ENTITY --
#
#	<!ENTITY ...> PI
#
# Arguments:
#	id	identifier for the entity
#	value	data
#
# Results:
#	Modifies the caller's entities array variable

proc sgml::DTD:ENTITY {id value} {
    variable param_entity_exp
    dbgputs DTD_parse [list DTD:ENTITY $id $value]
    upvar opts state
    upvar entities ents

    if {"%" ne $id } {
	# Entity declaration
	if {[info exists ents($id)]} {
	    eval $state(-errorcommand) entity [list "entity \"$id\" already declared"]
	} else {
	    if {![regexp {"([^"]*)"} $value x entvalue] && ![regexp {'([^']*)'} $value x entvalue]} {
		eval $state(-errorcommand) entityvalue [list "entity value \"$value\" not correctly specified"]
	    } ;# "
	    set ents($id) $entvalue
	}
    } else {
	# Parameter entity declaration
	switch -glob [regexp $param_entity_exp $value x name scheme data],[string compare {} $scheme] {
	    0,* {
		eval $state(-errorcommand) entityvalue [list "parameter entity \"$value\" not correctly specified"]
	    }
	    *,0 {
	    	# SYSTEM or PUBLIC declaration
	    }
	    default {
	    	set ents($id) $data
	    }
	}
    }
}

# sgml::DTD:NOTATION --

proc sgml::DTD:NOTATION {id value} {
    variable notation_exp
    upvar opts state

    if {[regexp $notation_exp $value x scheme data] == 2} {
    } else {
	eval $state(-errorcommand) notationvalue [list "notation value \"$value\" incorrectly specified"]
    }
}

### Utility procedures

# sgml::noop --
#
#	A do-nothing proc
#
# Arguments:
#	args	arguments
#
# Results:
#	Nothing.

proc sgml::noop args {
    return 0
}

# sgml::identity --
#
#	Identity function.
#
# Arguments:
#	a	arbitrary argument
#
# Results:
#	$a

proc sgml::identity a {
    return $a
}

# sgml::Error --
#
#	Throw an error
#
# Arguments:
#	args	arguments
#
# Results:
#	Error return condition.

proc sgml::Error args {
    uplevel return -code error [list $args]
}

### Following procedures are based on html_library

# sgml::zapWhite --
#
#	Convert multiple white space into a single space.
#
# Arguments:
#	data	plain text
#
# Results:
#	As above

proc sgml::zapWhite data {
    regsub -all "\[ \t\r\n\]+" $data { } data
    return $data
}

proc sgml::Boolean value {
    regsub {1|true|yes|on} $value 1 value
    regsub {0|false|no|off} $value 0 value
    return $value
}

proc sgml::dbgputs {where text} {
    variable dbg

    catch {if {$dbg} {puts stdout "DBG: $where ($text)"}}
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted assets/xotcl1.6.7/xml/xml.tcl.

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
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
# xml.tcl --
#
#	This file provides XML services.
#	These services include a XML document instance and DTD parser,
#	as well as support for generating XML.
#
# Copyright (c) 1998,1999 Zveno Pty Ltd
# http://www.zveno.com/
# 
# Zveno makes this software and all associated data and documentation
# ('Software') available free of charge for non-commercial purposes only. You
# may make copies of the Software but you must include all of this notice on
# any copy.
# 
# The Software was developed for research purposes and Zveno does not warrant
# that it is error free or fit for any purpose.  Zveno disclaims any
# liability for all claims, expenses, losses, damages and costs any user may
# incur as a result of using, copying or modifying the Software.
#
# Copyright (c) 1997 Australian National University (ANU).
# 
# ANU makes this software and all associated data and documentation
# ('Software') available free of charge for non-commercial purposes only. You
# may make copies of the Software but you must include all of this notice on
# any copy.
# 
# The Software was developed for research purposes and ANU does not warrant
# that it is error free or fit for any purpose.  ANU disclaims any
# liability for all claims, expenses, losses, damages and costs any user may
# incur as a result of using, copying or modifying the Software.
#
# $Id: xml.tcl,v 1.4 2006/09/27 08:12:40 neumann Exp $

package provide xml 1.8

package require sgml 1.6

namespace eval xml {

    # Procedures for parsing XML documents
    namespace export parser
    # Procedures for parsing XML DTDs
    namespace export DTDparser

    # Counter for creating unique parser objects
    variable ParserCounter 0

    # Convenience routine
    proc cl x {
	return "\[$x\]"
    }

    # Define various regular expressions
    # white space
    variable Wsp " \t\r\n"
    variable noWsp [cl ^$Wsp]

    # Various XML names and tokens

    # BUG: NameChar does not include CombiningChar or Extender
    variable NameChar [cl -a-zA-Z0-9._:]
    variable Name [cl a-zA-Z_:]$NameChar*
    variable Nmtoken $NameChar+

    # Tokenising expressions

    variable tokExpr <(/?)([cl ^$Wsp>]+)([cl $Wsp]*[cl ^>]*)>
    variable substExpr "\}\n{\\2} {\\1} {} {\\3} \{"

    # table of predefined entities

    variable EntityPredef
    array set EntityPredef {
	lt <   gt >   amp &   quot \"   apos '