jim-array-1.0.tcl

   1 # (c) 2008 Steve Bennett <steveb@workware.net.au>
   2 #
   3 # Implements a Tcl-compatible array command based on dict
   4 #
   5 # The FreeBSD license
   6 #
   7 # Redistribution and use in source and binary forms, with or without
   8 # modification, are permitted provided that the following conditions
   9 # are met:
  10 #
  11 # 1. Redistributions of source code must retain the above copyright
  12 #    notice, this list of conditions and the following disclaimer.
  13 # 2. Redistributions in binary form must reproduce the above
  14 #    copyright notice, this list of conditions and the following
  15 #    disclaimer in the documentation and/or other materials
  16 #    provided with the distribution.
  17 #
  18 # THIS SOFTWARE IS PROVIDED BY THE JIM TCL PROJECT ``AS IS'' AND ANY
  19 # EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
  20 # THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
  21 # PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  22 # JIM TCL PROJECT OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
  23 # INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
  24 # (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  25 # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  26 # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
  27 # STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  28 # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  29 # ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  30 #
  31 # The views and conclusions contained in the software and documentation
  32 # are those of the authors and should not be interpreted as representing
  33 # official policies, either expressed or implied, of the Jim Tcl Project.
  34
  35 package provide array 1.0
  36
  37 proc array {subcmd arrayname args} {
  38         # $name is the name of the array in the caller's context
  39         upvar $arrayname name
  40
  41         if {$subcmd eq "exists"} {
  42                 return [info exists name]
  43         }
  44
  45         if {![info exists name]} {
  46                 set name [dict create]
  47         }
  48
  49         switch $subcmd {
  50                 set {
  51                         # The argument should be a list, but we also
  52                         # support name value pairs
  53                         if {[llength $args] == 1} {
  54                                 set args [lindex $args 0]
  55                         }
  56                         foreach {key value} $args {
  57                                 dict set name $key $value
  58                         }
  59                         return $name
  60                 }
  61                 size {
  62                         return [/ [llength $name] 2]
  63                 }
  64         }
  65
  66         # The remaining options take a pattern
  67         if {[llength $args] > 0} {
  68                 set pattern [lindex $args 0]
  69         } else {
  70                 set pattern *
  71         }
  72
  73         switch $subcmd {
  74                 names {
  75                         set keys {}
  76                         foreach {key value} $name {
  77                                 if {[string match $pattern $key]} {
  78                                         lappend keys $key
  79                                 }
  80                         }
  81                         return $keys
  82                 }
  83                 get {
  84                         set list {}
  85                         foreach {key value} $name {
  86                                 if {[string match $pattern $key]} {
  87                                         lappend list $key $value
  88                                 }
  89                         }
  90                         return $list
  91                 }
  92                 unset {
  93                         foreach {key value} $name {
  94                                 if {[string match $pattern $key]} {
  95                                         dict unset name $key
  96                                 }
  97                         }
  98                         return
  99                 }
 100         }
 101
 102         # Tcl-compatible error message
 103         error "bad option \"$subcmd\": must be exists, get, names, set, size, or unset"
 104 }