client.tcl

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