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