# tko.tcl --
#
#   OO class like widget creation utilities.
#
# Copyright (c) <2023 r.zaumseil@freenet.de>
namespace eval ::tko {}

# Create tko widget from given widget with options matching one of
# usepatterns and ignore options from ignorelist.
#
# tkowidget   - newly create widget class
# widget      - name of widget to wrap
# usepatterns - list of "string match" patterns to find which of the options of the wrapped widget will be used.
# ignorlist   - list of options to ignore. This will be checked after the usepatterns.
proc ::tko::widget {tkowidget widget {usepatterns *} {ignorelist {}}} {
    set widget ::[string trimleft $widget :]
    set tkowidget ::[string trimleft $tkowidget :]
    # Create class
    set myClass [::oo::class create ::$tkowidget {
        ::tko_createwidget
        destructor {my _tko_destructor}
        method unknown {args} {$tko(..) {*}$args}
    }]
    # Get options from widget
    catch {destroy .__tko__}
    set myConf [[$widget .__tko__] configure]
    # Add options to class
    set myArgs {}
    set mySwitch [join $usepatterns {}]
    lappend mySwitch {} default {set o {}}
    foreach myList $myConf {
        lassign $myList o n c d v
	    switch -glob $o $mySwitch
	    if {$o eq {} || $o in $ignorelist} continue
	    switch [llength $myList] {
            2 {;# synonym options
                ::oo::define $myClass ::tko_option $o $n
            }
            5 {;# normal options
                if {[catch {.__tko__ configure $o $v}]} {;# readonly
                    ::oo::define $myClass ::tko_option $o $n $c $d\
                        {error readonly} {}
                    # no empty -class for ttk::* widgets
                    if {$o ne {-class} && $d ne {}} {
                        append myArgs "$o \$tko($o) "
                    }
                } else {;# writeable
                    ::oo::define $myClass ::tko_option $o $n $c $d\
"\$tko(..) configure $o \$tko($o) ; set tko($o) \[\$tko(..) cget $o\]"
                }
            }
        }
    }
    destroy .__tko__
    # Define constructor
    ::oo::define $myClass constructor {args}\
        "my _tko_constructor \$args $widget {$myArgs}; my _tko_init"
    return $myClass
}

# Called inside class definition context to initialize tko functionality.
# Mixin tko class features in current class context.
proc ::tko_createclass {} {
    uplevel 1 {
        mixin ::tko::mixin
        variable tko
        method _tko_configure {} {}
    }
    # emulate [self] in class context for tcl8.6
    if {[catch {set mySelf [uplevel 1 self]}]} {
        lassign [info level -1] myCmd mySelf
        if {$myCmd ne {::oo::define}} {
return -code error {could not get class name}
        }
    }
    set [info object namespace $mySelf]::Tko {}
}

# Called inside class definition context to initialize tko functionality.
# Mixin tko widget features in current class context.
proc ::tko_createwidget {} {
    uplevel 1 {
        mixin ::tko::mixin
        variable tko
        method _tko_configure {} {}
        self unexport create createWithNamespace destroy new
        self method unknown {args} {
            if {$args eq {}} {
return -code error "wrong # args: should be \"[self] pathName ?arg ...?\""
            }
            set args ::$args
            string trimleft [my create {*}$args] :
        }
    }
    # emulate [self] in class context for tcl8.6
    if {[catch {set mySelf [uplevel 1 self]}]} {
        lassign [info level -1] myCmd mySelf
        if {$myCmd ne {::oo::define}} {
return -code error {could not get class name}
        }
    }
    set [info object namespace $mySelf]::Tko {}
}

# Called inside class definition context to initialize tko functionality.
# Use tkoclass as superclass in current class context.
#
# tkoclass  - name of tko superclass
proc ::tko_createsuperclass {tkoclass} {
    uplevel 1 [list superclass -append ::$tkoclass]
    uplevel 1 {
        variable tko
    }
    # emulate [self] in class context for tcl8.6
    if {[catch {set mySelf [uplevel 1 self]}]} {
        lassign [info level -1] myCmd mySelf
        if {$myCmd ne {::oo::define}} {
return -code error {could not get class name}
        }
    }
    set [info object namespace $mySelf]::Tko\
        [set [info object namespace ::$tkoclass]::Tko]
}

