lib/data_proc.tcl

#!/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}"

}