extract

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
 
 # ==================================================================== #