# Called inside class definition context to initialize tko functionality.
# Use tkowidget as superclass in current class context.
#
# tkowidget - name of tko superwidget
proc ::tko_createsuperwidget {tkowidget} {
    uplevel 1 [list superclass -append ::$tkowidget]
    uplevel 1 {
        variable tko
        self unexport create createWithNamespace destroy new
        self method unknown {args} {
            if {$args eq {}} {
return -code error "wrong # args: should be \"[self] pathName ?arg ...?\""
            }
            set args ::$args
            string trimleft [my create {*}$args] :
        }
    }
    # emulate [self] in class context for tcl8.6
    if {[catch {set mySelf [uplevel 1 self]}]} {
        lassign [info level -1] myCmd mySelf
        if {$myCmd ne {::oo::define}} {
return -code error {could not get class name}
        }
    }
    set [info object namespace $mySelf]::Tko\
        [set [info object namespace ::$tkowidget]::Tko]
}

# Called inside class definition context to create and query class options. 
#
# args=
#   Return all defined options of current class
# args=-option
#   Return definition of given option
# args=-option -synonym
#   Create synonym option
# args=-option dbname dbclass default mode body
#   Create Tk like option. dbname and dbclass can be empty.
#   mode=i - set in constructor and call -option in init
#   mode=I - set in constructor and call -option and make readonly in init
#   mode=m - set and call -option in constructor
#   mode=M - set, call -option and make readonly in constructor
#   mode=s - set in constructor
#   mode=S - set and make readonly in constructor
proc ::tko_option {args} {
    # emulate [self] in class context for tcl8.6
    if {[catch {set myClass [uplevel 1 self]}]} {
        lassign [info level -1] myCmd myClass
        if {$myCmd ne {::oo::define}} {
return -code error {could not get class name}
        }
    }
    upvar [info object namespace $myClass]::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]} {
return -code error [::msgcat::mc {could not change existing option: %s} $args] 
            }
        }
        5 {;# add {-option dbname dbclass default body}
            lassign $args myOpt myDbname myDbclass myDef myBody
            if {[string index $myOpt 0] ne {-}} {
return -code error [::msgcat::mc {option not starting with "-": %s} $args] 
            }
            set myVal [list $myDbname $myDbclass $myDef]
            if {[dict exists $Tko $myOpt]} {
return -code error [::msgcat::mc {could not change existing option: %s} $args] 
            }
            ::oo::define $myClass method $myOpt {} $myBody
        }
        6 {;# add {-option dbname dbclass default body startbody}
            lassign $args myOpt myDbname myDbclass myDef myBody myStart
            if {[string index $myOpt 0] ne {-}} {
return -code error [::msgcat::mc {option not starting with "-": %s} $args] 
            }
            set myVal [list $myDbname $myDbclass $myDef $myBody]
            if {[dict exists $Tko $myOpt]} {
return -code error [::msgcat::mc {could not change existing option: %s} $args] 
            }
            ::oo::define $myClass method $myOpt {} $myStart
        }
        default {
return -code error [::msgcat::mc {wrong option args: %s} $args] 
        }
    }
    dict set Tko $myOpt $myVal
}

# Mixin ::tko::mixin
#   classvar Tko = {-option {deflist} ..}
#     Contain class option definitions. Set with ::tko_option.
#   variable tko = (-option)=value (.)=widget (..)=hidden widget
#     Array variable containing object option values.
#   method _tko_configure
#     Additional user supplied method.
#     Will be called in last _tko_init and in all configure calls.
#     Can be defined in every class separately. 
#   method -?option?
#     One method for each option to check and apply new values.
# In mixin is [info object class [self]]!=[self class] !!!
catch {::tko::mixin destroy}
oo::class create ::tko::mixin {}

# Public configure method to get and set options.
#
# args=
#   {}  Return list of options descriptions.
#   -*  Return value of given option
#   {?-* value? ..} Set given options to new values.
oo::define ::tko::mixin method configure {args} {
    variable tko
    upvar $tko(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]
                    }
                    3 - 4 {;# {dbname dbclass default ?body?}
                        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]
        }
        if {[dict exist $Tko $myOpt]} {
            set myDef [dict get $Tko $myOpt]
            if {[llength $myDef] == 1} {;# synonym
                set myOpt $myDef
                set myDef [dict get $Tko $myOpt]
            }
            return [list $myOpt [lindex $myDef 0] [lindex $myDef 1] [lindex $myDef 2] $tko($myOpt)]
        }
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 existence
        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
    }
    my _tko_configure
}

