# here for the world
package provide xowidget 0.1

catch {
    package require XOTcl
    # this is necessary
    namespace import ::xotcl::my
    namespace import ::xotcl::self

    package require Tk
}

namespace eval xowidget {
    # check if we got Tcl 8.5 to use {*}syntax
    variable _expand
    if {[package vsatisfies [package require Tcl] 8.5]} {
        set _expand yes
    } else  {
        set _expand no
    }
    namespace export XOWidget
    ::xotcl::Class create _XOWidget -superclass ::xotcl::Class
    _XOWidget instproc init {} {

        # default values
        my set __widget(hulltype) frame
        my set __widget(adaptor)  no
        my set __options(list)    ""
        my set __options(*,delegated) no 

        if {$::xowidget::_expand} {
            my instproc configurelist {{arg ""}} [expand {
                my configure %EXP%$arg
            }]
        } else  {
            my instproc configurelist {{arg ""}} {
                foreach {opt val} $arg {
                    my configure $opt $val
                }
            }
        }

        my instproc cget {opt} {
            array set options [[self class] array get __options]
            if {[lsearch -exact $options(list) $opt]<0} {
                return [[my set $options(*,target)] cget $opt]
            }
            if {[info exists options($opt,cgetcmd)]} {
                # this is a little machinery to avoid endless
                # loops (recursivity when calling configure/cget in
                # these handlers)
                [self class] unset __options($opt,cgetcmd)
                set value [my $options($opt,cgetcmd) $opt]
                [self class] set __options($opt,cgetcmd) \
                    $options($opt,cgetcmd)
                return $value
            }
            return [my set [::xowidget::xopt $opt]]
        }

        my instproc rawcget {opt} {
            return [my set [::xowidget::xopt $opt]]
        }

        my instproc rawconfigure {opt value} {
            my set [::xowidget::xopt $opt] $value
        }

        my instproc configure {args} {
            if {[llength $args] == 0} {
                return [my __show_configuration]
            }
            array set options [[self class] array get __options]
            foreach {opt val} $args {
                if {[lsearch -exact $options(list) $opt]<0} {
                    # unknown option, first look at option * delegation
                    if {$options(*,delegated)} {
                        [my set $options(*,target)] configure $opt $val
                    } else {
                        error "unknown option $opt"
                    }
                } elseif {$options($opt,delegated)} {
                    # delegated option
                    [my set $options($opt,target)] configure $options($opt,delname) $val
                } else {
                    # non-delegated option
                    if {[info exists options($opt,validatecmd)]} {
                        # throws an error when the value is invalid
                        my $options($opt,validatecmd) $val
                    }
                    if {[info exists options($opt,configurecmd)]} {
                        # this is a little machinery to avoid endless
                        # loops (recursivity when calling configure/cget in
                        # these handlers)
                        [self class] unset __options($opt,configurecmd)
                        my $options($opt,configurecmd) $opt $val
                        [self class] set __options($opt,configurecmd) \
                            $options($opt,configurecmd)
                    } else {
                        my set [::xowidget::xopt $opt] $val
                    }
                }
            }
            return
        }

        my instproc __show_configuration {} {
            set result ""
            foreach opt [[self class] set __options(list)] {
                set f $opt
                if {[my exists [::xowidget::xopt $opt]]} {
                    lappend f [my set [::xowidget::xopt $opt]]
                } else {
                    lappend f ""
                }
                lappend result $f
            }
            return $result
        }

        #
        # installhull : the first command to call when you instanciate it
        #                part of Widget-specific methods
        #
        my instproc installhull {} {
            # init options
            set class [self class]
            foreach opt [$class set __options(list)] {
                if {![$class set __options($opt,delegated)] && [$class set __options($opt,default)]} {
                    my set [::xowidget::xopt $opt] [$class set __options($opt,value)]
                }
            }
            # creates the hull
            set path  [::xowidget::pathFromSelf [self]]
            if {![$class set __widget(adaptor)] ||
                [$class set __widget(hulltype)] ne "existing"} {
                uplevel 1 [linsert [$class set __widget(hulltype)] 1 $path]
            }

            # wraps the original widget
            set i 0
            while 1 {
                incr i
                set newname ::WidgetCmd$i$path
                if {![llength [info commands $newname]]} break
            }
            rename ::$path $newname
                
            proc ::$path {args} [string map [list %PATH% [self]] {
                return [eval [linsert $args 0 %PATH%]]
            }]
            bind $path <Destroy> [list $path destroy]\n[list rename $path ""]
            if {[$class set __widget(adaptor)]} {
                my set hull $newname
            } else {
                    my set hull $path
            }
        }

        my instproc init {} {
            my installhull
        }
        
    }

