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