[Anton Kovalenko]: As I like the new [dict] command very much, I want to use it in all my new projects. But I don't want my programs to need tcl 8.5!

Here is a pure tcl emulation of [dict] command.

[Vince] -- this is very useful indeed. Thanks!

''dict update'', ''dict with'', and ''dict map'' are not yet supported here.  Any contributions?

----
======
# Poor man's dict -- a pure tcl [dict] emulation
# Very slow, but complete.
#
# Not all error checks are implemented!
# e.g. [dict create odd arguments here] will work
#
# Implementation is based on lists, [array set/get]
# and recursion

if {![llength [info commands dict]]} {
    proc dict {cmd args} {
        uplevel 1 [linsert $args 0 _dict_$cmd]
    }
    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_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_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_unset {dvar key args} {
        upvar 1 $dvar mydvar
        if {![info exists mydvar]} {return}
        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_keys {dv {pat *}} {
        array set dvx $dv
        return [array names dvx $pat]
    }
    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} {
        return $args
    }
    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_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_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_replace {dv args} {
        foreach {k v} $args {
            _dict_set dv $k $v
        }
        return $dv
    }
    proc _dict_remove {dv args} {
        foreach k $args {
            _dict_unset dv $k
        }
        return $dv
    }
    proc _dict_size {dv} {
        return [expr {[llength $dv]/2}]
    }
    proc _dict_values {dv {gp *}} {
        set r [list]
        foreach {k v} $dv {
            if {[string match $gp $v]} {
                lappend r $v
            }
        }
        return $r
    }
}
======

----
''[PS] I created a dict package based on the current (Nov2005) code of Tcl 8.5, which has all the features and most of the performance of the real thing. See the [dict] page, search for 'tclDict' ''

Here's an ugly 'dict update' implementation. Any improvements?

======
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) $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
}
======

----
[AMG]: This code has numerous issues and shortcomings, though many of them are due to being implemented in terms of [[[array]]].  However, some things just baffle me.  For example, what's this code supposed to do?

======
        foreach {globpattern} $args {break}
======

Why not just say `set globpattern [[lindex $args 0]]`?

----
28jan04 [jcw] - The "ihash" package in critlib [http://www.equi4.com/critlib/] might be a way to get good performance (from C, i.e. with a Tcl extension, not a core change).  See also the [Adding a hashed datatype] page where this extension is described in more detail.

----
[RHS] ''20Sept2004'' I included this code in the .tgz file for [RHS's Bytecode Package]. I wasn't sure who to ask about doing this, but I assumed it was ok, since its on the Wiki and my code is released open source (standard Tclish license). I made a note in the dict.tcl file that the code in that file is not copyrighted to me, and put a link to this page. If my including this file is an issue, let me know and I'll remove it.

[AMG]: See [Who owns the content on this Wiki] for more discussion on this subject.

<<categories>> Internals | Command | Data Structure