client.tcl

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