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