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