Re: [Tcllib-devel] 8.5+ packages?

SourceForge Headquarters 1320 Columbia Street Suite 310 San Diego, CA 92101 +1 (858) 422-6466

2006-08-17 kl. 06.44 skrev Andreas Kupries:
> Regarding the dict package in AciveTcl, it is possible to write a
> replacement in pure Tcl if we do not wish the dependency. If we do
> that Pascal's 'dict' compat package in ActiveTcl can be an accelerator
> for the pure Tcl version.

The quote below is from =20
http://alphatcl.cvs.sourceforge.net/alphatcl/Tcl/SystemCode/=20
coreFixes.tcl?revision=3D1.215&view=3Dmarkup (line 2219f.). Licence is =20=

Tcl-style. There might be other (better?) pure-Tcl implementations =20
around, though.

/Lars Hellstr=F6m

##
  # =20
------------------------------------------------------------------------=20=

--
  #
  # "dict" -- option arg ?arg ...?
  #
  # Manipulate dictionaries.  Performs one of several operations on =20
dictionary
  # values or variables containing dictionary values.
  #
  # See <http://www.tcl.tk/man/tcl8.5/TclCmd/dict.htm> for more =20
information.
  #
  # =20
------------------------------------------------------------------------=20=

--
  #
  # This is a "poor man's [dict]" -- a pure tcl [dict] emulation.  Very =20=

slow,
  # but complete.  Implementation is based on lists, [array set/get] and
  # recursion.  Similar to Tcl 8.5's [dict] command, abbreviations will =20=

work.
  #
  # Not all error checks are implemented!  e.g.
  #
  #     dict create odd arguments here
  #
  # will work.
  #
  # =20
------------------------------------------------------------------------=20=

--
  ##

