client.tcl

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