[occt.git] / src / DrawResources / StandardCommands.tcl

# Copyright (c) 1999-2014 OPEN CASCADE SAS
#
# This file is part of Open CASCADE Technology software library.
#
# This library is free software; you can redistribute it and/or modify it under
# the terms of the GNU Lesser General Public License version 2.1 as published
# by the Free Software Foundation, with special exception defined in the file
# OCCT_LGPL_EXCEPTION.txt. Consult the file LICENSE_LGPL_21.txt included in OCCT
# distribution for complete text of the license and disclaimer of any warranty.
#
# Alternatively, this file may be used under the terms of Open CASCADE
# commercial license or contractual agreement.

#
# Draw standard initialisation
#

#################################################
# prompts
#################################################

set Draw_CmdIndex 0
set tcl_prompt1 {
    incr Draw_CmdIndex
    puts -nonewline "Draw\[$Draw_CmdIndex\]> "
}

set tcl_prompt2 {puts -nonewline "> "}


#################################################
# the help command in TCL
#################################################


proc help {{command ""} {helpstring ""} {group "Procedures"}} {

    global Draw_Helps Draw_Groups

    if {$command == ""} {

    # help general
    foreach h [lsort [array names Draw_Groups]] {
        puts ""
        puts ""
        puts $h
        set i 0
        foreach f [lsort $Draw_Groups($h)] {
        if {$i == 0} {
            puts ""
            puts -nonewline "  "
        }
        puts -nonewline $f
        for {set j [string length $f]} {$j < 15} {incr j} {
            puts -nonewline " "
        }
        incr i
        if {$i == 4} {set i 0}
        }
        puts ""
    }
    } elseif {$helpstring == ""} {

    # help function
    set isfound 0
    foreach f [lsort [array names Draw_Helps]] {
        if {[string match $command $f]} {
        puts -nonewline $f
        for {set j [string length $f]} {$j < 15} {incr j} {
            puts -nonewline " "
        }
        puts " : $Draw_Helps($f)"
        set isfound 1
        }
    }
    if {!$isfound} {
        if {[string first * $command] != -1} {
            puts "No matching commands found!"
        } else {
            puts "No help found for '$command'! Please try 'help $command*' to find matching commands."
        }
    }
    } else {

    # set help
    lappend Draw_Groups($group) $command
    set Draw_Helps($command) $helpstring
    }
    
    flush stdout
}

help help {help pattern, or help command string group, to set help} {DRAW General Commands}
#################################################
# the getsourcefile command in TCL
#################################################

help getsourcefile {getsourcefile, or getsourcefile command } {DRAW General Commands}

proc getsourcefile {{command ""}} {

    global Draw_Helps Draw_Groups Draw_Files

    set out {}
    if {$command == ""} {

	# help general
	foreach h [lsort [array names Draw_Groups]] {
	    lappend out "" "" "$h"
	    set i 0
	    foreach f [lsort $Draw_Groups($h)] {
		if {$i == 0} {
		    lappend out ""
		}
		incr i
#
# check that the command has its source file set
#
		foreach command_that_has_file [array names Draw_Files] {
		    if {($command_that_has_file == $f)} {
			lappend out [format {%-20s %s} $f $Draw_Files($f)]
		    }
		}
	    }
	}
    } else {

	# getsourcefile fonction
	append command "*"
	foreach f [lsort [array names Draw_Files]] {
	    if {[string match $command $f]} {
                lappend out [format {%-20s %s} $f $Draw_Files($f)]
	    }
	}
	
    } 
    return [join $out "\n"]
}

#################################################
# whatis
#################################################

#proc gwhatis {aVarName} {
#    global $aVarName
#    puts -nonewline $aVarName; puts -nonewline " is a "; puts [dtyp ${aVarName}]
#}

help whatis "whatis object1 object2 ..." 

proc whatis args {
    set __out_string ""
    foreach i $args {
	if {$i == "."} {set i [dname $i]}
	#gwhatis $i
	global $i
	set __tmp_string "$i is a [dtyp $i]\n"
	set __out_string "${__out_string}${__tmp_string}"
    }
    return ${__out_string}
}

#################################################
# library, lsource
#################################################

proc library lib {
    global auto_path
    set auto_path [linsert $auto_path 0 $lib]
    if [file readable $lib/LibraryInit] {
	puts "Loading $lib/LibraryInit"
	uplevel "source $lib/LibraryInit"
    }
}

proc lsource file {
    if [file readable $file] {source $file} else {
	global auto_path
	foreach dir $auto_path {
	    if [file readable $dir/$file] {
		uplevel #0 "source $dir/$file"
		break
	    }
	}
    }
}

#################################################
# directory
#################################################

proc isgdraw {var} {
    global $var
    return [isdraw $var]
}

help directory {directory [pattern], list draw variables} {DRAW Variables management}

proc directory {{joker *}} {
    set res ""
    foreach var [info globals $joker] { 
	if [isgdraw $var] {lappend res $var}
    }
    return $res
}

proc lsd {} { exec ls [datadir] }

proc dall {} {
    set schmurtz ""
    foreach var [info globals] { 
	global $var
	if [isdraw $var] {
	    if ![isprot $var] {
		lappend schmurtz $var; unset $var
	    }
	}
    }
    return $schmurtz
}

#################################################
# repeat, do
#################################################

proc repeat {val script} {
    for {set i 1} {$i <= $val} {incr i} {uplevel $script}
}

