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