0028313: Extend Draw functionality with some new useful commands and features
[occt.git] / src / DrawResources / StandardCommands.tcl
1 # Copyright (c) 1999-2014 OPEN CASCADE SAS
2 #
3 # This file is part of Open CASCADE Technology software library.
4 #
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
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.
10 #
11 # Alternatively, this file may be used under the terms of Open CASCADE
12 # commercial license or contractual agreement.
13
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
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     }
62     } elseif {$helpstring == ""} {
63
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     }
83     } else {
84
85     # set help
86     lappend Draw_Groups($group) $command
87     set Draw_Helps($command) $helpstring
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
98 help getsourcefile {getsourcefile, or getsourcefile command } {DRAW General Commands}
99
100 proc getsourcefile {{command ""}} {
101
102     global Draw_Helps Draw_Groups Draw_Files
103
104     set out {}
105     if {$command == ""} {
106
107         # help general
108         foreach h [lsort [array names Draw_Groups]] {
109             lappend out "" "" "$h"
110             set i 0
111             foreach f [lsort $Draw_Groups($h)] {
112                 if {$i == 0} {
113                     lappend out ""
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)} {
121                         lappend out [format {%-20s %s} $f $Draw_Files($f)]
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]} {
132                 lappend out [format {%-20s %s} $f $Draw_Files($f)]
133             }
134         }
135         
136     } 
137     return [join $out "\n"]
138 }
139
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
149 help whatis "whatis object1 object2 ..." 
150
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
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
197 help directory {directory [pattern], list draw variables} {DRAW Variables management}
198
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
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
261 help datadir {datadir [directory]} "DRAW Variables management"
262
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
275 help save {save variable [filename]} "DRAW Variables management"
276
277 proc save {name {file ""}} {
278     if {$file == ""} {set file $name}
279     upvar $name n
280     if {![isdraw n]} {error "save : $name is not a Draw variable"}
281     global Draw_DataDir
282     bsave n [file join $Draw_DataDir $file]
283     return [file join $Draw_DataDir $file]
284 }
285
286 help restore {restore filename [variablename]} "DRAW Variables management"
287
288 proc restore {file {name ""}} {
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     }
293     global Draw_DataDir
294     upvar $name n
295     brestore [file join $Draw_DataDir $file ] n
296     return $name
297 }
298
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
313 help disp {display variables matched by glob pattern} "DRAW Variables management"
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
334 help don {display only variables matched by glob pattern} "DRAW Variables management"
335
336 proc don { args } {
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
355 help del {unset (remove) variables matched by glob pattern} "DRAW Variables management"
356
357 proc del args {
358     set res ""
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             }
369         }
370     }
371     return $res
372 }
373
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
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
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
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 }