tests/proc-new.test

   1 source [file dirname [info script]]/testing.tcl
   2
   3 needs constraint jim
   4 needs cmd array
   5
   6 proc aproc {} {
   7         list
   8 }
   9 proc bproc {b} {
  10         list b $b
  11 }
  12 proc cproc {b c} {
  13         list b $b c $c
  14 }
  15 proc dproc {b c {d dd}} {
  16         list b $b c $c d $d
  17 }
  18 proc eproc {b c {d dd} e} {
  19         list b $b c $c d $d e $e
  20 }
  21 proc fproc {b c {d dd} args} {
  22         list b $b c $c d $d args $args
  23 }
  24 proc gproc {b c {d dd} args e} {
  25         list b $b c $c d $d args $args e $e
  26 }
  27 proc hproc {{a aa} args} {
  28         list a $a args $args
  29 }
  30
  31 proc iproc {{a aa} b {c cc}} {
  32         list a $a b $b c $c
  33 }
  34
  35 proc jproc {args {a aa} b {c cc} d} {
  36         list a $a b $b c $c d $d args $args
  37 }
  38
  39 set n 1
  40 foreach {proc params result} {
  41         aproc {} {}
  42         bproc B {b B}
  43         cproc {B C} {b B c C}
  44         dproc {B C} {b B c C d dd}
  45         dproc {B C D} {b B c C d D}
  46         eproc {B C D E} {b B c C d D e E}
  47         eproc {B C E} {b B c C d dd e E}
  48         fproc {B C} {b B c C d dd args {}}
  49         fproc {B C D} {b B c C d D args {}}
  50         fproc {B C D E} {b B c C d D args E}
  51         fproc {B C D E F} {b B c C d D args {E F}}
  52         gproc {B C E} {b B c C d dd args {} e E}
  53         gproc {B C D E} {b B c C d D args {} e E}
  54         gproc {B C D X E} {b B c C d D args X e E}
  55         gproc {B C D X Y Z E} {b B c C d D args {X Y Z} e E}
  56         hproc {} {a aa args {}}
  57         hproc {A} {a A args {}}
  58         hproc {A X Y Z} {a A args {X Y Z}}
  59         iproc {B} {a aa b B c cc}
  60         iproc {A B} {a A b B c cc}
  61         iproc {A B C} {a A b B c C}
  62         jproc {B D} {a aa b B c cc d D args {}}
  63         jproc {A B D} {a A b B c cc d D args {}}
  64         jproc {A B C D} {a A b B c C d D args {}}
  65         jproc {E F A B C D} {a A b B c C d D args {E F}}
  66 } {
  67         test proc-1.$n "Proc args combos" [list $proc {*}$params] $result
  68         incr n
  69 }
  70
  71 proc onearg_search {{nocase ""} value list} {
  72         lsearch {*}$nocase $list $value
  73 }
  74
  75 proc multiarg_search {args value list} {
  76         lsearch {*}$args $list $value
  77 }
  78
  79 test proc-2.1 "Real test of optional switches" {
  80         onearg_search c {A a B b C c D d}
  81 } 5
  82
  83 test proc-2.2 "Real test of optional switches" {
  84         onearg_search -nocase c {A a B b C c D d}
  85 } 4
  86
  87 test proc-2.3 "Real test of optional switches" {
  88         multiarg_search -glob c* {A a B b C c D d}
  89 } 5
  90
  91 test proc-2.4 "Real test of optional switches" {
  92         multiarg_search -nocase -glob c* {A a B b C c D d}
  93 } 4
  94
  95 test proc-3.1 "Rename optional args" {
  96         proc a {b {args vars}} {
  97         }
  98         catch {a} msg
  99         set msg
 100 } {wrong # args: should be "a b ?vars ...?"}
 101
 102 test proc-3.2 "Rename optional args" {
 103         proc a {b {args vars} c} {
 104         }
 105         catch {a} msg
 106         set msg
 107 } {wrong # args: should be "a b ?vars ...? c"}
 108
 109 test proc-3.2 "Rename optional args" {
 110         proc a {b {args vars}} {
 111                 return $vars
 112         }
 113         a B C D
 114 } {C D}
 115
 116 test proc-3.3 "dict sugar arg" {
 117         proc a {b(c)} { return $b}
 118         a 4
 119 } {c 4}
 120
 121 test proc-3.4 "invalid upref in rightargs" {
 122         proc a {{x 2} &b} { return $b}
 123         unset -nocomplain B
 124         catch {a B}
 125 } 1
 126
 127 testreport