tcl/tests/link.test

   1 # Commands covered:  none
   2 #
   3 # This file contains a collection of tests for Tcl_LinkVar and related
   4 # library procedures.  Sourcing this file into Tcl runs the tests and
   5 # generates output for errors.  No output means no errors were found.
   6 #
   7 # Copyright (c) 1993 The Regents of the University of California.
   8 # Copyright (c) 1994 Sun Microsystems, Inc.
   9 # Copyright (c) 1998-1999 by Scriptics Corporation.
  10 #
  11 # See the file "license.terms" for information on usage and redistribution
  12 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13 #
  14 # RCS: @(#) $Id$
  15
  16 if {[lsearch [namespace children] ::tcltest] == -1} {
  17     package require tcltest
  18     namespace import -force ::tcltest::*
  19 }
  20
  21 if {[info commands testlink] == {}} {
  22     puts "This application hasn't been compiled with the \"testlink\""
  23     puts "command, so I can't test Tcl_LinkVar et al."
  24     ::tcltest::cleanupTests
  25     return
  26 }
  27
  28 foreach i {int real bool string} {
  29     catch {unset $i}
  30 }
  31 test link-1.1 {reading C variables from Tcl} {
  32     testlink delete
  33     testlink set 43 1.23 4 -
  34     testlink create 1 1 1 1
  35     list $int $real $bool $string
  36 } {43 1.23 1 NULL}
  37 test link-1.2 {reading C variables from Tcl} {
  38     testlink delete
  39     testlink create 1 1 1 1
  40     testlink set -3 2 0 "A long string with spaces"
  41     list $int $real $bool $string $int $real $bool $string
  42 } {-3 2.0 0 {A long string with spaces} -3 2.0 0 {A long string with spaces}}
  43
  44 test link-2.1 {writing C variables from Tcl} {
  45     testlink delete
  46     testlink set 43 1.21 4 -
  47     testlink create 1 1 1 1
  48     set int "00721"
  49     set real -10.5
  50     set bool true
  51     set string abcdef
  52     concat [testlink get] $int $real $bool $string
  53 } {465 -10.5 1 abcdef 00721 -10.5 true abcdef}
  54 test link-2.2 {writing bad values into variables} {
  55     testlink delete
  56     testlink set 43 1.23 4 -
  57     testlink create 1 1 1 1
  58     list [catch {set int 09a} msg] $msg $int
  59 } {1 {can't set "int": variable must have integer value} 43}
  60 test link-2.3 {writing bad values into variables} {
  61     testlink delete
  62     testlink set 43 1.23 4 -
  63     testlink create 1 1 1 1
  64     list [catch {set real 1.x3} msg] $msg $real
  65 } {1 {can't set "real": variable must have real value} 1.23}
  66 test link-2.4 {writing bad values into variables} {
  67     testlink delete
  68     testlink set 43 1.23 4 -
  69     testlink create 1 1 1 1
  70     list [catch {set bool gorp} msg] $msg $bool
  71 } {1 {can't set "bool": variable must have boolean value} 1}
  72
  73 test link-3.1 {read-only variables} {
  74     testlink delete
  75     testlink set 43 1.23 4 -
  76     testlink create 0 1 1 0
  77     list [catch {set int 4} msg] $msg $int \
  78         [catch {set real 10.6} msg] $msg $real \
  79         [catch {set bool no} msg] $msg $bool \
  80         [catch {set string "new value"} msg] $msg $string
  81 } {1 {can't set "int": linked variable is read-only} 43 0 10.6 10.6 0 no no 1 {can't set "string": linked variable is read-only} NULL}
  82 test link-3.2 {read-only variables} {
  83     testlink delete
  84     testlink set 43 1.23 4 -
  85     testlink create 1 0 0 1
  86     list [catch {set int 4} msg] $msg $int \
  87         [catch {set real 10.6} msg] $msg $real \
  88         [catch {set bool no} msg] $msg $bool \
  89         [catch {set string "new value"} msg] $msg $string
  90 } {0 4 4 1 {can't set "real": linked variable is read-only} 1.23 1 {can't set "bool": linked variable is read-only} 1 0 {new value} {new value}}
  91
  92 test link-4.1 {unsetting linked variables} {
  93     testlink delete
  94     testlink set -6 -2.5 0 stringValue
  95     testlink create 1 1 1 1
  96     unset int real bool string
  97     list [catch {set int} msg] $msg [catch {set real} msg] $msg \
  98             [catch {set bool} msg] $msg [catch {set string} msg] $msg
  99 } {0 -6 0 -2.5 0 0 0 stringValue}
 100 test link-4.2 {unsetting linked variables} {
 101     testlink delete
 102     testlink set -6 -2.1 0 stringValue
 103     testlink create 1 1 1 1
 104     unset int real bool string
 105     set int 102
 106     set real 16
 107     set bool true
 108     set string newValue
 109     testlink get
 110 } {102 16.0 1 newValue}
 111
 112 test link-5.1 {unlinking variables} {
 113     testlink delete
 114     testlink set -6 -2.25 0 stringValue
 115     testlink delete
 116     set int xx1
 117     set real qrst
 118     set bool bogus
 119     set string 12345
 120     testlink get
 121 } {-6 -2.25 0 stringValue}
 122 test link-5.2 {unlinking variables} {
 123     testlink delete
 124     testlink set -6 -2.25 0 stringValue
 125     testlink create 1 1 1 1
 126     testlink delete
 127     testlink set 25 14.7 7 -
 128     list $int $real $bool $string
 129 } {-6 -2.25 0 stringValue}
 130
 131 test link-6.1 {errors in setting up link} {
 132     testlink delete
 133     catch {unset int}
 134     set int(44) 1
 135     list [catch {testlink create 1 1 1 1} msg] $msg
 136 } {1 {can't set "int": variable is array}}
 137 catch {unset int}
 138
 139 test link-7.1 {access to linked variables via upvar} {
 140     proc x {} {
 141         upvar int y
 142         unset y
 143     }
 144     testlink delete
 145     testlink create 1 0 0 0
 146     testlink set 14 {} {} {}
 147     x
 148     list [catch {set int} msg] $msg
 149 } {0 14}
 150 test link-7.2 {access to linked variables via upvar} {
 151     proc x {} {
 152         upvar int y
 153         return [set y]
 154     }
 155     testlink delete
 156     testlink create 1 0 0 0
 157     testlink set 0 {} {} {}
 158     set int
 159     testlink set 23 {} {} {}
 160     x
 161     list [x] $int
 162 } {23 23}
 163 test link-7.3 {access to linked variables via upvar} {
 164     proc x {} {
 165         upvar int y
 166         set y 44
 167     }
 168     testlink delete
 169     testlink create 0 0 0 0
 170     testlink set 11 {} {} {}
 171     list [catch x msg] $msg $int
 172 } {1 {can't set "y": linked variable is read-only} 11}
 173 test link-7.4 {access to linked variables via upvar} {
 174     proc x {} {
 175         upvar int y
 176         set y abc
 177     }
 178     testlink delete
 179     testlink create 1 1 1 1
 180     testlink set -4 {} {} {}
 181     list [catch x msg] $msg $int
 182 } {1 {can't set "y": variable must have integer value} -4}
 183 test link-7.5 {access to linked variables via upvar} {
 184     proc x {} {
 185         upvar real y
 186         set y abc
 187     }
 188     testlink delete
 189     testlink create 1 1 1 1
 190     testlink set -4 16.75 {} {}
 191     list [catch x msg] $msg $real
 192 } {1 {can't set "y": variable must have real value} 16.75}
 193 test link-7.6 {access to linked variables via upvar} {
 194     proc x {} {
 195         upvar bool y
 196         set y abc
 197     }
 198     testlink delete
 199     testlink create 1 1 1 1
 200     testlink set -4 16.3 1 {}
 201     list [catch x msg] $msg $bool
 202 } {1 {can't set "y": variable must have boolean value} 1}
 203
 204 test link-8.1 {Tcl_UpdateLinkedVar procedure} {
 205     proc x args {
 206         global x int real bool string
 207         lappend x $args $int $real $bool $string
 208     }
 209     set x {}
 210     testlink create 1 1 1 1
 211     testlink set 14 -2.0 0 xyzzy
 212     trace var int w x
 213     testlink update 32 4.0 3 abcd
 214     trace vdelete int w x
 215     set x
 216 } {{int {} w} 32 -2.0 0 xyzzy}
 217 test link-8.2 {Tcl_UpdateLinkedVar procedure} {
 218     proc x args {
 219         global x int real bool string
 220         lappend x $args $int $real $bool $string
 221     }
 222     set x {}
 223     testlink create 1 1 1 1
 224     testlink set 14 -2.0 0 xyzzy
 225     testlink delete
 226     trace var int w x
 227     testlink update 32 4.0 6 abcd
 228     trace vdelete int w x
 229     set x
 230 } {}
 231 test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {
 232     testlink create 0 0 0 0
 233     list [catch {testlink update 47 {} {} {}} msg] $msg $int
 234 } {0 {} 47}
 235
 236 testlink set 0 0 0 -
 237 testlink delete
 238 foreach i {int real bool string} {
 239     catch {unset $i}
 240 }
 241
 242 # cleanup
 243 ::tcltest::cleanupTests
 244 return
 245
 246
 247
 248
 249
 250
 251
 252
 253
 254
 255
 256
 257