##
# \file tko.tcl
#
# proc ::tko::init mode args
#   Initialize class.
# proc ::tko::option class args
#   Define options.
#
# Mixin class ::tko
#   Provide cget/configure functionality.
#
#   classvar Tko
#     Contain class option definitions
#   variable tko
#     Array variable containing object option values
#   method configure args
#     Public configure method.
#   method cget -option
#     Public cget method.
#   method _tko_constructor arglist ?widget? ?widgetargs?
#     Setup call in constructor.
#   method _tko_destructor
#     Cleaup call for destructor
#   method _tko_init class
#     Call in constructor to call all -option methods of current class.
#   method -?option?
#     One method for each option to check and set value.
#   method __tko_trace_tko array field op
#     Internal array trace method.
#
namespace eval ::tko {}
set ::tko(mixinclass) {
    mixin ::tko
    variable tko
    set [info object namespace [self]]::Tko {}
}
set ::tko(mixinwidget) {
    mixin ::tko
    variable tko
    set [info object namespace [self]]::Tko {}
    self unexport createWithNamespace
    self unexport new
    self unexport create
    self method unknown {args} {
        string trimleft [my create {*}$args] :
    }
}
set ::tko(superclass) {
    superclass -append %C
    variable tko
    set [info object namespace [self]]::Tko [set [info object namespace %C]::Tko]
}
set ::tko(superwidget) {
    superclass -append %C
    variable tko
    set [info object namespace [self]]::Tko [set [info object namespace %C]::Tko]
    self unexport createWithNamespace
    self unexport new
    self unexport create
    self method unknown {args} {
        string trimleft [my create {*}$args] :
    }
}
set ::tko(wrapwidget) {
    mixin ::tko
    variable tko
    set [info object namespace [self]]::Tko {}
    self unexport createWithNamespace
    self unexport new
    self unexport create
    self method unknown {args} {
        string trimleft [my createWithNamespace [lindex $args 0] {*}$args] :
    }
    constructor {args} {my _tko_constructor $args %W %A}
    destructor {my _tko_destructor}
    method unknown {args} {$tko(..) {*}$args}
}
#-------------------------------------------------------------------------------
## Initialize tko class functionality
# \param mode
#   mixinclass
#   mixinwidget
#   superclass class
#   superwidget class
#   wrap widget
proc ::tko::init {mode args} {
    switch -- $mode {
        mixinclass {
            uplevel 1 $::tko(mixinclass)
        }
        mixinwidget {
            uplevel 1 $::tko(mixinwidget)
        }
        superclass {
            uplevel 1 [string map [list %C $args] $::tko(superclass)]
        }
        superwidget {
            uplevel 1 [string map [list %C $args] $::tko(superwidget)]
        }
        wrapwidget {
            set myClass [uplevel 1 self]
            lassign $args myWidget myIgnore
            # Get options from widget
            catch {destroy .__tko__}
            set myConf [[$myWidget .__tko__] configure]
            destroy .__tko__
            # Add options to class
            set myArgs {}
            foreach myList $myConf {
                lassign $myList o n c d v
                if {$o in $myIgnore} continue
                switch [llength $myList] {
                    2 {;# synonym options
                        ::tko::option $myClass $o $n {}
                    }
                    5 {;# normal options
                        if {[catch {.__tko__ configure $o $v}]} {
                            ::tko::option $myClass $o $n $c $d ::tko::readonly
                        } else {
                            ::tko::option $myClass $o $n $c $d\
"\$tko(..) configure $o \$tko($o) ; set tko($o) \[\$tko(..) cget $o\]"
                        }
                        append myArgs "$o \$tko($o) "
                    }
                }
            }
            # build new widget class
            uplevel 1 [string map [list %W $arg1 %A [list $myArgs]] $::tko(wrapwidget)]
        }
        default {
return -code error [::msgcat::mc {unknown mode: %s} $mode]
        }
    }
}
#-------------------------------------------------------------------------------
## ::tko::option -option dbclass dbname default mode body
#   mode=   - set in constructor
#   mode=c  - set and call in constructor
#   mode=cr - set, call and make readonly in constructor
#   mode=i  - set in constructor and call in init
#   mode=ir - set in constructor and call and make readonly in init
#   mode=r  - set and make readonly in constructor
#
# \param args
#   class
#   class -option
#   class -option -synonym
#   class -option dbname dbclass default body
proc ::tko::option {class args} {
    upvar [info object namespace $class]::Tko Tko
    switch -- [llength $args] {
        0 {;# return all definitions
            return $Tko
        }
        1 {;# return definition of given option
            lassign $args myOpt
            if {[string index $myOpt 0] ne {-}} {
return -code error [::msgcat::mc {option not starting with "-": %s} $myOpt] 
            }
            if {![dict exists $Tko $myOpt]} {
return -code error [::msgcat::mc {option not existing: %s} $myOpt] 
            }
            return [dict get $Tko $myOpt]
        }
        2 {;# add {-option -synonym}
            lassign $args myOpt myVal
            if {[string index $myOpt 0] ne {-}} {
return -code error [::msgcat::mc {option not starting with "-": %s} $args] 
            }
            if {[string index $myVal 0] ne {-}} {
return -code error [::msgcat::mc {alias not starting with "-": %s} $args] 
            }
            if {[dict exists $Tko $myOpt] && $myVal ne [dict get $Tko $myOpt]} {
return -code error [::msgcat::mc {could not change existing option: %s} $args] 
            }
        }
        5 - 6 {;# add {-option dbname dbclass default mode body}
            lassign $args myOpt myDbname myDbclass myDef myMode myBody
            if {[string index $myOpt 0] ne {-}} {
return -code error [::msgcat::mc {option not starting with "-": %s} $args] 
            }
            if {$myMode ni {{} c cr i ir r}} {
return -code error [::msgcat::mc {wrong mode "%s"in: %s} $myMode $args] 
            }
            set myVal [list $myDbname $myDbclass $myDef $myMode]
            if {[dict exists $Tko $myOpt] && $myVal ne [dict get $Tko $myOpt]} {
return -code error [::msgcat::mc {could not change existing option: %s} $args] 
            }
            ::oo::define $class method $myOpt {} $myBody
        }
        default {
return -code error [::msgcat::mc {wrong option args: %s} $args] 
        }
    }
    dict set Tko $myOpt $myVal
}
#-------------------------------------------------------------------------------
## Mixin ::tko
# classvar Tko
# variable tko (-option)=value (.)=widget (..)=hidden widget
# method _tko_constructor arglist ?widget? ?widgetargs?
# method _tko_destructor
# method _tko_init class
# method __tko_trace_tko array field op
# method -?option?
# method configure args
# method cget -option
catch {::tko destroy}
oo::class create ::tko {}
#-------------------------------------------------------------------------------
proc ::tko::readonly {} {error readonly}
## Should be first command in class constructor.
# \arglist  List of {?option vlaue? ..} pairs
oo::define ::tko method _tko_constructor {arglist {widget {}} {widgetargs {}}} {
    variable tko
    upvar [info object namespace [info object class [self]]]::Tko Tko
    # create dummy widget needed for "::option get" calls
    if {$widget ne {}} {
        set mySelf [self]
        rename $mySelf ::tko::self
        set myW [namespace tail $mySelf]
        ::frame $myW
    } else {
        set myW .
    }
    # initialize all options
    array set myOpts $arglist
    set tko(init) {}
    set myInit {}
    dict for {myOpt myDeflist} $Tko {
        switch -- [llength $myDeflist] {
            1 {;# {-synonym}
                if {[info exists myOpts($myOpt)]} {
                    set tko($myDeflist) $myOpts($myOpt)
                    unset myOpts($myOpt)
                }
            }
            4 {;# {dbname dbclass default mode}
                lassign $myDeflist myDbname myDbclass myDefault myMode
                if {[info exists myOpts($myOpt)]} {
                    set tko($myOpt) $myOpts($myOpt)
                    unset myOpts($myOpt)
                } elseif {$myDbname eq {}} {
                    set tko($myOpt) $myDefault
                } else {
                    set myVal [::option get $myW $myDbname $myDbclass]
                    if {$myVal eq {}} {
                        set tko($myOpt) $myDefault
                    } else {
                        set tko($myOpt) $myVal
                    }
                }
                switch -- $myMode {
                    c {lappend myInit $myOpt 0}
                    cr {lappend myInit $myOpt 1}
                    i {lappend tko(init) $myOpt 0}
                    ir {lappend tko(init) $myOpt 1}
                    r {::oo::objdefine [self] method $myOpt {} {error readonly}}
                }
            }
        }
    }
    # create widget if needed
    if {$widget ne {}} {
        destroy $myW
        set myW [uplevel 1 $widget $myW {*}$widgetargs]
        set myBind "catch {$myW destroy}"
        rename $myW ::${myW}__tko__
        rename ::tko::self ::$myW
        set tko(.) $myW
        set tko(..) ${myW}__tko__
        bindtags $myW [list tko$myW {*}[bindtags $myW]]
        bind tko$myW <Destroy> $myBind
    }
    foreach {myOpt myRo} $myInit {
        my $myOpt
        if {$myRo} {::oo::objdefine [self] method $myOpt {} {error readonly}}
    }
    # error on unsupported options
    if {[array size myOpts]} {
return -code error [::msgcat::mc {unknown options: %s} [array names myOpts]]
    }
    # start option value tracing
    trace add variable [my varname tko] write [list [namespace which my] __tko_trace_tko]
}
#-------------------------------------------------------------------------------
## Call -option functions.
oo::define ::tko method _tko_init {class} {
    variable tko
    if {![info exists tko(init)]} return
    upvar [info object namespace $class]::Tko Tko
    if {![info exists Tko]} {return $tko(init)}
    set myInit {}
    foreach {myOpt myRo} $tko(init) {
        if {[dict exists $Tko $myOpt]} {
            my $myOpt
            if {$myRo} {::oo::objdefine [self] method $myOpt {} {error readonly}}
        } else {
            lappend myInit $myOpt $myRo
        }
    }
    if {$myInit eq {}} {
        unset tko(init)
    } else {
        set tko(init) $myInit
    }
    return $myInit
}
#-------------------------------------------------------------------------------
## Remove internal tko related data.
oo::define ::tko method _tko_destructor {} {
    variable tko
    trace remove variable [my varname tko] write [list [namespace which my] __tko_trace_tko]
    catch {destroy $tko(.)}
}
#-------------------------------------------------------------------------------
## Internal command called from trace of tko(-*) variables.
oo::define ::tko method __tko_trace_tko {array field op} {
    if {[string index $field 0] eq {-}} {my $field}
}
#-------------------------------------------------------------------------------
## 
oo::define ::tko method _tko_configure {} {}
#-------------------------------------------------------------------------------
## Configuration of defined options.
# \param args
#   {}  Return list of options descriptions.
#   -*  Return value of given option
#   {?-* value? ..} Set given options to new values.
oo::define ::tko method configure {args} {
    variable tko
    upvar [info object namespace [info object class [self]]]::Tko Tko
    set myLength [llength $args]
    # get all configuration options
    if {$myLength == 0} {
        set myRet {}
        dict for {myKey myDef} $Tko {
            if {[string index $myKey 0] eq {-}} {
                switch -- [llength $myDef] {
                    1 {;# {-synonym}
                        lappend myRet [list $myKey $myDef]
                    }
                    4 {;# {dbname dbclass default mode}
                        lappend myRet [list $myKey {*}[lrange $myDef 0 2] $tko($myKey)]
                    }
                }
            }
        }
        return [lsort $myRet]
    }
    # get value of given option
    if {$myLength == 1} {
        set myOpt [lindex $args 0]
        if {[string index $myOpt 0] ne {-}} {
return -code error [::msgcat::mc {unknown option "%s"} $myOpt]
        }
        # try real option
        if {[info exist tko($myOpt)]} {
            return $tko($myOpt)
        }
        # try synonym option
        if {[dict exists $Tko $myOpt]} {
            set myDeflist [dict get $Tko $myOpt]
            if {[info exist tko($myDeflist)]} {
                return $tko($myDeflist)
            }
        }
return -code error [::msgcat::mc {unknown option "%s"} $myOpt]
    }
    # set one or more option values
    if {[expr {$myLength%2}]==1} {
return -code error [::msgcat::mc {value for "%s" missing} [lindex $args end]]
    }
    # get old values
    set myOld {}
    foreach {o v} $args {
        # check option existance
        if {[string index $o 0] ne {-} || ![dict exists $Tko $o]} {
return -code error [::msgcat::mc {unknown option "%s"} $o]
        }
        # apply synonym option
        set myOpt [dict get $Tko $o]
        if {[llength $myOpt] == 1} {set o $myOpt}
        lappend myOld $o $tko($o)
        lappend myNew $o $v
    }
    # try to set new values
    if {[catch {array set tko $myNew} m]} {
        catch {array set tko $myOld}
return -code error $m
    }
}
#-------------------------------------------------------------------------------
## Return current value of given option.
# \param option Name of option to get value from.
oo::define ::tko method cget {option} {
    variable tko
    if {[string index $option 0] eq {-}} {
        if {[info exist tko($option)]} {
            return $tko($option)
        }
        upvar [info object namespace [info object class [self]]]::Tko Tko
        if {[dict exists $Tko $option]} {
            set myOpt [dict get $Tko $option]
            if {[dict exists $Tko $myOpt]} {
                return $tko($myOpt)
            }
        }
    }
    return -code error [::msgcat::mc {Unknown option "%s"} $option]
}
#-------------------------------------------------------------------------------
## vim: set ts=4 sw=4 sts=4 et :
# uncomment the following lines to run tests from tko.test file:
#package req tcltest
#::tcltest::configure -testdir [file dirname [info script]] -file tko.test -singleproc 1 -match init-*
#::tcltest::runAllTests

