client.tcl

   1 #
   2 # $Log: client.tcl,v $
   3 # Revision 1.17  1995-03-31 09:34:57  adam
   4 # Search-button disabled when there is no connection.
   5 #
   6 # Revision 1.16  1995/03/31  08:56:36  adam
   7 # New button "Search".
   8 #
   9 # Revision 1.15  1995/03/28  12:45:22  adam
  10 # New ir method failback: called on disconnect/protocol error.
  11 # New ir set/get method: protocol: SR / Z3950.
  12 # Simple popup and disconnect when failback is invoked.
  13 #
  14 # Revision 1.14  1995/03/22  16:07:55  adam
  15 # Minor changes.
  16 #
  17 # Revision 1.13  1995/03/21  17:27:26  adam
  18 # Short-hand keys in setup.
  19 #
  20 # Revision 1.12  1995/03/21  13:41:03  adam
  21 # Comstack cs_create not used too often. Non-blocking connect.
  22 #
  23 # Revision 1.11  1995/03/21  10:39:06  adam
  24 # Diagnostic error message displayed with tkerror.
  25 #
  26 # Revision 1.10  1995/03/20  15:24:06  adam
  27 # Diagnostic records saved on searchResponse.
  28 #
  29 # Revision 1.9  1995/03/17  18:26:16  adam
  30 # Non-blocking i/o used now. Database names popup as cascade items.
  31 #
  32 # Revision 1.8  1995/03/17  15:45:00  adam
  33 # Improved target/database setup.
  34 #
  35 # Revision 1.7  1995/03/16  17:54:03  adam
  36 # Minor changes really.
  37 #
  38 # Revision 1.6  1995/03/15  19:10:20  adam
  39 # Database setup in protocol-setup (rather target setup).
  40 #
  41 # Revision 1.5  1995/03/15  13:59:23  adam
  42 # Minor changes.
  43 #
  44 # Revision 1.4  1995/03/14  17:32:29  adam
  45 # Presentation of full Marc record in popup window.
  46 #
  47 # Revision 1.3  1995/03/12  19:31:52  adam
  48 # Pattern matching implemented when retrieving MARC records. More
  49 # diagnostic functions.
  50 #
  51 # Revision 1.2  1995/03/10  18:00:15  adam
  52 # Actual presentation in line-by-line format. RPN query support.
  53 #
  54 # Revision 1.1  1995/03/09  16:15:07  adam
  55 # First presentRequest attempts. Hot-target list.
  56 #
  57 #
  58 set hotTargets {}
  59 set hotInfo {}
  60 set busy 0
  61
  62 set profile(Default) {{} {} {210} {} 16384 8192 tcpip {}}
  63 set hostid Default
  64 set settingsChanged 0
  65 set setNo 0
  66
  67 wm minsize . 300 250
  68
  69 if {[file readable "~/.tk-c"]} {
  70     source "~/.tk-c"
  71 }
  72
  73 proc top-down-window {w} {
  74     frame $w.top -relief raised -border 1
  75     frame $w.bot -relief raised -border 1
  76
  77     pack  $w.top $w.bot -side top -fill both -expand yes
  78 }
  79
  80 proc top-down-ok-cancel {w ok-action g} {
  81     frame $w.bot.left -relief sunken -border 1
  82     pack $w.bot.left -side left -expand yes -padx 5 -pady 5
  83     button $w.bot.left.ok -width 6 -text {Ok} \
  84             -command ${ok-action}
  85     pack $w.bot.left.ok -expand yes -padx 3 -pady 3
  86     button $w.bot.cancel -width 6 -text {Cancel} \
  87             -command "destroy $w"
  88     pack $w.bot.cancel -side left -expand yes
  89
  90     if {$g} {
  91         # Grab ...
  92         grab $w
  93         tkwait window $w
  94     }
  95 }
  96
  97 proc show-target {target} {
  98     .bot.target configure -text "$target"
  99 }
 100
 101 proc show-busy {v1 v2} {
 102     global busy
 103     if {$busy != 0} {
 104         .bot.status configure -fg $v1
 105         after 200 [list show-busy $v2 $v1]
 106     }
 107 }
 108
 109 proc show-status {status b} {
 110     global busy
 111     global statusbg
 112     .bot.status configure -text "$status"
 113     .bot.status configure -fg black
 114     if {$b != 0} {
 115         if {$busy == 0} {
 116             set busy $b
 117             show-busy red blue
 118         }
 119         #        . config -cursor {watch black white}
 120     } else {
 121         #        . config -cursor {top_left_arrow black white}
 122         puts "Normal"
 123     }
 124     set busy $b
 125 }
 126
 127 proc show-message {msg} {
 128     .bot.message configure -text "$msg"
 129 }
 130
 131 proc insertWithTags {w text args} {
 132     set start [$w index insert]
 133     $w insert insert $text
 134     foreach tag [$w tag names $start] {
 135         $w tag remove $tag $start insert
 136     }
 137     foreach i $args {
 138         $w tag add $i $start insert
 139     }
 140 }
 141
 142 proc show-full-marc {no} {
 143     global setNo
 144
 145     set w .full-marc
 146
 147     if {[winfo exists $w]} {
 148         $w.top.record delete 0.0 end
 149         set new 0
 150     } else {
 151
 152         toplevel $w
 153
 154         wm minsize $w 200 200
 155
 156         frame $w.top -relief raised -border 1
 157         frame $w.bot -relief raised -border 1
 158
 159         pack  $w.top -side top -fill both -expand yes
 160         pack  $w.bot -fill both
 161
 162         text $w.top.record -width 60 -height 12 -wrap word \
 163                 -yscrollcommand [list $w.top.s set]
 164         scrollbar $w.top.s -command [list $w.top.record yview]
 165
 166         set new 1
 167     }
 168     incr no
 169
 170     set r [z39.$setNo recordMarc $no line * * *]
 171
 172     $w.top.record tag configure marc-tag -foreground blue
 173     $w.top.record tag configure marc-data -foreground black
 174     $w.top.record tag configure marc-id -foreground red
 175
 176     foreach line $r {
 177         set tag [lindex $line 0]
 178         set indicator [lindex $line 1]
 179         set fields [lindex $line 2]
 180
 181         if {$indicator != ""} {
 182             insertWithTags $w.top.record "$tag $indicator" marc-tag
 183         } else {
 184             insertWithTags $w.top.record "$tag    " marc-tag
 185         }
 186         foreach field $fields {
 187             set id [lindex $field 0]
 188             set data [lindex $field 1]
 189             if {$id != ""} {
 190                 insertWithTags $w.top.record " $id " marc-id
 191             }
 192             set start [$w.top.record index insert]
 193             insertWithTags $w.top.record $data {}
 194         }
 195         $w.top.record insert end "\n"
 196     }
 197     if {$new} {
 198         bind $w <Return> {destroy .full-marc}
 199
 200         pack $w.top.s -side right -fill y
 201         pack $w.top.record -expand yes -fill both
 202
 203         frame $w.bot.left -relief sunken -border 1
 204         pack $w.bot.left -side left -expand yes -padx 5 -pady 5
 205         button $w.bot.left.close -width 6 -text {Close} \
 206                 -command {destroy .full-marc}
 207         pack $w.bot.left.close -expand yes -padx 3 -pady 3
 208         button $w.bot.edit -width 6 -text {Edit} \
 209                 -command {destroy .full-marc}
 210         pack $w.bot.edit -side left -expand yes
 211     }
 212 }
 213
 214 proc update-target-hotlist {target} {
 215     global hotTargets
 216
 217     set len [llength $hotTargets]
 218     if {$len > 0} {
 219         .top.target.m delete 5 [expr 5+[llength $hotTargets]]
 220     }
 221     set indx [lsearch $hotTargets $target]
 222     if {$indx >= 0} {
 223         set hotTargets [lreplace $hotTargets $indx $indx]
 224     }
 225     set hotTargets [linsert $hotTargets 0 $target]
 226     set-target-hotlist
 227 }
 228
 229 proc set-target-hotlist {} {
 230     global hotTargets
 231
 232     set i 1
 233     foreach target $hotTargets {
 234         .top.target.m add command -label "$i $target" -command \
 235                 "reopen-target $target {}"
 236         incr i
 237         if {$i > 8} {
 238              break
 239         }
 240     }
 241 }
 242
 243 proc reopen-target {target base} {
 244     close-target
 245     open-target $target $base
 246     update-target-hotlist $target
 247 }
 248
 249 proc define-target-action {} {
 250     global profile
 251
 252     set target [.target-define.top.target.entry get]
 253     if {$target == ""} {
 254         return
 255     }
 256     update-target-hotlist $target
 257     foreach n [array names profile] {
 258         if {$n == $target} {
 259             protocol-setup $n
 260             return
 261         }
 262     }
 263     set profile($target) $profile(Default)
 264     protocol-setup $target
 265     destroy .target-define
 266 }
 267
 268 proc fail-response {target} {
 269     close-target
 270     tkerror "Target connection closed or protocol error"
 271 }
 272
 273 proc connect-response {target} {
 274     puts "connect-response"
 275     show-target $target
 276     init-request
 277 }
 278
 279 proc open-target {target base} {
 280     global profile
 281     global hostid
 282
 283     z39 disconnect
 284     z39 comstack [lindex $profile($target) 6]
 285     # z39 idAuthentication [lindex $profile($target) 3]
 286     z39 maximumRecordSize [lindex $profile($target) 4]
 287     z39 preferredMessageSize [lindex $profile($target) 5]
 288     puts -nonewline "maximumRecordSize="
 289     puts [z39 maximumRecordSize]
 290     puts -nonewline "preferredMessageSize="
 291     puts [z39 preferredMessageSize]
 292     if {$base == ""} {
 293         z39 databaseNames [lindex [lindex $profile($target) 7] 0]
 294     } else {
 295         z39 databaseNames $base
 296     }
 297     z39 failback [list fail-response $target]
 298     z39 callback [list connect-response $target]
 299     z39 connect [lindex $profile($target) 1]:[lindex $profile($target) 2]
 300     show-status {Connecting} 1
 301     set hostid $target
 302     .top.target.m disable 0
 303     .top.target.m enable 1
 304     .top.search configure -state normal
 305 }
 306
 307 proc close-target {} {
 308     global hostid
 309
 310     set hostid Default
 311     z39 disconnect
 312     show-target {None}
 313     show-status {Not connected} 0
 314     show-message {}
 315     .top.target.m disable 1
 316     .top.target.m enable 0
 317     .top.search configure -state disabled
 318 }
 319
 320 proc load-set-action {} {
 321     global setNo
 322
 323     incr setNo
 324     ir-set z39.$setNo
 325
 326     set fname [.load-set.top.filename.entry get]
 327     destroy .load-set
 328     if {$fname != ""} {
 329         init-title-lines
 330
 331         show-status {Loading} 1
 332         z39.$setNo loadFile $fname
 333
 334         set no [z39.$setNo numberOfRecordsReturned]
 335         add-title-lines $setNo $no 1
 336     }
 337     show-status {Ready} 0
 338 }
 339
 340 proc load-set {} {
 341     set w .load-set
 342
 343     set oldFocus [focus]
 344     toplevel $w
 345
 346     place-force $w .
 347
 348     top-down-window $w
 349
 350     frame $w.top.filename
 351
 352     pack $w.top.filename -side top -anchor e -pady 2
 353
 354     entry-fields $w.top {filename} \
 355             {{Filename:}} \
 356             {load-set-action} {destroy .load-set}
 357
 358     top-down-ok-cancel $w {load-set-action} 1
 359     focus $oldFocus
 360 }
 361
 362 proc init-request {} {
 363     global setNo
 364
 365     z39 callback {init-response}
 366     z39 init
 367     show-status {Initializing} 1
 368 }
 369
 370 proc init-response {} {
 371     show-status {Ready} 0
 372     bind .mid.searchentry <Return> search-request
 373     focus .mid.searchentry
 374 }
 375
 376 proc search-request {} {
 377     global setNo
 378     global profile
 379     global hostid
 380
 381     set target $hostid
 382
 383     incr setNo
 384     ir-set z39.$setNo
 385
 386     if {[lindex $profile($target) 10]} {
 387         z39.$setNo setName $setNo
 388     }
 389     if {[lindex $profile($target) 8]} {
 390         z39 query rpn
 391     }
 392     if {[lindex $profile($target) 9]} {
 393         z39 query ccl
 394     }
 395     z39 callback {search-response}
 396     z39.$setNo search [.mid.searchentry get]
 397     show-status {Search} 1
 398 }
 399
 400 proc search-response {} {
 401     global setNo
 402     global setOffset
 403     global setMax
 404
 405     init-title-lines
 406     show-status {Ready} 0
 407     show-message "[z39.$setNo resultCount] hits"
 408     set setMax [z39.$setNo resultCount]
 409     puts $setMax
 410     if {$setMax == 0} {
 411         set status [z39.$setNo responseStatus]
 412         if {[lindex $status 0] == "NSD"} {
 413             set code [lindex $status 1]
 414             set msg [lindex $status 2]
 415             set addinfo [lindex $status 3]
 416             tkerror "NSD$code: $msg: $addinfo"
 417         }
 418         return
 419     }
 420     if {$setMax > 4} {
 421         set setMax 4
 422     }
 423     z39 callback {present-response}
 424     set setOffset 1
 425     z39.$setNo present $setOffset $setMax
 426     show-status {Retrieve} 1
 427 }
 428
 429 proc present-more {number} {
 430     global setNo
 431     global setOffset
 432     global setMax
 433
 434     puts "present-more"
 435     if {$setNo == 0} {
 436         return
 437     }
 438     set max [z39.$setNo resultCount]
 439     if {$max <= $setMax} {
 440         return
 441     }
 442     puts "max=$max"
 443     puts "setOffset=$setOffset"
 444     if {$number == ""} {
 445         set setMax $max
 446     } else {
 447         incr setMax $number
 448     }
 449     z39 callback {present-response}
 450     z39.$setNo present $setOffset [expr $setMax - $setOffset + 1]
 451     show-status {Retrieve} 1
 452 }
 453
 454 proc init-title-lines {} {
 455     .data.list delete 0 end
 456 }
 457
 458 proc add-title-lines {setno no offset} {
 459     for {set i 0} {$i < $no} {incr i} {
 460         set o [expr $i + $offset]
 461         set title [lindex [z39.$setno recordMarc $o field 245 * a] 0]
 462         set year  [lindex [z39.$setno recordMarc $o field 260 * c] 0]
 463         set nostr [format "%3d" $o]
 464         .data.list insert end "$nostr $title - $year"
 465     }
 466 }
 467
 468 proc present-response {} {
 469     global setNo
 470     global setOffset
 471     global setMax
 472
 473     puts "In present-response"
 474     set no [z39.$setNo numberOfRecordsReturned]
 475     puts "Returned $no records, setOffset $setOffset"
 476     add-title-lines $setNo $no $setOffset
 477     set setOffset [expr $setOffset + $no]
 478     set status [z39.$setNo responseStatus]
 479     if {[lindex $status 0] == "NSD"} {
 480         show-status {Ready} 0
 481         set code [lindex $status 1]
 482         set msg [lindex $status 2]
 483         set addinfo [lindex $status 3]
 484         tkerror "NSD$code: $msg: $addinfo"
 485         return
 486     }
 487     if {$no > 0 && $setOffset <= $setMax} {
 488         z39.$setNo present $setOffset [expr $setMax - $setOffset + 1]
 489     } else {
 490         show-status {Finished} 0
 491     }
 492 }
 493
 494 proc left-cursor {w} {
 495     set i [$w index insert]
 496     if {$i > 0} {
 497         incr i -1
 498         $w icursor $i
 499     }
 500 }
 501
 502 proc right-cursor {w} {
 503     set i [$w index insert]
 504     incr i
 505     $w icursor $i
 506 }
 507
 508 proc bind-fields {list returnAction escapeAction} {
 509     set max [expr [llength $list]-1]
 510     for {set i 0} {$i < $max} {incr i} {
 511         bind [lindex $list $i] <Return> $returnAction
 512         bind [lindex $list $i] <Escape> $escapeAction
 513         bind [lindex $list $i] <Tab> [list focus [lindex $list [expr $i+1]]]
 514         bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
 515         bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
 516     }
 517     bind [lindex $list $i] <Return> $returnAction
 518     bind [lindex $list $i] <Escape> $escapeAction
 519     bind [lindex $list $i] <Tab>    [list focus [lindex $list 0]]
 520     bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
 521     bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
 522     focus [lindex $list 0]
 523 }
 524
 525 proc entry-fields {parent list tlist returnAction escapeAction} {
 526     set alist {}
 527     set i 0
 528     foreach field $list {
 529         set label ${parent}.${field}.label
 530         set entry ${parent}.${field}.entry
 531         label $label -text [lindex $tlist $i] -anchor e
 532         entry $entry -width 32 -relief sunken
 533         pack $label -side left
 534         pack $entry -side right
 535         lappend alist $entry
 536         incr i
 537     }
 538     bind-fields $alist $returnAction $escapeAction
 539 }
 540
 541 proc define-target-dialog {} {
 542     set w .target-define
 543
 544     toplevel $w
 545
 546     place-force $w .
 547
 548     top-down-window $w
 549
 550     frame $w.top.target
 551
 552     pack $w.top.target \
 553             -side top -anchor e -pady 2
 554
 555     entry-fields $w.top {target} \
 556             {{Target:}} \
 557             {define-target-action} {destroy .target-define}
 558
 559     top-down-ok-cancel $w {define-target-action} 1
 560 }
 561
 562 proc protocol-setup-action {target} {
 563     global profile
 564     global csRadioType
 565     global settingsChanged
 566     global RPNCheck
 567     global CCLCheck
 568     global ResultSetCheck
 569
 570     set w .setup-${target}.top
 571
 572     #set w .protocol-setup.top
 573
 574     set b {}
 575     set settingsChanged 1
 576     set len [$w.databases.list size]
 577     for {set i 0} {$i < $len} {incr i} {
 578         lappend b [$w.databases.list get $i]
 579     }
 580     set profile($target) [list [$w.description.entry get] \
 581             [$w.host.entry get] \
 582             [$w.port.entry get] \
 583             [$w.idAuthentication.entry get] \
 584             [$w.maximumRecordSize.entry get] \
 585             [$w.preferredMessageSize.entry get] \
 586             $csRadioType \
 587             $b \
 588             $RPNCheck \
 589             $CCLCheck \
 590             $ResultSetCheck ]
 591
 592     cascade-target-list
 593     puts $profile($target)
 594     destroy .setup-${target}
 595 }
 596
 597 proc place-force {window parent} {
 598     set g [wm geometry $parent]
 599
 600     set p1 [string first + $g]
 601     set p2 [string last + $g]
 602
 603     set x [expr 40+[string range $g [expr $p1 +1] [expr $p2 -1]]]
 604     set y [expr 60+[string range $g [expr $p2 +1] end]]
 605     wm geometry $window +${x}+${y}
 606 }
 607
 608 proc add-database-action {target} {
 609     set w .setup-${target}
 610
 611     ${w}.top.databases.list insert end \
 612             [.database-select.top.database.entry get]
 613     destroy .database-select
 614 }
 615
 616 proc add-database {target} {
 617     set w .database-select
 618
 619     set oldFocus [focus]
 620     toplevel $w
 621
 622     place-force $w .setup-${target}
 623
 624     top-down-window $w
 625
 626     frame $w.top.database
 627
 628     pack $w.top.database -side top -anchor e -pady 2
 629
 630     entry-fields $w.top {database} \
 631             {{Database to add:}} \
 632             [list add-database-action $target] {destroy .database-select}
 633
 634     top-down-ok-cancel $w [list add-database-action $target] 1
 635     focus $oldFocus
 636 }
 637
 638 proc delete-database {target} {
 639     set w .setup-${target}
 640
 641     foreach i [lsort -decreasing \
 642             [$w.top.databases.list curselection]] {
 643         $w.top.databases.list delete $i
 644     }
 645 }
 646
 647 proc protocol-setup {target} {
 648     set w .setup-$target
 649
 650     global profile
 651     global csRadioType
 652     global RPNCheck
 653     global CCLCheck
 654     global ResultSetCheck
 655
 656     toplevel $w
 657
 658     wm title $w "Setup $target"
 659     place-force $w .
 660
 661     top-down-window $w
 662
 663     if {$target == ""} {
 664         set target Default
 665     }
 666     puts target
 667     puts $profile($target)
 668
 669     frame $w.top.host
 670     frame $w.top.port
 671     frame $w.top.description
 672     frame $w.top.idAuthentication
 673     frame $w.top.maximumRecordSize
 674     frame $w.top.preferredMessageSize
 675     frame $w.top.cs-type -relief ridge -border 2
 676     frame $w.top.query -relief ridge -border 2
 677     frame $w.top.databases -relief ridge -border 2
 678
 679     # Maximum/preferred/idAuth ...
 680     pack $w.top.description $w.top.host $w.top.port \
 681             $w.top.idAuthentication $w.top.maximumRecordSize \
 682             $w.top.preferredMessageSize -side top -anchor e -pady 2
 683
 684     entry-fields $w.top {description host port idAuthentication \
 685             maximumRecordSize preferredMessageSize} \
 686             {{Description:} {Host:} {Port:} {Id Authentification:} \
 687             {Maximum Record Size:} {Preferred Message Size:}} \
 688             [list protocol-setup-action $target] [list destroy $w]
 689
 690     foreach sub {description host port idAuthentication \
 691             maximumRecordSize preferredMessageSize} {
 692         puts $sub
 693         bind $w.top.$sub.entry <Control-a> "add-database $target"
 694         bind $w.top.$sub.entry <Control-d> "delete-database $target"
 695     }
 696     $w.top.description.entry insert 0 [lindex $profile($target) 0]
 697     $w.top.host.entry insert 0 [lindex $profile($target) 1]
 698     $w.top.port.entry insert 0 [lindex $profile($target) 2]
 699     $w.top.idAuthentication.entry insert 0 [lindex $profile($target) 3]
 700     $w.top.maximumRecordSize.entry insert 0 [lindex $profile($target) 4]
 701     $w.top.preferredMessageSize.entry insert 0 [lindex $profile($target) 5]
 702     set csRadioType [lindex $profile($target) 6]
 703     set RPNCheck [lindex $profile($target) 8]
 704     set CCLCheck [lindex $profile($target) 9]
 705     set ResultSetCheck [lindex $profile($target) 10]
 706
 707     # Databases ....
 708     pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill x
 709
 710     label $w.top.databases.label -text "Databases"
 711     button $w.top.databases.add -text "Add" \
 712             -command "add-database $target"
 713     button $w.top.databases.delete -text "Delete" \
 714             -command "delete-database $target"
 715     listbox $w.top.databases.list -geometry 20x6 \
 716             -yscrollcommand "$w.top.databases.scroll set"
 717     scrollbar $w.top.databases.scroll -orient vertical -border 1
 718     pack $w.top.databases.label -side top -fill x \
 719             -padx 2 -pady 2
 720     pack $w.top.databases.add $w.top.databases.delete -side top -fill x \
 721             -padx 2 -pady 2
 722     pack $w.top.databases.list -side left -fill both -expand yes \
 723             -padx 2 -pady 2
 724     pack $w.top.databases.scroll -side right -fill y \
 725             -padx 2 -pady 2
 726     $w.top.databases.scroll config -command "$w.top.databases.list yview"
 727
 728     foreach b [lindex $profile($target) 7] {
 729         $w.top.databases.list insert end $b
 730     }
 731
 732     # Transport ...
 733     pack $w.top.cs-type -pady 6 -padx 6 -side top
 734
 735     label $w.top.cs-type.label -text "Transport"
 736     radiobutton $w.top.cs-type.tcpip -text "TCP/IP" \
 737             -command {puts tcp/ip} -variable csRadioType -value tcpip
 738     radiobutton $w.top.cs-type.mosi -text "MOSI" \
 739             -command {puts mosi} -variable csRadioType -value mosi
 740
 741     pack $w.top.cs-type.label $w.top.cs-type.tcpip $w.top.cs-type.mosi \
 742             -padx 4 -side top -fill x
 743
 744     # Query ...
 745     pack $w.top.query -pady 6 -padx 6 -side top
 746
 747     label $w.top.query.label -text "Query support" -anchor e
 748     checkbutton $w.top.query.c1 -text "RPN query" -variable RPNCheck
 749     checkbutton $w.top.query.c2 -text "CCL query" -variable CCLCheck
 750     checkbutton $w.top.query.c3 -text "Result sets" -variable ResultSetCheck
 751
 752     pack $w.top.query.label -side top
 753     pack $w.top.query.c1 $w.top.query.c2 $w.top.query.c3 \
 754             -padx 4 -side top -fill x
 755
 756     # Ok-cancel
 757     top-down-ok-cancel $w [list protocol-setup-action $target] 0
 758 }
 759
 760 proc database-select-action {} {
 761     set w .database-select.top
 762     set b {}
 763     foreach indx [$w.databases.list curselection] {
 764         lappend b [$w.databases.list get $indx]
 765     }
 766     if {$b != ""} {
 767         z39 databaseNames $b
 768     }
 769     destroy .database-select
 770 }
 771
 772 proc database-select {} {
 773     set w .database-select
 774     global profile
 775     global hostid
 776
 777     toplevel $w
 778
 779     place-force $w .
 780
 781     top-down-window $w
 782
 783     frame $w.top.databases -relief ridge -border 2
 784
 785     pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill x
 786
 787     label $w.top.databases.label -text "List"
 788     listbox $w.top.databases.list -geometry 20x6 \
 789             -yscrollcommand "$w.top.databases.scroll set"
 790     scrollbar $w.top.databases.scroll -orient vertical -border 1
 791     pack $w.top.databases.label -side top -fill x \
 792             -padx 2 -pady 2
 793     pack $w.top.databases.list -side left -fill both -expand yes \
 794             -padx 2 -pady 2
 795     pack $w.top.databases.scroll -side right -fill y \
 796             -padx 2 -pady 2
 797     $w.top.databases.scroll config -command "$w.top.databases.list yview"
 798
 799     foreach b [lindex $profile($hostid) 7] {
 800         $w.top.databases.list insert end $b
 801     }
 802     top-down-ok-cancel $w {database-select-action} 1
 803 }
 804
 805 proc cascade-target-list {} {
 806     global profile
 807
 808     foreach sub [winfo children .top.target.m.clist] {
 809         puts "deleting $sub"
 810         destroy $sub
 811     }
 812     .top.target.m.clist delete 0 last
 813     foreach n [array names profile] {
 814         if {$n != "Default"} {
 815             set nl [string tolower $n]
 816             if {[llength [lindex $profile($n) 7]] > 1} {
 817                 .top.target.m.clist add cascade -label $n \
 818                         -menu .top.target.m.clist.$nl
 819                 menu .top.target.m.clist.$nl
 820                 foreach b [lindex $profile($n) 7] {
 821                     .top.target.m.clist.$nl add command -label $b \
 822                             -command "reopen-target $n $b"
 823                 }
 824             } else {
 825                 .top.target.m.clist add command -label $n \
 826                         -command "reopen-target $n {}"
 827             }
 828         }
 829     }
 830     .top.target.m.slist delete 0 last
 831     foreach n [array names profile] {
 832         if {$n != "Default"} {
 833             .top.target.m.slist add command -label $n \
 834                     -command "protocol-setup $n"
 835         }
 836     }
 837 }
 838
 839 proc save-settings {} {
 840     global hotTargets
 841     global profile
 842     global settingsChanged
 843
 844     set f [open "~/.tk-c" w]
 845     puts $f "# Setup file"
 846     puts $f "set hotTargets \{ $hotTargets \}"
 847
 848     foreach n [array names profile] {
 849         puts -nonewline $f "set profile($n) \{"
 850         puts -nonewline $f $profile($n)
 851         puts $f "\}"
 852     }
 853     close $f
 854     set settingsChanged 0
 855 }
 856
 857 proc alert {ask} {
 858     set w .alert
 859
 860     global alertAnswer
 861
 862     toplevel $w
 863     place-force $w .
 864     top-down-window $w
 865
 866     message $w.top.message -text $ask
 867
 868     pack $w.top.message -side left -pady 6 -padx 20 -expand yes -fill x
 869
 870     set alertAnswer 0
 871     top-down-ok-cancel $w {alert-action} 1
 872     return $alertAnswer
 873 }
 874
 875 proc alert-action {} {
 876     global alertAnswer
 877     set alertAnswer 1
 878     destroy .alert
 879 }
 880
 881 proc exit-action {} {
 882     global settingsChanged
 883
 884     if {$settingsChanged} {
 885         set a [alert "you havent saved your settings. Do you wish to save?"]
 886         if {$a} {
 887             save-settings
 888         }
 889     }
 890     destroy .
 891 }
 892
 893 frame .top  -border 1 -relief raised
 894 frame .mid  -border 1 -relief raised
 895 frame .data -border 1 -relief raised
 896 frame .bot  -border 1 -relief raised
 897 pack .top .mid -side top -fill x
 898 pack .data      -side top -fill both -expand yes
 899 pack .bot      -fill x
 900
 901 menubutton .top.file -text "File" -underline 0 -menu .top.file.m
 902 menu .top.file.m
 903 .top.file.m add command -label "Save settings" -command {save-settings}
 904 .top.file.m add command -label "Load Set" -command {load-set}
 905 .top.file.m add separator
 906 .top.file.m add command -label "Exit" -command {exit-action}
 907
 908 menubutton .top.target -text "Target" -underline 0 -menu .top.target.m
 909 menu .top.target.m
 910 .top.target.m add cascade -label "Connect" -menu .top.target.m.clist
 911 .top.target.m add command -label "Disconnect" -command {close-target}
 912 #.top.target.m add command -label "Initialize" -command {init-request}
 913 .top.target.m add cascade -label "Setup" -menu .top.target.m.slist
 914 .top.target.m add command -label "Setup new" -command {define-target-dialog}
 915 .top.target.m add separator
 916 set-target-hotlist
 917
 918 .top.target.m disable 1
 919
 920 menu .top.target.m.clist
 921 menu .top.target.m.slist
 922 cascade-target-list
 923
 924 menubutton .top.search -text "Search" -underline 0 -menu .top.search.m
 925 menu .top.search.m
 926 .top.search.m add command -label "Database" -command {database-select}
 927 .top.search.m add cascade -label "Query type" -menu .top.search.m.querytype
 928 menu .top.search.m.querytype
 929 .top.search.m.querytype add radiobutton -label "RPN"
 930 .top.search.m.querytype add radiobutton -label "CCL"
 931 .top.search.m add cascade -label "Present" -menu .top.search.m.present
 932 menu .top.search.m.present
 933 .top.search.m.present add command -label "More" -command [list present-more 10]
 934 .top.search.m.present add command -label "All" -command [list present-more {}]
 935 .top.search configure -state disabled
 936
 937 menubutton .top.help -text "Help" -menu .top.help.m
 938 menu .top.help.m
 939
 940 .top.help.m add command -label "Help on help" -command {puts "Help on help"}
 941 .top.help.m add command -label "About" -command {puts "About"}
 942
 943 pack .top.file .top.target .top.search -side left
 944 pack .top.help -side right
 945
 946 label .mid.searchlabel -text {Search:}
 947 entry .mid.searchentry -width 32 -relief sunken
 948 pack .mid.searchlabel  -side left
 949 pack .mid.searchentry -side left -fill x -expand yes
 950
 951 focus .mid.searchentry
 952 bind .mid.searchentry <Left> {left-cursor .mid.searchentry}
 953 bind .mid.searchentry <Right> {right-cursor .mid.searchentry}
 954
 955 listbox .data.list -yscrollcommand {.data.scroll set}
 956 scrollbar .data.scroll -orient vertical -border 1
 957 pack .data.list -side left -fill both -expand yes
 958 pack .data.scroll -side right -fill y
 959 .data.scroll config -command {.data.list yview}
 960
 961 message .bot.target -text "None" -aspect 1000 -relief sunken -border 1
 962 label .bot.status -text "Not connected" -width 12 -relief \
 963         sunken -anchor w -border 1
 964 label .bot.set -textvariable setNo -width 5 -relief \
 965         sunken -anchor w -border 1
 966 label .bot.message -text "" -width 14 -relief \
 967         sunken -anchor w -border 1
 968 pack .bot.target .bot.status .bot.set .bot.message -anchor nw \
 969         -side left -padx 2 -pady 2
 970
 971 bind .data.list <Double-Button-1> {set indx [.data.list nearest %y]
 972 show-full-marc $indx}
 973
 974 ir z39