#---------------------------------------------------------------------
# TITLE:
#       typefunction.test
#
# AUTHOR:
#       Arnulf Wiedemann with a lot of code form the snit tests by
#       Will Duquette
#
# DESCRIPTION:
#       Test cases for ::itcl::type proc, method, typemethod commands.
#       Uses the ::tcltest:: harness.
#
#    The tests assume tcltest 2.2
#-----------------------------------------------------------------------

package require tcltest 2.2
namespace import ::tcltest::*
::tcltest::loadTestedCommands
package require itcl

interp alias {} type {} ::itcl::type

#-----------------------------------------------------------------------
# procs

test proc-1.1 {proc args can span multiple lines} -body {
    # This case caused an error at definition time in 0.9 because the
    # arguments were included in a comment in the compile script, and
    # the subsequent lines weren't commented.
    type dog {
        proc foo {
            a
            b
        } { }
    }
} -cleanup {
    dog destroy
} -result {::dog}

#-----------------------------------------------------------------------
# methods

test method-1.1 {methods get called} -body {
    type dog {
        method bark {} {
            return "$self barks"
        }
    }

    dog create spot
    spot bark
} -cleanup {
    dog destroy
} -result {::spot barks}

test method-1.2 {methods can call other methods} -body {
    type dog {
        method bark {} {
            return "$self barks."
        }

        method chase {quarry} {
            return "$self chases $quarry; [$self bark]"
        }
    }

    dog create spot
    spot chase cat
} -cleanup {
    dog destroy
} -result {::spot chases cat; ::spot barks.}

test method-1.3 {instances can call one another} -body {
    type dog {
        method bark {} {
            return "$self barks."
        }

        method chase {quarry} {
            return "$self chases $quarry; [$quarry bark] [$self bark]"
        }
    }

    dog create spot
    dog create fido
    spot chase ::fido
} -cleanup {
    dog destroy
} -result {::spot chases ::fido; ::fido barks. ::spot barks.}

test method-1.4 {upvar works in methods} -body {
    type dog {
        method goodname {varname} {
            upvar $varname myvar
            set myvar spot
        }
    }

    dog create fido
    set thename fido
    fido goodname thename
    set thename
} -cleanup {
    dog destroy
} -result {spot}

test method-1.6 {unknown methods get an error } -body {
    type dog { }

    dog create spot
    set result ""
    spot chase
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result {bad option "chase": should be one of...
  spot callinstance <instancename>
  spot cget -option
  spot configure ?-option? ?value -option value...?
  spot destroy
  spot getinstancevar <instancename>
  spot isa className
  spot mymethod
  spot myvar
  spot unknown}

test method-1.7 {info type method returns the object's type} -body {
    type dog { }

    dog create spot
    spot info type
} -cleanup {
    dog destroy
} -result {::dog}

test method-1.8 {instance method can call type method} -body {
    type dog {
        typemethod hello {} {
            return "Hello"
        }
        method helloworld {} {
            return "[$type hello], World!"
        }
    }

    dog create spot
    spot helloworld
} -cleanup {
    dog destroy
} -result {Hello, World!}

test method-1.9 {type methods must be qualified} -body {
    type dog {
        typemethod hello {} {
            return "Hello"
        }
        method helloworld {} {
            return "[hello], World!"
        }
    }

    dog create spot
    spot helloworld
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result {invalid command name "hello"}

test method-1.11 {too few arguments} -body {
    type dog {
        method bark {volume} { }
    }

    dog create spot
    spot bark
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result {wrong # args: should be "spot bark volume"}

test method-1.13 {too many arguments} -body {
    type dog {
        method bark {volume} { }
    }

    dog create spot

    spot bark really loud
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result {wrong # args: should be "spot bark volume"}

test method-1.14 {method args can't include type} -body {
    type dog {
        method foo {a type b} { }
    }
} -returnCodes {
    error
} -result {method foo's arglist may not contain "type" explicitly}

test method-1.15 {method args can't include self} -body {
    type dog {
        method foo {a self b} { }
    }
} -returnCodes {
    error
} -result {method foo's arglist may not contain "self" explicitly}

test method-1.16 {method args can span multiple lines} -body {
    # This case caused an error at definition time in 0.9 because the
    # arguments were included in a comment in the compile script, and
    # the subsequent lines weren't commented.
    type dog {
        method foo {
                    a
                    b
                } { }
    }
} -cleanup {
    dog destroy
} -result {::dog}

#-----------------------------------------------------------------------
# mymethod actually works

test mymethod-1.1 {run mymethod handler} -body {
    type foo {
        option -command {}
        method runcmd {} {
            eval [linsert $itcl_options(-command) end $self snarf]
            return
        }
    }
    type bar {
        variable sub
        constructor {args} {
            set sub [foo fubar -command [mymethod Handler]]
            return
        }

        method Handler {args} {
            set ::RES $args
        }

        method test {} {
            $sub runcmd
            return
        }
    }

    set ::RES {}
    bar boogle
    boogle test
    set ::RES
} -cleanup {
    bar destroy
    foo destroy
} -result {::bar::fubar snarf}

#-----------------------------------------------------------------------
# myproc

test myproc-1.1 {myproc qualifies proc names} -body {
    type dog {
        proc foo {} {}

        typemethod getit {} {
            return [myproc foo]
        }
    }

    dog getit
} -cleanup {
    dog destroy
} -result {::dog::foo}

test myproc-1.2 {myproc adds arguments} -body {
    type dog {
        proc foo {} {}

        typemethod getit {} {
            return [myproc foo "a b"]
        }
    }

    dog getit
} -cleanup {
    dog destroy
} -result {::dog::foo {a b}}

test myproc-1.3 {myproc adds arguments} -body {
    type dog {
        proc foo {} {}

        typemethod getit {} {
            return [myproc foo "a b" c d]
        }
    }

    dog getit
} -cleanup {
    dog destroy
} -result {::dog::foo {a b} c d}

test myproc-1.4 {procs with selfns work} -body {
    type dog {
        variable datum foo

        method qualify {} {
            return [myproc getdatum $selfns]
        }
        proc getdatum {selfns} {
            return [set ${selfns}::datum]
        }
    }
    dog create spot
    eval [spot qualify]
} -cleanup {
    dog destroy
} -result {foo}

#-----------------------------------------------------------------------
# mytypemethod

test mytypemethod-1.1 {mytypemethod qualifies typemethods} -body {
    type dog {
        typemethod this {} {}

        typemethod a {} {
            return [mytypemethod this]
        }
        typemethod b {} {
            return [mytypemethod this x]
        }
        typemethod c {} {
            return [mytypemethod this "x y"]
        }
        typemethod d {} {
            return [mytypemethod this x y]
        }
    }
    list [dog a] [dog b] [dog c] [dog d]
} -cleanup {
    dog destroy
} -result {{::dog this} {::dog this x} {::dog this {x y}} {::dog this x y}}

#---------------------------------------------------------------------
# Clean up

cleanupTests
return