    _XOWidget instproc option {name args} {
        set opt [::xowidget::xopt $name]
        my lappend __options(list) $name
        my set __options($name,delegated) no
        if {[llength $args]==0} {
            # no default
            my set __options($name,default) no
        } elseif {[llength $args]==1} {
            my set __options($name,default) yes
            my set __options($name,value) [lindex $args 0]
            return
        }
        foreach {key value} $args {
            switch -- $key {
                -default {
                    my set __options($name,default) yes
                    my set __options($name,value) $value
                }
                -configurecmd {
                    my set __options($name,configurecmd) $value
                }
                -cgetcmd {
                    my set __options($name,cgetcmd) $value
                }
                -validatecmd {
                    my set __options($name,validatecmd) $value
                }
                default {
                    error "unknown option option $key"
                }
            }
        }
        return
    }
    _XOWidget instproc hulltype {widget} {
        if {[my set __widget(hulltype)]!="frame"} {
            error "hulltype statement called twice"
        }
        my set __widget(hulltype) $widget
    }
    _XOWidget instproc setadaptor {args} {
        my set __widget(adaptor) yes
        my set __widget(hulltype) $args
        my delegate option * to hull
        my delegate instproc * to hull
    }

    #
    # DELEGATION
    #
    _XOWidget instproc delegate {type args} {
        eval [linsert $args 0 my __delegate_$type]
    }

    _XOWidget instproc __delegate_instproc {name args} {
        set revamped $name
        foreach {key value} $args {
            switch -- $key {
                as {set revamped $value}
                to {set target $value}
                default {error "unknown delegate statement"}
            }
        }
        if {$name=="*"} {
            if {$::xowidget::_expand} {
                set body "\[my set $target\] \{*\}\$args"
            } else  {
               set body "eval \[linsert \$args 0 \[my set $target\]\]"
            }
            my instproc unknown {args} $body
        } else {
            if {$::xowidget::_expand} {
                set body "\[my set $target\] $revamped \{*\}\$args"
            } else  {
               set body "eval \[linsert \$args 0 \[my set $target\] $revamped\]"
            }
            my instproc $name {args} $body
        }
        return
    }
    
    _XOWidget instproc __delegate_option {name args} {
        if {[lsearch -exact [my set __options(list)] $name]>=0 && 
            $name ne "*"} {
            error "local option cannot be delegated"
        }
        if {$name ne "*"} {my lappend __options(list) $name}
        my set __options($name,delegated) yes
        my set __options($name,delname) $name
            foreach {key value} $args {
            switch -- $key {
                as {
                    my set __options($name,delname) $value
                }
                to {
                    set hastarget yes ; # a marker
                    my set __options($name,target) $value
                }
                default {error "unknown delegate statement"}
            }
        }
        if {![info exists hastarget]} {
            error "delegate ... to target\ndelegation target missing"
        }
        return
    }
    #
    # Entry point
    #
    proc XOWidget {class args} {
        set wclass [transpose $class]
        uplevel 1 ::xowidget::_XOWidget $wclass $args
        # destroys the existing alias
        catch {uplevel 1 [list interp alias {} $class {}]}
        uplevel 1 [list interp alias {} $class {} ::xowidget::wset $class]
        return $class
    }

