973c2be1 |
1 | # Copyright (c) 1999-2014 OPEN CASCADE SAS |
b311480e |
2 | # |
973c2be1 |
3 | # This file is part of Open CASCADE Technology software library. |
b311480e |
4 | # |
d5f74e42 |
5 | # This library is free software; you can redistribute it and/or modify it under |
6 | # the terms of the GNU Lesser General Public License version 2.1 as published |
973c2be1 |
7 | # by the Free Software Foundation, with special exception defined in the file |
8 | # OCCT_LGPL_EXCEPTION.txt. Consult the file LICENSE_LGPL_21.txt included in OCCT |
9 | # distribution for complete text of the license and disclaimer of any warranty. |
b311480e |
10 | # |
973c2be1 |
11 | # Alternatively, this file may be used under the terms of Open CASCADE |
12 | # commercial license or contractual agreement. |
b311480e |
13 | |
7fd59977 |
14 | # |
15 | # Draw standard initialisation |
16 | # |
17 | |
18 | ################################################# |
19 | # prompts |
20 | ################################################# |
21 | |
22 | set Draw_CmdIndex 0 |
23 | set tcl_prompt1 { |
24 | incr Draw_CmdIndex |
25 | puts -nonewline "Draw\[$Draw_CmdIndex\]> " |
26 | } |
27 | |
28 | set tcl_prompt2 {puts -nonewline "> "} |
29 | |
30 | |
31 | ################################################# |
32 | # the help command in TCL |
33 | ################################################# |
34 | |
35 | |
36 | proc help {{command ""} {helpstring ""} {group "Procedures"}} { |
37 | |
38 | global Draw_Helps Draw_Groups |
39 | |
40 | if {$command == ""} { |
41 | |
2bc75a1b |
42 | # help general |
43 | foreach h [lsort [array names Draw_Groups]] { |
44 | puts "" |
45 | puts "" |
46 | puts $h |
47 | set i 0 |
48 | foreach f [lsort $Draw_Groups($h)] { |
49 | if {$i == 0} { |
50 | puts "" |
51 | puts -nonewline " " |
52 | } |
53 | puts -nonewline $f |
54 | for {set j [string length $f]} {$j < 15} {incr j} { |
55 | puts -nonewline " " |
56 | } |
57 | incr i |
58 | if {$i == 4} {set i 0} |
59 | } |
60 | puts "" |
61 | } |
7fd59977 |
62 | } elseif {$helpstring == ""} { |
63 | |
2bc75a1b |
64 | # help function |
65 | set isfound 0 |
66 | foreach f [lsort [array names Draw_Helps]] { |
67 | if {[string match $command $f]} { |
68 | puts -nonewline $f |
69 | for {set j [string length $f]} {$j < 15} {incr j} { |
70 | puts -nonewline " " |
71 | } |
72 | puts " : $Draw_Helps($f)" |
73 | set isfound 1 |
74 | } |
75 | } |
76 | if {!$isfound} { |
77 | if {[string first * $command] != -1} { |
78 | puts "No matching commands found!" |
79 | } else { |
80 | puts "No help found for '$command'! Please try 'help $command*' to find matching commands." |
81 | } |
82 | } |
7fd59977 |
83 | } else { |
84 | |
2bc75a1b |
85 | # set help |
86 | lappend Draw_Groups($group) $command |
87 | set Draw_Helps($command) $helpstring |
7fd59977 |
88 | } |
89 | |
90 | flush stdout |
91 | } |
92 | |
93 | help help {help pattern, or help command string group, to set help} {DRAW General Commands} |
94 | ################################################# |
95 | # the getsourcefile command in TCL |
96 | ################################################# |
97 | |
472634fa |
98 | help getsourcefile {getsourcefile, or getsourcefile command } {DRAW General Commands} |
7fd59977 |
99 | |
100 | proc getsourcefile {{command ""}} { |
101 | |
102 | global Draw_Helps Draw_Groups Draw_Files |
103 | |
d33dea30 |
104 | set out {} |
7fd59977 |
105 | if {$command == ""} { |
106 | |
107 | # help general |
108 | foreach h [lsort [array names Draw_Groups]] { |
d33dea30 |
109 | lappend out "" "" "$h" |
7fd59977 |
110 | set i 0 |
111 | foreach f [lsort $Draw_Groups($h)] { |
112 | if {$i == 0} { |
d33dea30 |
113 | lappend out "" |
7fd59977 |
114 | } |
115 | incr i |
116 | # |
117 | # check that the command has its source file set |
118 | # |
119 | foreach command_that_has_file [array names Draw_Files] { |
120 | if {($command_that_has_file == $f)} { |
d33dea30 |
121 | lappend out [format {%-20s %s} $f $Draw_Files($f)] |
7fd59977 |
122 | } |
123 | } |
124 | } |
125 | } |
126 | } else { |
127 | |
128 | # getsourcefile fonction |
129 | append command "*" |
130 | foreach f [lsort [array names Draw_Files]] { |
131 | if {[string match $command $f]} { |
d33dea30 |
132 | lappend out [format {%-20s %s} $f $Draw_Files($f)] |
7fd59977 |
133 | } |
134 | } |
135 | |
136 | } |
d33dea30 |
137 | return [join $out "\n"] |
7fd59977 |
138 | } |
139 | |
7fd59977 |
140 | ################################################# |
141 | # whatis |
142 | ################################################# |
143 | |
144 | #proc gwhatis {aVarName} { |
145 | # global $aVarName |
146 | # puts -nonewline $aVarName; puts -nonewline " is a "; puts [dtyp ${aVarName}] |
147 | #} |
148 | |
472634fa |
149 | help whatis "whatis object1 object2 ..." |
150 | |
7fd59977 |
151 | proc whatis args { |
152 | set __out_string "" |
153 | foreach i $args { |
154 | if {$i == "."} {set i [dname $i]} |
155 | #gwhatis $i |
156 | global $i |
157 | set __tmp_string "$i is a [dtyp $i]\n" |
158 | set __out_string "${__out_string}${__tmp_string}" |
159 | } |
160 | return ${__out_string} |
161 | } |
162 | |
7fd59977 |
163 | ################################################# |
164 | # library, lsource |
165 | ################################################# |
166 | |
167 | proc library lib { |
168 | global auto_path |
169 | set auto_path [linsert $auto_path 0 $lib] |
170 | if [file readable $lib/LibraryInit] { |
171 | puts "Loading $lib/LibraryInit" |
172 | uplevel "source $lib/LibraryInit" |
173 | } |
174 | } |
175 | |
176 | proc lsource file { |
177 | if [file readable $file] {source $file} else { |
178 | global auto_path |
179 | foreach dir $auto_path { |
180 | if [file readable $dir/$file] { |
181 | uplevel #0 "source $dir/$file" |
182 | break |
183 | } |
184 | } |
185 | } |
186 | } |
187 | |
188 | ################################################# |
189 | # directory |
190 | ################################################# |
191 | |
192 | proc isgdraw {var} { |
193 | global $var |
194 | return [isdraw $var] |
195 | } |
196 | |
472634fa |
197 | help directory {directory [pattern], list draw variables} {DRAW Variables management} |
198 | |
7fd59977 |
199 | proc directory {{joker *}} { |
200 | set res "" |
201 | foreach var [info globals $joker] { |
202 | if [isgdraw $var] {lappend res $var} |
203 | } |
204 | return $res |
205 | } |
206 | |
7fd59977 |
207 | proc lsd {} { exec ls [datadir] } |
208 | |
209 | proc dall {} { |
210 | set schmurtz "" |
211 | foreach var [info globals] { |
212 | global $var |
213 | if [isdraw $var] { |
214 | if ![isprot $var] { |
215 | lappend schmurtz $var; unset $var |
216 | } |
217 | } |
218 | } |
219 | return $schmurtz |
220 | } |
221 | |
222 | ################################################# |
223 | # repeat, do |
224 | ################################################# |
225 | |
226 | proc repeat {val script} { |
227 | for {set i 1} {$i <= $val} {incr i} {uplevel $script} |
228 | } |
229 | |
230 | proc do {var start end args} { |
231 | global errorInfo errorCode |
232 | if {[llength args] == 1} { |
233 | set incr 1 |
234 | set body args |
235 | } else { |
236 | set incr [lindex 1 args] |
237 | set body [lindex 2 args] |
238 | } |
239 | upvar $var v |
240 | if {[dval $incr] < 0} {set rel >=} else {set rel <=} |
241 | for {dset v $start} {[dval v] $rel [dval end]} {dset v [dval v+($incr)]} { |
242 | set code [catch {uplevel $body} string] |
243 | if {$code == 1} { |
244 | return -code error -errorInfo $errorInfo -errorcode $errorCode $string |
245 | } elseif {$code == 2} { |
246 | return -code return $string |
247 | }elseif {$code == 3} { |
248 | return |
249 | } elseif {$code > 4} { |
250 | return -code $code $string |
251 | } |
252 | } |
253 | } |
254 | |
255 | ################################################# |
256 | # datadir, save, restore |
257 | ################################################# |
258 | |
259 | set Draw_DataDir "." |
260 | |
472634fa |
261 | help datadir {datadir [directory]} "DRAW Variables management" |
262 | |
7fd59977 |
263 | proc datadir {{dir ""}} { |
264 | global Draw_DataDir |
265 | if {$dir != ""} { |
266 | if {![file isdirectory $dir]} { |
267 | error "datadir : $dir is not a directory" |
268 | } else { |
269 | set Draw_DataDir $dir |
270 | } |
271 | } |
272 | return $Draw_DataDir |
273 | } |
274 | |
472634fa |
275 | help save {save variable [filename]} "DRAW Variables management" |
7fd59977 |
276 | |
277 | proc save {name {file ""}} { |
278 | if {$file == ""} {set file $name} |
191082ac |
279 | upvar $name n |
280 | if {![isdraw n]} {error "save : $name is not a Draw variable"} |
7fd59977 |
281 | global Draw_DataDir |
191082ac |
282 | bsave n [file join $Draw_DataDir $file] |
7fd59977 |
283 | return [file join $Draw_DataDir $file] |
284 | } |
285 | |
472634fa |
286 | help restore {restore filename [variablename]} "DRAW Variables management" |
7fd59977 |
287 | |
288 | proc restore {file {name ""}} { |
1598ec0e |
289 | if {$name == ""} { |
290 | # if name is not given explicitly, use name of the file w/o extension |
291 | set name [file rootname [file tail $file]] |
292 | } |
7fd59977 |
293 | global Draw_DataDir |
191082ac |
294 | upvar $name n |
295 | brestore [file join $Draw_DataDir $file ] n |
7fd59977 |
296 | return $name |
297 | } |
298 | |
7fd59977 |
299 | ################################################# |
300 | # misc... |
301 | ################################################# |
302 | |
303 | proc ppcurve {a} { |
304 | 2dclear; |
305 | uplevel pcurve $a; |
306 | 2dfit; |
307 | } |
308 | |
309 | ################################################# |
310 | # display and donly with jokers |
311 | ################################################# |
312 | |
472634fa |
313 | help disp {display variables matched by glob pattern} "DRAW Variables management" |
7fd59977 |
314 | |
315 | proc disp { args } { |
316 | set res "" |
317 | foreach joker $args { |
318 | if { $joker == "." } { |
319 | dtyp . |
320 | set joker [lastrep id x y b] |
321 | } |
322 | foreach var [info globals $joker] { |
323 | if { $var == "." } { |
324 | dtyp . |
325 | set var [lastrep id x y b] |
326 | } |
327 | if [isgdraw $var] {lappend res $var} |
328 | } |
329 | } |
330 | uplevel #0 eval display $res |
331 | return $res |
332 | } |
333 | |
472634fa |
334 | help don {display only variables matched by glob pattern} "DRAW Variables management" |
7fd59977 |
335 | |
472634fa |
336 | proc don { args } { |
7fd59977 |
337 | set res "" |
338 | foreach joker $args { |
339 | if { $joker == "." } { |
340 | dtyp . |
341 | set joker [lastrep id x y b] |
342 | } |
343 | foreach var [info globals $joker] { |
344 | if { $var == "." } { |
345 | dtyp . |
346 | set var [lastrep id x y b] |
347 | } |
348 | if [isgdraw $var] {lappend res $var} |
349 | } |
350 | } |
351 | uplevel #0 eval donly $res |
352 | return $res |
353 | } |
354 | |
472634fa |
355 | help del {unset (remove) variables matched by glob pattern} "DRAW Variables management" |
356 | |
357 | proc del args { |
7fd59977 |
358 | set res "" |
472634fa |
359 | foreach joker [eval concat $args] { |
360 | if { $joker == "." } { |
361 | dtyp . |
362 | set joker [lastrep id x y b] |
363 | } |
364 | foreach var [directory $joker] { |
365 | global $var |
366 | if ![isprot $var] { |
367 | lappend res $var; unset $var |
368 | } |
7fd59977 |
369 | } |
370 | } |
7fd59977 |
371 | return $res |
372 | } |
471b22de |
373 | |
472634fa |
374 | help era {erase variables matched by glob pattern} "DRAW Variables management" |
375 | |
376 | proc era args { |
377 | set res "" |
378 | foreach joker [eval concat $args] { |
379 | if { $joker == "." } { |
380 | dtyp . |
381 | set joker [lastrep id x y b] |
382 | } |
383 | eval lappend res [directory $joker] |
384 | } |
385 | if [llength $res] { |
386 | uplevel \#0 eval erase $res |
387 | } |
388 | } |
389 | |
471b22de |
390 | # The following commands (definitions are surrounded by if) are |
391 | # available in extended Tcl (Tclx). |
392 | # These procedures are added just to make full-working simulations of them. |
393 | |
ac0cdacd |
394 | if {[info commands lvarpop] == ""} { |
395 | proc lvarpop args { |
396 | upvar [lindex $args 0] lvar |
397 | set index 0 |
398 | set len [llength $lvar] |
399 | if {[llength $args] > 1} { |
400 | set ind [lindex $args 1] |
401 | if [regexp "^end" $ind] { |
402 | set index [expr $len-1] |
403 | } elseif [regexp "^len" $ind] { |
404 | set index $len |
405 | } else {set index $ind} |
406 | } |
407 | set el [lindex $lvar $index] |
408 | set newlvar {} |
409 | for {set i 0} {$i < $index} {incr i} { |
410 | lappend newlvar [lindex $lvar $i] |
411 | } |
412 | if {[llength $args] > 2} { |
413 | lappend newlvar [lindex $args 2] |
414 | } |
415 | for {set i [expr $index+1]} {$i < $len} {incr i} { |
416 | lappend newlvar [lindex $lvar $i] |
417 | } |
418 | set lvar $newlvar |
419 | return $el |
420 | } |
421 | } |
422 | |
471b22de |
423 | if {[info commands lmatch] == ""} { |
424 | proc lmatch args { |
425 | set mode [switch -- [lindex $args 0] { |
426 | -exact {format 0} |
427 | -glob {format 1} |
428 | -regexp {format 2}}] |
429 | if {$mode == ""} {set mode 1} else {lvarpop args} |
430 | if {[llength $args] < 2} {puts "usage: lmatch ?mode? list pattern";return} |
431 | set list [lindex $args 0] |
432 | set pattern [lindex $args 1] |
433 | set res {} |
434 | foreach a $list { |
435 | if [switch $mode { |
436 | 0 {expr [string compare $a $pattern] == 0} |
437 | 1 {string match $pattern $a} |
438 | 2 {regexp $pattern $a}}] {lappend res $a} |
439 | } |
440 | return $res |
441 | } |
442 | } |