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