tests/signals.test

   1 # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4
   2
   3 if {[lsearch [namespace children] ::tcltest] == -1} {
   4         package require tcltest 2.2.5
   5         namespace import ::tcltest::*
   6 }
   7
   8 package require TLC-base
   9
  10 test signals-1.1 {Create a Signal} -body { #<<<
  11         tlc::Signal #auto signal
  12         $signal isa tlc::Signal
  13 } -cleanup {
  14         if {[info exists signal] && [itcl::is object $signal]} {
  15                 delete object $signal
  16                 unset signal
  17         }
  18 } -result {1}
  19 #>>>
  20 test signals-1.2 {Test initial state is false} -body { #<<<
  21         tlc::Signal #auto signal
  22         $signal state
  23 } -cleanup {
  24         if {[info exists signal] && [itcl::is object $signal]} {
  25                 delete object $signal
  26                 unset signal
  27         }
  28 } -result {0}
  29 #>>>
  30 test signals-1.3 {Setting state true} -body { #<<<
  31         tlc::Signal #auto signal
  32         $signal set_state 1
  33         $signal state
  34 } -cleanup {
  35         if {[info exists signal] && [itcl::is object $signal]} {
  36                 delete object $signal
  37                 unset signal
  38         }
  39 } -result {1}
  40 #>>>
  41 test signals-1.4 {State normalization} -body { #<<<
  42         tlc::Signal #auto signal
  43         $signal set_state true
  44         $signal state
  45 } -cleanup {
  46         if {[info exists signal] && [itcl::is object $signal]} {
  47                 delete object $signal
  48                 unset signal
  49         }
  50 } -result {1}
  51 #>>>
  52 test signals-1.5 {Rejection of non booleans} -body { #<<<
  53         tlc::Signal #auto signal
  54         $signal set_state maybe
  55 } -cleanup {
  56         if {[info exists signal] && [itcl::is object $signal]} {
  57                 delete object $signal
  58                 unset signal
  59         }
  60 } -returnCodes {
  61         error
  62 } -result {newstate must be a valid boolean}
  63 #>>>
  64 test signals-1.6 {Toggle state} -body { #<<<
  65         tlc::Signal #auto signal
  66         $signal toggle_state
  67         $signal state
  68 } -cleanup {
  69         if {[info exists signal] && [itcl::is object $signal]} {
  70                 delete object $signal
  71                 unset signal
  72         }
  73 } -result {1}
  74 #>>>
  75 test signals-1.7 {Auto lifecycle management} -body { #<<<
  76         tlc::Signal #auto signal
  77         set hold        $signal
  78         set before      [itcl::is object $hold]
  79         unset signal
  80         set after       [itcl::is object $hold]
  81         list $before $after
  82 } -cleanup {
  83         if {[info exists signal] && [itcl::is object $signal]} {
  84                 delete object $signal
  85                 unset signal
  86         }
  87         if {[info exists hold]} {
  88                 unset hold
  89         }
  90 } -result {1 0}
  91 #>>>
  92 test signals-1.8 {State change callback} -body { #<<<
  93         tlc::Signal #auto signal
  94         $signal attach_output {apply {
  95                 {newstate} {
  96                         set ::state_from_callback       $newstate
  97                 }
  98         }}
  99         $signal set_state 1
 100         set ::state_from_callback
 101 } -cleanup {
 102         if {[info exists signal] && [itcl::is object $signal]} {
 103                 delete object $signal
 104                 unset signal
 105         }
 106         if {[info exists ::state_from_callback]} {
 107                 unset ::state_from_callback
 108         }
 109 } -result {1}
 110 #>>>
 111 test signals-1.9 {State change callback, state initialization} -body { #<<<
 112         tlc::Signal #auto signal
 113         $signal attach_output {apply {
 114                 {newstate} {
 115                         set ::state_from_callback       $newstate
 116                 }
 117         }}
 118         set ::state_from_callback
 119 } -cleanup {
 120         if {[info exists signal] && [itcl::is object $signal]} {
 121                 delete object $signal
 122                 unset signal
 123         }
 124         if {[info exists ::state_from_callback]} {
 125                 unset ::state_from_callback
 126         }
 127 } -result {0}
 128 #>>>
 129 test signals-1.10 {State change callback, state propagation optimization} -body { #<<<
 130         tlc::Signal #auto signal
 131         $signal attach_output {apply {
 132                 {newstate} {
 133                         lappend ::state_from_callback   $newstate
 134                 }
 135         }}
 136         $signal set_state 1
 137         $signal set_state 1
 138         $signal set_state 0
 139         $signal set_state 0
 140         set ::state_from_callback
 141 } -cleanup {
 142         if {[info exists signal] && [itcl::is object $signal]} {
 143                 delete object $signal
 144                 unset signal
 145         }
 146         if {[info exists ::state_from_callback]} {
 147                 unset ::state_from_callback
 148         }
 149 } -result {0 1 0}
 150 #>>>
 151 test signals-1.11 {Detatch state change callback} -body { #<<<
 152         tlc::Signal #auto signal
 153         set handler     {apply {
 154                 {newstate} {
 155                         lappend ::state_from_callback   $newstate
 156                 }
 157         }}
 158         $signal attach_output $handler
 159         $signal set_state 1
 160         $signal detach_output $handler
 161
 162         $signal set_state 0
 163         set ::state_from_callback
 164 } -cleanup {
 165         if {[info exists signal] && [itcl::is object $signal]} {
 166                 delete object $signal
 167                 unset signal
 168         }
 169         if {[info exists ::state_from_callback]} {unset ::state_from_callback}
 170         if {[info exists handler]} {unset handler}
 171 } -result {0 1}
 172 #>>>
 173 test signals-1.12 {Detatch from outputs at death} -body { #<<<
 174         tlc::Signal #auto signals(1)
 175         tlc::Signal #auto signals(2)
 176         tlc::Gate #auto signals(gate) -mode and
 177
 178         $signals(gate) attach_input $signals(1)
 179         $signals(gate) attach_input $signals(2)
 180
 181         $signals(2) set_state 1
 182
 183         set before      [$signals(gate) state]
 184         array unset signals 1
 185         set after       [$signals(gate) state]
 186
 187         list $before $after
 188 } -cleanup {
 189         array unset signals
 190         if {[info exists before]} {unset before}
 191         if {[info exists after]} {unset after}
 192 } -result {0 1}
 193 #>>>
 194 test signals-1.13 {Handling of -name} -body { #<<<
 195         tlc::Signal #auto signals(1) -name "Test signal"
 196         $signals(1) name
 197 } -cleanup {
 198         array unset signals
 199 } -result {Test signal}
 200 #>>>
 201 test signals-1.14 {explain_txt method} -body { #<<<
 202         tlc::Signal sigtest-1.14 signals(1) -name "Test signal"
 203         list [$signals(1) explain_txt] [$signals(1) explain_txt 2]
 204 } -cleanup {
 205         array unset signals
 206 } -result {{::sigtest-1.14 "Test signal": 0
 207 } {    ::sigtest-1.14 "Test signal": 0
 208 }}
 209 #>>>
 210 test signals-1.15 {waitfor, target state (false) already set} -body { #<<<
 211         tlc::Signal #auto signals(1)
 212         set killed      0
 213
 214         set afterid     [after 100 [list apply {
 215                 {obj} {
 216                         set ::killed    1
 217                         delete object   $obj
 218                 }
 219         } $signals(1)]]
 220
 221         $signals(1) waitfor false
 222         list $killed [$signals(1) state]
 223 } -cleanup {
 224         if {[info exists afterid]} {
 225                 after cancel $afterid
 226                 unset afterid
 227         }
 228         if {[info exists killed]} {
 229                 unset killed
 230         }
 231         array unset signals
 232 } -result {0 0}
 233 #>>>
 234 test signals-1.16 {waitfor, target state (true) already set} -body { #<<<
 235         tlc::Signal #auto signals(1)
 236         set killed      0
 237
 238         $signals(1) set_state 1
 239
 240         set afterid     [after 100 [list apply {
 241                 {obj} {
 242                         set ::killed    1
 243                         delete object   $obj
 244                 }
 245         } $signals(1)]]
 246
 247         $signals(1) waitfor true
 248         list $killed [$signals(1) state]
 249 } -cleanup {
 250         if {[info exists afterid]} {
 251                 after cancel $afterid
 252                 unset afterid
 253         }
 254         if {[info exists killed]} {
 255                 unset killed
 256         }
 257         array unset signals
 258 } -result {0 1}
 259 #>>>
 260 test signals-1.17 {waitfor, target state (false) not already set} -body { #<<<
 261         tlc::Signal #auto signals(1)
 262         $signals(1) set_state 1
 263
 264         set before      [clock milliseconds]
 265
 266         set timebomb    [after 1000 [list apply {
 267                 {obj} {
 268                         puts "signals-1.17: timebomb went off"
 269                         if {[itcl::is object $obj]} {
 270                                 delete object $obj
 271                         }
 272                 }
 273         } $signals(1)]]
 274
 275         set afterid     [after 200 [list apply {
 276                 {obj} {
 277                         $obj set_state 0
 278                 }
 279         } $signals(1)]]
 280
 281         $signals(1) waitfor false
 282         set after       [clock milliseconds]
 283         expr {$after - $before > 180}
 284 } -cleanup {
 285         if {[info exists afterid]} {
 286                 after cancel $afterid
 287                 unset afterid
 288         }
 289         if {[info exists timebomb]} {
 290                 after cancel $timebomb
 291                 unset timebomb
 292         }
 293         array unset signals
 294 } -result {1}
 295 #>>>
 296 test signals-1.18 {waitfor, target state (true) not already set} -body { #<<<
 297         tlc::Signal #auto signals(1)
 298
 299         set before      [clock milliseconds]
 300
 301         set timebomb    [after 1000 [list apply {
 302                 {obj} {
 303                         puts "signals-1.18: timebomb went off"
 304                         if {[itcl::is object $obj]} {
 305                                 delete object $obj
 306                         }
 307                 }
 308         } $signals(1)]]
 309
 310         set afterid     [after 200 [list apply {
 311                 {obj} {
 312                         $obj set_state 1
 313                 }
 314         } $signals(1)]]
 315
 316         $signals(1) waitfor true
 317         set after       [clock milliseconds]
 318         expr {$after - $before > 180}
 319 } -cleanup {
 320         if {[info exists afterid]} {
 321                 after cancel $afterid
 322                 unset afterid
 323         }
 324         if {[info exists timebomb]} {
 325                 after cancel $timebomb
 326                 unset timebomb
 327         }
 328         array unset signals
 329 } -result {1}
 330 #>>>
 331 test signals-1.19 {waitfor timeout, timeout reached} -body { #<<<
 332         tlc::Signal #auto signals(1) -name "Test signal"
 333
 334         set timebomb    [after 1000 [list apply {
 335                 {obj} {
 336                         puts "signals-1.19: timebomb went off"
 337                         if {[itcl::is object $obj]} {
 338                                 delete object $obj
 339                         }
 340                 }
 341         } $signals(1)]]
 342
 343         set before      [clock milliseconds]
 344
 345         catch {
 346                 $signals(1) waitfor true 200
 347         } errmsg options
 348         set options     [dict merge {-errorcode ""} $options]
 349
 350         set after       [clock milliseconds]
 351         list [expr {$after - $before >= 200}] $errmsg [dict get $options -errorcode]
 352 } -cleanup {
 353         if {[info exists timebomb]} {
 354                 after cancel $timebomb
 355                 unset timebomb
 356         }
 357         foreach var {before after} {
 358                 if {[info exists $var]} {
 359                         unset $var
 360                 }
 361         }
 362         array unset signals
 363 } -result {1 {Timeout waiting for signal "Test signal"} {timeout {Test signal}}}
 364 #>>>
 365 test signals-1.20 {waitfor timeout, timeout not reached} -body { #<<<
 366         tlc::Signal #auto signals(1) -name "Test signal"
 367
 368         set timebomb    [after 1000 [list apply {
 369                 {obj} {
 370                         puts "signals-1.20: timebomb went off"
 371                         if {[itcl::is object $obj]} {
 372                                 delete object $obj
 373                         }
 374                 }
 375         } $signals(1)]]
 376
 377         set afterid             [after 100 [list $signals(1) set_state 1]]
 378
 379         set before      [clock milliseconds]
 380         $signals(1) waitfor true 200
 381         set after       [clock milliseconds]
 382
 383         list [expr {$after - $before < 150}] [$signals(1) state]
 384 } -cleanup {
 385         if {[info exists afterid]} {
 386                 after cancel $afterid
 387                 unset afterid
 388         }
 389         if {[info exists timebomb]} {
 390                 after cancel $timebomb
 391                 unset timebomb
 392         }
 393         foreach var {before after} {
 394                 if {[info exists $var]} {
 395                         unset $var
 396                 }
 397         }
 398         array unset signals
 399 } -result {1 1}
 400 #>>>
 401 test signals-1.21 {waitfor timeout, died before timeout or state reached} -body { #<<<
 402         tlc::Signal #auto signals(1) -name "Test signal"
 403
 404         set timebomb    [after 100 [list apply {
 405                 {obj} {
 406                         if {[itcl::is object $obj]} {
 407                                 delete object $obj
 408                         }
 409                 }
 410         } $signals(1)]]
 411
 412         set afterid             [after 200 [list apply {
 413                 {obj} {
 414                         if {[itcl::is object $obj]} {
 415                                 $obj set_state 1
 416                         }
 417                 }
 418         } $signals(1)]]
 419
 420         catch {
 421                 $signals(1) waitfor true 1000
 422         } errmsg options
 423         set options     [dict merge {-errorcode ""} $options]
 424
 425         list $errmsg [dict get $options -errorcode]
 426 } -cleanup {
 427         if {[info exists afterid]} {
 428                 after cancel $afterid
 429                 unset afterid
 430         }
 431         if {[info exists timebomb]} {
 432                 after cancel $timebomb
 433                 unset timebomb
 434         }
 435         array unset signals
 436 } -result {{Source died while waiting for signal "Test signal"} {source_died {Test signal}}}
 437 #>>>
 438 test signals-1.22 {waitfor timeout, state flop race} -body { #<<<
 439         tlc::Signal ::#auto signals(1) -name "Test signal"
 440
 441         set afterid     [after 100 [list apply {
 442                 {obj} {
 443                         $obj set_state 1
 444                         $obj set_state 0
 445                 }
 446         } $signals(1)]]
 447
 448         catch {
 449                 $signals(1) waitfor true 1000
 450         } errmsg options
 451         set options     [dict merge {-errorcode ""} $options]
 452
 453         list $errmsg [dict get $options -errorcode]
 454 } -cleanup {
 455         if {[info exists afterid]} {
 456                 after cancel $afterid
 457                 unset afterid
 458         }
 459         array unset signals
 460 } -result {{Timeout waiting for signal "Test signal"} {timeout {Test signal}}} -match glob -errorOutput {*Woken up by transient spike while waiting for state true, waiting for more permanent change*}
 461 #>>>
 462 test signals-1.23 {Avoid double-adding output handler} -body { #<<<
 463         tlc::Signal #auto signals(1) -name "Test signal"
 464
 465         set handler     {apply {
 466                 {newstate} {}
 467         }}
 468
 469         set first       [$signals(1) attach_output $handler]
 470         set second      [$signals(1) attach_output $handler]
 471
 472         list $first $second
 473 } -cleanup {
 474         foreach var {first second} {
 475                 if {[info exists $var]} {
 476                         unset $var
 477                 }
 478         }
 479
 480         array unset signals
 481 } -result {1 0}
 482 #>>>
 483 test signals-1.24 {Detect double-removing output handler} -body { #<<<
 484         tlc::Signal #auto signals(1) -name "Test signal"
 485
 486         set handler     {apply {
 487                 {newstate} {}
 488         }}
 489
 490         $signals(1) attach_output $handler
 491         set first       [$signals(1) detach_output $handler]
 492         set second      [$signals(1) detach_output $handler]
 493
 494         list $first $second
 495 } -cleanup {
 496         foreach var {first second} {
 497                 if {[info exists $var]} {
 498                         unset $var
 499                 }
 500         }
 501
 502         array unset signals
 503 } -result {1 0}
 504 #>>>
 505 test signals-1.25 {Catch error in output handler} -body { #<<<
 506         tlc::Signal #auto signals(1) -name "Test signal"
 507
 508         set good_output_ok      0
 509
 510         $signals(1) attach_output {apply {
 511                 {newstate} {
 512                         error "Test error"
 513                 }
 514         }}
 515
 516         $signals(1) attach_output {apply {
 517                 {newstate} {
 518                         set ::good_output_ok    1
 519                 }
 520         }}
 521
 522         set good_output_ok
 523 } -cleanup {
 524         foreach var {good_output_ok} {
 525                 if {[info exists $var]} {
 526                         unset $var
 527                 }
 528         }
 529
 530         array unset signals
 531 } -result {1} -match glob -errorOutput {*"Test signal" error updating output (0) handler: (apply *Test error*}
 532 #>>>
 533 test signals-1.26 {Debug mode output} -body { #<<<
 534         tlc::Signal #auto signals(1) -name "Test signal" -debugmode 1 -output_handler_warntime 200
 535
 536         $signals(1) register_handler debug {apply {
 537                 {level msg} {
 538                         puts $msg
 539                 }
 540         }}
 541
 542         $signals(1) attach_output {apply {
 543                 {newstate} {
 544                         if {$newstate} {
 545                                 set ::foo       0
 546                                 set ::afterids(1)       [after 700 {set ::foo 1}]
 547                                 vwait ::foo
 548                                 unset ::foo
 549                         }
 550                 }
 551         }}
 552
 553         set hold        $signals(1)
 554
 555         set afterids(2) [after 100 [list array unset signals 1]]
 556         $signals(1) set_state 1
 557
 558         itcl::is object $hold
 559 } -cleanup {
 560         foreach {num handle} [array get afterids] {
 561                 after cancel $handle
 562         }
 563         array unset afterids
 564
 565         array unset signals
 566
 567         foreach var {hold foo} {
 568                 if {[info exists $var]} {
 569                         unset $var
 570                 }
 571         }
 572 } -result {0} -match glob -output {*tlc::Signal::scopevar_unset:
 573 ::tlc::Signal::scopevar_unset(args signals 1 u)
 574 *
 575 tlc::Signal::destructor: ::signal* Test signal dieing
 576 tlc::Signal::destructor: ::signal* dieing from:
 577 ::tlc::Signal::destructor(<undefined> {})
 578 ::tlc::Signal::scopevar_unset(args signals 1 u)
 579 *
 580 tlc::Signal::destructor: ------ twitch: (apply {
 581 *})
 582 tlc::Signal::detach_output: (apply {
 583 *})
 584 tlc::Signal::destructor: ::signal* truely dead
 585 tlc::Signal::update_outputs: Flagging changewaits: ()
 586 *}
 587 #>>>
 588 test signals-1.27 {Feedback for slow output handlers} -body { #<<<
 589         tlc::Signal #auto signals(1) -name "Test signal" -debugmode 1 -output_handler_warntime 200
 590
 591         $signals(1) attach_output {apply {
 592                 {newstate} {
 593                         if {$newstate} {
 594                                 set ::foo       0
 595                                 set ::afterids(1)       [after 700 {set ::foo 1}]
 596                                 vwait ::foo
 597                                 unset ::foo
 598                         }
 599                 }
 600         }}
 601
 602         $signals(1) set_state 1
 603
 604         $signals(1) state
 605 } -cleanup {
 606         foreach {num handle} [array get afterids] {
 607                 after cancel $handle
 608         }
 609         array unset afterids
 610
 611         array unset signals
 612
 613         foreach var {foo} {
 614                 if {[info exists $var]} {
 615                         unset $var
 616                 }
 617         }
 618 } -result {1} -match glob -errorOutput {*name: (Test signal) obj: (*) taking way too long to update output for handler: (apply *}
 619 #>>>
 620
 621 ::tcltest::cleanupTests
 622 return
 623
 624