# copyright (C) 1997-2006 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu

# $Id: datatrace.tcl,v 1.11 2006/01/28 19:16:59 jfontain Exp $


class dataTrace {                                   ;# work around the strict last come first served nature of the Tcl trace command

    proc dataTrace {this} {error {dataTrace objects disallowed}}

    proc register {object array script {last 0}} {                                              ;# object is a viewer or a dataTable
        variable objects
        variable command
        variable count

        if {[info exists objects($array)]} {
            catch {ldelete objects($array) $object}                                                  ;# do not appear more than once
            if {$last} {                                                    ;# command is to be invoked last when data update occurs
                lappend objects($array) $object
            } else {                                                                            ;# behave like the Tcl trace command
                set objects($array) [linsert $objects($array) 0 $object]
            }
        } else {
            trace variable ${array}(updates) w "dataTrace::updated $array"
            set objects($array) $object
        }
        if {[catch {incr count($object,$array)}]} {
            set command($object,$array) $script
            set count($object,$array) 1
        }
    }

    proc unregister {object {array {}}} {
        variable objects
        variable command
        variable count

        if {[string length $array] == 0} {                                                       ;# remove all traces for the object
            foreach array [array names objects] {
                if {[info exists count($object,$array)]} {                                      ;# array is monitored by this object
                    set count($object,$array) 0                                                               ;# force unregistering
                    unregister $object $array
                }
            }
            return
        }
        if {[incr count($object,$array) -1] <= 0} {
            ldelete objects($array) $object
            unset command($object,$array)
            unset count($object,$array)
        }
        if {[llength $objects($array)] == 0} {
            trace vdelete ${array}(updates) w "dataTrace::updated $array"                               ;# trace is no longer needed
            unset objects($array)
        }
    }

    proc updated {array args} {                                      ;# a module data array was just updated, ignore trace arguments
        variable objects
        variable command

        foreach object $objects($array) {                                                                  ;# update related objects
            uplevel #0 $command($object,$array)
        }
    }

}
