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