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