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