# Commands covered:  proc
#
# This file contains a collection of tests for one or more of the Tcl built-in
# commands.  Sourcing this file into Tcl runs the tests and generates output
# for errors.  No output means no errors were found.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

testConstraint procbodytest [expr {![catch {package require procbodytest}]}]

# proc-enh-1.x: error while parsing argspec
test proc-enh-1.1 {argspec parsing error: unexpected fields number} {
    list [catch {
	proc p {{a -default 1 -name}} {}
    } msg] $msg $errorCode
} {1 {unexpected fields number in argument specifier "a -default 1 -name"} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
test proc-enh-1.2 {argspec parsing error: argument with no name} {
    list [catch {
	proc p {{}} {}
    } msg] $msg $errorCode
} {1 {argument with no name} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
test proc-enh-1.3 {argspec parsing error: formal parameter is an array elt} {
    list [catch {
	proc p {a(1)} {}
    } msg] $msg $errorCode
} {1 {formal parameter "a(1)" is an array element} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
test proc-enh-1.4 {argspec parsing error: formal parameter is not a simple name} {
    list [catch {
	proc p {a::b} {}
    } msg] $msg $errorCode
} {1 {formal parameter "a::b" is not a simple name} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
test proc-enh-1.5 {argspec parsing error: unknown option} {
    list [catch {
	proc p {{a -foo 1}} {}
    } msg] $msg $errorCode
} {1 {unknown argument option "-foo" or too many fields in argument specifier "a -foo 1"} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
test proc-enh-1.5b {argspec parsing error: unknown option} {
    list [catch {
	proc p {{a foo 1}} {}
    } msg] $msg $errorCode
} {1 {unknown argument option "foo" or too many fields in argument specifier "a foo 1"} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
test proc-enh-1.6 {argspec parsing error: empty named argument} {
    list [catch {
	proc p {{a -name {""}}} {}
    } msg] $msg $errorCode
} {1 {named argument with no name} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
test proc-enh-1.7 {argspec parsing error: named argument with space} {
    list [catch {
	proc p {{a -name {"a b"}}} {}
    } msg] $msg $errorCode
} {1 {named argument "a b" with unexpected space character} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
test proc-enh-1.8 {argspec parsing error: empty named argument (switch)} {
    list [catch {
	proc p {{a -switch {a {}}}} {}
    } msg] $msg $errorCode
} {1 {incorrect switch value ""} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
test proc-enh-1.9 {argspec parsing error: named argument with space (switch)} {
    list [catch {
	proc p {{a -switch {a {"a b" 3}}}} {}
    } msg] $msg $errorCode
} {1 {named argument "a b" with unexpected space character} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
test proc-enh-1.10 {argspec parsing error: two many fields in switch} {
    list [catch {
	proc p {{a -switch {{a b c}}}} {}
    } msg] $msg $errorCode
} {1 {incorrect switch value "a b c"} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
test proc-enh-1.11 {argspec parsing error: upvar with bad level} {
    list [catch {
	proc p {{a -upvar foo}} {}
    } msg] $msg $errorCode
} {1 {Invalid level "foo" for -upvar arg specifier} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
test proc-enh-1.12 {argspec parsing error: upvar with bad level} {
    list [catch {
	proc p {{a -upvar -1}} {}
    } msg] $msg $errorCode
} {1 {Invalid level "-1" for -upvar arg specifier} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
test proc-enh-1.13 {argspec parsing error: required with no boolean} {
    list [catch {
	proc p {{a -required foo}} {}
    } msg] $msg $errorCode
} {1 {Invalid boolean "foo" for -required arg specifier} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
test proc-enh-1.14 {argspec parsing error: same arg name used twice} {
    list [catch {
	proc p {{a -name A} {b -name B} {a2 -name A}} {}
    } msg] $msg $errorCode
} {1 {named argument "A" has been used more than once in the same named group} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
test proc-enh-1.15 {argspec parsing error: -upvar with -switch} {
    list [catch {
	proc p {{a -switch A -upvar 1}} {}
    } msg] $msg $errorCode
} {1 {-upvar can't be used with -switch} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}

# proc-enh-2.x: correct usage
test proc-enh-2.1 {correct usage: -default} {
    proc p { { a -default 1 } } { list $a }
    list [p] [p 2]
} {1 2}
test proc-enh-2.2 {correct usage: -default set twice} {
    proc p { { a -default 1 -default 2 } } { return $a }; p
} {2}
test proc-enh-2.3 {correct usage: -name} {
    proc p {{a -name A} {b -name {B0 B1}} {c -name C0 -name C1}} {
	list $a $b $c
    };
    list [p -B0 5 -A 1 -C1 6] [p -C0 0 -B1 8 -A 2 -C0 3]
} {{1 5 6} {2 8 3}}
test proc-enh-2.4 {correct usage: -switch} {
    proc p {{a -switch {A}} {b -switch {B0 {B1 b1}}} {c -switch {{C0 c0}} -switch C1}} {
	list $a $b $c
    };
    list [p -B1 -C1 -A] [p -A -C0 -B0]
} {{A b1 C1} {A B0 c0}}
test proc-enh-2.5 {correct usage: -switch + -name} {
    proc p {{v -name val -switch {{low 0} {high 9}}}} { return $v }
    list [p -low] [p -val 5] [p -high]
} {0 5 9}
test proc-enh-2.6 {correct usage: -required} {
    proc p {{a -required 0}} {
	if {[info exists a]} { return $a } else { return unset }
    };
    list [p] [p 2]
} {unset 2}
test proc-enh-2.7 {correct usage: -required + -switch} {
    proc p {{a -required 0 -switch dbg}} {
	if {[info exists a]} { return $a } else { return unset }
    };
    list [p] [p -dbg]
} {unset dbg}
test proc-enh-2.8 {correct usage: -upvar} {
    proc p {{a -upvar #0}} { incr a; return $a }
    proc p2 {{a -upvar 2}} { incr a; return $a }
    proc p3 {name} { p2 $name }
    set i 5;
    if [info exists j] { unset j }
    list [p i] [p j] [p3 i] [list $i $j]
} {6 1 7 {7 1}}
test proc-enh-2.9 {correct usage: -upvar + -name} {
    proc p {{a -upvar 1 -name A} {b -name B -upvar 1}} {
	incr a; incr b; list $a $b
    }
    set i 5;
    if [info exists j] { unset j }
    list [p -B j -A i] [p -A j -B i] [list $i $j]
} {{6 1} {2 7} {7 2}}
test proc-enh-2.10 {correct usage: end of named group} {
    proc p {{a -name A -default 0} {b -default 1 -name B} args} {
	list $a $b $args
    }
    list [p foo] [p -B 3 -- -A 5]
} {{0 1 foo} {0 3 {-A 5}}}
test proc-enh-2.11 {correct usage: -upvar inside a named group (not last one)} {
    proc p {{v -name var -upvar 1} {i -default 1 -name incr}} {
	incr v $i
    }
    if [info exists i] {unset i}
    list [p -var i -incr 2] [p -incr 3 -var i] [p -var i]
} {2 5 6}
test proc-enh-2.12 {correct usage: -upvar inside a named group + end-of-option marker} {
    proc p {{v -name var -upvar 1} {i -default 1 -name incr} args} {
	incr v $i; list $v $args
    }
    set i 0
    list [p -var i] [p -var i -- -incr 3] [p -var i -- a b c] [p -var i -- -- abc]
} {{1 {}} {2 {-incr 3}} {3 {a b c}} {4 {-- abc}}}
test proc-enh-2.13 {correct usage: two distinct named group} {
    proc p {{a -switch A -default 0} {b -switch B -default 0} c {d -switch D -default 0} {e -switch E -default 0}} {
	list $a $b $c $d $e
    }
    list [p -B 5 -E -D] [p -- foo -E]
} {{0 B 5 D E} {0 0 foo 0 E}}
test proc-enh-2.14 {correct usage: named arg without required is optionnal} {
    proc p {{a -name A}} {
	if {[info exists a]} { return $a } else { return unset }
    };
    list [p] [p -A 2]
} {unset 2}
test proc-enh-2.15 {correct usage: fixed number of arguments after named group, automatically ended} {
    proc p {{a -name A -default 0} {b -name B -default 0} c} {
	list $a $b $c
    };
    set l [list -Z 1]
    list [p -2] [p -A 1 -5] [p -- -3] [p --]
} {{0 0 -2} {1 0 -5} {0 0 -3} {0 0 --}}

# proc-enh-3.x: wrong # args
test proc-enh-3.1 {wrong # args: -name arg without value} {
    proc p {{a -name A} {b -name B -default 1}} { }
    list [catch { p -A } msg] $msg $errorCode
} {1 {wrong # args: should be "p ?|-A a|? ?|-B b|?"} {TCL WRONGARGS}}
test proc-enh-3.2 {wrong # args: named group ended by an arg with leading dash} {
    proc p {{a -name A} {b -name B} args} { }
    list [catch { p -b Z -5 } msg] $msg $errorCode
} {1 {wrong # args: should be "p ?|-A a|? ?|-B b|? ?arg ...?"} {TCL WRONGARGS}}
test proc-enh-3.3 {wrong # args: named group followed by too many options} {
    proc p {{a -name A -default 1} b} { }
    list [catch { p -- 5 6 } msg] $msg $errorCode
} {1 {wrong # args: should be "p ?|-A a|? b"} {TCL WRONGARGS}}
test proc-enh-3.4 {wrong # args: required named group with name+switch} {
    proc p {{a -name A -switch {A0 A1} -required 1}} { }
    list [catch { p } msg] $msg $errorCode
} {1 {wrong # args: should be "p |-A a|-A0|-A1|"} {TCL WRONGARGS}}
test proc-enh-3.5 {wrong # args: required named group with upvar} {
    proc p {{a -name A -upvar 1 -required 1} {b -upvar 1}} { }
    list [catch { p } msg] $msg $errorCode
} {1 {wrong # args: should be "p |-A &a&| &b&"} {TCL WRONGARGS}}
test proc-enh-3.6 {wrong # args: two distinct named group, specified in wrong order} {
    proc p {{a -switch A} {b -switch B} c {d -switch D} {e -switch E}} { }
    list [catch { p -E 1 } msg] $msg $errorCode
} {1 {wrong # args: should be "p ?|-A|? ?|-B|? c ?|-D|? ?|-E|?"} {TCL WRONGARGS}}

# proc-enh-4.x: errors during call
test proc-enh-4.1 {errors during call: -upvar read access with non-existing arg} {
    proc p {{a -upvar 1}} { return $a }
    if [info exists v] { unset v}
    list [catch { p v } msg] $msg $errorCode
} {1 {can't read "a": no such variable} {TCL READ VARNAME}}
test proc-enh-4.2 {errors during call: -upvar read access with non-existing arg + -name} {
    proc p {{a -upvar 1 -name A}} { return $a }
    if [info exists v] { unset v}
    list [catch { p -A v } msg] $msg $errorCode
} {1 {can't read "a": no such variable} {TCL READ VARNAME}}

# proc-enh-5.x: precompiled
test proc-enh-5.1 {precompiled: inconsistent arg default value} -body {
    proc p {x y {z -default 2}} { }
    procbodytest::proc t {x y {z ZZ}} p
} -constraints procbodytest -returnCodes error -cleanup {
    catch {rename p ""}
    catch {rename t ""}
} -result {procedure "t": formal parameter "z" has argument spec inconsistent with precompiled body}
test proc-enh-5.2 {precompiled: inconsistent arg spec} -body {
    proc p {x y {z -name z}} { }
    procbodytest::proc t {x y {z -name ZZ}} p
} -constraints procbodytest -returnCodes error -cleanup {
    catch {rename p ""}
    catch {rename t ""}
} -result {procedure "t": formal parameter "z" has argument spec inconsistent with precompiled body}
test proc-enh-5.3 {precompiled: with upvar arg} -body {
    proc p {x {y -upvar 1} z} { }
    procbodytest::proc t {x {y -upvar 1} z} p
} -constraints procbodytest -result {}

# proc-enh-6.x: apply/lambda
test proc-enh-6.1 {apply/lambda: wrong args} {
    set lambda [list {{a -name A -switch A1 -required 1} {b -default B0 -name B}} {list $a $b}]
    list [catch {
	apply $lambda
    } msg] $msg $errorCode
} {1 {wrong # args: should be "apply lambdaExpr |-A a|-A1| ?|-B b|?"} {TCL WRONGARGS}}
test proc-enh-6.2 {apply/lambda: correct usage} {
    set lambda [list {{a -name A -switch A1} {b -default B0 -name B}} {list $a $b}]
    list [apply $lambda -A1] [apply $lambda -B 4 -A 8]
} {{A1 B0} {8 4}}

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End: