Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: code/branches/usability/data/tcl/init.tcl @ 10345

Last change on this file since 10345 was 7914, checked in by landauf, 14 years ago

since the mac_osx branch doesn't seem to get merged anytime soon, I fix this (potential) Tcl issue also in the trunk (see r7683)

  • Property svn:eol-style set to native
File size: 8.4 KB
Line 
1# Check if Tcl was properly initialized
2info library
3
4# Create orxonox namespace
5namespace eval orxonox {}
6
7# query --
8# Sends a query to the CommandExecutor of Orxonox and waits for the response.
9# This dummy procedure will be changed to it's real implementation by Orxonox itself.
10#
11# Arguments:
12# args - The command to send to Orxonox
13
14proc query args {
15    return -code error "Can't query Orxonox now"
16}
17
18
19# crossquery --
20# Sends a query to another Tcl-interpreter in Orxonox and waits for the response.
21# This dummy procedure will be changed to it's real implementation by Orxonox itself.
22#
23# Arguments:
24# id   - The ID of the other interpreter
25# args - The command to send to Orxonox
26
27proc crossquery {id args} {
28    return -code error "Can't query interpreter with ID $id now"
29}
30
31
32# execute --
33# Sends a command to the queue of Orxonox where it will be executed by the CommandExecutor after some time
34# This dummy procedure will be changed to it's real implementation by Orxonox itself.
35#
36# Arguments:
37# args - The command
38
39proc execute args {
40    return -code error "Can't execute a command now"
41}
42
43
44# crossexecute --
45# Sends a command to the queue of another Tcl-interpreter where it will be executed by after some time
46# This dummy procedure will be changed to it's real implementation by Orxonox itself.
47#
48# Arguments:
49# id   - The ID of the other interpreter
50# args - The command
51
52proc crossexecute {id args} {
53    return -code error "Can't execute a command now"
54}
55
56
57# running --
58# Returns true if the interpreter is still suposed to be running
59# This dummy procedure will be changed to it's real implementation by Orxonox itself.
60
61proc running {} {
62    return 1
63}
64
65
66# orxonox::while --
67# Works like while but breaks the loop if orxonox::running returns false
68
69proc ::orxonox::while {condition body} {
70    set condition_cmd [list expr $condition]
71    ::tcl::while {1} {
72        if {![uplevel 1 $condition_cmd] || ![::running]} {
73            break
74        }
75        uplevel 1 $body
76    }
77}
78
79
80# orxonox::for --
81# Works like for but breaks the loop if orxonox::running returns false
82
83proc ::orxonox::for {start condition step body} {
84    set condition_cmd [list expr $condition]
85    uplevel 1 $start
86    ::tcl::while {1} {
87        if {![uplevel 1 $condition_cmd] || ![::running]} {
88            break
89        }
90        uplevel 1 $body
91        uplevel 1 $step
92    }
93}
94
95
96# add the path to this file to the auto path
97
98set filepath [info script]
99#set ::orxonox::mediapath [string range $filepath 0 [string last "/" $filepath]]
100set ::orxonox::mediapath [file dirname $filepath]
101
102if {![info exists auto_path]} {
103   set auto_path [list]
104}
105
106if {[lsearch $auto_path $::orxonox::mediapath] == -1} {
107    lappend auto_path $::orxonox::mediapath
108}
109unset filepath
110
111
112# save the start directory and the library directory
113
114proc psd {} "return [pwd]"
115proc pld {} "return $::orxonox::mediapath"
116
117set pwd [pwd]
118set psd [psd]
119set pld [pld]
120
121
122# modify cd to automatically set $pwd
123
124if {[llength [info command ::tcl::cd]] == 0} {
125    rename cd ::tcl::cd
126}
127proc cd {{path "~"}} {
128    global pwd
129    ::tcl::cd $path
130    set pwd [pwd]
131}
132
133
134# change the working directory to the media path
135
136cd $::orxonox::mediapath
137
138
139# Redefines puts to write directly into the Orxonox console if the channel is stdout or stderr.
140
141if {[llength [info command ::tcl::puts]] == 0} {
142    rename puts ::tcl::puts
143}
144proc puts args {
145    set argc [llength $args]
146    if {$argc < 1 || $argc > 3} {
147        error "wrong # args: should be \"puts ?-nonewline? ?channelId? string\""
148    }
149
150    set newline 1
151    set input $args
152
153    if {$argc > 1 && [lindex $input 0] == "-nonewline"} {
154        set newline 0
155        set input [lrange $input 1 end]
156    } elseif {$argc == 3} {
157        if {[lindex $input 2] == "nonewline"} {
158            set newline 0
159            set input [lrange $input 0 1]
160        } else {
161            error "bad argument \"[lindex $input 2]\": should be \"nonewline\""
162        }
163    }
164
165    if {[llength $input] == 1} {
166        set input [list stdout [join $input]]
167    }
168
169    foreach {channel s} $input break
170
171    if {$channel == "stdout" || $channel == "stderr"} {
172        execute puts $newline $s
173    } else {
174        eval [concat ::tcl::puts $args]
175    }
176}
177
178
179# Redefines unknown to send unknown commands back to orxonox
180
181if {[llength [info commands unknown]] != 0} {
182    # check if a command named "undefined_proc" exists, if yes rename it temporarily
183    set undefined_was_defined 0
184    if {[llength [info commands undefined_proc]] != 0} {
185        set undefined_was_defined 0
186        rename undefined_proc _undefined
187    }
188
189    # get the returned errormessage if an undefined_proc command is called
190    if {[llength [info commands ::tcl::unknown]] == 0} {
191        set errorcode [catch {unknown undefined_proc} result]
192    } else {
193        set errorcode [catch {::tcl::unknown undefined_proc} result]
194    }
195
196    if {$errorcode} {
197        set result_list [split $result]
198        set ::orxonox::errormessage_unknown [list]
199
200        # parse the error message (the original message was something like "invalid command name "undefined_proc"" but we just want "invalid command name")
201        foreach token $result_list {
202            if {![string match "*undefined_proc*" $token]} {
203                lappend ::orxonox::errormessage_unknown $token
204            }
205        }
206
207        unset result_list
208        unset token
209
210        set ::orxonox::errormessage_unknown_length [llength $::orxonox::errormessage_unknown]
211
212        # rename the original unknown procedure
213        if {[llength [info commands ::tcl::unknown]] == 0} {
214            rename unknown ::tcl::unknown
215        }
216
217        # define the modified version of unknown
218        # we implement two versions, because tcl8.4 complains if this fork is moved inside [unknown]
219        if {[info tclversion] >= 8.5} {
220            # version >= 8.5
221            proc unknown args {
222                global ::orxonox::errormessage_unknown ::orxonox::errormessage_unknown_length
223
224                set cmd [concat ::tcl::unknown $args]
225                set errorcode [catch {eval $cmd} result options]
226                set resultlist [split $result]
227                set success 1
228
229                if {$errorcode && [llength $resultlist] >= $::orxonox::errormessage_unknown_length} {
230                    for {set i 0} {$i < $::orxonox::errormessage_unknown_length} {incr i} {
231                        if {[lindex $::orxonox::errormessage_unknown $i] != [lindex $resultlist $i]} {
232                            set success 0
233                            break
234                        }
235                    }
236                } else {
237                    set success 0
238                }
239
240                if {!$success} {
241                    return -code $errorcode -options $options $result
242                } else {
243                    return [query $args]
244                }
245            }
246        } else {
247            # version < 8.5
248            proc unknown args {
249                global ::orxonox::errormessage_unknown ::orxonox::errormessage_unknown_length
250
251                set cmd [concat ::tcl::unknown $args]
252                set errorcode [catch {eval $cmd} result]
253                set resultlist [split $result]
254                set success 1
255
256                if {$errorcode && [llength $resultlist] >= $::orxonox::errormessage_unknown_length} {
257                    for {set i 0} {$i < $::orxonox::errormessage_unknown_length} {incr i} {
258                        if {[lindex $::orxonox::errormessage_unknown $i] != [lindex $resultlist $i]} {
259                            set success 0
260                            break
261                        }
262                    }
263                } else {
264                    set success 0
265                }
266
267                if {!$success} {
268                    return -code $errorcode $result
269                } else {
270                    return [query $args]
271                }
272            }
273        }
274
275        set success 1
276    } else {
277        set success 0
278    }
279
280    unset errorcode
281    unset result
282
283    # if the "undefined_proc" command was renamed previously, undo this
284    if {$undefined_was_defined} {
285        rename _undefined undefined_proc
286    }
287
288    unset undefined_was_defined
289
290    if {!$success} {
291        unset success
292        # something went wrong, use the default method
293        proc unknown args {
294            return [query $args]
295        }
296    }
297    unset success
298} else {
299    # no original unknown procedure defined, use the default method
300    proc unknown args {
301        return [query $args]
302    }
303}
Note: See TracBrowser for help on using the repository browser.