proc do {var start end args} {
    global errorInfo errorCode
    if {[llength args] == 1} {
	set incr 1
	set body args
    } else {
	set incr [lindex 1 args]
	set body [lindex 2 args]
    }
    upvar $var v
    if {[dval $incr] < 0} {set rel >=} else {set rel <=}
    for {dset v $start} {[dval v] $rel [dval end]} {dset v [dval v+($incr)]} {
	set code [catch {uplevel $body} string]
	if {$code == 1} {
	    return -code error -errorInfo $errorInfo -errorcode $errorCode $string
	} elseif {$code == 2} {
	    return -code return $string
	}elseif {$code == 3} {
	    return
	} elseif {$code > 4} {
	    return -code $code $string
	}
    }
}

#################################################
# datadir, save, restore
#################################################

set Draw_DataDir "."

help datadir {datadir [directory]} "DRAW Variables management"

proc datadir {{dir ""}} {
    global Draw_DataDir
    if {$dir != ""} {
	if {![file isdirectory $dir]} {
	    error "datadir : $dir is not a directory"
	} else {
	    set Draw_DataDir $dir
	}
    }
    return $Draw_DataDir
}

help save {save variable [filename]} "DRAW Variables management"

proc save {name {file ""}} {
    if {$file == ""} {set file $name}
    upvar $name n
    if {![isdraw n]} {error "save : $name is not a Draw variable"}
    global Draw_DataDir
    bsave n [file join $Draw_DataDir $file]
    return [file join $Draw_DataDir $file]
}

help restore {restore filename [variablename]} "DRAW Variables management"

proc restore {file {name ""}} {
    if {$name == ""} {
        # if name is not given explicitly, use name of the file w/o extension
        set name [file rootname [file tail $file]]
    }
    global Draw_DataDir
    upvar $name n
    brestore [file join $Draw_DataDir $file ] n
    return $name
}

#################################################
# misc...
#################################################

proc ppcurve {a} {
	2dclear;
	uplevel pcurve $a;
	2dfit;
}

#################################################
# display and donly with jokers
#################################################

help disp {display variables matched by glob pattern} "DRAW Variables management"

proc disp { args } {
    set res ""
    foreach joker $args {
	if { $joker == "." } {
             dtyp .
             set joker [lastrep id x y b]
	}
        foreach var [info globals $joker] { 
	   if { $var == "." } {
               dtyp .
               set var [lastrep id x y b]
	   }
	   if [isgdraw $var] {lappend res $var}
        }
    }
    uplevel #0 eval display $res
    return $res
}

help don {display only variables matched by glob pattern} "DRAW Variables management"

proc don { args } {
    set res ""
    foreach joker $args {
	if { $joker == "." } {
             dtyp .
             set joker [lastrep id x y b]
	}
        foreach var [info globals $joker] { 
	   if { $var == "." } {
               dtyp .
               set var [lastrep id x y b]
	   }
	   if [isgdraw $var] {lappend res $var}
        }
    }
    uplevel #0 eval donly $res
    return $res
}

help del {unset (remove) variables matched by glob pattern} "DRAW Variables management"

proc del args {
    set res ""
    foreach joker [eval concat $args] {
        if { $joker == "." } {
            dtyp .
            set joker [lastrep id x y b]
        }
        foreach var [directory $joker] {
            global $var
            if ![isprot $var] {
                lappend res $var; unset $var
            }
        }
    }
    return $res
}

help era {erase variables matched by glob pattern} "DRAW Variables management"

proc era args {
    set res ""
    foreach joker [eval concat $args] {
        if { $joker == "." } {
            dtyp .
            set joker [lastrep id x y b]
        }
        eval lappend res [directory $joker]
    }
    if [llength $res] {
        uplevel \#0 eval erase $res
    }
}

# The following commands (definitions are surrounded by if) are
# available in extended Tcl (Tclx).
# These procedures are added just to make full-working simulations of them.

if {[info commands lvarpop] == ""} {
    proc lvarpop args {
	upvar [lindex $args 0] lvar
	set index 0
	set len [llength $lvar]
	if {[llength $args] > 1} {
	    set ind [lindex $args 1]
	    if [regexp "^end" $ind] {
		set index [expr $len-1]
	    } elseif [regexp "^len" $ind] {
		set index $len
	    } else {set index $ind}
	}
	set el [lindex $lvar $index]
	set newlvar {}
	for {set i 0} {$i < $index} {incr i} {
	    lappend newlvar [lindex $lvar $i]
	}
	if {[llength $args] > 2} {
	    lappend newlvar [lindex $args 2]
	}
	for {set i [expr $index+1]} {$i < $len} {incr i} {
	    lappend newlvar [lindex $lvar $i]
	}
	set lvar $newlvar
	return $el
    }
}

if {[info commands lmatch] == ""} {
    proc lmatch args {
	set mode [switch -- [lindex $args 0] {
	    -exact {format 0}
	    -glob {format 1}
	    -regexp {format 2}}]
	if {$mode == ""} {set mode 1} else {lvarpop args}
	if {[llength $args] < 2} {puts "usage: lmatch ?mode? list pattern";return}
	set list [lindex $args 0]
	set pattern [lindex $args 1]
	set res {}
	foreach a $list {
	    if [switch $mode {
		0 {expr [string compare $a $pattern] == 0}
		1 {string match $pattern $a}
		2 {regexp $pattern $a}}] {lappend res $a}
	}
	return $res
    }
}
Commit	Line	Data
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
d5f74e42	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
973c2be1	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 == ""} {
7fd59977	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 {
7fd59977	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	}
7fd59977	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 ..."
472634fa	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}
472634fa	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"
472634fa	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
191082ac	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
7fd59977	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
191082ac	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	}
7fd59977	370	}
7fd59977	371	return $res
7fd59977	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	}