From 35b8a5a2cf0f9861fc2747128e6b2c3679abe5d7 Mon Sep 17 00:00:00 2001 From: bugmaster Date: Tue, 27 Feb 2018 17:15:39 +0300 Subject: [PATCH] Update testing system for compatibly test case with master during prepare delivery --- src/DrawResources/CheckCommands.tcl | 716 +++++++++++++++++++++++-- src/DrawResources/StandardCommands.tcl | 119 +++- 2 files changed, 780 insertions(+), 55 deletions(-) diff --git a/src/DrawResources/CheckCommands.tcl b/src/DrawResources/CheckCommands.tcl index d456d046df..668e59ef31 100644 --- a/src/DrawResources/CheckCommands.tcl +++ b/src/DrawResources/CheckCommands.tcl @@ -170,15 +170,23 @@ proc _check_arg {check_name check_result {get_value 0}} { upvar narg narg upvar args args if { $arg == ${check_name} } { - if {${get_value}} { + if { ${get_value} == "?" } { + set next_arg_index [expr $narg + 1] + if { $next_arg_index < [llength $args] && ! [regexp {^-[^0-9]} [lindex $args $next_arg_index]] } { + set ${check_result} "[lindex $args $next_arg_index]" + set narg ${next_arg_index} + } else { + set ${check_result} "true" + } + } elseif {${get_value}} { incr narg - if { $narg < [llength $args] && ! [regexp {^-} [lindex $args $narg]] } { + if { $narg < [llength $args] && ! [regexp {^-[^0-9]} [lindex $args $narg]] } { set ${check_result} "[lindex $args $narg]" } else { error "Option ${check_result} requires argument" } } else { - set ${check_result} 1 + set ${check_result} "true" } return 1 } @@ -351,26 +359,36 @@ proc checkfreebounds {shape ref_value args} { } help checkmaxtol { - Compare max tolerance of shape with ref_value. - Argument "source_shapes" is a list of used for sewing shapes. - It can be empty to skip comparison of tolerance with source shapes. + Returns max tolerance of the shape and prints error message if specified + criteria are not satisfied. - Use: checkmaxtol shape ref_value [source_shapes={}] [options...] - Allowed options are: - -min_tol: minimum tolerance for comparison - -multi_tol: tolerance multiplier + Use: checkmaxtol shape [options...] + + Options specify criteria for checking the maximal tolerance value: + -ref : check it to be equal to reference value. + -min_tol : check it to be not greater than specified value. + -source : check it to be not greater than + maximal tolerance of specified shape(s) + -multi_tol : additional multiplier for value specified by -min_tol + or -shapes options. } -proc checkmaxtol {shape ref_value {source_shapes {}} args} { - puts "checkmaxtol ${shape} ${ref_value} ${source_shapes} ${args}" + +proc checkmaxtol {shape args} { + puts "checkmaxtol ${shape} ${args}" upvar ${shape} ${shape} + set ref_value "" + set source_shapes {} set min_tol 0 set tol_multiplier 0 + # check arguments for {set narg 0} {$narg < [llength $args]} {incr narg} { set arg [lindex $args $narg] if {[_check_arg "-min_tol" min_tol 1] || - [_check_arg "-multi_tol" tol_multiplier 1] + [_check_arg "-multi_tol" tol_multiplier 1] || + [_check_arg "-source" source_shapes 1] || + [_check_arg "-ref" ref_value 1] } { continue } @@ -382,26 +400,33 @@ proc checkmaxtol {shape ref_value {source_shapes {}} args} { } # get max tol of shape - regexp {max tol = ([-0-9.+eE]+)} [tolmax ${shape}] full max_tol - - checkreal "Max tolerance" $max_tol $ref_value 0.0001 0.01 - if {[llength $source_shapes]} { - # find max tol of source shapes - foreach source_shape $source_shapes { - upvar ${source_shape} ${source_shape} - regexp {max tol = ([-0-9.+eE]+)} [tolmax $source_shape] full _src_max_tol - if { ${_src_max_tol} > ${min_tol} } { - set min_tol ${_src_max_tol} - } - } - if {${tol_multiplier}} { - set min_tol [expr ${tol_multiplier} * ${_src_max_tol}] - } - # compare max tol of source shapes with max tol of sewing_result - if { ${max_tol} > ${min_tol} } { - puts "Error: tolerance of \"${shape}\" (${max_tol}) is greater than max tolerance of source shapes (${min_tol})" + set max_tol 0 + if {[regexp "Tolerance MAX=(\[-0-9.+eE\]+)" [tolerance ${shape}] full maxtol_temp]} { + set max_tol ${maxtol_temp} + } else { + error "Error: cannot get tolerances of shape \"${shape}\"" + } + + # find max tol of source shapes + foreach source_shape ${source_shapes} { + upvar ${source_shape} ${source_shape} + set _src_max_tol [checkmaxtol ${source_shape}] + if { [expr ${_src_max_tol} > ${min_tol} ] } { + set min_tol ${_src_max_tol} } } + # apply -multi_tol option + if {${tol_multiplier}} { + set min_tol [expr ${tol_multiplier} * ${_src_max_tol}] + } + # compare max tol of source shapes with checking tolerance + if { ${min_tol} && [expr ${max_tol} > ${min_tol}] } { + puts "Error: tolerance of \"${shape}\" (${max_tol}) is greater than checking tolerance (${min_tol})" + } + if { ${ref_value} != "" } { + checkreal "Max tolerance" ${max_tol} ${ref_value} 0.0001 0.01 + } + return ${max_tol} } help checkfaults { @@ -435,3 +460,632 @@ proc checkfaults {shape source_shape {ref_value 0}} { puts "Error : Number of faults is $nb_r" } } + +# auxiliary: check all arguments +proc _check_args { args {options {}} {command_name ""}} { + # check arguments + for {set narg 0} {${narg} < [llength ${args}]} {incr narg} { + set arg [lindex ${args} ${narg}] + set toContinue 0 + foreach option ${options} { + set option_name [lindex ${option} 0] + set variable_to_save_value [lindex ${option} 1] + set get_value [lindex ${option} 2] + set local_value "" + if { [_check_arg ${option_name} local_value ${get_value}] } { + upvar 1 ${variable_to_save_value} ${variable_to_save_value} + set ${variable_to_save_value} ${local_value} + set toContinue 1 + } + } + if {${toContinue}} { continue } + # unsupported option + if { [regexp {^-} ${arg}] } { + error "Error: unsupported option \"${arg}\"" + } + error "Error: cannot interpret argument ${narg} (${arg})" + } + foreach option ${options} { + set option_name [lindex ${option} 0] + set variable_to_save_value [lindex ${option} 1] + set should_exist [lindex ${option} 3] + if {![info exists ${variable_to_save_value}] && ${should_exist} == 1} { + error "Error: wrong using of command '${command_name}', '${option_name}' option is required" + } + } +} + +help checkprops { + Procedure includes commands to compute length, area and volume of input shape. + + Use: checkprops shapename [options...] + Allowed options are: + -l LENGTH: command lprops, computes the mass properties of all edges in the shape with a linear density of 1 + -s AREA: command sprops, computes the mass properties of all faces with a surface density of 1 + -v VOLUME: command vprops, computes the mass properties of all solids with a density of 1 + -eps EPSILON: the epsilon defines relative precision of computation + -deps DEPSILON: the epsilon defines relative precision to compare corresponding values + -equal SHAPE: compare area\volume\length of input shapes. Puts error if its are not equal + -notequal SHAPE: compare area\volume\length of input shapes. Puts error if its are equal + -skip: count shared shapes only once, skipping repeatitions + Options -l, -s and -v are independent and can be used in any order. Tolerance epsilon is the same for all options. +} + +proc checkprops {shape args} { + puts "checkprops ${shape} ${args}" + upvar ${shape} ${shape} + + if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} { + puts "Error: The command cannot be built" + return + } + + set length -1 + set area -1 + set volume -1 + set epsilon 1.0e-4 + set compared_equal_shape -1 + set compared_notequal_shape -1 + set equal_check 0 + set skip 0 + set depsilon 1e-2 + + set options {{"-eps" epsilon 1} + {"-equal" compared_equal_shape 1} + {"-notequal" compared_notequal_shape 1} + {"-skip" skip 0} + {"-deps" depsilon 1}} + + if { [regexp {\-[not]*equal} $args] } { + lappend options {"-s" area 0} + lappend options {"-l" length 0} + lappend options {"-v" volume 0} + set equal_check 1 + } else { + lappend options {"-s" area 1} + lappend options {"-l" length 1} + lappend options {"-v" volume 1} + } + _check_args ${args} ${options} "checkprops" + + if { ${length} != -1 || ${equal_check} == 1 } { + lappend CommandNames {lprops} + set equal_check 0 + } + if { ${area} != -1 || ${equal_check} == 1 } { + lappend CommandNames {sprops} + set equal_check 0 + } + if { ${volume} != -1 || ${equal_check} == 1 } { + lappend CommandNames {vprops} + set equal_check 0 + } + + set skip_option "" + if { $skip } { + set skip_option "-skip" + } + + foreach CommandName ${CommandNames} { + switch $CommandName { + "lprops" { set mass ${length}; set prop "length" } + "sprops" { set mass ${area}; set prop "area" } + "vprops" { set mass ${volume}; set prop "volume" } + } + regexp {Mass +: +([-0-9.+eE]+)} [eval ${CommandName} ${shape} ${epsilon} $skip_option] full m + + if { ${compared_equal_shape} != -1 } { + upvar ${compared_equal_shape} ${compared_equal_shape} + regexp {Mass +: +([-0-9.+eE]+)} [eval ${CommandName} ${compared_equal_shape} ${epsilon} $skip_option] full compared_m + if { $compared_m != $m } { + puts "Error: Shape ${compared_equal_shape} is not equal to shape ${shape}" + } + } + + if { ${compared_notequal_shape} != -1 } { + upvar ${compared_notequal_shape} ${compared_notequal_shape} + regexp {Mass +: +([-0-9.+eE]+)} [eval ${CommandName} ${compared_notequal_shape} ${epsilon} $skip_option] full compared_m + if { $compared_m == $m } { + puts "Error: Shape ${compared_notequal_shape} is equal shape to ${shape}" + } + } + + if { ${compared_equal_shape} == -1 && ${compared_notequal_shape} == -1 } { + if { [string compare "$mass" "empty"] != 0 } { + if { $m == 0 } { + puts "Error : The command is not valid. The $prop is 0." + } + if { $mass > 0 } { + puts "The expected $prop is $mass" + } + #check of change of area is < 1% + if { ($mass != 0 && [expr 1.*abs($mass - $m)/$mass] > $depsilon) || ($mass == 0 && $m != 0) } { + puts "Error : The $prop of result shape is $m" + } + } else { + if { $m != 0 } { + puts "Error : The command is not valid. The $prop is $m" + } + } + } + } +} + +help checkdump { + Procedure includes command to parse output dump and compare it with reference values. + + Use: checkdump shapename [options...] + Allowed options are: + -name NAME: list of parsing parameters (e.g. Center, Axis, etc) + -ref VALUE: list of reference values for each parameter in NAME + -eps EPSILON: the epsilon defines relative precision of computation +} + +proc checkdump {shape args} { + puts "checkdump ${shape} ${args}" + upvar ${shape} ${shape} + + set ddump -1 + set epsilon -1 + set options {{"-name" params 1} + {"-ref" ref 1} + {"-eps" epsilon 1} + {"-dump" ddump 1}} + + if { ${ddump} == -1 } { + set ddump [dump ${shape}] + } + _check_args ${args} ${options} "checkdump" + + set index 0 + foreach param ${params} { + set pattern "${param}\\s*:\\s*" + set number_pattern "(\[-0-9.+eE\]+)\\s*" + set ref_values "" + set local_ref ${ref} + if { [llength ${params}] > 1 } { + set local_ref [lindex ${ref} ${index}] + } + foreach item ${local_ref} { + if { ![regexp "$pattern$number_pattern" $ddump full res] } { + puts "Error: cheked parameter ${param} is not listed in dump" + break + } + lappend ref_values $res + set pattern "${pattern}${res},\\s*" + ## without precision + if { ${epsilon} == -1 } { + if { ${item} != ${res} } { + puts "Error: parameter ${param} - current value (${res}) is not equal to reference value (${item})" + } else { + puts "OK: parameter ${param} - current value (${res}) is equal to reference value (${item})" + } + ## with precision + } else { + set precision 0.0000001 + if { ( abs($res) > $precision ) || ( abs($item) > $precision ) } { + if { ($item != 0 && [expr 1.*abs($item - $res)/$item] > $epsilon) || ($item == 0 && $res != 0) } { + puts "Error: The $param of the resulting shape is $res and the expected $param is $item" + } else { + puts "OK: parameter ${param} - current value (${res}) is equal to reference value (${item})" + } + } + } + } + incr index + } +} + +help checklength { + Procedure includes commands to compute length of input curve. + + Use: checklength curvename [options...] + Allowed options are: + -l LENGTH: command length, computes the length of input curve with precision of computation + -eps EPSILON: the epsilon defines relative precision of computation + -equal CURVE: compare length of input curves. Puts error if its are not equal + -notequal CURVE: compare length of input curves. Puts error if its are equal +} + +proc checklength {shape args} { + puts "checklength ${shape} ${args}" + upvar ${shape} ${shape} + + if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} { + puts "Error: The command cannot be built" + return + } + + set length -1 + set epsilon 1.0e-4 + set compared_equal_shape -1 + set compared_notequal_shape -1 + set equal_check 0 + + set options {{"-eps" epsilon 1} + {"-equal" compared_equal_shape 1} + {"-notequal" compared_notequal_shape 1}} + + if { [regexp {\-[not]*equal} $args] } { + lappend options {"-l" length 0} + set equal_check 1 + } else { + lappend options {"-l" length 1} + } + _check_args ${args} ${options} "checkprops" + + if { ${length} != -1 || ${equal_check} == 1 } { + set CommandName length + set mass $length + set prop "length" + set equal_check 0 + } + + regexp "The +length+ ${shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${shape} ${epsilon}] full m + + if { ${compared_equal_shape} != -1 } { + upvar ${compared_equal_shape} ${compared_equal_shape} + regexp "The +length+ ${compared_equal_shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${compared_equal_shape} ${epsilon}] full compared_m + if { $compared_m != $m } { + puts "Error: length of shape ${compared_equal_shape} is not equal to shape ${shape}" + } + } + + if { ${compared_notequal_shape} != -1 } { + upvar ${compared_notequal_shape} ${compared_notequal_shape} + regexp "The +length+ ${compared_notequal_shape} +is +(\[-0-9.+eE\]+)" [${CommandName} ${compared_notequal_shape} ${epsilon}] full compared_m + if { $compared_m == $m } { + puts "Error: length of shape ${compared_notequal_shape} is equal shape to ${shape}" + } + } + + if { ${compared_equal_shape} == -1 && ${compared_notequal_shape} == -1 } { + if { [string compare "$mass" "empty"] != 0 } { + if { $m == 0 } { + puts "Error : The command is not valid. The $prop is 0." + } + if { $mass > 0 } { + puts "The expected $prop is $mass" + } + #check of change of area is < 1% + if { ($mass != 0 && [expr 1.*abs($mass - $m)/$mass] > 0.01) || ($mass == 0 && $m != 0) } { + puts "Error : The $prop of result shape is $m" + } + } else { + if { $m != 0 } { + puts "Error : The command is not valid. The $prop is $m" + } + } + } +} + +help checkview { + Display shape in selected viewer. + + Use: checkview [options...] + Allowed options are: + -display shapename: display shape with name 'shapename' + -3d: display shape in 3d viewer + -2d [ v2d / smallview ]: display shape in 2d viewer (default viewer is a 'smallview') + -vdispmode N: it is possible to set vdispmode for 3d viewer (default value is 1) + -screenshot: procedure will try to make screenshot of already created viewer + -path : location of saved screenshot of viewer + + Procedure can check some property of shape (length, area or volume) and compare it with some value N: + -l [N] + -s [N] + -v [N] + If current property is equal to value N, shape is marked as valid in procedure. + If value N is not given procedure will mark shape as valid if current property is non-zero. + -with {a b c}: display shapes 'a' 'b' 'c' together with 'shape' (if shape is valid) + -otherwise {d e f}: display shapes 'd' 'e' 'f' instead of 'shape' (if shape is NOT valid) + Note that one of two options -2d/-3d is required. +} + +proc checkview {args} { + puts "checkview ${args}" + + set 3dviewer 0 + set 2dviewer false + set shape "" + set PathToSave "" + set dispmode 1 + set isScreenshot 0 + set check_length false + set check_area false + set check_volume false + set otherwise {} + set with {} + + set options {{"-3d" 3dviewer 0} + {"-2d" 2dviewer ?} + {"-display" shape 1} + {"-path" PathToSave 1} + {"-vdispmode" dispmode 1} + {"-screenshot" isScreenshot 0} + {"-otherwise" otherwise 1} + {"-with" with 1} + {"-l" check_length ?} + {"-s" check_area ?} + {"-v" check_volume ?}} + + # check arguments + _check_args ${args} ${options} "checkview" + + if { ${PathToSave} == "" } { + set PathToSave "./photo.png" + } + + if { ${3dviewer} == 0 && ${2dviewer} == false } { + error "Error: wrong using of command 'checkview', please use -2d or -3d option" + } + + if { ${isScreenshot} } { + if { ${3dviewer} } { + vdump ${PathToSave} + } else { + xwd ${PathToSave} + } + return + } + + set mass 0 + set isBAD 0 + upvar ${shape} ${shape} + if {[isdraw ${shape}]} { + # check area + if { [string is boolean ${check_area}] } { + if { ${check_area} } { + regexp {Mass +: +([-0-9.+eE]+)} [sprops ${shape}] full mass + } + } else { + set mass ${check_area} + } + # check length + if { [string is boolean ${check_length}] } { + if { ${check_length} } { + regexp {Mass +: +([-0-9.+eE]+)} [lprops ${shape}] full mass + } + } else { + set mass ${check_length} + } + # check volume + if { [string is boolean ${check_volume}] } { + if { ${check_volume} } { + regexp {Mass +: +([-0-9.+eE]+)} [vprops ${shape}] full mass + } + } else { + set mass ${check_volume} + } + } else { + set isBAD 1 + } + if { ${3dviewer} } { + vinit + vclear + } elseif { ([string is boolean ${2dviewer}] && ${2dviewer}) || ${2dviewer} == "smallview"} { + smallview + clear + } elseif { ${2dviewer} == "v2d"} { + v2d + 2dclear + } + if {[isdraw ${shape}]} { + if { ( ${check_area} == false && ${check_length} == false && ${check_volume} == false ) || ( ${mass} != 0 ) } { + foreach s ${with} { + upvar ${s} ${s} + } + lappend with ${shape} + if { ${3dviewer} } { + vdisplay {*}${with} + } else { + donly {*}${with} + } + } else { + set isBAD 1 + } + } else { + set isBAD 1 + } + + if { ${isBAD} && [llength ${otherwise}] } { + foreach s ${otherwise} { + upvar ${s} ${s} + } + if { ${3dviewer} } { + vdisplay {*}${otherwise} + } else { + donly {*}${otherwise} + } + } + + if { ${3dviewer} } { + vsetdispmode ${dispmode} + vfit + vdump ${PathToSave} + } else { + if { ([string is boolean ${2dviewer}] && ${2dviewer}) || ${2dviewer} == "smallview"} { + fit + } elseif { ${2dviewer} == "v2d"} { + 2dfit + } + xwd ${PathToSave} + } + +} + +help checktrinfo { + Compare maximum deflection, number of nodes and triangles in "shape" mesh with given reference data + + Use: checktrinfo shapename [options...] + Allowed options are: + -tri [N]: compare current number of triangles in "shapename" mesh with given reference data. + If reference value N is not given and current number of triangles is equal to 0 + procedure checktrinfo will print an error. + -nod [N]: compare current number of nodes in "shapename" mesh with given reference data. + If reference value N is not givenand current number of nodes is equal to 0 + procedure checktrinfo will print an error. + -defl [N]: compare current value of maximum deflection in "shapename" mesh with given reference data + If reference value N is not given and current maximum deflection is equal to 0 + procedure checktrinfo will print an error. + -max_defl N: compare current value of maximum deflection in "shapename" mesh with max possible value + -tol_abs_tri N: absolute tolerance for comparison of number of triangles (default value 0) + -tol_rel_tri N: relative tolerance for comparison of number of triangles (default value 0) + -tol_abs_nod N: absolute tolerance for comparison of number of nodes (default value 0) + -tol_rel_nod N: relative tolerance for comparison of number of nodes (default value 0) + -tol_abs_defl N: absolute tolerance for deflection comparison (default value 0) + -tol_rel_defl N: relative tolerance for deflection comparison (default value 0) + -ref [trinfo a]: compare deflection, number of triangles and nodes in "shapename" and in "a" +} +proc checktrinfo {shape args} { + puts "checktrinfo ${shape} ${args}" + upvar ${shape} ${shape} + + if {![isdraw ${shape}] || [regexp "${shape} is a \n" [whatis ${shape}]]} { + puts "Error: The command cannot be built" + return + } + + set ref_nb_triangles false + set ref_nb_nodes false + set ref_deflection false + set tol_abs_defl 0 + set tol_rel_defl 0 + set tol_abs_tri 0 + set tol_rel_tri 0 + set tol_abs_nod 0 + set tol_rel_nod 0 + set max_defl -1 + set ref_info "" + + set options {{"-tri" ref_nb_triangles ?} + {"-nod" ref_nb_nodes ?} + {"-defl" ref_deflection ?} + {"-tol_abs_defl" tol_abs_defl 1} + {"-tol_rel_defl" tol_rel_defl 1} + {"-tol_abs_tri" tol_abs_tri 1} + {"-tol_rel_tri" tol_rel_tri 1} + {"-tol_abs_nod" tol_abs_nod 1} + {"-tol_rel_nod" tol_rel_nod 1} + {"-max_defl" max_defl 1} + {"-ref" ref_info 1}} + + _check_args ${args} ${options} "checktrinfo" + + # get current number of triangles and nodes, value of max deflection + set tri_info [trinfo ${shape}] + set triinfo_pattern "(\[0-9\]+) +triangles.*\[^0-9]\(\[0-9\]+) +nodes.*deflection +(\[-0-9.+eE\]+)" + if {![regexp "${triinfo_pattern}" ${tri_info} dump cur_nb_triangles cur_nb_nodes cur_deflection]} { + puts "Error: command trinfo prints empty info" + } + + # get reference values from -ref option + if { "${ref_info}" != ""} { + if {![regexp "${triinfo_pattern}" ${ref_info} dump ref_nb_triangles ref_nb_nodes ref_deflection]} { + puts "Error: reference information gived by -ref option is wrong" + } + } + + # check number of triangles + if { [string is boolean ${ref_nb_triangles}] } { + if { ${cur_nb_triangles} <= 0 && ${ref_nb_triangles} } { + puts "Error: Number of triangles is equal to 0" + } + } else { + if {[regexp {!([-0-9.+eE]+)} $ref_nb_triangles full ref_nb_triangles_value]} { + if {${ref_nb_triangles_value} == ${cur_nb_triangles} } { + puts "Error: Number of triangles is equal to ${ref_nb_triangles_value} but it should not" + } + } else { + checkreal "Number of triangles" ${cur_nb_triangles} ${ref_nb_triangles} ${tol_abs_tri} ${tol_rel_tri} + } + } + + # check number of nodes + if { [string is boolean ${ref_nb_nodes}] } { + if { ${cur_nb_nodes} <= 0 && ${ref_nb_nodes} } { + puts "Error: Number of nodes is equal to 0" + } + } else { + if {[regexp {!([-0-9.+eE]+)} $ref_nb_nodes full ref_nb_nodes_value]} { + if {${ref_nb_nodes_value} == ${cur_nb_nodes} } { + puts "Error: Number of nodes is equal to ${ref_nb_nodes_value} but it should not" + } + } else { + checkreal "Number of nodes" ${cur_nb_nodes} ${ref_nb_nodes} ${tol_abs_nod} ${tol_rel_nod} + } + } + + # check deflection + if { [string is boolean ${ref_deflection}] } { + if { ${cur_deflection} <= 0 && ${ref_deflection} } { + puts "Error: Maximal deflection is equal to 0" + } + } else { + checkreal "Maximal deflection" ${cur_deflection} ${ref_deflection} ${tol_abs_defl} ${tol_rel_defl} + } + + if { ${max_defl} != -1 && ${cur_deflection} > ${max_defl} } { + puts "Error: Maximal deflection is too big" + } +} + +help checkplatform { + Return name of current platform if no options are given. + + Use: checkplatform [options...] + Allowed options are: + -windows : return 1 if current platform is 'Windows', overwise return 0 + -linux : return 1 if current platform is 'Linux', overwise return 0 + -osx : return 1 if current platform is 'MacOS X', overwise return 0 + + Only one option can be used at once. + If no option is given, procedure will return the name of current platform. +} +proc checkplatform {args} { + set check_for_windows false + set check_for_linux false + set check_for_macosx false + + set options {{"-windows" check_for_windows 0} + {"-linux" check_for_linux 0} + {"-osx" check_for_macosx 0}} + + _check_args ${args} ${options} "checkplatform" + + if { [regexp "indows" $::tcl_platform(os)] } { + set current_platform Windows + } elseif { $::tcl_platform(os) == "Linux" } { + set current_platform Linux + } elseif { $::tcl_platform(os) == "Darwin" } { + set current_platform MacOS + } + + # no args are given + if { !${check_for_windows} && !${check_for_linux} && !${check_for_macosx}} { + return ${current_platform} + } + + # check usage of proc checkplatform + if { [expr [string is true ${check_for_windows}] + [string is true ${check_for_linux}] + [string is true ${check_for_macosx}] ] > 1} { + error "Error: wrong usage of command checkplatform, only single option can be used at once" + } + + # checking for Windows platform + if { ${check_for_windows} && ${current_platform} == "Windows" } { + return 1 + } + + # checking for Mac OS X platforms + if { ${check_for_linux} && ${current_platform} == "Linux" } { + return 1 + } + + # checking for Mac OS X platforms + if { ${check_for_macosx} && ${current_platform} == "MacOS" } { + return 1 + } + + # current platform is not equal to given as argument platform, return false + return 0 +} diff --git a/src/DrawResources/StandardCommands.tcl b/src/DrawResources/StandardCommands.tcl index 737cdc3cb5..4436b606d6 100644 --- a/src/DrawResources/StandardCommands.tcl +++ b/src/DrawResources/StandardCommands.tcl @@ -95,6 +95,7 @@ help help {help pattern, or help command string group, to set help} {DRAW Genera # the getsourcefile command in TCL ################################################# +help getsourcefile {getsourcefile, or getsourcefile command } {DRAW General Commands} proc getsourcefile {{command ""}} { @@ -136,8 +137,6 @@ proc getsourcefile {{command ""}} { return [join $out "\n"] } -help getsourcefile {getsourcefile, or getsourcefile command } {DRAW General Commands} - ################################################# # whatis ################################################# @@ -147,6 +146,8 @@ help getsourcefile {getsourcefile, or getsourcefile command } {DRAW General Comm # puts -nonewline $aVarName; puts -nonewline " is a "; puts [dtyp ${aVarName}] #} +help whatis "whatis object1 object2 ..." + proc whatis args { set __out_string "" foreach i $args { @@ -159,8 +160,6 @@ proc whatis args { return ${__out_string} } -help whatis "whatis object1 object2 ..." - ################################################# # library, lsource ################################################# @@ -195,6 +194,8 @@ proc isgdraw {var} { return [isdraw $var] } +help directory {directory [pattern], list draw variables} {DRAW Variables management} + proc directory {{joker *}} { set res "" foreach var [info globals $joker] { @@ -203,8 +204,6 @@ proc directory {{joker *}} { return $res } -help directory {directory [pattern], list draw variables} {DRAW Variables management} - proc lsd {} { exec ls [datadir] } proc dall {} { @@ -259,6 +258,8 @@ proc do {var start end args} { set Draw_DataDir "." +help datadir {datadir [directory]} "DRAW Variables management" + proc datadir {{dir ""}} { global Draw_DataDir if {$dir != ""} { @@ -271,7 +272,7 @@ proc datadir {{dir ""}} { return $Draw_DataDir } -help datadir {datadir [directory]} "DRAW Variables management" +help save {save variable [filename]} "DRAW Variables management" proc save {name {file ""}} { if {$file == ""} {set file $name} @@ -282,7 +283,7 @@ proc save {name {file ""}} { return [file join $Draw_DataDir $file] } -help save {save variable [filename]} "DRAW Variables management" +help restore {restore filename [variablename]} "DRAW Variables management" proc restore {file {name ""}} { if {$name == ""} { @@ -295,8 +296,6 @@ proc restore {file {name ""}} { return $name } -help restore {restore filename [variablename]} "DRAW Variables management" - ################################################# # misc... ################################################# @@ -311,6 +310,7 @@ proc ppcurve {a} { # display and donly with jokers ################################################# +help disp {display variables matched by glob pattern} "DRAW Variables management" proc disp { args } { set res "" @@ -331,8 +331,9 @@ proc disp { args } { return $res } +help don {display only variables matched by glob pattern} "DRAW Variables management" -proc donl { args } { +proc don { args } { set res "" foreach joker $args { if { $joker == "." } { @@ -351,21 +352,91 @@ proc donl { args } { return $res } -proc don { args } { +help del {unset (remove) variables matched by glob pattern} "DRAW Variables management" + +proc del 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} + 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 + } } } - uplevel #0 eval donly $res 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 + } +} -- 2.39.5