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