examples/test_dschan_backend.itcl

   1 #!/usr/bin/tclsh
   2
   3 set auto_path   [concat [list ..] $auto_path]
   4
   5 #package require TLC-base 0.79
   6 package require TLC 0.79
   7
   8 if {[file exists loglevels_class]} {
   9         tlc::Baselog::load_classmap loglevels_class
  10 }
  11
  12 namespace eval crypto {
  13         variable devmode        1
  14 }
  15
  16 array set signals       {}
  17 tlc::Signal #auto signals(bar_pool) -name "bar_pool"
  18
  19 package require Authenticator
  20 authenticator::Authenticator auth -ip localhost -pbkey "authenticator.pub"
  21
  22 authenticator::Component comp -svc "test" -auth ::auth -prkeyfn "test.priv"
  23
  24 tlc::DSchan_backend ds -comp comp -tag "testds" -headers {
  25         "ID" "Foo" "Bar" "Baz"
  26 } -dbfile "/tmp/test_dschan.db" -persist 1
  27 #-persist 1
  28
  29 proc check_cb {user pool extra} {
  30         puts "check_cb: user: ($user) pool: ($pool) extra: ($extra)"
  31         return [expr {[$user type] == "user"}]
  32 }
  33
  34 ds register_pool "foo" [list check_cb]
  35
  36 set id  0
  37 set count       0
  38 foreach rid [ds id_list "foo"] {
  39         if {$rid > $id} {
  40                 set id  $rid
  41         }
  42         incr count
  43 }
  44
  45 proc randomstring {} {
  46         set length      [expr {round(rand() * 5) + 4}]
  47         set build       ""
  48         while {$length} {
  49                 set lotto       [expr {round(rand() * 25) + 97}]
  50                 append build    [format %c $lotto]
  51                 incr length -1
  52         }
  53
  54         return $build
  55 }
  56
  57 while {$count < 3} {
  58         ds add_item "foo" [list [incr ::id] [randomstring] [randomstring] [randomstring]]
  59         incr count
  60 }
  61
  62 set starttime   [clock seconds]
  63 set afterid     ""
  64 proc frob {} {
  65         after cancel $::afterid; set ::afterid  ""
  66         puts "delta from start: ([expr {([clock seconds] - $::starttime) % 10}])"
  67         if {([clock seconds] - $::starttime) % 10 > 5} {
  68                 $::signals(bar_pool) set_state 1
  69         } else {
  70                 $::signals(bar_pool) set_state 0
  71         }
  72         set item_count  [ds item_count "foo"]
  73         if {$item_count < 10} {
  74                 set action      "add"
  75         } elseif {$item_count > 200} {
  76                 set action      "remove"
  77         } else {
  78                 set action      [lindex {add change remove} [expr {round(rand() * 3)}]]
  79         }
  80
  81         switch -- $action {
  82                 "add" {
  83                         ds add_item "foo" [list [incr ::id] [randomstring] [randomstring] [randomstring]]
  84                 }
  85
  86                 "change" {
  87                         set id  [lindex [ds id_list "foo"] [expr {round(rand() * ($item_count-1))}]]
  88                         ds change_item "foo" $id [list $id [randomstring] [randomstring] [randomstring]]
  89                 }
  90
  91                 "remove" {
  92                         set id  [lindex [ds id_list "foo"] [expr {round(rand() * ($item_count-1))}]]
  93                         ds remove_item "foo" $id
  94                 }
  95         }
  96
  97         set ::afterid   [after 2000 frob]
  98 }
  99
 100 frob
 101
 102 proc bar_pool_changed {newstate} {
 103         if {$newstate} {
 104                 ds register_pool "bar" [list check_cb]
 105                 ds add_item "bar" [list [incr ::id] "Hello from bar" [randomstring] [randomstring]]
 106         } else {
 107                 if {[ds pool_exists "bar"]} {
 108                         ds deregister_pool "bar"
 109                 }
 110         }
 111 }
 112
 113 tlc::Tools .tools
 114 .tools add "Add pool" {
 115         ds register_pool "baz" [list check_cb]
 116         ds add_item "baz" [list [incr ::id] "Hello from baz" [randomstring] [randomstring]]
 117 }
 118 .tools add "Add item" {
 119         ds add_item "baz" [list [incr ::id] "Hello from baz" "Additional item" [randomstring]]
 120 }
 121 .tools add "Remove pool" {
 122         ds deregister_pool "baz"
 123 }
 124 .tools add "Add A" {
 125         ds add_item "foo" [list [incr ::id] "Only A" "filter test" [randomstring]]
 126 }
 127 .tools add "Add B" {
 128         ds add_item "foo" [list [incr ::id] "Only B" "filter test" [randomstring]]
 129 }
 130 .tools add "Close" {exit} right
 131
 132 blt::table . \
 133                 .tools  1,1 -fill x
 134
 135 $signals(bar_pool) attach_output [list bar_pool_changed]
 136
 137 tlc::fake_mainloop
 138