    #
    # Widget part (also in installhull method)
    #
    proc wset {class path args} {
        set wclass [transpose $class]
        if {[string index $path 0] ne "."} {
            return [uplevel 1 [linsert $args 0 $wclass $path]]
        }
        set i 0
        while {[llength [info commands ::Widget$i$path]]} {
            incr i
        }
        set body [$wclass info instbody init]
        if {![regexp {my installhull} $body]} {
            uplevel 1 [list $wclass instproc init {} "my installhull\n$body"]
        }
        uplevel 1 $wclass create Widget$i$path
        # parse arguments as any widget should: ?option value ?option value...??
        if {[llength $args]} {uplevel 1 [list Widget$i$path configurelist $args]}
        return $path
    }

     
     
    proc xopt {name} {
        if {[string index $name 0] ne "-"} {
            error "does not look like an option: $name"
        }
        return _[string range $name 1 end]
    }
    
    
    
    # introduce the expand syntax without making pre-8.5 Tcl 
    # arguing for this syntax
    # to use like: [expand {configure %EXP%$args}]
    # returns in this case : {configure {*}$args}
    proc expand {body} {
        string map {%EXP% \{*\}} $body
    }
    
    # given an instance identifier (obfuscated), finds the widget's path
    proc pathFromSelf {self} {
        return [string range $self [string first . $self] end]
    }
    
    
    #
    # procs to transpose a (visible) type name into a (hidden) XOTcl class name
    #
    proc untranspose {name} {
        return [string range $name 0 end-[string length __Widget]]
    }
    
    # gives the visible type name of an instance
    proc transpose {name} {
        return ${name}__Widget
    }

}

    # widget example to be launched by wish
    package require Tk
    lappend auto_path .
    package require xowidget
    xowidget::XOWidget Button
    # options
    Button option -fontfamily -default "" -configurecmd fontfamily
    Button setadaptor existing
    Button instproc init {} {
        my instvar hull
        $hull configure -text "Click me"
    }
    Button instproc fontfamily {opt value} {
        my instvar hull
        set font [$hull cget -font]
        lset font 0 $value
        $hull configure -font $font
        my rawconfigure $opt $value
    }
    proc try {firstname name} {
        global btn
        tk_messageBox -message "Have you ever tried to look like $firstname $name?"
        destroy $btn
        button $btn
        Button $btn -text "Exit" -command exit
        pack $btn
        update
    }
    
    # 'Button' arguments are treated after creation
    # by calling automatically the configure method
    button .btn
    set btn [Button .btn -fontfamily times -text "Top Cool Language" -command {try Freddie Mercury}]
    # comment this when you've got a toplevel hulltype, of course
    pack .btn
    update
    tk_messageBox -message "option list : [$btn configure]"

    # widget example to be launched by wish
    package require Tk
    lappend auto_path .
    package require xowidget
    xowidget::XOWidget Button
    # options
    Button option -packpad -default 10 -configurecmd packpad
    Button option -fontfamily -default "" -configurecmd fontfamily
    Button delegate option * to button
    Button delegate option -text to button
        
    Button instproc init {} {
        my instvar hull
        my set button [button $hull.b -text "Click me"]
        pack [my set button] -padx 10 -pady 10 -in $hull
    }
    Button instproc destroy {} {
        catch {destroy [my set button]}
    }
    Button instproc packpad {opt value} {
        pack configure [my set button] -padx $value -pady $value
        my rawconfigure $opt $value
    }
    Button instproc fontfamily {opt value} {
        my instvar button
        set font [$button cget -font]
        lset font 0 $value
        $button configure -font $font
        my rawconfigure $opt $value
    }
    proc try {firstname name} {
        global btn
        tk_messageBox -message "Have you ever tried to look like $firstname $name?"
        destroy $btn
        Button $btn -text "Exit" -command exit -packpad 5
        pack $btn
    }
    
    # 'Button' arguments are treated after creation
    # by calling automatically the configure method
    set btn [Button .btn -fontfamily times -text "Top Cool Language" -command {try Paul McCartney;update}]
    # comment this when you've got a toplevel hulltype, of course
    pack .btn
    update
    .btn configure -packpad 15
    tk_messageBox -message "option list : [$btn configure]"