client.tcl

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