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