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