package require tcltest
namespace import ::tcltest::*

proc cleanup {} {
    destroy {*}[winfo children .]
    catch {namespace delete ::TEST}
}
proc setup {args} {
    cleanup
    foreach x $args {
        setup_$x
    }
}
proc setup_C1 {} {
    oo::class create ::TEST::C1 {
        ::tko::init mixinclass
        ::tko::option [self] -o1 o1 O1 "o1" i {}
        ::tko::option [self] -o2 {} {} "o2" i {}
        ::tko::option [self] -r1 r1 R1 "r1" cr
        ::tko::option [self] -s1 -o1
        constructor {args} {
            my _tko_constructor $args
            my _tko_init ::TEST::C1
        }
        destructor {my _tko_destructor}
    }
}
proc setup_C2 {} {
    oo::class create ::TEST::C2 {
        ::tko::init superclass ::TEST::C1
        ::tko::option [self] -o3 o3 O3 "o3" i {}
        constructor {args} {
            next {*}$args
            my _tko_init ::TEST::C2
        }
        destructor {my _tko_destructor}
    }
}
proc setup_W1 {} {
    oo::class create ::TEST::W1 {
        ::tko::init mixinwidget
        ::tko::option [self] -o1 o1 O1 "o1" i {}
        ::tko::option [self] -o2 {} {} "o2" i {}
        ::tko::option [self] -class class Class "myWidget" ir
        ::tko::option [self] -s1 -o1
        constructor {args} {
            my _tko_constructor $args ::frame {-borderwidth 2 -class $tko(-class)}
            my _tko_init ::TEST::W1
        }
        destructor {my _tko_destructor}
    }
}
proc setup_W2 {} {
    oo::class create ::TEST::W2 {
        ::tko::init superwidget ::TEST::W1
        ::tko::option [self] -o3 o3 O3 "o3" i {}
        constructor {args} {
            next {*}$args
            my _tko_init ::TEST::W2
        }
        destructor {next}
    }
}

