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