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