# copyright (C) 1997-2005 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: store.tcl,v 1.57 2005/01/02 00:45:07 jfontain Exp $

# Remember cells the data of which is to be stored for history purposes, in a database, by the moomps daemon.
# A dialog box is used with a table as a drop site for data cells.


class store {

    variable number
    variable titles {label active current comment}
    set column 0
    foreach title $titles {                                                  ;# note: current column data is only for dialog box use
        set number($title) $column
        incr column
    }
    unset column

    proc store {this args} switched {$args} viewer {} {
        variable singleton

        if {[info exists singleton]} {
            error {only 1 store object can exist}
        }
        switched::complete $this
    }

    proc ~store {this} {
        error {not implemented}
    }

    proc options {this} {
        return [list\
            [list -configurations {} {}]\
        ]
    }

    proc set-configurations {this value} {}                                    ;# list of lists of switch/value pairs from save file

    proc setData {dataName row cell active comment} {
        variable number
        upvar 1 $dataName data

        viewer::parse $cell array cellRow cellColumn type
        foreach {label incomplete} [viewer::label $array $cellRow $cellColumn 1] {}
        set data($row,-1) $cell
        set data($row,$number(label)) $label
        set data($row,$number(active)) $active
        set data($row,$number(current)) {}                                                                  ;# updated in dialog box
        set data($row,$number(comment)) $comment
        return $incomplete
    }

    proc sortedRows {dataName} {
        upvar 1 $dataName data

        set rows {}
        foreach name [array names data *,-1] {                                                    ;# cells are kept in hidden column
            lappend rows [lindex [split $name ,] 0]
        }
        return [lsort -integer $rows]                                                                           ;# in creation order
    }

    proc supportedTypes {this} {
        return $global::dataTypes                                                                                       ;# all types
    }

    # invoked by core during initialization from save file only, dropped cells must be handled below by dialog box
    proc monitorCell {this array row column} {
        variable data
        variable number

        if {[llength $switched::($this,-configurations)] == 0} return                            ;# done initializing from save file
        set cell ${array}($row,$column)
        viewer::registerTrace $this $array
        set rowIndex [llength [array names data *,-1]]                                                         ;# next available row
        set index 0
        foreach configuration $switched::($this,-configurations) {
            catch {unset option}; array set option $configuration
            if {![info exists option(-cell)]} break                                                                    ;# old format
            if {[string equal $option(-cell) $cell]} break          ;# new format, from 19.1, found configuration for monitored cell
            # since cells and their configurations are recorded in the same order, skip configurations of void cells, which
            # can happen when their module has not been loaded due to some initialization problem
            incr index
        }
        set incomplete [setData data $rowIndex $cell $option(-active) $option(-comment)]
        # eat processed configurations. note: there cannot be several configurations fro the same cell.
        switched::configure $this -configurations [lrange $switched::($this,-configurations) [incr index] end]
        if {$incomplete} {                                                                         ;# label cannot be determined yet
            set ($this,relabel,$rowIndex) {}
        }
        set ($this,register,$rowIndex) {}                                                    ;# register with the database once only
    }

