Implement TIP #288

See http://www.tcl.tk/cgi-bin/tct/tip/288.html
Args and optional args may be to the left of required args

3 files changed, 96 insertions, 7 deletions

diff --git a/tests/proc-new.test b/tests/proc-new.test
new file mode 100644
index 0000000..324a976
--- /dev/null
+++ b/tests/proc-new.test
@@ -0,0 +1,79 @@
+source testing.tcl
+
+proc aproc {} {
+	list
+}
+proc bproc {b} {
+	list b $b
+}
+proc cproc {b c} {
+	list b $b c $c
+}
+proc dproc {b c {d dd}} {
+	list b $b c $c d $d
+}
+proc eproc {b c {d dd} e} {
+	list b $b c $c d $d e $e
+}
+proc fproc {b c {d dd} args} {
+	list b $b c $c d $d args $args
+}
+proc gproc {b c {d dd} args e} {
+	list b $b c $c d $d args $args e $e
+}
+proc hproc {{a aa} args} {
+	list a $a args $args
+}
+
+section "Proc - TIP #288"
+
+set n 1
+foreach {proc params result} {
+	aproc {} {}
+	bproc B {b B}
+	cproc {B C} {b B c C}
+	dproc {B C} {b B c C d dd}
+	dproc {B C D} {b B c C d D}
+	eproc {B C D E} {b B c C d D e E}
+	eproc {B C E} {b B c C d dd e E}
+	fproc {B C} {b B c C d dd args {}}
+	fproc {B C D} {b B c C d D args {}}
+	fproc {B C D E} {b B c C d D args E}
+	fproc {B C D E F} {b B c C d D args {E F}}
+	gproc {B C E} {b B c C d dd args {} e E}
+	gproc {B C D E} {b B c C d D args {} e E}
+	gproc {B C D X E} {b B c C d D args X e E}
+	gproc {B C D X Y Z E} {b B c C d D args {X Y Z} e E}
+	hproc {} {a aa args {}}
+	hproc {A} {a A args {}}
+	hproc {A X Y Z} {a A args {X Y Z}}
+} {
+	test proc-1.$n "Proc args combos" [list $proc {*}$params] $result
+	incr n
+}
+
+proc onearg_search {{nocase ""} value list} {
+	lsearch {*}$nocase $list $value
+}
+
+proc multiarg_search {args value list} {
+	lsearch {*}$args $list $value
+}
+
+test proc-2.1 "Real test of optional switches" {
+	onearg_search c {A a B b C c D d}
+} 5
+
+test proc-2.2 "Real test of optional switches" {
+	onearg_search -nocase c {A a B b C c D d}
+} 4
+
+test proc-2.3 "Real test of optional switches" {
+	multiarg_search -glob c* {A a B b C c D d}
+} 5
+
+test proc-2.4 "Real test of optional switches" {
+	multiarg_search -nocase -glob c* {A a B b C c D d}
+} 4
+
+testreport
diff --git a/tests/proc.test b/tests/proc.test
index 2e65c35..56ed59a 100644
--- a/tests/proc.test
+++ b/tests/proc.test
@@ -174,14 +174,15 @@ test proc-old-3.7 {arguments and defaults} {
     }
     list [catch {tproc} msg]
 } {1}
+# Note: This requires new TIP #288 support
 test proc-old-3.8 {arguments and defaults} {
     list [catch {
 	proc tproc {x {y y-default} z} {
 	    return [list $x $y $z]
 	}
 	tproc 2 3
-    } msg]
-} {1}
+    } msg] $msg
+} {0 {2 y-default 3}}
 test proc-old-3.9 {arguments and defaults} {
     proc tproc {x {y y-default} args} {
 	return [list $x $y $args]
@@ -246,13 +247,13 @@ test proc-old-5.3 {error conditions} {
 
 test proc-old-5.5 {error conditions} {
     list [catch {proc tproc {{} y} {return foo}} msg] $msg
-} {1 {procedure "tproc" has argument with no name}}
+} {1 {procedure has argument with no name}}
 test proc-old-5.6 {error conditions} {
     list [catch {proc tproc {{} y} {return foo}} msg] $msg
-} {1 {procedure "tproc" has argument with no name}}
+} {1 {procedure has argument with no name}}
 test proc-old-5.7 {error conditions} {
     list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg
-} {1 {too many fields in argument specifier "x 1 2"}}
+} {1 {procedure has argument with too many fields}}
 test proc-old-5.8 {error conditions} {
     catch {return}
 } 2
diff --git a/tests/testing.tcl b/tests/testing.tcl
index 221d6be..a675c5e 100644
--- a/tests/testing.tcl
+++ b/tests/testing.tcl
@@ -38,13 +38,20 @@ set testresults(numpass) 0
 set testresults(failed) {}
 
 proc test {id descr script expected} {
-	puts -nonewline "$id "
+	if {!$::testquiet} {
+		puts -nonewline "$id "
+	}
 	set rc [catch {uplevel 1 $script} result]
 	# Note that rc=2 is return
 	if {($rc == 0 || $rc == 2) && $result eq $expected} {
-		puts "OK  $descr"
+		if {!$::testquiet} {
+			puts "OK  $descr"
+		}
 		incr ::testresults(numpass)
 	} else {
+		if {$::testquiet} {
+			puts -nonewline "$id "
+		}
 		puts "ERR $descr"
 		puts "Expected: '$expected'"
 		puts "Got     : '$result'"
@@ -71,3 +78,5 @@ proc testerror {} {
 puts [string repeat = 40]
 puts $argv0
 puts [string repeat = 40]
+
+set ::testquiet [info exists ::env(testquiet)]