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