    proc update {this array} {     ;# if array is void, it means to eventually update database static data (invoked from dialog box)
        variable data
        variable number

        set externalUpdate [string length $array]
        foreach {name cell} [array get data *,-1] {                                               ;# cells are kept in hidden column
            if {$externalUpdate && ([string first $array $cell] != 0)} continue          ;# check that cell belongs to updated array
            set row [lindex [split $name ,] 0]
            viewer::parse $cell array cellRow cellColumn type  ;# note: array needs be (re)set here in case array parameter was void
            if {[info exists ($this,relabel,$row)] && [info exists $cell]} {               ;# if label is not yet defined, update it
                foreach [list data($row,$number(label)) incomplete] [viewer::label $array $cellRow $cellColumn 1] {}
                if {!$incomplete} {
                    unset ($this,relabel,$row)                                                       ;# label now completely defined
                }
                set ($this,register,$row) {}                                                            ;# eventually register again
            }
            set database $global::database
            if {$database == 0} continue                                                      ;# no history to be stored in database
            if {!$data($row,$number(active))} continue                         ;# no history to be stored for this cell at this time
            set label $data($row,$number(label))
            set comment $data($row,$number(comment))
if {$global::withGUI} {
            if {[catch {set instance $($this,databaseInstance,$array)}]} {            ;# module instance registration yet to be done
                set instance [database::register $database [modules::instanceData $array]]
                if {[string length $database::($database,error)] > 0} {                 ;# any database error is fatal at this point
                    traceDialog {moodss fatal error: database module instance registration} $database::($database,error) 1
                    _exit 1                                                                                                 ;# abort
                }
                set ($this,databaseInstance,$array) $instance
            }
            if {[info exists ($this,register,$row)]} {       ;# note: do not prefix label with module identifier to avoid redundancy
                database::monitor\
                    $database $instance $cellRow $cellColumn [lindex [viewer::label $array $cellRow $cellColumn 0] 0] $comment
                unset ($this,register,$row)
            }
            if {$externalUpdate} {                                                ;# only update static data when invoked internally
                set value ?; catch {set value [set $cell]}                                   ;# cell data may not or no longer exist
                database::update $database $instance $cellRow $cellColumn $value
            }
} else {
            if {[catch {set instance $($this,databaseInstance,$array)}]} {            ;# module instance registration yet to be done
                set instance [$database register [modules::instanceData $array]]           ;# use database object in its interpreter
                if {[string length [$database error]] > 0} {
                    exit 1                                                                                            ;# fatal error
                }
                set ($this,databaseInstance,$array) $instance
            }
            if {[info exists ($this,register,$row)]} {       ;# note: do not prefix label with module identifier to avoid redundancy
                $database monitor $instance $cellRow $cellColumn [lindex [viewer::label $array $cellRow $cellColumn 0] 0] $comment
                unset ($this,register,$row)
            }
            # note: there are only external (core) updates in daemon mode
            set value ?; catch {set value [set $cell]}                                       ;# cell data may not or no longer exist
            $database update $instance $cellRow $cellColumn $value
}
        }
    }

    proc cells {this} {                                                               ;# note: always return cells in the same order
        variable data

        set cells {}
        foreach row [sortedRows data] {
            lappend cells $data($row,-1)
        }
        return $cells
    }

    proc manageable {this} {return 0}                                           ;# dialog box is displayed and managed locally below

if {$global::withGUI} {

    proc initializationConfiguration {this} {        ;# return a list of comments, one for each stored cell, in the cells list order
        variable number
        variable data

        set arguments {}
        foreach row [sortedRows data] {                                     ;# note: -cell option added from 19.1: see monitorCell{}
            lappend arguments [list -cell $data($row,-1) -active $data($row,$number(active)) -comment $data($row,$number(comment))]
        }
        return [list -configurations $arguments]                             ;# note: always return configurations in the same order
    }

    proc reload {dataName} {                                  ;# data comes from dialog box table that the user edited and validated
        variable data
        variable singleton
        upvar 1 $dataName new

        reset $singleton
        array set data [array get new]
        foreach row [sortedRows data] {
            viewer::parse $data($row,-1) array dummy dummy dummy
            viewer::registerTrace $singleton $array
            set ($singleton,register,$row) {}           ;# register with the database for new cells or in case comments were changed
            store::update $singleton {}                                                    ;# eventually update static database data
        }
    }

    proc monitored {this cell} {
        variable data

        foreach {name monitored} [array get data *,-1] {
            if {[string equal $monitored $cell]} {
                return 1
            }
        }
        return 0
    }

    proc anyActiveCells {this} {
        variable data
        variable number

        foreach name [array names data *,-1] {                                                    ;# cells are kept in hidden column
            set row [lindex [split $name ,] 0]
            if {$data($row,$number(active))} {return 1}
        }
        return 0
    }

}

