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