if {![llength [info commands dict]]} {
     alpha::stderr {Defining the core command [dict]}

     proc dict {cmd args} {
         set validCmds [list "append" "create" "exists" "filter" "for" \
           "get" "incr" "info" "keys" "lappend" "merge" "remove" \
           "replace" "set" "size" "unset" "update" "values" "with"]
         if {([set idx [lsearch -glob $validCmds "${cmd}*"]] =3D=3D -1)} =
{
             error "bad option \"$cmd\": must be [join $validArgs {, }]"
         }
         set cmd [lindex $validCmds $idx]
         uplevel 1 [linsert $args 0 _dict_$cmd]
     }
     proc _dict_append {dvar key {args}} {
         upvar 1 $dvar dv
         if {![info exists dv]} {
             set dv [list]
         }
         array set dvx $dv
         eval [linsert $args 0 append dvx($key) ]
         set dv [array get dvx]
     }
     proc _dict_create {args} {
         if {([llength $args] % 2)} {
             return -code error \
               {wrong # args: should be "dict create ?key value ...?"}
         }
         return $args
     }
     proc _dict_exists {dv key args} {
         array set dvx $dv
         set r [info exists dvx($key)]
         if {!$r} {
             return 0
         }
         if {[llength $args]} {
             return [eval [linsert $args 0 _dict_exists $dvx($key) ]]
         } else {
             return 1
         }
     }
     proc _dict_filter {dv ftype args} {
         set r [list]
         foreach {globpattern} $args {break}
         foreach {varlist script} $args {break}

         switch $ftype {
             key {
                 foreach {key value} $dv {
                     if {[string match $globpattern $key]} {
                         lappend r $key $value
                     }
                 }
             }
             value {
                 foreach {key value} $dv {
                     if {[string match $globpattern $value]} {
                         lappend r $key $value
                     }
                 }
             }
             script {
                 foreach {Pkey Pval} $varlist {break}
                 upvar 1 $Pkey key $Pval value
                 foreach {key value} $dv {
                     if {[uplevel 1 $script]} {
                         lappend r $key $value
                     }
                 }
             }
             default {
                 error "Wrong filter type"
             }
         }
         return $r
     }
     proc _dict_for {kv dict body} {
         uplevel 1 [list foreach $kv $dict $body]
     }
     proc _dict_get {dv args} {
         if {![llength $args]} {
             return $dv
         } else {
             array set dvx $dv
             set key [lindex $args 0]
             set dv $dvx($key)
             set args [lrange $args 1 end]
             return [eval [linsert $args 0 _dict_get $dv]]
         }
     }
     proc _dict_incr {dvar key {incr 1}} {
         upvar 1 $dvar dv
         if {![info exists dv]} {
             set dv [list]
         }
         array set dvx $dv
         if {![info exists dvx($key)]} {
             set dvx($key) 0
         }
         incr dvx($key) $incr
         set dv [array get dvx]
     }
     proc _dict_info {dv} {
         return "Dictionary is represented as plain list"
     }
     proc _dict_keys {dv {pat *}} {
         array set dvx $dv
         return [array names dvx $pat]
     }
     proc _dict_lappend {dvar key args} {
         upvar 1 $dvar dv
         if {![info exists dv]} {
             set dv [list]
         }
         array set dvx $dv
         eval [linsert $args 0 lappend dvx($key)]
         set dv [array get dvx]
     }
     proc _dict_merge {args} {
         foreach dv $args {
             array set dvx $dv
         }
         array get dvx
     }
     proc _dict_remove {dv args} {
         foreach k $args {
             _dict_unset dv $k
         }
         return $dv
     }
     proc _dict_replace {dv args} {
         if {([llength $args] % 2)} {
             return -code error \
               {wrong # args: should be "dict replace ?key value ...?"}
         }
         foreach {k v} $args {
             _dict_set dv $k $v
         }
         return $dv
     }
     proc _dict_set {dvar key value args } {
         upvar 1 $dvar dv
         if {![info exists dv]} {
             set dv [list]
         }
         array set dvx $dv
         if {![llength $args]} {
             set dvx($key) $value
         } else {
             eval [linsert $args 0 _dict_set dvx($key) $value]
         }
         set dv [array get dvx]
     }
     proc _dict_size {dv} {
         return [expr {[llength $dv]/2}]
     }
     proc _dict_unset {dvar key args} {
         upvar 1 $dvar mydvar
         if {![info exists mydvar]} {
             set mydvar [list]
         }
         array set dv $mydvar
         if {![llength $args]} {
             if {[info exists dv($key)]} {
                 unset dv($key)
             }
         } else {
             eval [linsert $args 0 _dict_unset dv($key) ]
         }
         set mydvar [array get dv]
         return {}
     }
     proc _dict_update {dvar args} {
         set name [string map {: {} ( {} ) {}} $dvar]
         upvar 1 $dvar dv
         upvar 1 _my_dict_array$name local

         array set local $dv
         foreach {k v} [lrange $args 0 end-1] {
             if {[info exists local($k)]} {
                 if {![uplevel 1 [list info exists $v]]} {
                     uplevel 1 [list upvar 0 _my_dict_array${name}($k) =20=

$v]
                 } else {
                     uplevel 1 [list set $v $local($k)]
                 }
             }
         }
         set code [catch {uplevel 1 [lindex $args end]} res]

         foreach {k v} [lrange $args 0 end-1] {
             if {[uplevel 1 [list info exists $v]]} {
                 set local($k) [uplevel 1 [list set $v]]
             } else {
                 unset -nocomplain local($k)
             }
         }
         set dv [array get local]
         unset local

         return -code $code $res
     }
     proc _dict_values {dv {gp *}} {
         set r [list]
         foreach {k v} $dv {
             if {[string match $gp $v]} {
                 lappend r $v
             }
         }
         return $r
     }
     proc _dict_with {dvar script} {
         set name [string map {: {} ( {} ) {}} $dvar]
         upvar 1 $dvar dv
         upvar 1 _my_dict_array$name local

         array set local $dv
         foreach k [array names local] {
             if {[info exists local($k)]} {
                 if {![uplevel 1 [list info exists $k]]} {
                     uplevel 1 [list upvar 0 _my_dict_array${name}($k) =20=

$k]
                 } else {
                     uplevel 1 [list set $k $local($k)]
                 }
             }
         }
         set code [catch {uplevel 1 $script} res]

         foreach k [array names local] {
             if {[uplevel 1 [list info exists $k]]} {
                 set local($k) [uplevel 1 [list set $k]]
             } else {
                 unset -nocomplain local($k)
             }
         }
         set dv [array get local]
         unset local

         return -code $code $res
     }
}