Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: code/branches/gamestates2/data/tcl/init.tcl @ 7024

Last change on this file since 7024 was 5781, checked in by rgrieder, 15 years ago

Reverted trunk again. We might want to find a way to delete these revisions again (x3n's changes are still available as diff in the commit mails).

  • Property svn:eol-style set to native
File size: 8.3 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]
101if {[lsearch $auto_path $::orxonox::mediapath] == -1} {
102    lappend auto_path $::orxonox::mediapath
103}
104unset filepath
105
106
107# save the start directory and the library directory
108
109proc psd {} "return [pwd]"
110proc pld {} "return $::orxonox::mediapath"
111
112set pwd [pwd]
113set psd [psd]
114set pld [pld]
115
116
117# modify cd to automatically set $pwd
118
119if {[llength [info command ::tcl::cd]] == 0} {
120    rename cd ::tcl::cd
121}
122proc cd {{path "~"}} {
123    global pwd
124    ::tcl::cd $path
125    set pwd [pwd]
126}
127
128
129# change the working directory to the media path
130
131cd $::orxonox::mediapath
132
133
134# Redefines puts to write directly into the Orxonox console if the channel is stdout or stderr.
135
136if {[llength [info command ::tcl::puts]] == 0} {
137    rename puts ::tcl::puts
138}
139proc puts args {
140    set argc [llength $args]
141    if {$argc < 1 || $argc > 3} {
142        error "wrong # args: should be \"puts ?-nonewline? ?channelId? string\""
143    }
144
145    set newline 1
146    set input $args
147
148    if {$argc > 1 && [lindex $input 0] == "-nonewline"} {
149        set newline 0
150        set input [lrange $input 1 end]
151    } elseif {$argc == 3} {
152        if {[lindex $input 2] == "nonewline"} {
153            set newline 0
154            set input [lrange $input 0 1]
155        } else {
156            error "bad argument \"[lindex $input 2]\": should be \"nonewline\""
157        }
158    }
159
160    if {[llength $input] == 1} {
161        set input [list stdout [join $input]]
162    }
163
164    foreach {channel s} $input break
165
166    if {$channel == "stdout" || $channel == "stderr"} {
167        execute puts $newline $s
168    } else {
169        eval [concat ::tcl::puts $args]
170    }
171}
172
173
174# Redefines unknown to send unknown commands back to orxonox
175
176if {[llength [info commands unknown]] != 0} {
177    # check if a command named "undefined_proc" exists, if yes rename it temporarily
178    set undefined_was_defined 0
179    if {[llength [info commands undefined_proc]] != 0} {
180        set undefined_was_defined 0
181        rename undefined_proc _undefined
182    }
183
184    # get the returned errormessage if an undefined_proc command is called
185    if {[llength [info commands ::tcl::unknown]] == 0} {
186        set errorcode [catch {unknown undefined_proc} result]
187    } else {
188        set errorcode [catch {::tcl::unknown undefined_proc} result]
189    }
190
191    if {$errorcode} {
192        set result_list [split $result]
193        set ::orxonox::errormessage_unknown [list]
194
195        # parse the error message (the original message was something like "invalid command name "undefined_proc"" but we just want "invalid command name")
196        foreach token $result_list {
197            if {![string match "*undefined_proc*" $token]} {
198                lappend ::orxonox::errormessage_unknown $token
199            }
200        }
201
202        unset result_list
203        unset token
204
205        set ::orxonox::errormessage_unknown_length [llength $::orxonox::errormessage_unknown]
206
207        # rename the original unknown procedure
208        if {[llength [info commands ::tcl::unknown]] == 0} {
209            rename unknown ::tcl::unknown
210        }
211
212        # define the modified version of unknown
213        # we implement two versions, because tcl8.4 complains if this fork is moved inside [unknown]
214        if {[info tclversion] >= 8.5} {
215            # version >= 8.5
216            proc unknown args {
217                global ::orxonox::errormessage_unknown ::orxonox::errormessage_unknown_length
218
219                set cmd [concat ::tcl::unknown $args]
220                set errorcode [catch {eval $cmd} result options]
221                set resultlist [split $result]
222                set success 1
223
224                if {$errorcode && [llength $resultlist] >= $::orxonox::errormessage_unknown_length} {
225                    for {set i 0} {$i < $::orxonox::errormessage_unknown_length} {incr i} {
226                        if {[lindex $::orxonox::errormessage_unknown $i] != [lindex $resultlist $i]} {
227                            set success 0
228                            break
229                        }
230                    }
231                } else {
232                    set success 0
233                }
234
235                if {!$success} {
236                    return -code $errorcode -options $options $result
237                } else {
238                    return [query $args]
239                }
240            }
241        } else {
242            # version < 8.5
243            proc unknown args {
244                global ::orxonox::errormessage_unknown ::orxonox::errormessage_unknown_length
245
246                set cmd [concat ::tcl::unknown $args]
247                set errorcode [catch {eval $cmd} result]
248                set resultlist [split $result]
249                set success 1
250
251                if {$errorcode && [llength $resultlist] >= $::orxonox::errormessage_unknown_length} {
252                    for {set i 0} {$i < $::orxonox::errormessage_unknown_length} {incr i} {
253                        if {[lindex $::orxonox::errormessage_unknown $i] != [lindex $resultlist $i]} {
254                            set success 0
255                            break
256                        }
257                    }
258                } else {
259                    set success 0
260                }
261
262                if {!$success} {
263                    return -code $errorcode $result
264                } else {
265                    return [query $args]
266                }
267            }
268        }
269
270        set success 1
271    } else {
272        set success 0
273    }
274
275    unset errorcode
276    unset result
277
278    # if the "undefined_proc" command was renamed previously, undo this
279    if {$undefined_was_defined} {
280        rename _undefined undefined_proc
281    }
282
283    unset undefined_was_defined
284
285    if {!$success} {
286        unset success
287        # something went wrong, use the default method
288        proc unknown args {
289            return [query $args]
290        }
291    }
292    unset success
293} else {
294    # no original unknown procedure defined, use the default method
295    proc unknown args {
296        return [query $args]
297    }
298}
Note: See TracBrowser for help on using the repository browser.