client.tcl

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