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