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