client.tcl

   1 #
   2 # $Log: client.tcl,v $
   3 # Revision 1.2  1995-03-10 18:00:15  adam
   4 # Actual presentation in line-by-line format. RPN query support.
   5 #
   6 # Revision 1.1  1995/03/09  16:15:07  adam
   7 # First presentRequest attempts. Hot-target list.
   8 #
   9 #
  10 set hotTargets {}
  11 set hotInfo {}
  12 set busy 0
  13
  14 wm minsize . 360 200
  15 wm maxsize . 800 800
  16
  17 if {[file readable "~/.tk-c"]} {
  18     source "~/.tk-c"
  19 }
  20
  21 proc show-target {target} {
  22     .bot.target configure -text "$target"
  23 }
  24
  25 proc show-busy {v1 v2} {
  26     global busy
  27     if {$busy != 0} {
  28         .bot.status configure -fg $v1
  29         after 200 [list show-busy $v2 $v1]
  30     }
  31 }
  32
  33 proc show-status {status b} {
  34     global busy
  35     global statusbg
  36     .bot.status configure -text "$status"
  37     .bot.status configure -fg black
  38     if {$b != 0} {
  39         if {$busy == 0} {
  40             set busy $b
  41             show-busy red blue
  42         }
  43         #        . config -cursor {watch black white}
  44     } else {
  45         #        . config -cursor {top_left_arrow black white}
  46         puts "Normal"
  47     }
  48     set busy $b
  49 }
  50
  51 proc show-message {msg} {
  52     .bot.message configure -text "$msg"
  53 }
  54
  55 proc update-target-hotlist {target} {
  56     global hotTargets
  57
  58     set len [llength $hotTargets]
  59     if {$len > 0} {
  60         .top.target.m delete 5 [expr 5+[llength $hotTargets]]
  61     }
  62     set indx [lsearch $hotTargets $target]
  63     if {$indx >= 0} {
  64         set hotTargets [lreplace $hotTargets $indx $indx]
  65     }
  66     set hotTargets [linsert $hotTargets 0 $target]
  67     set-target-hotlist
  68 }
  69
  70 proc set-target-hotlist {} {
  71     global hotTargets
  72
  73     set i 1
  74     foreach target $hotTargets {
  75         .top.target.m add command -label $target -command \
  76             "menu-open-target $target"
  77         incr i
  78         if {$i > 8} {
  79              break
  80         }
  81     }
  82 }
  83
  84 proc menu-open-target {target} {
  85     open-target $target
  86     update-target-hotlist $target
  87 }
  88
  89 proc open-target-action {} {
  90     set host [.target-connect.top.host.entry get]
  91     set port [.target-connect.top.port.entry get]
  92
  93     if {$host == ""} {
  94         return
  95     }
  96     if {$port == ""} {
  97         set port 210
  98     }
  99     open-target "${host}:${port}"
 100     update-target-hotlist ${host}:${port}
 101     destroy .target-connect
 102 }
 103
 104 proc open-target {target} {
 105     z39 disconnect
 106     global csRadioType
 107     z39 comstack ${csRadioType}
 108     show-target $target
 109     z39 connect $target
 110
 111     init-request
 112 }
 113
 114 proc init-request {} {
 115     global SetNo
 116
 117     z39 callback {init-response}
 118     z39 init
 119     show-status {Initializing} 1
 120     set SetNo 0
 121 }
 122
 123 proc init-response {} {
 124     show-status {Ready} 0
 125     pack .mid.searchlabel .mid.searchentry -side left
 126     bind .mid.searchentry <Return> search-request
 127     focus .mid.searchentry
 128 }
 129
 130 proc search-request {} {
 131     global SetNo
 132
 133     incr SetNo
 134     ir-set z39.$SetNo
 135
 136     z39 callback {search-response}
 137     z39.$SetNo search [.mid.searchentry get]
 138     show-status {Search} 1
 139 }
 140
 141 proc search-response {} {
 142     global SetNo
 143     global setOffset
 144     global setMax
 145
 146     .data.list delete 0 end
 147     show-status {Ready} 0
 148     show-message "[z39.$SetNo resultCount] hits"
 149     set setMax [z39.$SetNo resultCount]
 150     puts $setMax
 151     if {$setMax > 16} {
 152         set setMax 16
 153     }
 154     z39 callback {present-response}
 155     set setOffset 1
 156     z39.$SetNo present 1 $setMax
 157     show-status {Retrieve} 1
 158 }
 159
 160 proc present-response {} {
 161     global SetNo
 162     global setOffset
 163     global setMax
 164
 165     puts "In present-response"
 166     set no [z39.$SetNo numberOfRecordsReturned]
 167     puts "Returned $no records, setOffset $setOffset"
 168     for {set i 0} {$i < $no} {incr i} {
 169         set o [expr $i + $setOffset]
 170         set title [lindex [z39.$SetNo getRecord $o 245 a] 0]
 171         set year  [lindex [z39.$SetNo getRecord $o 260 c] 0]
 172         .data.list insert end "$title - $year"
 173     }
 174     set setOffset [expr $setOffset + $no]
 175     if { $setOffset <= $setMax} {
 176         z39.$SetNo present $setOffset [expr $setMax - $setOffset + 1]
 177     } else {
 178         show-status {Finished} 0
 179     }
 180 }
 181
 182 proc bind-fields {list returnAction escapeAction} {
 183     set max [expr [llength $list]-1]
 184     for {set i 0} {$i < $max} {incr i} {
 185         bind [lindex $list $i] <Return> $returnAction
 186         bind [lindex $list $i] <Escape> $escapeAction
 187         bind [lindex $list $i] <Tab> [list focus [lindex $list [expr $i+1]]]
 188     }
 189     bind [lindex $list $i] <Return> $returnAction
 190     bind [lindex $list $i] <Escape> $escapeAction
 191     bind [lindex $list $i] <Tab>    [list focus [lindex $list 0]]
 192     focus [lindex $list 0]
 193 }
 194
 195 proc entry-fields {parent list tlist returnAction escapeAction} {
 196     set alist {}
 197     set i 0
 198     foreach field $list {
 199         set label ${parent}.${field}.label
 200         set entry ${parent}.${field}.entry
 201         label $label -text [lindex $tlist $i] -anchor e
 202         entry $entry -width 30 -relief sunken
 203         pack $label -side left
 204         pack $entry -side right
 205         lappend alist $entry
 206         incr i
 207     }
 208     bind-fields $alist $returnAction $escapeAction
 209 }
 210
 211 proc open-target-dialog {} {
 212     set w .target-connect
 213
 214     toplevel $w
 215
 216     place-force $w .
 217
 218     frame $w.top -relief sunken -border 1
 219     frame $w.bot -relief sunken -border 1
 220
 221     pack  $w.top $w.bot -side top -fill both -expand yes
 222
 223     frame $w.top.host
 224     frame $w.top.port
 225
 226     pack $w.top.host $w.top.port \
 227             -side top -anchor e -pady 2
 228
 229     entry-fields $w.top {host port } \
 230             {{Hostname:} {Port number:}} \
 231             {open-target-action} {destroy .target-connect}
 232
 233     frame $w.bot.left -relief sunken -border 1
 234     pack $w.bot.left -side left -expand yes -padx 5 -pady 5
 235     button $w.bot.left.ok -width 6 -text {Ok} \
 236             -command {open-target-action}
 237     pack $w.bot.left.ok -expand yes -padx 3 -pady 3
 238     button $w.bot.cancel -width 6 -text {Cancel} \
 239             -command {destroy .target-connect}
 240     pack $w.bot.cancel -side left -expand yes
 241
 242     grab $w
 243
 244     tkwait window $w
 245 }
 246
 247 proc close-target {} {
 248     pack forget .mid.searchlabel .mid.searchentry
 249     z39 disconnect
 250     show-target {None}
 251     show-status {Not connected} 0
 252     show-message {}
 253 }
 254
 255 proc protocol-setup-action {} {
 256     destroy .protocol-setup
 257 }
 258
 259
 260 proc place-force {window parent} {
 261     set g [wm geometry $parent]
 262
 263     set p1 [string first + $g]
 264     set p2 [string last + $g]
 265
 266     set x [expr 40+[string range $g [expr $p1 +1] [expr $p2 -1]]]
 267     set y [expr 60+[string range $g [expr $p2 +1] end]]
 268     wm geometry $window +${x}+${y}
 269 }
 270
 271 proc protocol-setup {} {
 272     set w .protocol-setup
 273
 274     toplevel $w
 275
 276     place-force $w .
 277
 278     frame $w.top -relief sunken -border 1
 279     frame $w.bot -relief sunken -border 1
 280
 281     pack  $w.top $w.bot -side top -fill both -expand yes
 282
 283     frame $w.top.description
 284     frame $w.top.idAuthentification
 285     frame $w.top.maximumMessageSize
 286     frame $w.top.preferredMessageSize
 287     frame $w.top.cs-type -relief ridge -border 2
 288     frame $w.top.query -relief ridge -border 2
 289
 290 # Maximum/preferred/idAuth ...
 291     pack $w.top.description \
 292             $w.top.idAuthentification $w.top.maximumMessageSize \
 293             $w.top.preferredMessageSize -side top -anchor e -pady 2
 294
 295     entry-fields $w.top {description idAuthentification maximumMessageSize \
 296             preferredMessageSize} \
 297             {{Description:} {Id Authentification:} {Maximum Message Size:}
 298             {Preferred Message Size:}} \
 299             {protocol-setup-action} {destroy .protocol-setup}
 300
 301 # Transport ...
 302     pack $w.top.cs-type -side left -pady 2 -padx 2
 303
 304     global csRadioType
 305
 306     label $w.top.cs-type.label -text "Transport" -anchor e
 307         radiobutton $w.top.cs-type.tcpip -text "TCP/IP" \
 308             -command {puts tcp/ip} -variable csRadioType -value tcpip
 309     radiobutton $w.top.cs-type.mosi -text "MOSI" \
 310             -command {puts mosi} -variable csRadioType -value mosi
 311
 312     pack $w.top.cs-type.label $w.top.cs-type.tcpip $w.top.cs-type.mosi \
 313         -padx 4 -side top -fill x
 314
 315 # Query ...
 316     pack $w.top.query -side right -pady 2 -padx 2 -expand yes
 317
 318     label $w.top.query.label -text "Query support" -anchor e
 319     checkbutton $w.top.query.c1 -text "CCL query"
 320     checkbutton $w.top.query.c2 -text "RPN query"
 321     checkbutton $w.top.query.c3 -text "Result sets"
 322
 323     pack $w.top.query.label -side top -anchor w
 324     pack $w.top.query.c1 $w.top.query.c2 $w.top.query.c3 \
 325          -padx 4 -side left -fill x
 326
 327 # Buttons ...
 328     frame $w.bot.left -relief sunken -border 1
 329     pack $w.bot.left -side left -expand yes -padx 5 -pady 5
 330     button $w.bot.left.ok -width 6 -text {Ok} \
 331             -command {protocol-setup-action}
 332     pack $w.bot.left.ok -expand yes -padx 3 -pady 3
 333     button $w.bot.cancel -width 6 -text {Cancel} \
 334             -command "destroy $w"
 335     pack $w.bot.cancel -side left -expand yes
 336
 337 # Grab ...
 338     grab $w
 339
 340     tkwait window $w
 341
 342 }
 343
 344 proc database-select-action {} {
 345     z39 databaseNames [.database-select.top.database.entry get]
 346     destroy .database-select
 347 }
 348
 349 proc database-select {} {
 350     set w .database-select
 351
 352     toplevel $w
 353
 354     place-force $w .
 355
 356     frame $w.top -relief sunken -border 1
 357     frame $w.bot -relief sunken -border 1
 358
 359     pack  $w.top $w.bot -side top -fill both -expand yes
 360
 361     frame $w.top.database
 362
 363 # Database select
 364     pack $w.top.database -side top -anchor e -pady 2
 365
 366     entry-fields $w.top {database} \
 367             {{Database:}} \
 368             {database-select-action} {destroy .database-select}
 369
 370 # Buttons ...
 371     frame $w.bot.left -relief sunken -border 1
 372     pack $w.bot.left -side left -expand yes -padx 5 -pady 5
 373     button $w.bot.left.ok -width 6 -text {Ok} \
 374             -command {protocol-setup-action}
 375     pack $w.bot.left.ok -expand yes -padx 3 -pady 3
 376     button $w.bot.cancel -width 6 -text {Cancel} \
 377             -command "destroy .database-select"
 378     pack $w.bot.cancel -side left -expand yes
 379
 380 # Grab ...
 381     grab $w
 382
 383     tkwait window $w
 384 }
 385
 386 proc save-settings {} {
 387     global hotTargets
 388
 389     set f [open "~/.tk-c" w]
 390     puts $f "# Setup file"
 391     puts $f "set hotTargets \{ $hotTargets \}"
 392     close $f
 393 }
 394
 395 frame .top -border 1 -relief raised
 396 frame .mid  -border 1 -relief raised
 397 frame .data -border 1 -relief raised
 398 frame .bot -border 1 -relief raised
 399 pack .top .mid -side top -fill x
 400 pack .data      -side top -fill both -expand yes
 401 pack .bot      -fill x
 402
 403 menubutton .top.file -text "File" -menu .top.file.m
 404 menu .top.file.m
 405 .top.file.m add command -label "Save settings" -command {save-settings}
 406 .top.file.m add command -label "Exit" -command {destroy .}
 407
 408 menubutton .top.target -text "Target" -menu .top.target.m
 409 menu .top.target.m
 410 .top.target.m add command -label "Connect" -command {open-target-dialog}
 411 .top.target.m add command -label "Disconnect" -command {close-target}
 412 .top.target.m add command -label "Initialize" -command {init-request}
 413 .top.target.m add command -label "Setup" -command {protocol-setup}
 414 .top.target.m add separator
 415 set-target-hotlist
 416
 417 menubutton .top.database -text "Database" -menu .top.database.m
 418 menu .top.database.m
 419 .top.database.m add command -label "Select ..." -command {database-select}
 420 .top.database.m add command -label "Add ..." -command {puts "Add"}
 421
 422 menubutton .top.help -text "Help" -menu .top.help.m
 423 menu .top.help.m
 424 .top.help.m add command -label "Help on help" -command {puts "Help on help"}
 425 .top.help.m add command -label "About" -command {puts "About"}
 426
 427 pack .top.file .top.target .top.database -side left
 428 pack .top.help -side right
 429
 430 label .mid.searchlabel -text {Search:}
 431 entry .mid.searchentry -width 50 -relief sunken
 432
 433 listbox .data.list -yscrollcommand {.data.scroll set}
 434 #-geometry 50x10
 435 scrollbar .data.scroll -orient vertical -border 1
 436 pack .data.list -side left -fill both -expand yes
 437 pack .data.scroll -side right -fill y
 438 .data.scroll config -command {.data.list yview}
 439
 440 message .bot.target -text "None" -aspect 1000 -relief sunken -border 1
 441 label .bot.status -text "Not connected" -width 12 -relief \
 442     sunken -anchor w -border 1
 443 label .bot.message -text "" -width 20 -relief \
 444     sunken -anchor w -border 1
 445 pack .bot.target .bot.status .bot.message -anchor nw -side left -padx 2 -pady 2
 446
 447 for {set i 0} {$i < 30} {incr i} {
 448     .data.list insert end "Record $i"
 449 }
 450
 451 bind .data.list <Double-Button-1> {set indx [.data.list nearest %y]
 452 puts "y=%y index $indx" }
 453
 454 ir z39
 455 z39 comstack tcpip
 456 set csRadioType [z39 comstack]