# This file is a Tcl script to test out the "::tko_*" and "tko::option"
# commands of Tko. It is organized in the standard fashion for Tcl
# tests.
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.

package require tcltest
namespace import ::tcltest::*
package require tko

namespace eval ::TEST {

proc ::TEST::deleteWindows {} {
    destroy {*}[winfo children .]
    catch {::C destroy}
    catch {::D destroy}
}

proc ::TEST::create {type class {super {}}} {
    switch -- $type {
        mixinclass {
            ::oo::class create $class {
                ::tko_createclass
                ::tko_option -class class Class myClass {error readonly} {}
                constructor args {
                    my _tko_constructor $args
                    my _tko_init
                }
                destructor {my _tko_destructor}
            }
        }
        mixinwidget {
            ::oo::class create $class {
                ::tko_createwidget
                ::tko_option -class class Class myWidget {error readonly} {}
                constructor args {
                    my _tko_constructor $args ::frame {-class $tko(-class)}
                    my _tko_init
                }
                destructor {my _tko_destructor}
            }
        }
        superclass {
            ::oo::class create $class "::tko_createsuperclass $super"
            ::oo::define $class {
                constructor args {
                    next {*}$args
                    my _tko_init
                }
            }
        }
        superwidget {
            ::oo::class create $class "::tko_createsuperwidget $super"
            ::oo::define $class {
                constructor args {
                    next {*}$args
                    my _tko_init
                }
            }
        }
        default error
    }
}

#
# Test "::tko_ .."
#
test init-1.1 {tko_createclass wrong context} -setup {
    deleteWindows
} -body {
    ::tko_createclass
} -cleanup {
    deleteWindows
} -returnCodes error -match glob -result {invalid command name "mixin"}

test init-1.2 {tko_createclass wrong context} -setup {
    deleteWindows
} -body {
    namespace eval ::C {
        ::tko_createclass
    }
} -cleanup {
    namespace delete ::C
    deleteWindows
} -returnCodes error -match glob -result {invalid command name "mixin"}

test init-1.3 {tko_createclass wrong args} -setup {
    deleteWindows
} -body {
    ::tko_createclass ::dummy
} -cleanup {
    deleteWindows
} -returnCodes error -match glob -result {wrong # args: should be "::tko_createclass"}

test init-1.4 {tko_createclass} -setup {
    deleteWindows
} -body {
    ::TEST::create mixinclass ::C
    ::oo::class create ::D {
        constructor args {
            my _tko_constructor $args
            my _tko_init
        }
        destructor {my _tko_destructor}
    }
    ::oo::define ::D ::tko_createclass
    ::C create c1
    ::D create d1
    set myRet [list [c1 configure] [d1 configure]]
} -cleanup {
    deleteWindows
} -match glob -result {{{-class class Class myClass myClass}} {}}

test init-1.5 {tko_createwidget} -setup {
    deleteWindows
} -body {
    ::TEST::create mixinwidget ::C
    ::oo::class create ::D {}
    ::oo::define ::D {
        ::tko_createwidget
        ::tko_option -class class ClassD myWidget {error readonly} {}
        constructor args {
            my _tko_constructor $args ::frame {-class $tko(-class)}
            my _tko_init
        }
        destructor {my _tko_destructor}
    }
    ::C .c1
    ::D .d1
    set myRet [list [.c1 configure] [.d1 configure]]
} -cleanup {
    deleteWindows
} -match glob -result {{{-class class Class myWidget myWidget}} {{-class class ClassD myWidget myWidget}}}

test init-1.6 {tko_createsuperwidget} -setup {
    deleteWindows
} -body {
    ::TEST::create mixinwidget ::C
    ::TEST::create superwidget ::D ::C
    ::D .d1
    .d1 configure
} -cleanup {
    deleteWindows
} -match glob -result {{-class class Class myWidget myWidget}}

test init-1.7 {tko::create} -setup {
    deleteWindows
} -body {
    ::tko::widget ::C frame -b*
    ::C .c1
    .c1 configure
} -cleanup {
    deleteWindows
} -match glob -result {{-background background Background SystemButtonFace SystemButtonFace} {-backgroundimage backgroundImage BackgroundImage {} {}} {-bd -borderwidth} {-bg -background} {-bgimg -backgroundimage} {-borderwidth borderWidth BorderWidth 0 0}}

#
# Test "::tko::option .."
#
test init-2.1 {tko::option wrong args} -setup {
    deleteWindows
} -body {
    ::TEST::create mixinwidget ::C
    catch {::oo::define ::C tko_option -x} m1
    catch {::oo::define ::C tko_option -x x} m2
    catch {::oo::define ::C tko_option -x x x} m3
    catch {::oo::define ::C tko_option -X x x {}} m4
    list $m1 $m2 $m3 $m4
} -cleanup {
    deleteWindows
} -match glob -result {{option not existing: -x} {alias not starting with "-": -x x} {wrong option args: -x x x} {wrong option args: -X x x {}}}

test init-2.2 {tko::option create} -setup {
    deleteWindows
} -body {
    ::TEST::create mixinwidget ::C
    ::oo::define ::C tko_option -ro ro Ro r {error readonly} {lappend ::TEST::RZ ro1}
    ::oo::define ::C tko_option -init init Init i {lappend ::TEST::RZ init2} {lappend ::TEST::RZ init1}
    ::oo::define ::C tko_option -normal normal Normal n {lappend ::TEST::RZ normal}
    C .c1
    set ::TEST::RZ [.c1 configure]
    catch {.c1 configure -ro rr} m
    lappend ::TEST::RZ $m
    .c1 configure -init ii
    .c1 configure -normal nn
    lappend ::TEST::RZ [.c1 configure]
} -cleanup {
    deleteWindows
    unset -nocomplain ::TEST::RZ
} -match glob -result {{-class class Class myWidget myWidget} {-init init Init i i} {-normal normal Normal n n} {-ro ro Ro r r} {can't set "tko(-ro)": readonly} init2 normal {{-class class Class myWidget myWidget} {-init init Init i ii} {-normal normal Normal n nn} {-ro ro Ro r r}}}

test init-2.3 {tko::option default values} -setup {
    deleteWindows
} -body {
    ::TEST::create mixinwidget ::C
    ::oo::define ::C tko_option -ro ro Ro r {error readonly} {}
    ::oo::define ::C tko_option -init init Init i {}
    ::oo::define ::C tko_option -normal normal Normal n {}
    C .c1 -class c2
    .c1 configure
} -cleanup {
    deleteWindows
} -match glob -result {{-class class Class myWidget c2} {-init init Init i i} {-normal normal Normal n n} {-ro ro Ro r r}}

test init-2.4 {tko::option cget/configure} -setup {
    deleteWindows
} -body {
    ::TEST::create mixinwidget ::C
    ::oo::define ::C tko_option -ro ro Ro r {error readonly} {}
    ::oo::define ::C tko_option -init init Init i {}
    ::oo::define ::C tko_option -normal normal Normal n {}
    C .c1 -ro r3 -init i3 -normal n3
    set myRet [list [.c1 cget -ro] [.c1 cget -init] [.c1 cget -normal]]
    .c1 configure -normal n4 -init i4
    lappend myRet [.c1 cget -init] [.c1 cget -normal]
} -cleanup {
    deleteWindows
} -match glob -result {r3 i3 n3 i4 n4}

test init-2.5 {tko::option -option proc} -setup {
    deleteWindows
} -body {
    ::TEST::create mixinwidget ::C
    ::oo::define ::C tko_option -ro ro Ro r {error readonly} {set tko(-ro) r1}
    ::oo::define ::C tko_option -init init Init i {variable tko;set tko(-init) i2} {set tko(-init) i1}
    ::oo::define ::C tko_option -normal normal Normal n {set tko(-normal) n1}
    C .c1 -ro rr -init ii -normal nn
    set myRet [list [.c1 cget -ro] [.c1 cget -init] [.c1 cget -normal]]
    .c1 configure -init i9 -normal n9
    lappend myRet [.c1 cget -init] [.c1 cget -normal]
} -cleanup {
    deleteWindows
} -match glob -result {r1 i1 n1 i2 n1}

#
# Performance
#
test init-99.1 {performance comparison} -setup {
    deleteWindows
} -body {
    ::tko::widget ::wrapframe frame
    ::tko::widget ::wrapframe0 frame {-width}
    ::tko::widget ::wraplabelframe labelframe
    ::tko::widget ::wraplabelframe0 labelframe {-width}
    ::tko::widget ::wraptoplevel toplevel
    ::tko::widget ::wraptoplevel0 toplevel {-width}
    ::oo::class create ::ooclass {
        method configure {args} {}
        method cget {args} {}
        self method unknown {pathName args} {tailcall ::ooclass create $pathName} 
    }
    if {![catch {package req snit}]} {
        ::snit::widget ::snit::frame {
            hulltype ::frame
            delegate option * to hull
        }
        ::snit::widget ::snit::labelframe {
            hulltype ::labelframe
            delegate option * to hull
        }
        ::snit::widget ::snit::toplevel {
            hulltype ::toplevel
            delegate option * to hull
        }
    }
    proc ::TEST::Do {cmd} {set i 0; format %8.1f [lindex [time $cmd 100] 0]}
    proc ::TEST::Test {wdg} {
        if {[info commands $wdg] eq {}} return
        set ret [format %18s $wdg]
        append ret [::TEST::Do "$wdg .\[incr i\]"]
        append ret [::TEST::Do {.[incr i] cget -width}]
        append ret [::TEST::Do {.[incr i] configure -width 100}]
        append ret [::TEST::Do {.[incr i] configure}]
        if {$wdg in {::ooclass ::tkoclass}} {
            append ret [::TEST::Do {.[incr i] destroy}]
        } else {
            append ret [::TEST::Do {destroy .[incr i]}]
        }
        return $ret
    }
    puts "Class:     command  create    cget  config    list destroy"
    puts [::TEST::Test ::ooclass]
    puts "Frame:     command  create    cget  config    list destroy"
    puts [::TEST::Test ::frame]
    puts [::TEST::Test ::ttk::frame]
    puts [::TEST::Test ::tko::frame]
    puts [::TEST::Test ::snit::frame]
    puts [::TEST::Test ::wrapframe]
    puts [::TEST::Test ::wrapframe0]
    puts "Labelframe:command  create    cget  config    list destroy"
    puts [::TEST::Test ::labelframe]
    puts [::TEST::Test ::ttk::labelframe]
    puts [::TEST::Test ::tko::labelframe]
    puts [::TEST::Test ::snit::labelframe]
    puts [::TEST::Test ::wraplabelframe]
    puts [::TEST::Test ::wraplabelframe0]
    puts "Toplevel:  command  create    cget  config    list destroy"
    puts [::TEST::Test ::toplevel]
    puts [::TEST::Test ::tko::toplevel]
    puts [::TEST::Test ::snit::toplevel]
    puts [::TEST::Test ::wraptoplevel]
    puts [::TEST::Test ::wraptoplevel0]
    puts "Tko widget:command  create    cget  config    list destroy"
    puts [::TEST::Test ::tko::path]
    puts [::TEST::Test ::tko::graph]
} -cleanup {
    catch {::ooclass destroy}
    catch {::tkoclass destroy}
    catch {::snit::frame destroy}
    catch {::snit::labelframe destroy}
    catch {::snit::toplevel destroy}
    catch {::wrapframe destroy}
    catch {::wrapframe0 destroy}
    catch {::wraplabelframe destroy}
    catch {::wraplabelframe0 destroy}
    catch {::wraptoplevel destroy}
    catch {::wraptoplevel0 destroy}
    deleteWindows
} -result {}

# cleanup
deleteWindows
cleanupTests
}
catch {namespace delete ::TEST}

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