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