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