#
# Test "::zz .."
#
test init-1.1 {class init wrong args} -cleanup cleanup\
-setup {setup C1}\
-body {
    ::TEST::C1 xx
}\
-match glob -returnCodes error\
-result {unknown method "xx": must be create, destroy or new}

test init-1.2 {widget init wrong args} -cleanup cleanup\
-setup {setup W1}\
-body {
    ::TEST::W1 x
}\
-match glob -returnCodes error\
-result {bad window path name "x"}

test init-2.1 {widget configure} -cleanup cleanup\
-setup {setup W1}\
-body {
    ::TEST::W1 .x -class Xx -o1 oo1 -o2 oo2
    .x configure
}\
-result {{-class class Class myWidget Xx} {-o1 o1 O1 o1 oo1} {-o2 {} {} o2 oo2} {-s1 -o1}}

test init-2.2 {widget configure} -cleanup cleanup\
-setup {setup W1}\
-body {
    ::TEST::W1 .x -class Xx -o1 oo1 -o2 oo2 -s1 ss1
    .x configure
}\
-result {{-class class Class myWidget Xx} {-o1 o1 O1 o1 ss1} {-o2 {} {} o2 oo2} {-s1 -o1}}

test init-2.3 {widget configure} -cleanup cleanup\
-setup {setup W1}\
-body {
    ::TEST::W1 .x -o1 xxx
    set myRet [.x configure -s1]
    .x configure -s1 yyy
    lappend myRet [.x configure -o1]
    lappend myRet [.x configure -s1]
}\
-result {xxx yyy yyy}

