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