    proc reset {this} {                                                       ;# return to original state when singleton was created
        variable data

        foreach row [sortedRows data] {
            viewer::parse $data($row,-1) array dummy dummy dummy
            viewer::unregisterTrace $this $array
        }
        catch {unset data}
    }

    proc active {options} {                                                  ;# public procedure: returns the number of active cells
        array set value $options
        if {![info exists value(-configurations)]} {
            return 0                                                                                                     ;# no cells
        }
        set cells 0
        foreach options $value(-configurations) {                                              ;# list of switch, value, switch, ...
            array set option $options
            if {$option(-active)} {incr cells}
        }
        return $cells
    }

}

set ::store::singleton [new store]


if {$global::withGUI} {

class store {

    proc edit {writable destroyCommand} {
        if {[info exists (dialog)]} {                                                                                      ;# exists
            raise $widget::($dialog::($(dialog),dialog),path)                                                     ;# make it visible
        } else {
            append destroyCommand "\nunset store::(dialog)"
            set (dialog) [new dialog . $writable $destroyCommand]
        }
    }

    proc setCellColor {this cell color} {
        variable ${this}data

        if {![info exists (dialog)]} return                                                                    ;# nothing to display
        dialog::setCellColor $(dialog) $cell $color
    }

    class dialog {

        proc dialog {this parentPath writable {deleteCommand {}}} viewer {} {
            variable ${this}data

            set dialog [new dialogBox .\
                -buttons hoc -default o -title [mc {moodss: Database archiving}]\
                -helpcommand {generalHelpWindow #menus.edit.database} -x [winfo pointerx .] -y [winfo pointery .]\
                -grab release -otherbuttons delete -command "set store::dialog::($this,valid) 1" -deletecommand "delete $this"\
            ]
            lappend ($this,tips) [linkedHelpWidgetTip $composite::($dialog,help,path)]
            foreach {string underline} [underlineAmpersand [mc &Delete]] {}
            composite::configure $dialog delete -text $string -underline $underline -command "store::dialog::delete $this"\
                -state disabled
            set frame [frame $widget::($dialog,path).frame]
            set table [createTable $this $frame]
            set ($this,drop) [new dropSite -path $selectTable::($table,tablePath) -formats DATACELLS\
                -command "store::dialog::dropped $this \$dragSite::data(DATACELLS)"\
            ]
            pack $widget::($table,path) -anchor nw -fill both -expand 1
            wm geometry $widget::($dialog,path) 400x300
            dialogBox::display $dialog $frame
            set ($this,table) $table
            set ($this,dialog) $dialog
            array set ${this}data [array get store::data]                                    ;# copy valid data in case user cancels
            selectTable::rows $table [llength [array names ${this}data *,-1]]
            initialize $this [store::sortedRows ${this}data] $writable
            selectTable::refreshBorders $table                                                ;# needed if there are multi-line rows
            selectTable::adjustTableColumns $table
            colorRows $this
            set ($this,valid) 0                                                            ;# whether the user validated its choices
            set ($this,deleteCommand) $deleteCommand
        }

        proc ~dialog {this} {                                ;# note: all data trace unregistering occurs in viewer layer destructor
            variable ${this}data

            if {$($this,valid)} {                                                                      ;# user validated its choices
                store::reload ${this}data
            }
            eval ::delete $($this,tips) $($this,drop) $($this,table)
            catch {unset ${this}data}
            if {[string length $($this,deleteCommand)] > 0} {
                uplevel #0 $($this,deleteCommand)                                           ;# always invoke command at global level
            }
        }

        proc createTable {this parentPath} {
            variable ${this}data

            set help(label) [mc {data cell identification}]
            set help(active) [mc {whether data cell history should be recorded in database}]
            set help(current) [mc {current value of data cell}]
            set help(comment) [mc {user editable comment}]
            set table [new selectTable $parentPath\
                -selectcommand "store::dialog::select $this" -variable store::dialog::${this}data -titlerows 1 -roworigin -1\
                -columns [llength $store::titles]\
            ]                                                                   ;# set number of columns according to title row data
            set path $selectTable::($table,tablePath)
            set column 0
            foreach title $store::titles {
                set label [label $path.$column -font $font::(mediumBold) -text [mc $title]]
                selectTable::windowConfigure $table -1,$column -window $label -padx 1 -pady 1 -sticky nsew
                lappend ($this,tips) [new widgetTip -path $label -text $help($title)]
                incr column
            }
            return $table
        }

        proc dropped {this cells} {                                                           ;# cells is a list of data array cells
            variable ${this}data

            set table $($this,table)
            foreach {name cell} [array get ${this}data *,-1] {                                    ;# cells are kept in hidden column
                set saved($cell) {}
            }
            set rows [store::sortedRows ${this}data]
            set length [llength $rows]
            if {$length == 0} {
                set last -1
            } else {
                set last [lindex $rows end]
            }
            set row $last
            set new {}
            foreach cell $cells {
                if {[info exists saved($cell)]} continue                                                            ;# already saved
                viewer::parse $cell array ignore ignore ignore
                set module [modules::identifier $array]
                if {[string length $module] == 0} {                                ;# ignore cells not attached to a module instance
                    lifoLabel::flash $global::messenger [mc {data does not belong to an original module table}]
                    bell
                    continue
                }
                if {[string equal $module trace]} {                                                     ;# ignore trace module cells
                    lifoLabel::flash $global::messenger [mc {cannot monitor cells from trace module}]
                    bell
                    continue
                }
                store::setData ${this}data [incr row] $cell 1 {}
                # row height is number of lines
                selectTable::height $table $row [linesCount [set ${this}data($row,$store::number(label))]]
                lappend new $row
                incr length
            }
            if {[llength $new] > 0} {                                                             ;# one or more new rows were added
                selectTable::rows $table $length                                                              ;# including title row
                initialize $this $new
                selectTable::refreshBorders $table
                selectTable::adjustTableColumns $table
                # color rows according to threshold condition (do it last since a tktable bug undoes it when number of rows changes)
                colorRows $this
                update $this {}
            }
        }

        proc select {this row} {
            set topPath $widget::($($this,dialog),path)
            set button $composite::($($this,dialog),delete,path)
            $button configure -state normal
            bind $topPath <Alt-KeyPress-d> "$button configure -relief sunken"      ;# make sure that only this button sees the event
            bind $topPath <Alt-KeyRelease-d> "$button configure -relief raised; $button invoke"
            return 1
        }

        proc delete {this} {
            variable ${this}data

            set table $($this,table)
            set row [selectTable::selected $table]
            if {[string length $row] == 0} return
            set path $selectTable::($table,tablePath)
            foreach index [store::sortedRows ${this}data] {                                                    ;# delete all entries
                destroy $path.$index,active $path.$index,comment
            }
            viewer::parse [set ${this}data($row,-1)] array dummy dummy dummy
            viewer::unregisterTrace $this $array
            array unset ${this}data $row,*                                                                ;# delete related row data
            array set data [array get ${this}data]
            unset ${this}data
            set row 0; set rows {}
            foreach index [store::sortedRows data] {
                set ${this}data($row,-1) $data($index,-1)
                set column $store::number(label); set ${this}data($row,$column) $data($index,$column)
                set column $store::number(active); set ${this}data($row,$column) $data($index,$column)
                set column $store::number(comment); set ${this}data($row,$column) $data($index,$column)
                lappend rows $row; incr row
            }
            selectTable::rows $table $row
            initialize $this $rows
            selectTable::clear $table
            selectTable::refreshBorders $table                                                ;# needed if there are multi-line rows
            selectTable::adjustTableColumns $table
            colorRows $this                                                  ;# possibly recolor rows since indexes may have changed
            set topPath $widget::($($this,dialog),path)
            bind $topPath <Alt-KeyPress-d> {}; bind $topPath <Alt-KeyRelease-d> {}
            composite::configure $($this,dialog) delete -state disabled
        }

        proc setCellColor {this cell color} {                                          ;# implementation of the base class procedure
            variable ${this}data

            foreach {name value} [array get ${this}data *,-1] {                                   ;# cells are kept in hidden column
                if {[string equal $value $cell]} {                                                                  ;# cell is saved
                    colorRow $this [lindex [split $name ,] 0] $color
                    return
                }
            }
        }

        proc colorRow {this row color} {                                ;# actually only the cell current value column changes color
            # note: no need to handle special corner case since the last column contains data that is not subject to highlighting
            set cell $row,$store::number(current)
            if {[string length $color] == 0} {
                selectTable::tag $($this,table) cell {} $cell                                                    ;# reset cell color
            } else {
                selectTable::tag $($this,table) configure color$color -background $color
                selectTable::tag $($this,table) cell color$color $cell
            }
        }

        proc colorRows {this} {                                                ;# color all rows according to cells threshold colors
            variable ${this}data

            foreach {name cell} [array get ${this}data *,-1] {                                    ;# cells are kept in hidden column
                viewer::parse $cell array row column type
                colorRow $this [lindex [split $name ,] 0] [viewer::cellThresholdColor $array $row $column]
            }
        }

        proc initialize {this rows {writable 1}} {
            variable ${this}data

            set table $($this,table)
            set path $selectTable::($table,tablePath)
            set background [$path cget -background]
            foreach row $rows {
                set cell [set ${this}data($row,-1)]
                viewer::parse $cell array dummy dummy dummy
                viewer::registerTrace $this $array                                     ;# monitor data cell for current value column
                set cell $row,$store::number(active)
                set button [checkbutton $path.$row,active\
                    -activebackground $background -highlightthickness 0 -variable store::dialog::${this}data($cell) -takefocus 0\
                ]
                bind $button <ButtonRelease-1> "selectTable::select $table $row"
                selectTable::windowConfigure $table $cell -window $button -padx 1 -pady 1 -sticky nsew
                set cell $row,$store::number(comment)
                set entry [entry $path.$row,comment\
                    -font $font::(mediumNormal) -textvariable store::dialog::${this}data($cell) -borderwidth 0\
                    -highlightthickness 0\
                ]
                if {!$writable} {
                    $entry configure -state disabled
                }
                bind $entry <FocusIn> "selectTable::select $table $row"
                selectTable::windowConfigure $table $cell -window $entry -padx 1 -pady 1 -sticky nsew
                # row height is number of lines
                selectTable::height $table $row [linesCount [set ${this}data($row,$store::number(label))]]
            }
            update $this {}
        }

        proc update {this array} {                            ;# if array is empty, it is an internal invocation to update all cells
            variable ${this}data

            set externalUpdate [string length $array]
            foreach {name cell} [array get ${this}data *,-1] {                                    ;# cells are kept in hidden column
                if {$externalUpdate && ([string first $array $cell] != 0)} continue      ;# check that cell belongs to updated array
                set row [lindex [split $name ,] 0]
                set value ?
                catch {set value [set $cell]}
                set ${this}data($row,$store::number(current)) $value
            }
        }

        proc saved {this} {return 0}                                                                  ;# no need to save this viewer

        proc manageable {this} {return 0}                                           ;# dialog box is obviously not managed in canvas

        proc reset {this} {                                                ;# invoked by core for example when clearing display, ...
            ::delete $($this,dialog)                                        ;# delete dialog object which in turn delete this object
        }

    }

}

}