client.tcl

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