| #!/usr/bin/wish |
| |
| # This file provides many valuable data processing procedures like |
| # lappend_unique, get_var, etc. |
| |
| |
| proc lappend_unique { args } { |
| |
| # Add the each entry to a list if and only if they do not already exist in |
| # the list. |
| |
| # Description of argument(s): |
| # args The first argument should be the list |
| # name. All other arguments are items to be |
| # added to the list. |
| |
| set list_name [lindex $args 0] |
| # Remove first entry from args list. |
| set args [lreplace $args 0 0] |
| |
| upvar 1 $list_name list |
| |
| if { ! [info exists list] } { set list {} } |
| |
| foreach arg $args { |
| if { [lsearch -exact $list "${arg}"] != -1 } { continue } |
| lappend list $arg |
| } |
| |
| } |
| |
| |
| proc lsubtract {main_list_name removal_list} { |
| upvar $main_list_name ref_main_list |
| |
| # Remove any entry from the main list that is contained in removal list. |
| |
| # Description of argument(s): |
| # main_list_name The name of your master list. |
| # removal_list The list of items to be removed from |
| # master list. |
| |
| # For each element in the removal list, find the corresponding entry in the |
| # master list and remove it. |
| for {set removal_ix 0} {$removal_ix < [llength $removal_list ]}\ |
| {incr removal_ix} { |
| set value [lindex $removal_list $removal_ix] |
| set master_ix [lsearch $ref_main_list $value] |
| set ref_main_list [lreplace $ref_main_list $master_ix $master_ix] |
| } |
| |
| } |
| |
| |
| proc list_map { list expression } { |
| |
| # Create and return a new list where each element of the new list is a |
| # result of running the given expression on the corresponding entry from the |
| # original list. |
| |
| # Description of argument(s): |
| # list A list to be operated on. |
| # expression A command expression to be run on each |
| # element in the list (e.g. '[string range |
| # $x 1 end]'). |
| |
| foreach x $list { |
| set cmd_buf "lappend new_list ${expression}" |
| eval $cmd_buf |
| } |
| |
| return $new_list |
| |
| } |
| |
| |
| proc list_filter { list expression } { |
| |
| # Create and return a new list consisting of all elements of the original |
| # list that do NOT pass the expression. |
| |
| # Description of argument(s): |
| # list A list to be operated on. |
| # expression A command expression to be run on each |
| # element in the list (e.g. 'regexp |
| # -expanded {^[[:blank:]]*\#|^[[:blank:]]*$} |
| # $x', 'string equal $x ""', etc.). |
| |
| set new_list {} |
| |
| foreach x $list { |
| set cmd_buf "set result \[${expression}\]" |
| eval $cmd_buf |
| if { ! $result } { lappend new_list $x } |
| } |
| |
| return $new_list |
| |
| } |
| |
| |
| proc list_filter_comments { list } { |
| |
| # Filter comments from list and return new_list as a result. |
| |
| # Description of argument(s): |
| # list A list to be operated on. |
| |
| set comment_regexp {^[[:blank:]]*\#|^[[:blank:]]*$} |
| |
| set new_list [list_filter $list "regexp -expanded {$comment_regexp} \$x"] |
| |
| return $new_list |
| |
| } |
| |
| |
| proc get_var { var_var { default ""} } { |
| upvar 1 $var_var var_ref |
| |
| # Return the value of the variable expression or the value of default if |
| # the variable is not defined. |
| |
| # Example use: |
| # set PATH [get_var ::env(PATH) "/usr/bin"] |
| |
| # Description of argument(s): |
| # var_var The name of a variable (e.g. |
| # "::env(NANOSECOND)" or "var1"). |
| # default The default value to return if the |
| # variable named in var_var does not exist. |
| |
| expr { [info exists var_ref] ? [return $var_ref] : [return $default] } |
| |
| } |
| |
| |
| proc set_var_default { var_name { default ""} } { |
| upvar 1 $var_name var_ref |
| |
| # If the variable named in var_name is either blank or non-existent, set |
| # its value to the default. |
| |
| # Example use: |
| # set_var_default indent 0 |
| |
| # Description of argument(s): |
| # var_name The name of a variable. |
| # default The default value to assign to the |
| # variable if the variable named in var_name |
| # is blank or non-existent. |
| |
| if { ! ([info exists var_ref] && $var_ref != "") } { |
| set var_ref $default |
| } |
| |
| } |
| |
| |
| proc split_path {path dir_path base_name} { |
| upvar $dir_path ref_dir_path |
| upvar $base_name ref_base_name |
| |
| # Split a path into it's dir_path and base_name. The dir_path variable |
| # will include a trailing slash. |
| |
| # Description of argument(s): |
| # path The directory or file path. |
| # dir_path The variable to contain the resulting |
| # directory path which will include a |
| # trailing slash. |
| # base_name The variable to contain the resulting base |
| # directory or file name. |
| |
| set ref_dir_path "[file dirname ${path}]/" |
| set ref_base_name "[file tail $path]" |
| |
| } |
| |
| |
| proc read_properties_file {parm_file_path} { |
| |
| # Read properties files and return key/value pairs as a list. |
| |
| # Description of argument(s): |
| # parm_file_path The path to the properties file. |
| |
| # The properties file must have the following format: |
| # var_name=var_value |
| # Comment lines (those beginning with a "#") and blank lines are allowed |
| # and will be ignored. Leading and trailing single or double quotes will be |
| # stripped from the value. E.g. |
| # var1="This one" |
| # Quotes are stripped so the resulting value for var1 is: |
| # This one |
| |
| # Suggestion: The caller can then process the result as an array or a |
| # dictionary. |
| |
| # Example usage: |
| |
| # array set properties [read_properties_file $file_path] |
| # print_var properties |
| |
| # With the following result... |
| |
| # properties: |
| # properties(command): string |
| |
| # Or... |
| |
| # set properties [read_properties_file $file_path] |
| # print_dict properties |
| |
| # With the following result... |
| |
| # properties: |
| # properties[command]: string |
| |
| # Initialize properties array. |
| |
| set properties [list] |
| |
| # Read the entire file into a list, filtering comments out. |
| set file_descriptor [open $parm_file_path r] |
| set file_data [list_filter_comments [split [read $file_descriptor] "\n"]] |
| close $file_descriptor |
| |
| foreach line $file_data { |
| # Split <var_name>=<var_value> into component parts. |
| set pair [split $line =] |
| lappend properties [lindex ${pair} 0] |
| lappend properties [string trim [lindex ${pair} 1] {"}] |
| } |
| |
| return $properties |
| |
| } |
| |
| |
| proc convert_array_key {key {convert_commands} {prefix ""} } { |
| |
| # Convert the key according to the caller's convert_commands and return the |
| # result. |
| |
| # This is designed as a helper procedure to be called by convert_array_keys. |
| |
| # See convert_array_keys for description of arguments. |
| |
| set new_key $key |
| foreach command $convert_commands { |
| if { $command == "prefix" } { |
| regsub -all "^$prefix" $new_key {} new_key |
| set new_key "$prefix$new_key" |
| } elseif { $command == "rm_prefix" } { |
| regsub -all "^$prefix" $new_key {} new_key |
| set new_key "$new_key" |
| } |
| if { $command == "upper" } { |
| set new_key [string toupper $new_key] |
| } elseif { $command == "lower" } { |
| set new_key [string tolower $new_key] |
| } |
| } |
| |
| return $new_key |
| |
| } |
| |
| |
| proc convert_array_keys {source_arr target_arr {convert_commands}\ |
| {prefix ""} } { |
| upvar $source_arr source_arr_ref |
| upvar $target_arr target_arr_ref |
| |
| # Convert the keys of source_arr according to the caller's convert_commands |
| # and put the resulting array in target_arr. If this procedure fails for any |
| # reason, it will return non-zero. |
| |
| # Note that despite the name of this procedure, it will also work on a |
| # dictionary. In other words, if source_arr is NOT an array, it will be |
| # processed as a dictionary and target_arr will be created as a dictionary |
| # as well. |
| |
| # Description of argument(s): |
| # source_arr The source array that is to be converted. |
| # target_arr The target array that results from the |
| # conversion. |
| # convert_commands A list of custom commands that indicate |
| # the type of conversion(s) the caller |
| # wishes to see. Currently the accepted |
| # values are as follows: |
| # upper Convert key value to uppercase. |
| # lower Convert key value to lowercase. |
| # prefix Prepend prefix to the key, provided that |
| # it does not already exist. If upper or |
| # lower is included in convert_commands |
| # list, the prefix will be converted to the |
| # specified case as well. |
| # rm_prefix Remove a prefix that is prepended, |
| # provided that it exists. |
| # prefix The prefix to be used for "prefix" and |
| # "rm_prefix" commands (see convert_commands |
| # text above). |
| |
| # Validate arguments. |
| if { [lsearch $convert_commands lower] != -1 } { |
| if { [lsearch $convert_commands upper] != -1 } { |
| return -code error "Cannot convert to both upper and lower cases." |
| } |
| } |
| |
| if { [lsearch $convert_commands rm_prefix] != -1} { |
| if { [lsearch $convert_commands prefix] != -1} { |
| return -code error "Cannot add and remove a prefix." |
| } |
| } |
| |
| if { [lsearch $convert_commands prefix] != -1 ||\ |
| [lsearch $convert_commands rm_prefix] != -1 } { |
| if { [lsearch $convert_commands upper] != -1 } { |
| set prefix [string toupper $prefix] |
| } elseif { [lsearch $convert_commands lower] != -1 } { |
| set prefix [string tolower $prefix] |
| } |
| } |
| |
| if { [array exists source_arr_ref] } { |
| # Initialize targ array. |
| array set target_arr_ref {} |
| # Walk the source array doing the conversion specified in convert_commands. |
| set search_token [array startsearch source_arr_ref] |
| while {[array anymore source_arr_ref $search_token]} { |
| set key [array nextelement source_arr_ref $search_token] |
| set value $source_arr_ref($key) |
| |
| set new_key [convert_array_key $key $convert_commands $prefix] |
| set cmd_buf "set target_arr_ref($new_key) $value" |
| eval $cmd_buf |
| } |
| array donesearch source_arr_ref $search_token |
| |
| } else { |
| # Initialize targ dictionary. |
| set target_arr_ref [list] |
| # Walk the source dictionary doing the conversion specified in |
| # convert_commands. |
| foreach {key value} $source_arr_ref { |
| set new_key [convert_array_key $key $convert_commands $prefix] |
| set cmd_buf "dict append target_arr_ref $new_key \$value" |
| eval $cmd_buf |
| } |
| } |
| |
| } |
| |
| |
| proc expand_shell_string {buffer} { |
| upvar $buffer ref_buffer |
| |
| # Call upon the shell to expand the string in "buffer", i.e. the shell will |
| # make substitutions for environment variables and glob expressions. |
| |
| # Description of argument(s): |
| # buffer The buffer to be expanded. |
| |
| # This is done to keep echo from interpreting all of the double quotes away. |
| regsub -all {\"} $ref_buffer "\\\"" ref_buffer |
| |
| # Bash will compress extra space delimiters if you don't quote the string. |
| # So, we quote the argument to echo. |
| if {[catch {set ref_buffer [exec bash -c "echo \"$ref_buffer\""]} result]} { |
| puts stderr $result |
| exit 1 |
| } |
| |
| } |
| |
| |
| proc add_trailing_string { buffer { add_string "/" } } { |
| upvar $buffer ref_buffer |
| |
| # Add the add string to the end of the buffer if and only if it doesn't |
| # already end with the add_string. |
| |
| # Description of argument(s): |
| # buffer The buffer to be modified. |
| # add_string The string to conditionally append to the |
| # buffer. |
| |
| regsub -all "${add_string}$" $ref_buffer {} ref_buffer |
| set ref_buffer "${ref_buffer}${add_string}" |
| |
| } |
| |
| |