test init-2.4 {widget configure} -cleanup cleanup\
-setup {setup W1 W2}\
-body {
    ::TEST::W2 .x -class x -o1 1 -o2 2 -o3 3
    .x configure
}\
-result {{-class class Class myWidget x} {-o1 o1 O1 o1 1} {-o2 {} {} o2 2} {-o3 o3 O3 o3 3} {-s1 -o1}}

test init-2.5 {widget configure} -cleanup cleanup\
-setup {setup W1 W2}\
-body {
    ::TEST::W2 .x -class x -o1 1 -o2 2 -o3 3
    catch {.x configure -o1 11 -x dummy -o2 22} myRet
    lappend myRet [.x configure]
}\
-result {unknown option -x {{-class class Class myWidget x} {-o1 o1 O1 o1 1} {-o2 {} {} o2 2} {-o3 o3 O3 o3 3} {-s1 -o1}}}

test init-2.6 {widget configure} -cleanup cleanup\
-setup {setup W1 W2}\
-body {
    ::TEST::W2 .x -class x -o1 1 -o2 2 -o3 3
    .x configure -o1 11 -o2 22 -s1 111 -o3 33
    .x configure
}\
-result {{-class class Class myWidget x} {-o1 o1 O1 o1 111} {-o2 {} {} o2 22} {-o3 o3 O3 o3 33} {-s1 -o1}}


# vim: set ts=4 sw=4 sts=4 ff=unix et :