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