# Return current value of given option.
#
# option    - Name of option to get value from.
oo::define ::tko::mixin method cget {option} {
    variable tko
    if {[string index $option 0] eq {-}} {
        if {[info exist tko($option)]} {
            return $tko($option)
        }
        # check on alias option
        upvar $tko(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]
}

# Should be first command in class constructor.
# Setup call in constructor. Should be called in constructor of each
# class with defined tko options.
#
# arglist   - List of {?option value? ..} pairs to configure the widget.
# widget    - if given then use this widget as tko(.) hull widget.
# widgetargs- List of ?option value? pairs to initialize the given widget.
#             This is used to set p.e. readonly options on creation time.
oo::define ::tko::mixin method _tko_constructor {arglist {widget {}} {widgetargs {}}} {
    variable tko
    # Save configuration variable from outermost class
    set tko(Tko) [info object namespace [info object class [self]]]::Tko
    upvar $tko(Tko) Tko
    # create dummy widget needed for "::option get" calls TODO tip 682
    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) {};# list of {?option ro-flag? ..} method calls in _tko_init
    set myInit {};# list of {?option ro-flag? ..} method calls used here
    dict for {myOpt myDeflist} $Tko {
        switch -- [llength $myDeflist] {
            1 {;# {-synonym}
                if {[info exists myOpts($myOpt)]} {
                    set tko($myDeflist) $myOpts($myOpt)
                    unset myOpts($myOpt)
                }
            }
            3 {;# {dbname dbclass default}
                lassign $myDeflist myDbname myDbclass myDefault
                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
                    }
                }
                lappend tko(init) $myOpt
            }
            4 {;# {dbname dbclass default body}
                lassign $myDeflist myDbname myDbclass myDefault myBody
                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
                    }
                }
                lappend myInit $myOpt $myBody
            }
        }
    }
    # create widget if needed
    if {$widget ne {}} {
        destroy $myW
        # create widget in constructor context. tko(-*) vars are available.
        uplevel 1 "$widget $myW $widgetargs"
        set tko(.)  $myW
        set tko(..) ${myW}__tko__
        rename $myW ::$tko(..)
        rename ::tko::self ::$myW
        bindtags $myW [list tko::$tko(..) {*}[bindtags $myW]]
        bind tko::$tko(..) <Destroy> "catch {$myW destroy}"
    }
    # error on unsupported options
    if {[array size myOpts]} {
return -code error [::msgcat::mc {unknown options: %s} [array names myOpts]]
    }
    # process init calls
    foreach {myOpt myBody} $myInit {
        my $myOpt;# call with startbody
        ::oo::objdefine [self] method $myOpt {} $myBody;# set new body
    }
    # start option value tracing
    trace add variable [my varname tko] write [list [namespace which my] __tko_trace_tko]
}

# Remove internal tko related data. Only needed in mixin case.
# Should be called in the class destructor method.
oo::define ::tko::mixin method _tko_destructor {} {
    variable tko
    trace remove variable [my varname tko] write [list [namespace which my] __tko_trace_tko]
    after 1 "catch {destroy $tko(.)}"
}

# Call -option functions of current class.
# Should be called at the end of constructors of classes with defined
# tko options.
#
# class - name of current class, only needed for C-coded widgets.
oo::define ::tko::mixin method _tko_init {{class {}}} {
    if {$class eq {}} {set class [uplevel 1 self class]}
    variable tko
    if {![info exists tko(init)]} return
    # get configuration from current class
    upvar [info object namespace $class]::Tko Tko
    if {![info exists Tko]} {return $tko(init)};# no options in current class
    set myInit {};# collect not used options
    foreach myOpt $tko(init) {
        if {[dict exists $Tko $myOpt]} {
            my $myOpt
        } else {
            lappend myInit $myOpt
        }
    }
    # check result
    if {$myInit eq {}} {;# all options ok, call final _tko_configure
        unset tko(init)
        my _tko_configure
    } else {;# save remaining {option ro-flag} list
        set tko(init) $myInit
    }
    return $myInit
}

# Internal array trace method called from trace of tko(-*) variables.
oo::define ::tko::mixin method __tko_trace_tko {array field op} {
    if {[string index $field 0] eq {-}} {my $field}
}

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