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