client.tcl

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