Version 4 of extract

Updated 2010-05-14 11:04:43 by MGS

MGS [2005/03/18] - In PHP, there's a useful function for extracting array keys as local variables. Here's a similar proc for Tcl:

---

 # ==================================================================== #

 # extract --

 # Description
 #   Extract array variable into current scope

 # Arguments
 #   array                : name of array variable
 #   -prefix    <string>  : prefix variable names
 #   -postfix   <string>  : append variable names
 #   -overwrite <boolean> : overwrite existing variables
 #   args                 : wildcard pattern for array names

 # Return
 #   on error, error messages
 #   otherwise, number of extracted variables

 proc extract {array args} {

   upvar $array _

   set prefix    ""
   set postfix   ""
   set overwrite 0

   if { ![array exists _] } {
     return -code error "can't extract \"$array\": no such array"
   }

   set argv [list]   ; # list of array names to extract
   set n 0           ; # number of variables extracted
   set error 0       ; # number of errors
   set errors [list] ; # list of error messages

   set argc [llength $args]
   for {set i 0} {$i < $argc} {incr i} {
     set arg [lindex $args $i]
 #   puts "parse arg\[$i\] \[$arg\]"
     switch -- $arg {
       -overwrite {
         set overwrite [lindex $args [incr i]]
       }
       -postfix {
         set postfix [lindex $args [incr i]]
       }
       -prefix {
         set prefix [lindex $args [incr i]]
       }
       -- {
         set argv [concat $argv [lrange $args [incr i] end]]
       }
       default {
         lappend argv $arg
       }
     }
   }
 # puts "argv = \[$argv\]"

   if { ![llength $argv] } { set argv [list *] }

   foreach arg $argv {
     foreach name [array names _ $arg] {
       set name2 ${prefix}${name}${postfix}
       upvar $name2 var
       if { [array exists var] } {
         incr error
         lappend errors "extract: can't set \"$name2\": variable is array"
       } elseif { ![info exists var] || $overwrite } {
         set var $_($name)
         incr n
       } else {
         incr error
         lappend errors "extract: not overwriting var \"$name2\""
       }
     }
   }

   if { $error > 0 } {
     set code error
     set return [join $errors \n]
   } else {
     set code ok
     set return $n
   }

   return -code $code $return

 }

 # ==================================================================== #

 proc test {} {

   global env

 # array set env_HOME [list home /home]
 # set env_HOME /home

   if { [catch {extract env -prefix env_ -overwrite 1 H*} extract] } {
     puts stderr "$extract"
   } else {
     puts "extracted \[$extract\] variables"
   }

   puts "found \[[llength [info vars env_*]]\] vars"
   foreach var [info vars env_*] {
     if { [array exists $var] } {
       puts "\[$var\] is an array"
    } else {
       puts "\[$var\] = \[[set $var]\]"
     }
   }

 }

   test

 # ==================================================================== #

---

See also:

• array

---