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