client.tcl

   1 # IR toolkit for tcl/tk
   2 # (c) Index Data 1995
   3 # See the file LICENSE for details.
   4 # Sebastian Hammer, Adam Dickmeiss
   5 #
   6 # $Log: client.tcl,v $
   7 # Revision 1.44  1995-06-16 14:55:18  adam
   8 # Book logo mirrored.
   9 #
  10 # Revision 1.43  1995/06/16  14:41:05  adam
  11 # Scan line entries can be copied to a search entry.
  12 #
  13 # Revision 1.42  1995/06/16  12:28:13  adam
  14 # Implemented preferredRecordSyntax.
  15 # Minor changes in diagnostic handling.
  16 # Record list deleted when connection closes.
  17 #
  18 # Revision 1.41  1995/06/14  15:07:59  adam
  19 # Bug fix in cascade-target-list. Uses yaz-version.h.
  20 #
  21 # Revision 1.40  1995/06/14  13:37:17  adam
  22 # Setting recordType implemented.
  23 # Setting implementationVersion implemented.
  24 # Settings implementationId / implementationName edited.
  25 #
  26 # Revision 1.39  1995/06/14  12:16:22  adam
  27 # hotTargets, textWrap and displayFormat saved in clientg.tcl.
  28 #
  29 # Revision 1.38  1995/06/14  07:22:45  adam
  30 # Target definitions can be deleted.
  31 # Listbox used in the query definition dialog.
  32 #
  33 # Revision 1.37  1995/06/13  14:37:59  adam
  34 # Work on query setup.
  35 # Better about origin/target.
  36 # Better presentation formats.
  37 #
  38 # Revision 1.36  1995/06/13  07:42:14  adam
  39 # Bindings removed from text widgets.
  40 #
  41 # Revision 1.35  1995/06/12  15:17:31  adam
  42 # Text widget used in main window (instead of listbox) to support
  43 # better presentation formats.
  44 #
  45 # Revision 1.34  1995/06/12  07:59:07  adam
  46 # More work on geometry handling.
  47 #
  48 # Revision 1.33  1995/06/09  11:17:35  adam
  49 # Start work on geometry management.
  50 #
  51 # Revision 1.32  1995/06/07  09:16:37  adam
  52 # New presentation format.
  53 #
  54 # Revision 1.31  1995/06/06  16:31:09  adam
  55 # Bug fix: target names couldn't contain blanks.
  56 # Bug fix: scan.
  57 #
  58 # Revision 1.30  1995/06/06  11:35:41  adam
  59 # Work on scan. Display of old sets.
  60 #
  61 # Revision 1.29  1995/06/05  14:11:18  adam
  62 # Bug fix in present-more.
  63 #
  64 # Revision 1.28  1995/06/02  14:52:13  adam
  65 # Minor changes really.
  66 #
  67 # Revision 1.27  1995/06/02  14:29:42  adam
  68 # Work on scan interface - up/down buttons.
  69 #
  70 # Revision 1.26  1995/06/01  16:36:46  adam
  71 # About buttons. Minor bug fixes.
  72 #
  73 # Revision 1.25  1995/05/31  13:09:57  adam
  74 # Client searches/presents may be interrupted.
  75 # New moving book-logo.
  76 #
  77 # Revision 1.24  1995/05/31  08:36:24  adam
  78 # Bug fix in client.tcl: didn't save options on clientrc.tcl.
  79 # New method: referenceId. More work on scan.
  80 #
  81 # Revision 1.23  1995/05/29  10:33:41  adam
  82 # README and rename of startup script.
  83 #
  84 # Revision 1.22  1995/05/26  11:44:09  adam
  85 # Bugs fixed. More work on MARC utilities and queries. Test
  86 # client is up-to-date again.
  87 #
  88 # Revision 1.21  1995/05/11  15:34:46  adam
  89 # Scan request changed a bit. This version works with RLG.
  90 #
  91 # Revision 1.20  1995/04/21  16:31:57  adam
  92 # New radiobutton: protocol (z39v2/SR).
  93 #
  94 # Revision 1.19  1995/04/18  16:11:50  adam
  95 # First version of graphical Scan. Some work on query-by-form.
  96 #
  97 # Revision 1.18  1995/04/10  10:50:22  adam
  98 # Result-set name defaults to suffix of ir-set name.
  99 # Started working on scan. Not finished at this point.
 100 #
 101 # Revision 1.17  1995/03/31  09:34:57  adam
 102 # Search-button disabled when there is no connection.
 103 #
 104 # Revision 1.16  1995/03/31  08:56:36  adam
 105 # New button "Search".
 106 #
 107 # Revision 1.15  1995/03/28  12:45:22  adam
 108 # New ir method failback: called on disconnect/protocol error.
 109 # New ir set/get method: protocol: SR / Z3950.
 110 # Simple popup and disconnect when failback is invoked.
 111 #
 112 # Revision 1.14  1995/03/22  16:07:55  adam
 113 # Minor changes.
 114 #
 115 # Revision 1.13  1995/03/21  17:27:26  adam
 116 # Short-hand keys in setup.
 117 #
 118 # Revision 1.12  1995/03/21  13:41:03  adam
 119 # Comstack cs_create not used too often. Non-blocking connect.
 120 #
 121 # Revision 1.11  1995/03/21  10:39:06  adam
 122 # Diagnostic error message displayed with tkerror.
 123 #
 124 # Revision 1.10  1995/03/20  15:24:06  adam
 125 # Diagnostic records saved on searchResponse.
 126 #
 127 # Revision 1.9  1995/03/17  18:26:16  adam
 128 # Non-blocking i/o used now. Database names popup as cascade items.
 129 #
 130 # Revision 1.8  1995/03/17  15:45:00  adam
 131 # Improved target/database setup.
 132 #
 133 # Revision 1.7  1995/03/16  17:54:03  adam
 134 # Minor changes really.
 135 #
 136 # Revision 1.6  1995/03/15  19:10:20  adam
 137 # Database setup in protocol-setup (rather target setup).
 138 #
 139 # Revision 1.5  1995/03/15  13:59:23  adam
 140 # Minor changes.
 141 #
 142 # Revision 1.4  1995/03/14  17:32:29  adam
 143 # Presentation of full Marc record in popup window.
 144 #
 145 # Revision 1.3  1995/03/12  19:31:52  adam
 146 # Pattern matching implemented when retrieving MARC records. More
 147 # diagnostic functions.
 148 #
 149 # Revision 1.2  1995/03/10  18:00:15  adam
 150 # Actual presentation in line-by-line format. RPN query support.
 151 #
 152 # Revision 1.1  1995/03/09  16:15:07  adam
 153 # First presentRequest attempts. Hot-target list.
 154 #
 155 #
 156 set hotTargets {}
 157 set hotInfo {}
 158 set busy 0
 159
 160 set libDir ""
 161
 162 set profile(Default) {{} {} {210} {} 16384 8192 tcpip {} 1 {} {} z39v2}
 163 set hostid Default
 164 set settingsChanged 0
 165 set setNo 0
 166 set lastSetNo 0
 167 set cancelFlag 0
 168 set searchEnable 0
 169 set scanEnable 0
 170 set fullMarcSeq 0
 171 set displayFormat 1
 172 set popupMarcdf 0
 173 set textWrap word
 174
 175 set queryTypes {Simple}
 176 set queryButtons { { {I 0} {I 1} {I 2} } }
 177 set queryInfo { { {Title {1=4 4=1}} {Author {1=1}} \
 178         {Subject {1=21}} {Any {1=1016}} } }
 179 wm minsize . 0 0
 180
 181 set setOffset 0
 182 set setMax 0
 183
 184 proc read-formats {} {
 185     global displayFormats
 186     set formats [glob -nocomplain formats/*.tcl]
 187     foreach f $formats {
 188         source $f
 189         set l [expr [string length $f] - 5]
 190         lappend displayFormats [string range $f 8 $l]
 191     }
 192 }
 193
 194 proc set-wrap {m} {
 195     global textWrap
 196
 197     set textWrap $m
 198     .data.record configure -wrap $m
 199 }
 200
 201 proc set-display-format {f} {
 202     global displayFormat
 203     global setNo
 204     global busy
 205
 206     set displayFormat $f
 207     if {$setNo == 0} {
 208         return
 209     }
 210     if {!$busy} {
 211         .bot.a.status configure -text "Reformatting"
 212     }
 213     update idletasks
 214     add-title-lines 0 10000 1
 215     if {!$busy} {
 216         .bot.a.status configure -text "Ready"
 217     }
 218 }
 219
 220 proc initBindings {} {
 221     set w Text
 222     bind $w <1> {}
 223     bind $w <Double-1> {}
 224     bind $w <Triple-1> {}
 225     bind $w <B1-Motion> {}
 226     bind $w <Shift-1> {}
 227     bind $w <Shift-B1-Motion> {}
 228     bind $w <2> {}
 229     bind $w <B2-Motion> {}
 230     bind $w <Any-KeyPress> {}
 231     bind $w <Return> {}
 232     bind $w <BackSpace> {}
 233     bind $w <Delete> {}
 234     bind $w <Control-h> {}
 235     bind $w <Control-d> {}
 236     bind $w <Control-v> {}
 237
 238     set w Listbox
 239     bind $w <B1-Motion> {}
 240     bind $w <Shift-B1-Motion> {}
 241
 242     set w Entry
 243 }
 244
 245 proc post-menu {wbutton wmenu} {
 246     $wmenu activate none
 247     focus $wmenu
 248     $wmenu post [winfo rootx $wbutton] \
 249             [expr [winfo rooty $wbutton]+[winfo height $wbutton]]
 250
 251 }
 252
 253 proc destroyGW {w} {
 254     global windowGeometry
 255     set windowGeometry($w) [wm geometry $w]
 256 }
 257 proc toplevelG {w} {
 258     global windowGeometry
 259
 260     toplevel $w
 261     if {[info exists windowGeometry($w)]} {
 262         set g $windowGeometry($w)
 263         if {$g != ""} {
 264             wm geometry $w $g
 265         }
 266     }
 267     bind $w <Destroy> [list destroyGW $w]
 268 }
 269
 270 if {[file readable "clientrc.tcl"]} {
 271     source "clientrc.tcl"
 272 }
 273
 274 if {[file readable "clientg.tcl"]} {
 275     source "clientg.tcl"
 276 }
 277
 278 set queryButtonsFind [lindex $queryButtons 0]
 279 set queryInfoFind [lindex $queryInfo 0]
 280
 281 proc top-down-window {w} {
 282     frame $w.top -relief raised -border 1
 283     frame $w.bot -relief raised -border 1
 284
 285     pack  $w.top -side top -fill both -expand yes
 286     pack  $w.bot -fill both
 287 }
 288
 289 proc top-down-ok-cancel {w ok-action g} {
 290     frame $w.bot.left -relief sunken -border 1
 291     pack $w.bot.left -side left -expand yes -ipadx 2 -ipady 2 -padx 5 -pady 5
 292     button $w.bot.left.ok -width 6 -text {Ok} \
 293             -command ${ok-action}
 294     pack $w.bot.left.ok -expand yes -ipadx 2 -ipady 2 -padx 3 -pady 3
 295     button $w.bot.cancel -width 6 -text {Cancel} \
 296             -command [list destroy $w]
 297     pack $w.bot.cancel -side left -expand yes
 298
 299     if {$g} {
 300         grab $w
 301         tkwait window $w
 302     }
 303 }
 304
 305 proc bottom-buttons {w buttonList g} {
 306     set i 0
 307     set l [llength $buttonList]
 308
 309     frame $w.bot.$i -relief sunken -border 1
 310     pack $w.bot.$i -side left -expand yes -padx 5 -pady 5
 311     button $w.bot.$i.ok -text [lindex $buttonList $i] \
 312             -command [lindex $buttonList [expr $i+1]]
 313     pack $w.bot.$i.ok -expand yes -ipadx 3 -ipady 2 -padx 3 -pady 3 -side left
 314
 315     incr i 2
 316     while {$i < $l} {
 317         button $w.bot.$i -text [lindex $buttonList $i] \
 318                 -command [lindex $buttonList [expr $i+1]]
 319         pack $w.bot.$i -expand yes -ipadx 2 -ipady 2 -padx 3 -pady 3 -side left
 320         incr i 2
 321     }
 322     if {$g} {
 323         # Grab ...
 324         grab $w
 325         tkwait window $w
 326     }
 327 }
 328
 329 proc cancel-operation {} {
 330     global cancelFlag
 331     global busy
 332
 333     set cancelFlag 1
 334     if {$busy} {
 335         show-status Canceling 0 {}
 336     }
 337 }
 338
 339 proc show-target {target} {
 340     .bot.a.target configure -text "$target"
 341 }
 342
 343 proc show-logo {v1} {
 344     global busy
 345     if {$busy != 0} {
 346         incr v1
 347         if {$v1==10} {
 348             set v1 1
 349         }
 350         .bot.logo configure -bitmap @book${v1}
 351         after 120 [list show-logo $v1]
 352         return
 353     }
 354     while {1} {
 355         .bot.logo configure -bitmap @book1
 356         tkwait variable busy
 357         if {$busy} {
 358             show-logo 1
 359             return
 360         }
 361     }
 362 }
 363
 364 proc show-status {status b sb} {
 365     global busy
 366     global searchEnable
 367     global scanEnable
 368     global setOffset
 369     global setMax
 370
 371     .bot.a.status configure -text "$status"
 372     if {$b == 1} {
 373         if {$busy == 0} {set busy 1}
 374     } else {
 375         set busy 0
 376     }
 377     if {$sb == {}} {
 378         return
 379     }
 380     if {$sb} {
 381         .top.service configure -state normal
 382         .mid.search configure -state normal
 383         if {$scanEnable} {
 384             .mid.scan configure -state normal
 385         }
 386         if {$setOffset > 0 && $setOffset <= $setMax} {
 387             .top.service.m enable 1
 388             .mid.present configure -state normal
 389         } else {
 390             .top.service.m disable 1
 391         }
 392         if {[winfo exists .scan-window]} {
 393             .scan-window.bot.2 configure -state normal
 394             .scan-window.bot.4 configure -state normal
 395         }
 396         set searchEnable 1
 397     } else {
 398         .top.service configure -state disabled
 399         .mid.search configure -state disabled
 400         .mid.scan configure -state disabled
 401         .mid.present configure -state disabled
 402
 403         if {[winfo exists .scan-window]} {
 404             .scan-window.bot.2 configure -state disabled
 405             .scan-window.bot.4 configure -state disabled
 406         }
 407         set searchEnable 0
 408     }
 409 }
 410
 411 proc show-message {msg} {
 412     .bot.a.message configure -text "$msg"
 413 }
 414
 415 proc insertWithTags {w text args} {
 416     set start [$w index insert]
 417     $w insert insert $text
 418     foreach tag [$w tag names $start] {
 419         $w tag remove $tag $start insert
 420     }
 421     foreach i $args {
 422         $w tag add $i $start insert
 423     }
 424 }
 425
 426 proc popup-license {} {
 427     set w .popup-licence
 428     toplevel $w
 429
 430     wm title $w "License"
 431
 432     wm minsize $w 0 0
 433
 434     top-down-window $w
 435
 436     text $w.top.t -width 80 -height 10 -wrap word \
 437         -yscrollcommand [list $w.top.s set]
 438     scrollbar $w.top.s -command [list $w.top.t yview]
 439
 440     pack $w.top.s -side right -fill y
 441     pack $w.top.t -expand yes -fill both
 442
 443     set f [open "LICENSE" r]
 444     while {[gets $f buf] != -1} {
 445         $w.top.t insert end $buf
 446         $w.top.t insert end "\n"
 447     }
 448     close $f
 449     bottom-buttons $w [list {Close} [list destroy $w]] 1
 450 }
 451
 452 proc about-target {} {
 453     set w .about-target-w
 454     global hostid
 455
 456     toplevel $w
 457
 458     wm title $w "About target"
 459     top-down-window $w
 460
 461     frame $w.top.a -relief ridge -border 2
 462     frame $w.top.p -relief ridge -border 2
 463
 464     pack $w.top.a $w.top.p -side top -fill x
 465
 466     label $w.top.a.about -text "About"
 467     label $w.top.a.irtcl -text $hostid \
 468             -font -Adobe-Helvetica-Bold-R-Normal-*-240-*
 469     pack $w.top.a.about $w.top.a.irtcl -side top
 470
 471     set i [z39 targetImplementationName]
 472     label $w.top.p.in -text "Implementation name: $i"
 473     set i [z39 targetImplementationId]
 474     label $w.top.p.ii -text "Implementation id: $i"
 475     set i [z39 targetImplementationVersion]
 476     label $w.top.p.iv -text "Implementation version: $i"
 477     set i [z39 options]
 478     label $w.top.p.op -text "Protocol options: $i"
 479
 480     pack $w.top.p.in $w.top.p.ii $w.top.p.iv $w.top.p.op -side top -anchor nw
 481
 482     bottom-buttons $w [list {Close} [list destroy $w]] 1
 483 }
 484
 485 proc about-origin-logo {n} {
 486     set w .about-origin-w
 487     if {![winfo exists $w]} {
 488         return
 489     }
 490     incr n
 491     if {$n==10} {
 492         set n 1
 493     }
 494     $w.top.a.logo configure -bitmap @book$n
 495     after 120 [list about-origin-logo $n]
 496 }
 497
 498 proc about-origin {} {
 499     set w .about-origin-w
 500
 501     if {[winfo exists $w]} {
 502         destroy $w
 503     }
 504     toplevel $w
 505
 506     wm title $w "About IrTcl"
 507     place-force $w .
 508     top-down-window $w
 509
 510     frame $w.top.a -relief ridge -border 2
 511     frame $w.top.p -relief ridge -border 2
 512
 513     pack $w.top.a $w.top.p -side top -fill x
 514
 515     label $w.top.a.irtcl -text "IrTcl" \
 516             -font -Adobe-Helvetica-Bold-R-Normal-*-240-*
 517     label $w.top.a.logo -bitmap @book1
 518     pack $w.top.a.irtcl $w.top.a.logo -side left -expand yes
 519
 520     set i [z39 implementationName]
 521     label $w.top.p.in -text "Implementation name: $i"
 522     set i [z39 implementationId]
 523     label $w.top.p.ii -text "Implementation id: $i"
 524     set i [z39 implementationVersion]
 525     label $w.top.p.iv -text "Implementation version: $i"
 526
 527     pack $w.top.p.in $w.top.p.ii $w.top.p.iv -side top -anchor nw
 528
 529     about-origin-logo 1
 530     bottom-buttons $w [list {Close} [list destroy $w] \
 531                             {License} [list popup-license]] 0
 532 }
 533
 534 proc popup-marc {sno no b df} {
 535     global fullMarcSeq
 536     global displayFormats
 537     global popupMarcdf
 538
 539     if {[z39.$sno type $no] != "DB"} {
 540         return
 541     }
 542     if {$b} {
 543         set w .full-marc-$fullMarcSeq
 544         incr fullMarcSeq
 545         set df $popupMarcdf
 546     } else {
 547         set w .full-marc
 548         set df $popupMarcdf
 549     }
 550     if {[winfo exists $w]} {
 551         set new 0
 552     } else {
 553
 554         toplevelG $w
 555
 556         wm minsize $w 0 0
 557
 558         frame $w.top -relief raised -border 1
 559         frame $w.bot -relief raised -border 1
 560
 561         pack  $w.top -side top -fill both -expand yes
 562         pack  $w.bot -fill both
 563
 564         text $w.top.record -width 60 -height 5 -wrap word \
 565                 -yscrollcommand [list $w.top.s set]
 566         scrollbar $w.top.s -command [list $w.top.record yview]
 567
 568         if {[tk colormodel .] == "color"} {
 569             $w.top.record tag configure marc-tag -foreground blue
 570             $w.top.record tag configure marc-id -foreground red
 571         } else {
 572             $w.top.record tag configure marc-tag -foreground black
 573             $w.top.record tag configure marc-id -foreground black
 574         }
 575         $w.top.record tag configure marc-data -foreground black
 576         set new 1
 577     }
 578     $w.top.record delete 0.0 end
 579     set recordType [z39.$sno recordType $no]
 580     wm title $w "$recordType record #$no"
 581
 582     set ffunc [lindex $displayFormats $df]
 583     set ffunc "display-$ffunc"
 584
 585     $ffunc $sno $no $w.top.record 0
 586
 587     if {$new} {
 588         bind $w.top.record <Return> {destroy .full-marc}
 589
 590         pack $w.top.s -side right -fill y
 591         pack $w.top.record -expand yes -fill both
 592
 593         if {$b} {
 594             bottom-buttons $w [list \
 595                 {Close} [list destroy $w]] 0
 596         } else {
 597             bottom-buttons $w [list \
 598                     {Close} [list destroy $w] \
 599                     {Duplicate} [list popup-marc $sno $no 1 0]] 0
 600             menubutton $w.bot.formats -text "Format" -menu $w.bot.formats.m
 601             menu $w.bot.formats.m
 602             set i 0
 603             foreach f $displayFormats {
 604                 $w.bot.formats.m add radiobutton -label $f \
 605                         -variable popupMarcdf -value $i \
 606                         -command [list display-$f $sno $no $w.top.record 0]
 607                 incr i
 608             }
 609             pack $w.bot.formats -expand yes -ipadx 2 -ipady 2 \
 610                     -padx 3 -pady 3 -side left
 611         }
 612     } else {
 613         set i 0
 614         foreach f $displayFormats {
 615             $w.bot.formats.m entryconfigure $i \
 616                     -command [list display-$f $sno $no $w.top.record 0]
 617             incr i
 618         }
 619     }
 620 }
 621
 622 proc update-target-hotlist {target} {
 623     global hotTargets
 624
 625     set len [llength $hotTargets]
 626     if {$len > 0} {
 627         .top.target.m delete 6 [expr 6+[llength $hotTargets]]
 628     }
 629     set indx [lsearch $hotTargets $target]
 630     if {$indx >= 0} {
 631         set hotTargets [lreplace $hotTargets $indx $indx]
 632     }
 633     set hotTargets [linsert $hotTargets 0 $target]
 634     set-target-hotlist
 635 }
 636
 637 proc set-target-hotlist {} {
 638     global hotTargets
 639
 640     set i 1
 641     foreach target $hotTargets {
 642         .top.target.m add command -label "$i $target" -command \
 643                 [list reopen-target $target {}]
 644         incr i
 645         if {$i > 8} {
 646              break
 647         }
 648     }
 649 }
 650
 651 proc reopen-target {target base} {
 652     close-target
 653     open-target $target $base
 654     update-target-hotlist $target
 655 }
 656
 657 proc define-target-action {} {
 658     global profile
 659
 660     set target [.target-define.top.target.entry get]
 661     if {$target == ""} {
 662         return
 663     }
 664     update-target-hotlist $target
 665     foreach n [array names profile] {
 666         if {$n == $target} {
 667             protocol-setup $n
 668             return
 669         }
 670     }
 671     set seq [lindex $profile(Default) 12]
 672     puts "seq=${seq}"
 673     set profile($target) $profile(Default)
 674     set profile(Default) [lreplace $profile(Default) 12 12 [incr seq]]
 675
 676     protocol-setup $target
 677     destroy .target-define
 678 }
 679
 680 proc fail-response {target} {
 681     close-target
 682     tkerror "Target connection closed or protocol error"
 683 }
 684
 685 proc connect-response {target} {
 686     puts "connect-response"
 687     show-target $target
 688     init-request
 689 }
 690
 691 proc open-target {target base} {
 692     global profile
 693     global hostid
 694
 695     z39 disconnect
 696     z39 comstack [lindex $profile($target) 6]
 697     z39 idAuthentication [lindex $profile($target) 3]
 698     z39 maximumRecordSize [lindex $profile($target) 4]
 699     z39 preferredMessageSize [lindex $profile($target) 5]
 700     puts -nonewline "maximumRecordSize="
 701     puts [z39 maximumRecordSize]
 702     puts -nonewline "preferredMessageSize="
 703     puts [z39 preferredMessageSize]
 704     show-status {Connecting} 0 0
 705     if {$base == ""} {
 706         z39 databaseNames [lindex [lindex $profile($target) 7] 0]
 707     } else {
 708         z39 databaseNames $base
 709     }
 710     z39 failback [list fail-response $target]
 711     z39 callback [list connect-response $target]
 712     z39 connect [lindex $profile($target) 1]:[lindex $profile($target) 2]
 713 #    z39 options search present scan namedResultSets triggerResourceCtrl
 714     show-status {Connecting} 1 {}
 715     set hostid $target
 716     .top.target.m disable 0
 717     .top.target.m enable 1
 718     .top.target.m enable 2
 719 }
 720
 721 proc close-target {} {
 722     global hostid
 723     global cancelFlag
 724     global setNo
 725
 726     set cancelFlag 0
 727     set setNo 0
 728     .bot.a.set configure -text ""
 729     set hostid Default
 730     z39 disconnect
 731     show-target {}
 732     show-status {Not connected} 0 0
 733     init-title-lines
 734     show-message {}
 735     .top.target.m disable 1
 736     .top.target.m disable 2
 737     .top.target.m enable 0
 738 }
 739
 740 proc load-set-action {} {
 741     global setNo
 742
 743     incr setNo
 744     ir-set z39.$setNo z39
 745
 746     set fname [.load-set.top.filename.entry get]
 747     destroy .load-set
 748     if {$fname != ""} {
 749         show-status {Loading} 1 {}
 750         update
 751         z39.$setNo loadFile $fname
 752
 753         set no [z39.$setNo numberOfRecordsReturned]
 754         add-title-lines $setNo $no 1
 755     }
 756     set l [format "%-4d %7d" $setNo $no]
 757     .top.rset.m add command -label $l \
 758             -command [list add-title-lines $setNo 10000 1]
 759     show-status {Ready} 0 {}
 760 }
 761
 762 proc load-set {} {
 763     set w .load-set
 764
 765     set oldFocus [focus]
 766     toplevel $w
 767
 768     place-force $w .
 769     top-down-window $w
 770
 771     frame $w.top.filename
 772     pack $w.top.filename -side top -anchor e -pady 2
 773
 774     entry-fields $w.top {filename} \
 775             {{Filename:}} \
 776             {load-set-action} {destroy .load-set}
 777
 778     top-down-ok-cancel $w {load-set-action} 1
 779     focus $oldFocus
 780 }
 781
 782 proc init-request {} {
 783     global setNo
 784     global cancelFlag
 785
 786     if {$cancelFlag} {
 787         close-target
 788         return
 789     }
 790     z39 callback {init-response}
 791     show-status {Initializing} 1 {}
 792     z39 init
 793 }
 794
 795 proc init-response {} {
 796     global cancelFlag
 797     global scanEnable
 798
 799     if {$cancelFlag} {
 800         close-target
 801         return
 802     }
 803     if {![z39 initResult]} {
 804         show-status {Ready} 0 1
 805         set u [z39 userInformationField]
 806         close-target
 807         tkerror "Connection rejected by target: $u"
 808     } else {
 809         if {[lsearch [z39 options] scan] >= 0} {
 810             set scanEnable 1
 811         } else {
 812             set scanEnable 0
 813         }
 814         show-status {Ready} 0 1
 815     }
 816 }
 817
 818 proc search-request {} {
 819     global setNo
 820     global profile
 821     global hostid
 822     global busy
 823     global cancelFlag
 824     global searchEnable
 825
 826     set target $hostid
 827
 828     if {$searchEnable == 0} {
 829         return
 830     }
 831     set query [index-query]
 832     if {$query==""} {
 833         return
 834     }
 835     incr setNo
 836     ir-set z39.$setNo z39
 837     z39.$setNo preferredRecordSyntax SUTRS
 838
 839     if {[lindex $profile($target) 10] == 1} {
 840         z39.$setNo setName $setNo
 841         puts "setName=${setNo}"
 842     } else {
 843         z39.$setNo setName Default
 844         puts "setName=Default"
 845     }
 846     if {[lindex $profile($target) 8] == 1} {
 847         z39.$setNo queryType rpn
 848     }
 849     if {[lindex $profile($target) 9] == 1} {
 850         z39.$setNo queryType ccl
 851     }
 852     z39 callback {search-response}
 853     z39.$setNo search $query
 854     show-status {Searching} 1 0
 855 }
 856
 857 proc scan-copy {y entry} {
 858     set w .scan-window
 859     set no [$w.top.list nearest $y]
 860     puts "no=$no"
 861     .lines.$entry.e delete 0 end
 862     .lines.$entry.e insert 0 [string range [$w.top.list get $no] 8 end]
 863 }
 864
 865 proc scan-request {} {
 866     set w .scan-window
 867
 868     global profile
 869     global hostid
 870     global scanView
 871     global scanTerm
 872     global curIndexEntry
 873     global queryButtonsFind
 874     global queryInfoFind
 875
 876     set target $hostid
 877     set scanView 0
 878     set scanTerm {}
 879
 880     set b [lindex $queryButtonsFind $curIndexEntry]
 881     set attr {}
 882     foreach a [lrange [lindex $queryInfoFind [lindex $b 1]] 1 end] {
 883         set attr "@attr $a $attr"
 884     }
 885     set title [lindex [lindex $queryInfoFind [lindex $b 1]] 0]
 886     ir-scan z39.scan z39
 887
 888     if {![winfo exists $w]} {
 889         toplevelG $w
 890
 891         wm minsize $w 0 0
 892
 893         top-down-window $w
 894
 895         entry $w.top.entry -relief sunken
 896         pack $w.top.entry -fill x -padx 4 -pady 2
 897         bind $w.top.entry <KeyRelease> [list scan-term-h $attr]
 898         if {1} {
 899             listbox $w.top.list -yscrollcommand [list $w.top.scroll set] \
 900                     -font fixed
 901             scrollbar $w.top.scroll -orient vertical -border 1
 902             pack $w.top.list -side left -fill both -expand yes
 903             pack $w.top.scroll -side right -fill y
 904             $w.top.scroll config -command [list $w.top.list yview]
 905         } else {
 906             listbox $w.top.list -font fixed -geometry 60x14
 907             pack $w.top.list -side left -fill both -expand yes
 908         }
 909
 910         bottom-buttons $w [list {Close} [list destroy $w] \
 911                 {Up} [list scan-up $attr] \
 912                 {Down} [list scan-down $attr]] 0
 913         bind $w.top.list <Up> [list scan-up $attr]
 914         bind $w.top.list <Down> [list scan-down $attr]
 915     }
 916     bind $w.top.list <Double-Button-1> [list scan-copy %y $curIndexEntry]
 917     wm title $w "Scan $title"
 918
 919     z39 callback [list scan-response $attr 0 35]
 920     z39.scan numberOfTermsRequested 5
 921     z39.scan preferredPositionInResponse 1
 922     z39.scan scan "${attr} 0"
 923
 924     show-status {Scanning} 1 0
 925 }
 926
 927 proc scan-term-h {attr} {
 928     global busy
 929     global scanTerm
 930
 931     if {$busy} {
 932         return
 933     }
 934     set w .scan-window
 935     set nScanTerm [$w.top.entry get]
 936     if {$nScanTerm == $scanTerm} {
 937         return
 938     }
 939     set scanTerm $nScanTerm
 940     z39 callback [list scan-response $attr 0 35]
 941     z39.scan numberOfTermsRequested 5
 942     z39.scan preferredPositionInResponse 1
 943     puts "${attr} \{${scanTerm}\}"
 944     if {$scanTerm == ""} {
 945         z39.scan scan "${attr} 0"
 946     } else {
 947         z39.scan scan "${attr} \{${scanTerm}\}"
 948     }
 949     show-status {Scanning} 1 0
 950 }
 951
 952 proc scan-response {attr start toget} {
 953     global cancelFlag
 954     global scanTerm
 955     global scanView
 956
 957     set w .scan-window
 958     puts "In scan-response"
 959     set m [z39.scan numberOfEntriesReturned]
 960     puts $m
 961     puts attr=$attr
 962     puts start=$start
 963     puts toget=$toget
 964
 965     if {![winfo exists .scan-window]} {
 966         show-status {Ready} 0 1
 967         set cancelFlag 0
 968         return
 969     }
 970     set nScanTerm [$w.top.entry get]
 971     if {$nScanTerm != $scanTerm} {
 972         z39 callback [list scan-response $attr 0 35]
 973         z39.scan numberOfTermsRequested 5
 974         z39.scan preferredPositionInResponse 1
 975         set scanTerm $nScanTerm
 976         puts "${attr} \{${scanTerm}\}"
 977         if {$scanTerm == ""} {
 978             z39.scan scan "${attr} 0"
 979         } else {
 980             z39.scan scan "${attr} \{${scanTerm}\}"
 981         }
 982         show-status {Scanning} 1 0
 983         return
 984     }
 985     set status [z39.scan scanStatus]
 986     if {$status == 6} {
 987         tkerror "Scan fail"
 988         show-status {Ready} 0 1
 989         set cancelFlag 0
 990         return
 991     }
 992     if {$toget < 0} {
 993         for {set i 0} {$i < $m} {incr i} {
 994             set term [lindex [z39.scan scanLine $i] 1]
 995             set nostr [format " %-6d" [lindex [z39.scan scanLine $i] 2]]
 996             $w.top.list insert $i "$nostr $term"
 997         }
 998         incr scanView $m
 999         $w.top.list yview $scanView
1000     } else {
1001         $w.top.list delete $start end
1002         for {set i 0} {$i < $m} {incr i} {
1003             set term [lindex [z39.scan scanLine $i] 1]
1004             set nostr [format " %-6d" [lindex [z39.scan scanLine $i] 2]]
1005             $w.top.list insert end "$nostr $term"
1006         }
1007     }
1008     if {$cancelFlag} {
1009         show-status {Ready} 0 1
1010         set cancelFlag 0
1011         return
1012     }
1013     if {$toget > 0 && $m > 1 && $m < $toget} {
1014         set ntoget [expr $toget - $m + 1]
1015         puts ntoget=$ntoget
1016         z39 callback [list scan-response $attr [expr $start + $m - 1] $ntoget]
1017         set q $term
1018         puts "down continue: $q"
1019         if {$ntoget > 10} {
1020             z39.scan numberOfTermsRequested 10
1021         } else {
1022             z39.scan numberOfTermsRequested $ntoget
1023         }
1024         z39.scan preferredPositionInResponse 1
1025         puts "${attr} \{$q\}"
1026         z39.scan scan "${attr} \{$q\}"
1027         return
1028     }
1029     if {$toget < 0 && $m > 1 && $m < [expr - $toget]} {
1030         set ntoget [expr - $toget - $m]
1031         puts ntoget=$ntoget
1032         z39 callback [list scan-response $attr 0 -$ntoget]
1033         set q [string range [$w.top.list get 0] 8 end]
1034         puts "up continue: $q"
1035         if {$ntoget > 10} {
1036             z39.scan numberOfTermsRequested 10
1037             z39.scan preferredPositionInResponse 11
1038         } else {
1039             z39.scan numberOfTermsRequested $ntoget
1040             z39.scan preferredPositionInResponse [incr ntoget]
1041         }
1042         puts "${attr} \{$q\}"
1043         z39.scan scan "${attr} \{$q\}"
1044         return
1045     }
1046     show-status {Ready} 0 1
1047 }
1048
1049 proc scan-down {attr} {
1050     global scanView
1051
1052     set w .scan-window
1053     set scanView [expr $scanView + 5]
1054     set s [$w.top.list size]
1055     if {$scanView > $s} {
1056         z39 callback [list scan-response $attr [expr $s - 1] 25]
1057         set q [string range [$w.top.list get [expr $s - 1]] 8 end]
1058         puts "down: $q"
1059         z39.scan numberOfTermsRequested 10
1060         z39.scan preferredPositionInResponse 1
1061         show-status {Scanning} 1 0
1062         puts "${attr} \{$q\}"
1063         z39.scan scan "${attr} \{$q\}"
1064         return
1065     }
1066     $w.top.list yview $scanView
1067 }
1068
1069 proc scan-up {attr} {
1070     global scanView
1071
1072     set w .scan-window
1073     set scanView [expr $scanView - 5]
1074     if {$scanView < 0} {
1075         z39 callback [list scan-response $attr 0 -25]
1076         set q [string range [$w.top.list get 0] 8 end]
1077         puts "up: $q"
1078         z39.scan numberOfTermsRequested 10
1079         z39.scan preferredPositionInResponse 11
1080         show-status {Scanning} 1 0
1081         z39.scan scan "${attr} \{$q\}"
1082         return
1083     }
1084     $w.top.list yview $scanView
1085 }
1086
1087 proc search-response {} {
1088     global setNo
1089     global setOffset
1090     global setMax
1091     global cancelFlag
1092     global busy
1093
1094     puts "In search-response"
1095     init-title-lines
1096     set setMax [z39.$setNo resultCount]
1097     show-message "${setMax} hits"
1098     set l [format "%-4d %7d" $setNo $setMax]
1099     .top.rset.m add command -label $l \
1100             -command [list add-title-lines $setNo 10000 1]
1101     if {$setMax <= 0} {
1102         show-status {Ready} 0 1
1103         set status [z39.$setNo responseStatus]
1104         if {[lindex $status 0] == "NSD"} {
1105             set code [lindex $status 1]
1106             set msg [lindex $status 2]
1107             set addinfo [lindex $status 3]
1108             tkerror "NSD$code: $msg: $addinfo"
1109         }
1110         return
1111     }
1112     if {$setMax > 20} {
1113         set setMax 20
1114     }
1115     set setOffset 1
1116     show-status {Ready} 0 1
1117     if {$cancelFlag} {
1118         set cancelFlag 0
1119         return
1120     }
1121     z39 callback {present-response}
1122     z39.$setNo present $setOffset 1
1123     show-status {Retrieving} 1 0
1124 }
1125
1126 proc present-more {number} {
1127     global setNo
1128     global setOffset
1129     global setMax
1130
1131     puts "setOffset=$setOffset"
1132     puts "present-more"
1133     if {$setNo == 0} {
1134         puts "setNo=$setNo"
1135         return
1136     }
1137     set max [z39.$setNo resultCount]
1138     if {$max <= $setOffset} {
1139         puts "max=$max"
1140         puts "setOffset=$setOffset"
1141         return
1142     }
1143     if {$number == ""} {
1144         set setMax $max
1145     } else {
1146         incr setMax $number
1147         if {$setMax > $max} {
1148             set setMax $max
1149         }
1150     }
1151     z39 callback {present-response}
1152
1153     set toGet [expr $setMax - $setOffset + 1]
1154     if {$toGet <= 0} {
1155         return
1156     }
1157     if {$toGet > 3} {
1158         set toGet 3
1159     }
1160     z39.$setNo present $setOffset $toGet
1161     show-status {Retrieving} 1 0
1162 }
1163
1164 proc init-title-lines {} {
1165     .data.record delete 0.0 end
1166 }
1167
1168 proc title-press {y setno} {
1169     show-full-marc $setno [expr 1 + [.data.list nearest $y]] 0
1170 }
1171
1172 proc add-title-lines {setno no offset} {
1173     global displayFormats
1174     global displayFormat
1175     global lastSetNo
1176
1177     if {$setno == 0} {
1178         set setno $lastSetNo
1179     } else {
1180         set lastSetNo $setno
1181     }
1182     if {$offset == 1} {
1183         .bot.a.set configure -text $setno
1184         .data.record delete 0.0 end
1185     }
1186     set ffunc [lindex $displayFormats $displayFormat]
1187     set ffunc "display-$ffunc"
1188     for {set i 0} {$i < $no} {incr i} {
1189         set o [expr $i + $offset]
1190         set type [z39.$setno type $o]
1191         if {$type == ""} {
1192             break
1193         }
1194         .data.record tag bind r$o <Any-Enter> {}
1195         .data.record tag bind r$o <Any-Leave> {}
1196         set insert0 [.data.record index insert]
1197         $ffunc $setno $o .data.record 1
1198         .data.record tag add r$o $insert0 insert
1199         .data.record tag bind r$o <1> \
1200                 [list popup-marc $setno $o 0 0]
1201         update idletasks
1202     }
1203 }
1204
1205 proc present-response {} {
1206     global setNo
1207     global setOffset
1208     global setMax
1209     global cancelFlag
1210
1211     puts "In present-response"
1212     set no [z39.$setNo numberOfRecordsReturned]
1213     puts "Returned $no records, setOffset $setOffset"
1214     add-title-lines $setNo $no $setOffset
1215     set setOffset [expr $setOffset + $no]
1216     set status [z39.$setNo responseStatus]
1217     if {[lindex $status 0] == "NSD"} {
1218         show-status {Ready} 0 1
1219         set code [lindex $status 1]
1220         set msg [lindex $status 2]
1221         set addinfo [lindex $status 3]
1222         tkerror "NSD$code: $msg: $addinfo"
1223         return
1224     }
1225     if {$cancelFlag} {
1226         show-status {Ready} 0 1
1227         set cancelFlag 0
1228         return
1229     }
1230     if {$no > 0 && $setOffset <= $setMax} {
1231         puts "present-request from ${setOffset}"
1232         set toGet [expr $setMax - $setOffset + 1]
1233         if {$toGet > 3} {
1234             set toGet 3
1235         }
1236         z39.$setNo present $setOffset $toGet
1237     } else {
1238         show-status {Ready} 0 1
1239     }
1240 }
1241
1242 proc left-cursor {w} {
1243     set i [$w index insert]
1244     if {$i > 0} {
1245         incr i -1
1246         $w icursor $i
1247     }
1248 }
1249
1250 proc right-cursor {w} {
1251     set i [$w index insert]
1252     incr i
1253     $w icursor $i
1254 }
1255
1256 proc bind-fields {list returnAction escapeAction} {
1257     set max [expr [llength $list]-1]
1258     for {set i 0} {$i < $max} {incr i} {
1259         bind [lindex $list $i] <Return> $returnAction
1260         bind [lindex $list $i] <Escape> $escapeAction
1261         bind [lindex $list $i] <Tab> [list focus [lindex $list [expr $i+1]]]
1262         bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
1263         bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
1264     }
1265     bind [lindex $list $i] <Return> $returnAction
1266     bind [lindex $list $i] <Escape> $escapeAction
1267     bind [lindex $list $i] <Tab>    [list focus [lindex $list 0]]
1268     bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
1269     bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
1270     focus [lindex $list 0]
1271 }
1272
1273 proc entry-fields {parent list tlist returnAction escapeAction} {
1274     set alist {}
1275     set i 0
1276     foreach field $list {
1277         set label ${parent}.${field}.label
1278         set entry ${parent}.${field}.entry
1279         label $label -text [lindex $tlist $i] -anchor e
1280         entry $entry -width 32 -relief sunken
1281         pack $label -side left
1282         pack $entry -side right
1283         lappend alist $entry
1284         incr i
1285     }
1286     bind-fields $alist $returnAction $escapeAction
1287 }
1288
1289 proc define-target-dialog {} {
1290     set w .target-define
1291
1292     toplevel $w
1293     place-force $w .
1294     top-down-window $w
1295     frame $w.top.target
1296     pack $w.top.target \
1297             -side top -anchor e -pady 2
1298     entry-fields $w.top {target} \
1299             {{Target:}} \
1300             {define-target-action} {destroy .target-define}
1301     top-down-ok-cancel $w {define-target-action} 1
1302 }
1303
1304 proc protocol-setup-delete {target} {
1305     global profile
1306
1307     set a [alert "Are you sure you want to delete the target \
1308 definition $target ?"]
1309     if {$a} {
1310         set wno [lindex $profile($target) 12]
1311         set w .setup-${wno}
1312         destroy $w
1313         unset profile($target)
1314         cascade-target-list
1315     }
1316 }
1317
1318 proc protocol-setup-action {target} {
1319     global profile
1320     global csRadioType
1321     global protocolRadioType
1322     global settingsChanged
1323     global RPNCheck
1324     global CCLCheck
1325     global ResultSetCheck
1326
1327     set wno [lindex $profile($target) 12]
1328     set w .setup-${wno}
1329
1330     set b {}
1331     set settingsChanged 1
1332     set len [$w.top.databases.list size]
1333     for {set i 0} {$i < $len} {incr i} {
1334         lappend b [$w.top.databases.list get $i]
1335     }
1336     set profile($target) [list [$w.top.description.entry get] \
1337             [$w.top.host.entry get] \
1338             [$w.top.port.entry get] \
1339             [$w.top.idAuthentication.entry get] \
1340             [$w.top.maximumRecordSize.entry get] \
1341             [$w.top.preferredMessageSize.entry get] \
1342             $csRadioType \
1343             $b \
1344             $RPNCheck \
1345             $CCLCheck \
1346             $ResultSetCheck \
1347             $protocolRadioType \
1348             $wno]
1349
1350     cascade-target-list
1351     puts $profile($target)
1352     destroy $w
1353 }
1354
1355 proc place-force {window parent} {
1356     set g [wm geometry $parent]
1357
1358     set p1 [string first + $g]
1359     set p2 [string last + $g]
1360
1361     set x [expr 40+[string range $g [expr $p1 +1] [expr $p2 -1]]]
1362     set y [expr 60+[string range $g [expr $p2 +1] end]]
1363     wm geometry $window +${x}+${y}
1364 }
1365
1366 proc add-database-action {target} {
1367     global profile
1368
1369     set wno [lindex $profile($target) 12]
1370     set w .setup-${wno}
1371
1372     $w.top.databases.list insert end \
1373             [.database-select.top.database.entry get]
1374     destroy .database-select
1375 }
1376
1377 proc add-database {target} {
1378     global profile
1379
1380     set w .database-select
1381
1382     set oldFocus [focus]
1383     toplevel $w
1384
1385     set wno [lindex $profile($target) 12]
1386     place-force $w .setup-${wno}
1387
1388     top-down-window $w
1389
1390     frame $w.top.database
1391
1392     pack $w.top.database -side top -anchor e -pady 2
1393
1394     entry-fields $w.top {database} \
1395             {{Database to add:}} \
1396             [list add-database-action $target] {destroy .database-select}
1397
1398     top-down-ok-cancel $w [list add-database-action $target] 1
1399     focus $oldFocus
1400 }
1401
1402 proc delete-database {target} {
1403     global profile
1404
1405     set wno [lindex $profile($target) 12]
1406     set w .setup-${wno}
1407     set l {}
1408     foreach i [$w.top.databases.list curselection] {
1409         set b [$w.top.databases.list get $i]
1410         set l "$l $b"
1411     }
1412     set a [alert "Are you sure you want to remove the database(s)${l}?"]
1413     if {$a} {
1414         foreach i [lsort -decreasing \
1415                 [$w.top.databases.list curselection]] {
1416             $w.top.databases.list delete $i
1417         }
1418     }
1419 }
1420
1421 proc protocol-setup {target} {
1422     global profile
1423     global csRadioType
1424     global protocolRadioType
1425     global RPNCheck
1426     global CCLCheck
1427     global ResultSetCheck
1428
1429     set wno [lindex $profile($target) 12]
1430     set w .setup-${wno}
1431
1432     toplevelG $w
1433
1434     wm title $w "Setup $target"
1435
1436     top-down-window $w
1437
1438     if {$target == ""} {
1439         set target Default
1440     }
1441     puts target
1442     puts $profile($target)
1443
1444     frame $w.top.host
1445     frame $w.top.port
1446     frame $w.top.description
1447     frame $w.top.idAuthentication
1448     frame $w.top.maximumRecordSize
1449     frame $w.top.preferredMessageSize
1450     frame $w.top.cs-type -relief ridge -border 2
1451     frame $w.top.protocol -relief ridge -border 2
1452     frame $w.top.query -relief ridge -border 2
1453     frame $w.top.databases -relief ridge -border 2
1454
1455     # Maximum/preferred/idAuth ...
1456     pack $w.top.description $w.top.host $w.top.port \
1457             $w.top.idAuthentication $w.top.maximumRecordSize \
1458             $w.top.preferredMessageSize -side top -anchor e -pady 2
1459
1460     entry-fields $w.top {description host port idAuthentication \
1461             maximumRecordSize preferredMessageSize} \
1462             {{Description:} {Host:} {Port:} {Id Authentication:} \
1463             {Maximum Record Size:} {Preferred Message Size:}} \
1464             [list protocol-setup-action $target] [list destroy $w]
1465
1466     foreach sub {description host port idAuthentication \
1467             maximumRecordSize preferredMessageSize} {
1468         puts $sub
1469         bind $w.top.$sub.entry <Control-a> [list add-database $target]
1470         bind $w.top.$sub.entry <Control-d> [list delete-database $target]
1471     }
1472     $w.top.description.entry insert 0 [lindex $profile($target) 0]
1473     $w.top.host.entry insert 0 [lindex $profile($target) 1]
1474     $w.top.port.entry insert 0 [lindex $profile($target) 2]
1475     $w.top.idAuthentication.entry insert 0 [lindex $profile($target) 3]
1476     $w.top.maximumRecordSize.entry insert 0 [lindex $profile($target) 4]
1477     $w.top.preferredMessageSize.entry insert 0 [lindex $profile($target) 5]
1478     set csRadioType [lindex $profile($target) 6]
1479     set RPNCheck [lindex $profile($target) 8]
1480     set CCLCheck [lindex $profile($target) 9]
1481     set ResultSetCheck [lindex $profile($target) 10]
1482     set protocolRadioType [lindex $profile($target) 11]
1483     if {$protocolRadioType == ""} {
1484         set protocolRadioType z39v2
1485     }
1486
1487     # Databases ....
1488     pack $w.top.databases -side left -pady 4 -padx 4 -expand yes -fill both
1489
1490     label $w.top.databases.label -text "Databases"
1491     button $w.top.databases.add -text "Add" \
1492             -command [list add-database $target]
1493     button $w.top.databases.delete -text "Delete" \
1494             -command [list delete-database $target]
1495     listbox $w.top.databases.list -geometry 20x6 \
1496             -yscrollcommand "$w.top.databases.scroll set"
1497     scrollbar $w.top.databases.scroll -orient vertical -border 1
1498     pack $w.top.databases.label -side top -fill x \
1499             -padx 2 -pady 2
1500     pack $w.top.databases.add $w.top.databases.delete -side top -fill x \
1501             -padx 2 -pady 2
1502     pack $w.top.databases.list -side left -fill both -expand yes \
1503             -padx 2 -pady 2
1504     pack $w.top.databases.scroll -side right -fill y \
1505             -padx 2 -pady 2
1506     $w.top.databases.scroll config -command "$w.top.databases.list yview"
1507
1508     foreach b [lindex $profile($target) 7] {
1509         $w.top.databases.list insert end $b
1510     }
1511
1512     # Transport ...
1513     pack $w.top.cs-type -pady 4 -padx 4 -side top -fill x
1514
1515     label $w.top.cs-type.label -text "Transport"
1516     radiobutton $w.top.cs-type.tcpip -text "TCP/IP" -anchor w \
1517             -command {puts tcp/ip} -variable csRadioType -value tcpip
1518     radiobutton $w.top.cs-type.mosi -text "MOSI" -anchor w\
1519             -command {puts mosi} -variable csRadioType -value mosi
1520
1521     pack $w.top.cs-type.label $w.top.cs-type.tcpip $w.top.cs-type.mosi \
1522             -padx 4 -side top -fill x
1523
1524     # Protocol ...
1525     pack $w.top.protocol -pady 4 -padx 4 -side top -fill x
1526
1527     label $w.top.protocol.label -text "Protocol"
1528     radiobutton $w.top.protocol.z39v2 -text "Z39.50" -anchor w \
1529             -command {puts z39v2} -variable protocolRadioType -value z39v2
1530     radiobutton $w.top.protocol.sr -text "SR" -anchor w \
1531             -command {puts sr} -variable protocolRadioType -value sr
1532
1533     pack $w.top.protocol.label $w.top.protocol.z39v2 $w.top.protocol.sr \
1534             -padx 4 -side top -fill x
1535
1536     # Query ...
1537     pack $w.top.query -pady 4 -padx 4 -side top -fill x
1538
1539     label $w.top.query.label -text "Query support"
1540     checkbutton $w.top.query.c1 -text "RPN query" -anchor w -variable RPNCheck
1541     checkbutton $w.top.query.c2 -text "CCL query" -anchor w -variable CCLCheck
1542     checkbutton $w.top.query.c3 -text "Result sets" -anchor w -variable ResultSetCheck
1543
1544     pack $w.top.query.label -side top
1545     pack $w.top.query.c1 $w.top.query.c2 $w.top.query.c3 \
1546             -padx 4 -side top -fill x
1547
1548     # Ok-cancel
1549     bottom-buttons $w [list {Ok} [list protocol-setup-action $target] \
1550             {Delete} [list protocol-setup-delete $target] \
1551             {Cancel} [list destroy $w]] 0
1552 }
1553
1554 proc database-select-action {} {
1555     set w .database-select.top
1556     set b {}
1557     foreach indx [$w.databases.list curselection] {
1558         lappend b [$w.databases.list get $indx]
1559     }
1560     if {$b != ""} {
1561         z39 databaseNames $b
1562     }
1563     destroy .database-select
1564 }
1565
1566 proc database-select {} {
1567     set w .database-select
1568     global profile
1569     global hostid
1570
1571     toplevel $w
1572
1573     place-force $w .
1574
1575     top-down-window $w
1576
1577     frame $w.top.databases -relief ridge -border 2
1578
1579     pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill x
1580
1581     label $w.top.databases.label -text "List"
1582     listbox $w.top.databases.list -geometry 20x6 \
1583             -yscrollcommand "$w.top.databases.scroll set"
1584     scrollbar $w.top.databases.scroll -orient vertical -border 1
1585     pack $w.top.databases.label -side top -fill x \
1586             -padx 2 -pady 2
1587     pack $w.top.databases.list -side left -fill both -expand yes \
1588             -padx 2 -pady 2
1589     pack $w.top.databases.scroll -side right -fill y \
1590             -padx 2 -pady 2
1591     $w.top.databases.scroll config -command "$w.top.databases.list yview"
1592
1593     foreach b [lindex $profile($hostid) 7] {
1594         $w.top.databases.list insert end $b
1595     }
1596     top-down-ok-cancel $w {database-select-action} 1
1597 }
1598
1599 proc cascade-target-list {} {
1600     global profile
1601
1602     foreach sub [winfo children .top.target.m.clist] {
1603         destroy $sub
1604     }
1605     .top.target.m.clist delete 0 last
1606     foreach n [array names profile] {
1607         if {$n != "Default"} {
1608             set nl [lindex $profile($n) 12]
1609             if {[llength [lindex $profile($n) 7]] > 1} {
1610                 .top.target.m.clist add cascade -label $n \
1611                         -menu .top.target.m.clist.$nl
1612                 menu .top.target.m.clist.$nl
1613                 foreach b [lindex $profile($n) 7] {
1614                     .top.target.m.clist.$nl add command -label $b \
1615                             -command [list reopen-target $n $b]
1616                 }
1617             } else {
1618                 .top.target.m.clist add command -label $n \
1619                         -command [list reopen-target $n {}]
1620             }
1621         }
1622     }
1623     .top.target.m.slist delete 0 last
1624     foreach n [array names profile] {
1625         if {$n != "Default"} {
1626             .top.target.m.slist add command -label $n \
1627                     -command [list protocol-setup $n]
1628         }
1629     }
1630 }
1631
1632 proc query-select {i} {
1633     global queryButtonsFind
1634     global queryInfoFind
1635     global queryButtons
1636     global queryInfo
1637
1638     set queryInfoFind [lindex $queryInfo $i]
1639     set queryButtonsFind [lindex $queryButtons $i]
1640
1641     index-lines .lines 1 $queryButtonsFind $queryInfoFind activate-index
1642 }
1643
1644 proc query-new-action {} {
1645     global queryTypes
1646     global queryButtons
1647     global queryInfo
1648     global settingsChanged
1649
1650     set settingsChanged 1
1651     lappend queryTypes [.query-new.top.index.entry get]
1652     lappend queryButtons {}
1653     lappend queryInfo {}
1654
1655     destroy .query-new
1656     cascade-query-list
1657 }
1658
1659 proc query-new {} {
1660     set w .query-new
1661
1662     toplevel $w
1663     place-force $w .
1664     top-down-window $w
1665     frame $w.top.index
1666     pack $w.top.index \
1667             -side top -anchor e -pady 2
1668     entry-fields $w.top index \
1669             {{Query Name:}} \
1670             query-new-action {destroy .query-new}
1671     top-down-ok-cancel $w query-new-action 1
1672 }
1673
1674 proc query-delete-action {queryNo} {
1675     global queryTypes
1676     global queryButtons
1677     global queryInfo
1678     global settingsChanged
1679
1680     set settingsChanged 1
1681
1682     set queryTypes [lreplace $queryTypes $queryNo $queryNo]
1683     set queryButtons [lreplace $queryButtons $queryNo $queryNo]
1684     set queryInfo [lreplace $queryInfo $queryNo $queryNo]
1685     destroy .query-delete
1686     cascade-query-list
1687 }
1688
1689 proc query-delete {queryNo} {
1690     global queryTypes
1691
1692     set w .query-delete
1693
1694     toplevel $w
1695     place-force $w .
1696     top-down-window $w
1697     set n [lindex $queryTypes $queryNo]
1698
1699     label $w.top.warning -bitmap warning
1700     message $w.top.quest -text "Are you sure you want to delete the \
1701 query type $n ?"  -aspect 200
1702     pack $w.top.warning $w.top.quest -side left -expand yes -padx 10 -pady 5
1703     bottom-buttons $w [list {Ok} [list query-delete-action $queryNo] \
1704                             {Cancel} [list destroy $w]] 1
1705 }
1706
1707 proc cascade-query-list {} {
1708     global queryTypes
1709     set w .top.options.m.query
1710
1711     set i 0
1712     $w.slist delete 0 last
1713     foreach n $queryTypes {
1714         $w.slist add command -label $n -command [list query-setup $i]
1715         incr i
1716     }
1717
1718     set i 0
1719     $w.clist delete 0 last
1720     foreach n $queryTypes {
1721         $w.clist add command -label $n -command [list query-select $i]
1722         incr i
1723     }
1724     set i 0
1725     $w.dlist delete 0 last
1726     foreach n $queryTypes {
1727         $w.dlist add command -label $n -command [list query-delete $i]
1728         incr i
1729     }
1730 }
1731
1732 proc save-geometry {} {
1733     global windowGeometry
1734     global hotTargets
1735     global textWrap
1736     global displayFormat
1737     global popupMarcdf
1738
1739     set windowGeometry(.) [wm geometry .]
1740
1741     set f [open "clientg.tcl" w]
1742
1743     puts $f "set hotTargets \{ $hotTargets \}"
1744     puts $f "set textWrap $textWrap"
1745     puts $f "set displayFormat $displayFormat"
1746     puts $f "set popupMarcdf $popupMarcdf"
1747     foreach n [array names windowGeometry] {
1748         puts -nonewline $f "set \{windowGeometry($n)\} \{"
1749         puts -nonewline $f $windowGeometry($n)
1750         puts $f "\}"
1751     }
1752     close $f
1753 }
1754
1755 proc save-settings {} {
1756     global profile
1757     global settingsChanged
1758     global queryTypes
1759     global queryButtons
1760     global queryInfo
1761
1762     set f [open "clientrc.tcl" w]
1763     puts $f "# Setup file"
1764
1765     foreach n [array names profile] {
1766         puts -nonewline $f "set \{profile($n)\} \{"
1767         puts -nonewline $f $profile($n)
1768         puts $f "\}"
1769     }
1770     puts -nonewline $f "set queryTypes \{"
1771     puts -nonewline $f $queryTypes
1772     puts $f "\}"
1773
1774     puts -nonewline $f "set queryButtons \{"
1775     puts -nonewline $f $queryButtons
1776     puts $f "\}"
1777
1778     puts -nonewline $f "set queryInfo \{"
1779     puts -nonewline $f $queryInfo
1780     puts $f "\}"
1781     close $f
1782     set settingsChanged 0
1783 }
1784
1785 proc alert {ask} {
1786     set w .alert
1787
1788     global alertAnswer
1789
1790     toplevel $w
1791     place-force $w .
1792     top-down-window $w
1793
1794     label $w.top.warning -bitmap warning
1795     message $w.top.message -text $ask -aspect 200 \
1796             -font -Adobe-Times-Medium-R-Normal-*-180-*
1797
1798     pack $w.top.warning $w.top.message -side left -pady 5 -padx 10 -expand yes
1799
1800     set alertAnswer 0
1801     top-down-ok-cancel $w {alert-action} 1
1802     return $alertAnswer
1803 }
1804
1805 proc alert-action {} {
1806     global alertAnswer
1807     set alertAnswer 1
1808     destroy .alert
1809 }
1810
1811 proc exit-action {} {
1812     global settingsChanged
1813
1814     if {$settingsChanged} {
1815         set a [alert "you havent saved your settings. Do you wish to save?"]
1816         if {$a} {
1817             save-settings
1818         }
1819     }
1820     save-geometry
1821     exit 0
1822 }
1823
1824 proc listbuttonaction {w name h user i} {
1825     $w configure -text [lindex $name 0]
1826     $h [lindex $name 1] $user $i
1827 }
1828
1829 proc listbuttonx {button no names handle user} {
1830     if {[winfo exists $button]} {
1831         $button configure -text [lindex [lindex $names $no] 0]
1832         ${button}.m delete 0 last
1833     } else {
1834         menubutton $button -text [lindex [lindex $names $no] 0] \
1835                 -width 10 -menu ${button}.m -relief raised -border 1
1836         menu ${button}.m
1837     }
1838     set i 0
1839     foreach name $names {
1840         ${button}.m add command -label [lindex $name 0] \
1841                 -command [list listbuttonaction ${button} $name \
1842                 $handle $user $i]
1843         incr i
1844     }
1845 }
1846
1847 proc listbutton {button no names} {
1848     menubutton $button -text [lindex $names $no] -width 10 -menu ${button}.m \
1849             -relief raised -border 1
1850     menu ${button}.m
1851     foreach name $names {
1852         ${button}.m add command -label $name \
1853                 -command [list ${button} configure -text $name]
1854     }
1855 }
1856
1857 proc listbuttonv-action {button var names i} {
1858     global $var
1859
1860     set $var [lindex $names [expr $i+1]]
1861     $button configure -text [lindex $names $i]
1862 }
1863
1864 proc listbuttonv {button var names} {
1865     global $var
1866
1867     set n "-"
1868     eval "set val $$var"
1869     set l [llength $names]
1870     for {set i 1} {$i < $l} {incr i 2} {
1871         if {$val == [lindex $names $i]} {
1872             incr i -1
1873             set n [lindex $names $i]
1874             break
1875         }
1876     }
1877     if {[winfo exists $button]} {
1878         $button configure -text $n
1879         return
1880     }
1881     menubutton $button -text $n -menu ${button}.m \
1882             -relief raised -border 1
1883     menu ${button}.m
1884     for {set i 0} {$i < $l} {incr i 2} {
1885         ${button}.m add command -label [lindex $names $i] \
1886                 -command [list listbuttonv-action $button $var $names $i]
1887     }
1888 }
1889
1890 proc query-add-index-action {queryNo} {
1891     set w .query-setup
1892
1893     global queryInfoTmp
1894     global queryButtonsTmp
1895
1896     set newI [.query-add-index.top.index.entry get]
1897     lappend queryInfoTmp [list $newI {}]
1898     $w.top.index.list insert end $newI
1899     destroy .query-add-index
1900     #destroy $w.top.lines
1901     #frame $w.top.lines -relief ridge -border 2
1902     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1903     #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1904 }
1905
1906 proc query-add-line {queryNo} {
1907     set w .query-setup
1908
1909     global queryInfoTmp
1910     global queryButtonsTmp
1911
1912     lappend queryButtonsTmp {I 0}
1913
1914     #destroy $w.top.lines
1915     #frame $w.top.lines -relief ridge -border 2
1916     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1917     #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1918 }
1919
1920 proc query-del-line {queryNo} {
1921     set w .query-setup
1922
1923     global queryInfoTmp
1924     global queryButtonsTmp
1925
1926     set l [llength $queryButtonsTmp]
1927     if {$l <= 0} {
1928         return
1929     }
1930     incr l -1
1931     set queryButtonsTmp [lreplace $queryButtonsTmp $l $l]
1932     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1933 }
1934
1935 proc query-add-index {queryNo} {
1936     set w .query-add-index
1937
1938     toplevel $w
1939     place-force $w .query-setup
1940     top-down-window $w
1941     frame $w.top.index
1942     pack $w.top.index \
1943             -side top -anchor e -pady 2
1944     entry-fields $w.top {index} \
1945             {{Index Name:}} \
1946             [list query-add-index-action $queryNo] [list destroy $w]
1947     top-down-ok-cancel $w [list query-add-index-action $queryNo] 1
1948 }
1949
1950 proc query-setup-action {queryNo} {
1951     global queryButtons
1952     global queryInfo
1953     global queryButtonsTmp
1954     global queryInfoTmp
1955     global queryButtonsFind
1956     global queryInfoFind
1957
1958     global settingsChanged
1959
1960     set settingsChanged 1
1961
1962     set queryInfo [lreplace $queryInfo $queryNo $queryNo \
1963             $queryInfoTmp]
1964     set queryButtons [lreplace $queryButtons $queryNo $queryNo \
1965             $queryButtonsTmp]
1966     set queryInfoFind $queryInfoTmp
1967     set queryButtonsFind $queryButtonsTmp
1968
1969     destroy .query-setup
1970     index-lines .lines 1 $queryButtonsFind $queryInfoFind activate-index
1971 }
1972
1973 proc activate-e-index {value no i} {
1974     global queryButtonsTmp
1975     global queryIndexTmp
1976
1977     set queryButtonsTmp [lreplace $queryButtonsTmp $no $no [list I $i]]
1978     puts $queryButtonsTmp
1979     set queryIndexTmp $i
1980 }
1981
1982 proc activate-index {value no i} {
1983     global queryButtonsFind
1984
1985     set queryButtonsFind [lreplace $queryButtonsFind $no $no [list I $i]]
1986
1987     puts "queryButtonsFind $queryButtonsFind"
1988 }
1989
1990 proc update-attr {} {
1991     set w .index-setup
1992     listbuttonv $w.top.relation.b relationTmpValue\
1993             {{None} 0 {Less than} 1 {Greater than or equal} 2 {Equal} 3 \
1994             {Greater than or equal} 4 {Greater than} 5 {Not equal} 6 \
1995             {Phonetic} 100 {Stem} 101 {Relevance} 102 {AlwaysMatches} 103}
1996     listbuttonv $w.top.position.b positionTmpValue {{None} 0 \
1997             {First in field} 1 {First in subfield} 2 {Any position in field} 3}
1998     listbuttonv $w.top.structure.b structureTmpValue {{None} 0 {Phrase} 1 \
1999             {Word} 2 {Key} 3 {Year} 4 {Date (norm)} 5 {Word list}  6 \
2000             {Date (un-norm)} 100 {Name (norm)} 101 {Date (un-norm)} 102 \
2001             {Structure} 103 {urx} 104 {free-form} 105 {doc-text} 106 \
2002             {local-number} 107 {string} 108 {numeric string} 109}
2003     listbuttonv $w.top.truncation.b truncationTmpValue {{Auto} 0 {Right} 1 \
2004             {Left} 2 {Left and right} 3 {No truncation} 100 \
2005             {Process #} 101 {Re-1} 102 {Re-2} 103}
2006     listbuttonv $w.top.completeness.b completenessTmpValue {{None} 0 \
2007             {Incomplete subfield} 1 {Complete subfield} 2 {Complete field} 3}
2008 }
2009
2010 proc use-attr {init} {
2011     set attr {
2012         {None}                           0
2013         {Personal name}                  1
2014         {Corporate name}                 2
2015         {Conference name}                3
2016         {Title}                          4
2017         {Title-series}                   5
2018         {Title-uniform}                  6
2019         {ISBN}                           7
2020         {ISSN}                           8
2021         {LC card number}                 9
2022         {BNB card number}                10
2023         {BGF(sic) number}                11
2024         {Local number}                   12
2025         {Dewey classification}           13
2026         {UDC classification}             14
2027         {Bliss classification}           15
2028         {LC call number}                 16
2029         {NLM call number}                17
2030         {NAL call number}                18
2031         {MOS call number}                19
2032         {Local classification}           20
2033         {Subject heading}                21
2034         {Subject-RAMEAU}                 22
2035         {BDI-index-subject}              23
2036         {INSPEC-subject}                 24
2037         {MESH-subject}                   25
2038         {PA-subject}                     26
2039         {LC-subject-heading}             27
2040         {RVM-subject-heading}            28
2041         {Local subject index}            29
2042         {Date}                           30
2043         {Date of publication}            31
2044         {Date of acquisition}            32
2045         {Title-key}                      33
2046         {Title-collective}               34
2047         {Title-parallel}                 35
2048         {Title-cover}                    36
2049         {Title-added-title-page}         37
2050         {Title-caption}                  38
2051         {Title-running}                  39
2052         {Title-spine}                    40
2053         {Title-other-variant}            41
2054         {Title-former}                   42
2055         {Title-abbreviated}              43
2056         {Title-expanded}                 44
2057         {Subject-PRECIS}                 45
2058         {Subject-RSWK}                   46
2059         {Subject-subdivision}            47
2060         {Number-natl-bibliography}       48
2061         {Number-legal-deposit}           49
2062         {Number-govt-publication}        50
2063         {Number-publisher-for-music}     51
2064         {Number-DB}                      52
2065         {Number-local-call}              53
2066         {Code-language}                  54
2067         {Code-geographic-area}           55
2068         {Code-institution}               56
2069         {Name and title}                 57
2070         {Name-geographic}                58
2071         {Place-publication}              59
2072         {CODEN}                          60
2073         {Microform-generation}           61
2074         {Abstract}                       62
2075         {Note}                           63
2076         {Author-title}                 1000
2077         {Record type}                  1001
2078         {Name}                         1002
2079         {Author}                       1003
2080         {Author-name-personal}         1004
2081         {Author-name-corporate}        1005
2082         {Author-name-conference}       1006
2083         {Identifier-standard}          1007
2084         {Subject-LC-children's}        1008
2085         {Subject-name-personal}        1009
2086         {Body of text}                 1010
2087         {Date/time added to database}  1011
2088         {Date/time last modified}      1012
2089         {Authority/format identifier}  1013
2090         {Concept-text}                 1014
2091         {Concept-reference}            1015
2092         {Any}                          1016
2093         {Server choice}                1017
2094         {Publisher}                    1018
2095         {Record source}                1019
2096         {Editor}                       1020
2097         {Bib-level}                    1021
2098         {Geographic class}             1022
2099         {Indexed by}                   1023
2100         {Map scale}                    1024
2101         {Music key}                    1025
2102         {Related periodical}           1026
2103         {Report number}                1027
2104         {Stock number}                 1028
2105         {Thematic number}              1030
2106         {Material type}                1031
2107         {Doc ID}                       1032
2108         {Host item}                    1033
2109         {Content type}                 1034
2110         {Anywhere}                     1035
2111     }
2112     set w .index-setup
2113     global useTmpValue
2114     set l [llength $attr]
2115
2116     if {$init} {
2117         set s 0
2118         set lno 0
2119         for {set i 0} {$i < $l} {incr i} {
2120             $w.top.use.list insert end [lindex $attr $i]
2121             incr i
2122             if {$useTmpValue == [lindex $attr $i]} {
2123                 set s $lno
2124             }
2125             incr lno
2126         }
2127         $w.top.use.list select from $s
2128         $w.top.use.list select to $s
2129         incr s -3
2130         if {$s < 0} {
2131             set s 0
2132         }
2133         $w.top.use.list yview $s
2134     } else {
2135         set lno [lindex [$w.top.use.list curselection] 0]
2136         set i [expr $lno+$lno+1]
2137         set useTmpValue [lindex $attr $i]
2138         puts "useTmpValue=$useTmpValue"
2139     }
2140 }
2141
2142 proc index-setup-action {oldAttr queryNo indexNo} {
2143     set attr [lindex $oldAttr 0]
2144
2145     global useTmpValue
2146     global relationTmpValue
2147     global structureTmpValue
2148     global truncationTmpValue
2149     global completenessTmpValue
2150     global positionTmpValue
2151     global queryInfoTmp
2152
2153     use-attr 0
2154
2155     puts "index-setup-action"
2156     puts "queryNo $queryNo"
2157     puts "indexNo $indexNo"
2158     if {$useTmpValue > 0} {
2159         lappend attr "1=$useTmpValue"
2160     }
2161     if {$relationTmpValue > 0} {
2162         lappend attr "2=$relationTmpValue"
2163     }
2164     if {$positionTmpValue > 0} {
2165         lappend attr "3=$positionTmpValue"
2166     }
2167     if {$structureTmpValue > 0} {
2168         lappend attr "4=$structureTmpValue"
2169     }
2170     if {$truncationTmpValue > 0} {
2171         lappend attr "5=$truncationTmpValue"
2172     }
2173     if {$completenessTmpValue > 0} {
2174         lappend attr "6=$completenessTmpValue"
2175     }
2176     puts "new attr $attr"
2177     set queryInfoTmp [lreplace $queryInfoTmp $indexNo $indexNo $attr]
2178     destroy .index-setup
2179 }
2180
2181 proc index-setup {attr queryNo indexNo} {
2182     set w .index-setup
2183
2184     global relationTmpValue
2185     global structureTmpValue
2186     global truncationTmpValue
2187     global completenessTmpValue
2188     global positionTmpValue
2189     global useTmpValue
2190     set relationTmpValue 0
2191     set truncationTmpValue 0
2192     set structureTmpValue 0
2193     set positionTmpValue 0
2194     set completenessTmpValue 0
2195     set useTmpValue 0
2196
2197     set len [llength $attr]
2198     for {set i 1} {$i < $len} {incr i} {
2199         set q [lindex $attr $i]
2200         set l [string first = $q]
2201         if {$l > 0} {
2202             set t [string range $q 0 [expr $l - 1]]
2203             set v [string range $q [expr $l + 1] end]
2204             switch $t {
2205                 1
2206                 { set useTmpValue $v }
2207                 2
2208                 { set relationTmpValue $v }
2209                 3
2210                 { set positionTmpValue $v }
2211                 4
2212                 { set structureTmpValue $v }
2213                 5
2214                 { set truncationTmpValue $v }
2215                 6
2216                 { set completenessTmpValue $v }
2217             }
2218         }
2219     }
2220     if {[winfo exists $w]} {
2221         destroy $w
2222     }
2223     toplevelG $w
2224
2225     set n [lindex $attr 0]
2226     wm title $w "Index setup $n"
2227
2228     top-down-window $w
2229
2230     frame $w.top.use -relief ridge -border 2
2231     frame $w.top.relation -relief ridge -border 2
2232     frame $w.top.position -relief ridge -border 2
2233     frame $w.top.structure -relief ridge -border 2
2234     frame $w.top.truncation -relief ridge -border 2
2235     frame $w.top.completeness -relief ridge -border 2
2236
2237     update-attr
2238
2239     # Use Attributes
2240
2241     pack $w.top.use -side left -pady 6 -padx 6 -fill y
2242
2243     label $w.top.use.label -text "Use"
2244     listbox $w.top.use.list -geometry 26x10 \
2245             -yscrollcommand "$w.top.use.scroll set"
2246     scrollbar $w.top.use.scroll -orient vertical -border 1
2247     pack $w.top.use.label -side top -fill x \
2248             -padx 2 -pady 2
2249     pack $w.top.use.list -side left -fill both -expand yes \
2250             -padx 2 -pady 2
2251     pack $w.top.use.scroll -side right -fill y \
2252             -padx 2 -pady 2
2253     $w.top.use.scroll config -command "$w.top.use.list yview"
2254
2255     use-attr 1
2256
2257     # Relation Attributes
2258
2259     pack $w.top.relation -pady 6 -padx 6 -side top
2260     label $w.top.relation.label -text "Relation" -width 18
2261
2262     pack $w.top.relation.label $w.top.relation.b -fill x
2263
2264     # Position Attributes
2265
2266     pack $w.top.position -pady 6 -padx 6 -side top
2267     label $w.top.position.label -text "Position" -width 18
2268
2269     pack $w.top.position.label $w.top.position.b -fill x
2270
2271     # Structure Attributes
2272
2273     pack $w.top.structure -pady 6 -padx 6 -side top
2274     label $w.top.structure.label -text "Structure" -width 18
2275
2276     pack $w.top.structure.label $w.top.structure.b -fill x
2277
2278     # Truncation Attributes
2279
2280     pack $w.top.truncation -pady 6 -padx 6 -side top
2281     label $w.top.truncation.label -text "Truncation" -width 18
2282
2283     pack $w.top.truncation.label $w.top.truncation.b -fill x
2284
2285     # Completeness Attributes
2286
2287     pack $w.top.completeness -pady 6 -padx 6 -side top
2288     label $w.top.completeness.label -text "Completeness" -width 18
2289
2290     pack $w.top.completeness.label $w.top.completeness.b -fill x
2291
2292     # Ok-cancel
2293     bottom-buttons $w [list \
2294             {Ok} [list index-setup-action $attr $queryNo $indexNo] \
2295             {Cancel} [list destroy $w]] 0
2296
2297 }
2298
2299 proc query-edit-index {queryNo} {
2300     global queryInfoTmp
2301     set w .query-setup
2302
2303     set i [lindex [$w.top.index.list curselection] 0]
2304     if {$i == ""} {
2305         return
2306     }
2307     set attr [lindex $queryInfoTmp $i]
2308     puts "Editing no $i $attr"
2309     index-setup $attr $queryNo $i
2310 }
2311
2312 proc query-delete-index {queryNo} {
2313     global queryInfoTmp
2314     global queryButtonsTmp
2315     set w .query-setup
2316
2317     set i [lindex [$w.top.index.list curselection] 0]
2318     if {$i == ""} {
2319         return
2320     }
2321     set queryInfoTmp [lreplace $queryInfoTmp $i $i]
2322     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
2323     $w.top.index.list delete $i
2324 }
2325
2326 proc query-setup {queryNo} {
2327     set w .query-setup
2328
2329     global queryTypes
2330     global queryButtons
2331     global queryInfo
2332     global queryButtonsTmp
2333     global queryInfoTmp
2334     global queryIndexTmp
2335
2336     set queryIndexTmp 0
2337     set queryName [lindex $queryTypes $queryNo]
2338     set queryInfoTmp [lindex $queryInfo $queryNo]
2339     set queryButtonsTmp [lindex $queryButtons $queryNo]
2340
2341     toplevelG $w
2342
2343     wm minsize $w 0 0
2344     wm title $w "Query setup $queryName"
2345
2346     top-down-window $w
2347
2348     frame $w.top.lines -relief ridge -border 2
2349
2350     pack $w.top.lines -side left -pady 6 -padx 6 -fill y
2351
2352     # Index Lines
2353
2354     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
2355
2356     button $w.top.lines.add -text "Add" \
2357             -command [list query-add-line $queryNo]
2358     button $w.top.lines.del -text "Remove" \
2359             -command [list query-del-line $queryNo]
2360
2361     pack $w.top.lines.del -fill x -side bottom
2362     pack $w.top.lines.add -fill x -pady 10 -side bottom
2363
2364     # Indexes
2365
2366     frame $w.top.index -relief ridge -border 2
2367     pack $w.top.index -pady 6 -padx 6 -side right -fill y
2368
2369     listbox $w.top.index.list -yscrollcommand [list $w.top.index.scroll set]
2370     scrollbar $w.top.index.scroll -orient vertical -border 1 \
2371         -command [list $w.top.index.list yview]
2372     bind $w.top.index.list <2> [list query-edit-index $queryNo]
2373
2374     pack $w.top.index.list -side left -fill both -expand yes -padx 2 -pady 2
2375     pack $w.top.index.scroll -side right -fill y -padx 2 -pady 2
2376
2377     $w.top.index.list select from 0
2378     $w.top.index.list select to 0
2379
2380     foreach x $queryInfoTmp {
2381         $w.top.index.list insert end [lindex $x 0]
2382     }
2383     # Bottom
2384     bottom-buttons $w [list \
2385             {Ok} [list query-setup-action $queryNo] \
2386             {Add index} [list query-add-index $queryNo] \
2387             {Edit index} [list query-edit-index $queryNo] \
2388             {Delete index} [list query-delete-index $queryNo] \
2389             {Cancel} [list destroy $w]] 0
2390 }
2391
2392 proc index-clear {} {
2393     global queryButtonsFind
2394
2395     set i 0
2396     foreach b $queryButtonsFind {
2397         .lines.$i.e delete 0 end
2398         incr i
2399     }
2400 }
2401
2402 proc index-query {} {
2403     global queryButtonsFind
2404     global queryInfoFind
2405
2406     set i 0
2407     set qs {}
2408
2409     foreach b $queryButtonsFind {
2410         set term [string trim [.lines.$i.e get]]
2411         if {$term != ""} {
2412             set attr [lrange [lindex $queryInfoFind [lindex $b 1]] 1 end]
2413
2414             set len [string length $term]
2415             incr len -1
2416             set left 0
2417             set right 0
2418             if {[string index $term $len] == "?"} {
2419                 set right 1
2420                 set term [string range $term 0 [expr $len - 1]]
2421             }
2422             if {[string index $term 0] == "?"} {
2423                 set left 1
2424                 set term [string range $term 1 end]
2425             }
2426             set term "\{${term}\}"
2427             if {$right && $left} {
2428                 set term "@attr 5=3 ${term}"
2429             } elseif {$right} {
2430                 set term "@attr 5=1 ${term}"
2431             } elseif {$left} {
2432                 set term "@attr 5=2 ${term}"
2433             }
2434             foreach a $attr {
2435                 set term "@attr $a ${term}"
2436             }
2437             if {$qs != ""} {
2438                 set qs "@and ${qs} ${term}"
2439             } else {
2440                 set qs $term
2441             }
2442         }
2443         incr i
2444     }
2445     puts "qs=  $qs"
2446     return $qs
2447 }
2448
2449 proc index-focus-in {w i} {
2450     global curIndexEntry
2451
2452     $w.$i configure -background red
2453     set curIndexEntry $i
2454 }
2455
2456 proc index-lines {w realOp buttonInfo queryInfo handle} {
2457     set i 0
2458     foreach b $buttonInfo {
2459         if {! [winfo exists $w.$i]} {
2460             frame $w.$i -background white -border 1
2461         }
2462         listbuttonx $w.$i.l [lindex $b 1] $queryInfo $handle $i
2463
2464         if {$realOp} {
2465             if {! [winfo exists $w.$i.e]} {
2466                 entry $w.$i.e -width 32 -relief sunken -border 1
2467                 bind $w.$i.e <FocusIn> [list index-focus-in $w $i]
2468                 bind $w.$i.e <FocusOut> [list $w.$i configure \
2469                         -background white]
2470                 pack $w.$i.l -side left
2471                 pack $w.$i.e -side left -fill x -expand yes
2472                 pack $w.$i -side top -fill x -padx 2 -pady 2
2473                 bind $w.$i.e <Left> [list left-cursor $w.$i.e]
2474                 bind $w.$i.e <Right> [list right-cursor $w.$i.e]
2475                 bind $w.$i.e <Return> search-request
2476             }
2477         } else {
2478             pack $w.$i.l -side left
2479             pack $w.$i -side top -fill x -padx 2 -pady 2
2480         }
2481         incr i
2482     }
2483     set j $i
2484     while {[winfo exists $w.$j]} {
2485         destroy $w.$j
2486         incr j
2487     }
2488     if {! $realOp} {
2489         return
2490     }
2491     set j 0
2492     incr i -1
2493     while {$j < $i} {
2494         set k [expr $j+1]
2495         bind $w.$j.e <Tab> "focus $w.$k.e"
2496         set j $k
2497     }
2498     if {$i >= 0} {
2499         bind $w.$i.e <Tab> "focus $w.0.e"
2500         focus $w.0.e
2501     }
2502 }
2503
2504 proc search-fields {w buttondefs} {
2505     set i 0
2506     foreach buttondef $buttondefs {
2507         frame $w.$i -background white
2508
2509         listbutton $w.$i.l 0 $buttondef
2510         entry $w.$i.e -width 32 -relief sunken
2511
2512         pack $w.$i.l -side left
2513         pack $w.$i.e -side left -fill x -expand yes
2514
2515         pack $w.$i -side top -fill x -padx 2 -pady 2
2516
2517         bind $w.$i.e <Left> [list left-cursor $w.$i.e]
2518         bind $w.$i.e <Right> [list right-cursor $w.$i.e]
2519
2520         incr i
2521     }
2522     set j 0
2523     incr i -1
2524     while {$j < $i} {
2525         set k [expr $j+1]
2526         bind $w.$j.e <Tab> "focus $w.$k.e \n
2527         $w.$k configure -background red \n
2528         $w.$j configure -background white"
2529         set j $k
2530     }
2531     bind $w.$i.e <Tab> "focus $w.0.e \n
2532         $w.0 configure -background red \n
2533         $w.$i configure -background white"
2534     focus $w.0.e
2535     $w.0 configure -background red
2536 }
2537
2538 if {[info exists windowGeometry(.)]} {
2539     set g $windowGeometry(.)
2540     if {$g != ""} {
2541         wm geometry . $g
2542     }
2543 }
2544
2545 read-formats
2546
2547 frame .top  -border 1 -relief raised
2548 frame .lines  -border 1 -relief raised
2549 frame .mid  -border 1 -relief raised
2550 frame .data -border 1 -relief raised
2551 frame .bot  -border 1 -relief raised
2552 pack .top .lines .mid -side top -fill x
2553 pack .data -side top -fill both -expand yes
2554 pack .bot -fill x
2555
2556 menubutton .top.file -text "File" -menu .top.file.m
2557 menu .top.file.m
2558 .top.file.m add command -label "Save settings" -command {save-settings}
2559 .top.file.m add separator
2560 .top.file.m add command -label "Exit" -command {exit-action}
2561
2562 menubutton .top.target -text "Target" -menu .top.target.m
2563 menu .top.target.m
2564 .top.target.m add cascade -label "Connect" -menu .top.target.m.clist
2565 .top.target.m add command -label "Disconnect" -command {close-target}
2566 .top.target.m add command -label "About" -command {about-target}
2567 .top.target.m add cascade -label "Setup" -menu .top.target.m.slist
2568 .top.target.m add command -label "Setup new" -command {define-target-dialog}
2569 .top.target.m add separator
2570 set-target-hotlist
2571
2572 .top.target.m disable 1
2573 .top.target.m disable 2
2574
2575 menu .top.target.m.clist
2576 menu .top.target.m.slist
2577 cascade-target-list
2578
2579 menubutton .top.service -text "Service" -menu .top.service.m
2580 menu .top.service.m
2581 .top.service.m add command -label "Database" -command {database-select}
2582 .top.service.m add cascade -label "Present" -menu .top.service.m.present
2583 menu .top.service.m.present
2584 .top.service.m.present add command -label "10 More" \
2585         -command [list present-more 10]
2586 .top.service.m.present add command -label "All" \
2587         -command [list present-more {}]
2588 .top.service.m add command -label "Search" -command {search-request}
2589 .top.service.m add command -label "Scan" -command {scan-request}
2590
2591 .top.service configure -state disabled
2592
2593 menubutton .top.rset -text "Set" -menu .top.rset.m
2594 menu .top.rset.m
2595 .top.rset.m add command -label "Load" -command {load-set}
2596 .top.rset.m add separator
2597
2598 menubutton .top.options -text "Options" -menu .top.options.m
2599 menu .top.options.m
2600 .top.options.m add cascade -label "Query" -menu .top.options.m.query
2601 .top.options.m add cascade -label "Format" -menu .top.options.m.formats
2602 .top.options.m add cascade -label "Wrap" -menu .top.options.m.wrap
2603
2604 menu .top.options.m.query
2605 .top.options.m.query add cascade -label "Select" \
2606         -menu .top.options.m.query.clist
2607 .top.options.m.query add cascade -label "Edit" \
2608         -menu .top.options.m.query.slist
2609 .top.options.m.query add command -label "New" \
2610         -command {query-new}
2611 .top.options.m.query add cascade -label "Delete" \
2612         -menu .top.options.m.query.dlist
2613
2614 menu .top.options.m.query.slist
2615 menu .top.options.m.query.clist
2616 menu .top.options.m.query.dlist
2617 cascade-query-list
2618
2619 menu .top.options.m.formats
2620 set i 0
2621 foreach f $displayFormats {
2622     .top.options.m.formats add radiobutton -label $f -value $i \
2623             -command [list set-display-format $i] -variable displayFormat
2624     incr i
2625 }
2626
2627 menu .top.options.m.wrap
2628 .top.options.m.wrap add radiobutton -label "Character" \
2629         -value char -variable textWrap -command {set-wrap char}
2630 .top.options.m.wrap add radiobutton -label "Word" \
2631         -value word -variable textWrap -command {set-wrap word}
2632 .top.options.m.wrap add radiobutton -label "None" \
2633         -value none -variable textWrap -command {set-wrap none}
2634
2635 menubutton .top.help -text "Help" -menu .top.help.m
2636 menu .top.help.m
2637
2638 .top.help.m add command -label "Help on help" \
2639         -command {tkerror "Help on help not available. Sorry"}
2640 .top.help.m add command -label "About" -command {about-origin}
2641
2642 pack .top.file .top.target .top.service .top.rset .top.options -side left
2643 pack .top.help -side right
2644
2645 index-lines .lines 1 $queryButtonsFind [lindex $queryInfo 0] activate-index
2646
2647 button .mid.search -width 7 -text {Search} -command search-request \
2648         -state disabled
2649 button .mid.scan -width 7 -text {Scan} \
2650         -command scan-request -state disabled
2651 button .mid.present -width 7 -text {Present} -command [list present-more 10] \
2652         -state disabled
2653
2654 button .mid.clear -width 7 -text {Clear} -command index-clear
2655 pack .mid.search .mid.scan .mid.present .mid.clear -side left \
2656         -fill y -padx 5 -pady 3
2657
2658 text .data.record -height 2 -width 20 -wrap none \
2659         -yscrollcommand [list .data.scroll set] -wrap $textWrap
2660 scrollbar .data.scroll -command [list .data.record yview]
2661 pack .data.scroll -side right -fill y
2662 pack .data.record -expand yes -fill both
2663 initBindings
2664
2665 if {[tk colormodel .] == "color"} {
2666     .data.record tag configure marc-tag -foreground blue
2667     .data.record tag configure marc-id -foreground red
2668 } else {
2669     .data.record tag configure marc-tag -foreground black
2670     .data.record tag configure marc-id -foreground black
2671 }
2672 .data.record tag configure marc-data -foreground black
2673
2674 button .bot.logo  -bitmap @book1 -command cancel-operation
2675 frame .bot.a
2676 pack .bot.a -side left -fill x
2677 pack .bot.logo -side right -padx 2 -pady 2
2678
2679 message .bot.a.target -text "" -aspect 1000 -border 1
2680
2681 label .bot.a.status -text "Not connected" -width 15 -relief \
2682         sunken -anchor w -border 1
2683 label .bot.a.set -text "" -width 5 -relief \
2684         sunken -anchor w -border 1
2685 label .bot.a.message -text "" -width 15 -relief \
2686         sunken -anchor w -border 1
2687
2688 pack .bot.a.target -side top -anchor nw -padx 2 -pady 2
2689 pack .bot.a.status .bot.a.set .bot.a.message \
2690         -side left -padx 2 -pady 2
2691
2692 ir z39
2693
2694 show-logo 1
2695