1#!/usr/bin/wish
2
3# This file provides many valuable data processing functions like
4# lappend_unique, get_var, etc.
5
6
7proc lappend_unique { args } {
8
9  # Add the each entry to a list if and only if they do not already exist in
10  # the list.
11
12  # Description of argument(s):
13  # args                            The first argument should be the list
14  #                                 name.  All other arguments are items to be
15  #                                 added to the list.
16
17  set list_name [lindex $args 0]
18  # Remove first entry from args list.
19  set args [lreplace $args 0 0]
20
21  upvar 1 $list_name list
22
23  if { ! [info exists list] } { set list {} }
24
25  foreach arg $args {
26    if { [lsearch -exact $list "${arg}"] != -1 } { continue }
27    lappend list $arg
28  }
29
30}
31
32
33proc lsubtract {main_list_name removal_list} {
34  upvar $main_list_name ref_main_list
35
36  # Remove any entry from the main list that is contained in removal list.
37
38  # Description of argument(s):
39  # main_list_name                  The name of your master list.
40  # removal_list                    The list of items to be removed from
41  #                                 master list.
42
43  # For each element in the removal list, find the corresponding entry in the
44  # master list and remove it.
45  for {set removal_ix 0} {$removal_ix < [llength $removal_list ]}\
46      {incr removal_ix} {
47    set value [lindex $removal_list $removal_ix]
48    set master_ix [lsearch $ref_main_list $value]
49    set ref_main_list [lreplace $ref_main_list $master_ix $master_ix]
50  }
51
52}
53
54
55proc list_map { list expression } {
56
57  # Create and return a new list where each element of the new list is a
58  # result of running the given expression on the corresponding entry from the
59  # original list.
60
61  # Description of argument(s):
62  # list                            A list to be operated on.
63  # expression                      A command expression to be run on each
64  #                                 element in the list (e.g. '[string range
65  #                                 $x 1 end]').
66
67  foreach x $list {
68    set cmd_buf "lappend new_list ${expression}"
69    eval $cmd_buf
70  }
71
72  return $new_list
73
74}
75
76
77proc list_filter { list expression } {
78
79  # Create and return a new list consisting of all elements of the original
80  # list that do NOT pass the expression.
81
82  # Description of argument(s):
83  # list                            A list to be operated on.
84  # expression                      A command expression to be run on each
85  #                                 element in the list (e.g. 'regexp
86  #                                 -expanded {^[[:blank:]]*\#|^[[:blank:]]*$}
87  #                                 $x', 'string equal $x ""', etc.).
88
89  set new_list {}
90
91  foreach x $list {
92    set cmd_buf "set result \[${expression}\]"
93    eval $cmd_buf
94    if { ! $result } { lappend new_list $x }
95  }
96
97  return $new_list
98
99}
100
101
102proc list_filter_comments { list } {
103
104  # Filter comments from list and return new_list as a result.
105
106  # Description of argument(s):
107  # list                            A list to be operated on.
108
109  set comment_regexp {^[[:blank:]]*\#|^[[:blank:]]*$}
110
111  set new_list [list_filter $list "regexp -expanded {$comment_regexp} \$x"]
112
113  return $new_list
114
115}
116
117
118proc get_var { var_var { default ""} } {
119  upvar 1 $var_var var_ref
120
121  # Return the value of the variable expression or the value of default if
122  # the variable is not defined.
123
124  # Example use:
125  # set PATH [get_var ::env(PATH) "/usr/bin"]
126
127  # Description of argument(s):
128  # var_var                         The name of a variable (e.g.
129  #                                 "::env(NANOSECOND)" or "var1").
130  # default                         The default value to return if the
131  #                                 variable named in var_var does not exist.
132
133  expr { [info exists var_ref] ? [return $var_ref] : [return $default] }
134
135}
136
137
138proc set_var_default { var_name { default ""} } {
139  upvar 1 $var_name var_ref
140
141  # If the variable named in var_name is either blank or non-existent, set
142  # its value to the default.
143
144  # Example use:
145  # set_var_default indent 0
146
147  # Description of argument(s):
148  # var_name                        The name of a variable.
149  # default                         The default value to assign to the
150  #                                 variable if the variable named in var_name
151  #                                 is blank or non-existent.
152
153  if { ! ([info exists var_ref] && $var_ref != "") } {
154    set var_ref $default
155  }
156
157}
158
159
160proc split_path {path dir_path base_name} {
161  upvar $dir_path ref_dir_path
162  upvar $base_name ref_base_name
163
164  # Split a path into it's dir_path and base_name.  The dir_path variable
165  # will include a trailing slash.
166
167  # Description of argument(s):
168  # path                            The directory or file path.
169  # dir_path                        The variable to contain the resulting
170  #                                 directory path which will include a
171  #                                 trailing slash.
172  # base_name                       The variable to contain the resulting base
173  #                                 directory or file name.
174
175  set ref_dir_path "[file dirname ${path}]/"
176  set ref_base_name "[file tail $path]"
177
178}
179
180
181proc read_properties_file {parm_file_path} {
182
183  # Read properties files and return key/value pairs as a list.
184
185  # Description of argument(s):
186  # parm_file_path                  The path to the properties file.
187
188  # The properties file must have the following format:
189  # var_name=var_value
190  # Comment lines (those beginning with a "#") and blank lines are allowed
191  # and will be ignored.  Leading and trailing single or double quotes will be
192  # stripped from the value.  E.g.
193  # var1="This one"
194  # Quotes are stripped so the resulting value for var1 is:
195  # This one
196
197  # Suggestion: The caller can then process the result as an array or a
198  # dictionary.
199
200  # Example usage:
201
202  # array set properties [read_properties_file $file_path]
203  # print_var properties
204
205  # With the following result...
206
207  # properties:
208  #   properties(command):  string
209
210  # Or...
211
212  # set properties [read_properties_file $file_path]
213  # print_dict properties
214
215  # With the following result...
216
217  # properties:
218  #   properties[command]:  string
219
220  # Initialize properties array.
221
222  set properties [list]
223
224  # Read the entire file into a list, filtering comments out.
225  set file_descriptor [open $parm_file_path r]
226  set file_data [list_filter_comments [split [read $file_descriptor] "\n"]]
227  close $file_descriptor
228
229  foreach line $file_data {
230    # Split <var_name>=<var_value> into component parts.
231    set pair [split $line =]
232    lappend properties [lindex ${pair} 0]
233    lappend properties [string trim [lindex ${pair} 1] {"}]
234  }
235
236  return $properties
237
238}
239
240
241proc convert_array_keys {source_arr target_arr {convert_commands}\
242  {prefix ""} } {
243  upvar $source_arr source_arr_ref
244  upvar $target_arr target_arr_ref
245
246  # Convert the keys of source_arr according to the caller's convert_commands
247  # and put the resulting array in target_arr. If this function fails for any
248  # reason, it will return non-zero
249
250  # Description of argument(s):
251  # source_arr                      The source array that is to be converted.
252  # target_arr                      The target array that results from the
253  #                                 conversion.
254  # convert_commands                A list of custom commands that indicate
255  #                                 the type of conversion(s) the caller
256  #                                 wishes to see. Currently the accepted
257  #                                 values are as follows:
258  #   - upper         Convert key value to uppercase.
259  #   - lower         Convert key value to lowercase.
260  # - prefix        Prepend prefix to the key, provided that it does not
261  # already exist. If upper or lower is included in convert_commands list, the
262  # prefix will be converted to the specified case as well.
263  #   - rm_prefix   Remove a prefix that is prepended, provided that it exists.
264  # prefix                          The prefix to be used for "prefix" and
265  #                                 "rm_prefix" commands (see convert_commands
266  #                                 text above).
267
268  # Validate arguments.
269  if { [lsearch $convert_commands lower] != -1 } {
270    if { [lsearch $convert_commands upper] != -1 } {
271      return -code error "Cannot convert to both upper and lower cases."
272    }
273  }
274
275  if { [lsearch $convert_commands rm_prefix] != -1} {
276    if { [lsearch $convert_commands prefix] != -1} {
277      return -code error "Cannot add and remove a prefix."
278    }
279  }
280
281  if { [lsearch $convert_commands prefix] != -1 ||\
282       [lsearch $convert_commands rm_prefix] != -1 } {
283    if { [lsearch $convert_commands upper] != -1 } {
284      set prefix [string toupper $prefix]
285    } elseif { [lsearch $convert_commands lower] != -1 } {
286      set prefix [string tolower $prefix]
287    }
288  }
289
290  # Initialize targ array.
291  array set target_arr_ref {}
292
293  # Walk the source array doing the conversion specified in convert_commands.
294  set search_token [array startsearch source_arr_ref]
295  while {[array anymore source_arr_ref $search_token]} {
296    set key [array nextelement source_arr_ref $search_token]
297    set arr_value $source_arr_ref($key)
298    set new_key "$key"
299
300    foreach command $convert_commands {
301      if { $command == "prefix" } {
302        regsub -all "^$prefix" $new_key {} new_key
303        set new_key "$prefix$new_key"
304      } elseif { $command == "rm_prefix" } {
305        regsub -all "^$prefix" $new_key {} new_key
306        set new_key "$new_key"
307      }
308      if { $command == "upper" } {
309        set new_key [string toupper $new_key]
310      } elseif { $command == "lower" } {
311        set new_key [string tolower $new_key]
312      }
313    }
314    set cmd_buf "set target_arr_ref($new_key) $arr_value"
315    eval $cmd_buf
316  }
317  array donesearch source_arr_ref $search_token
318
319}
320
321
322proc expand_shell_string {buffer} {
323  upvar $buffer ref_buffer
324
325  # Call upon the shell to expand the string in "buffer", i.e. the shell will
326  # make substitutions for environment variables and glob expressions.
327
328  # Description of argument(s):
329  # buffer                          The buffer to be expanded.
330
331  # This is done to keep echo from interpreting all of the double quotes away.
332  regsub -all {\"} $ref_buffer "\\\"" ref_buffer
333
334  # Bash will compress extra space delimiters if you don't quote the string.
335  # So, we quote the argument to echo.
336  if {[catch {set ref_buffer [exec bash -c "echo \"$ref_buffer\""]} result]} {
337    puts stderr $result
338    exit 1
339  }
340
341}
342
343
344proc add_trailing_string { buffer { add_string "/" } } {
345  upvar $buffer ref_buffer
346
347  # Add the add string to the end of the buffer if and only if it doesn't
348  # already end with the add_string.
349
350  # Description of argument(s):
351  # buffer                          The buffer to be modified.
352  # add_string                      The string to conditionally append to the
353  #                                 buffer.
354
355  regsub -all "${add_string}$" $ref_buffer {} ref_buffer
356  set ref_buffer "${ref_buffer}${add_string}"
357
358}
359
360
361