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