client.tcl

   1 # IR toolkit for tcl/tk
   2 # (c) Index Data 1995-1996
   3 # See the file LICENSE for details.
   4 # Sebastian Hammer, Adam Dickmeiss
   5 #
   6 # $Log: client.tcl,v $
   7 # Revision 1.99  1997-04-13 19:00:37  adam
   8 # Added support for Tcl8.0/Tk8.0.
   9 # New command ir-log-init to setup yaz logging facilities.
  10 #
  11 # Revision 1.98  1996/11/14 17:11:04  adam
  12 # Added Explain documentaion.
  13 #
  14 # Revision 1.97  1996/09/13  10:54:22  adam
  15 # Started work on Explain in client.
  16 #
  17 # Revision 1.96  1996/08/09  15:30:18  adam
  18 # Procedure destroyGW modified to handle multiple calls - probably an
  19 # error introduced by tk4.1 patch level 1.
  20 #
  21 # Revision 1.95  1996/07/26  09:15:08  adam
  22 # IrTcl version 1.2 patch level 1.
  23 #
  24 # Revision 1.94  1996/07/25  15:55:34  adam
  25 # IrTcl version 1.2 release.
  26 #
  27 # Revision 1.93  1996/06/28  08:43:54  adam
  28 # Moved towards version 1.2.
  29 #
  30 # Revision 1.92  1996/03/29  16:04:30  adam
  31 # Work on GRS-1 presentation.
  32 #
  33 # Revision 1.91  1996/03/27  17:00:53  adam
  34 # Fix: main defined when using Tk3.6; it shouldn't be.
  35 #
  36 # Revision 1.90  1996/03/20  13:54:02  adam
  37 # The Tcl_File structure is only manipulated in the Tk-event interface
  38 # in tkinit.c.
  39 #
  40 # Revision 1.89  1996/03/05  09:16:04  adam
  41 # Sets tearoff to off on several menus.
  42 #
  43 # Revision 1.88  1996/01/23  15:24:09  adam
  44 # Wrore more comments.
  45 #
  46 # Revision 1.87  1996/01/22  17:13:34  adam
  47 # Wrote comments.
  48 #
  49 # Revision 1.86  1996/01/22  09:29:01  adam
  50 # Wrote comments.
  51 #
  52 # Revision 1.85  1996/01/19  16:22:36  adam
  53 # New method: apduDump - returns information about last incoming APDU.
  54 #
  55 # Revision 1.84  1996/01/11  13:12:10  adam
  56 # Bug fix.
  57 #
  58 # Revision 1.83  1995/11/28  17:26:36  adam
  59 # Removed Carriage return from ir-tcl.c!
  60 # Removed misc. debug logs.
  61 #
  62 # Revision 1.82  1995/11/02  08:47:56  adam
  63 # Text widgets are flat now.
  64 #
  65 # Revision 1.81  1995/10/19  10:34:43  adam
  66 # More configurable client.
  67 #
  68 # Revision 1.80  1995/10/18  17:20:32  adam
  69 # Work on target setup in client.tcl.
  70 #
  71 # Revision 1.79  1995/10/18  16:42:37  adam
  72 # New settings: smallSetElementSetNames and mediumSetElementSetNames.
  73 #
  74 # Revision 1.78  1995/10/18  15:45:36  quinn
  75 # *** empty log message ***
  76 #
  77 # Revision 1.77  1995/10/18  15:37:46  adam
  78 # Piggy-back present.
  79 #
  80 # Revision 1.76  1995/10/18  15:15:20  adam
  81 # Fixed bug.
  82 #
  83 # Revision 1.75  1995/10/17  14:18:05  adam
  84 # Minor changes in presentation formats.
  85 #
  86 # Revision 1.74  1995/10/17  12:18:57  adam
  87 # Bug fix: when target connection closed, the connection was not
  88 # properly reestablished.
  89 #
  90 # Revision 1.73  1995/10/17  10:58:06  adam
  91 # More work on presentation formats.
  92 #
  93 # Revision 1.72  1995/10/16  17:00:52  adam
  94 # New setting: elementSetNames.
  95 # Various client improvements. Medium presentation format looks better.
  96 #
  97 # Revision 1.71  1995/10/13  15:35:27  adam
  98 # Relational operators may be used in search entries - changes
  99 # in proc index-query.
 100 #
 101 # Revision 1.70  1995/10/12  14:46:52  adam
 102 # Better record popup windows. Next/prev buttons in popup record windows.
 103 # The record position in the raw format is much more visible.
 104 #
 105 # Revision 1.69  1995/09/21  13:42:54  adam
 106 # Bug fixes.
 107 #
 108 # Revision 1.68  1995/09/21  13:11:49  adam
 109 # Support of dynamic loading.
 110 # Test script uses load command if necessary.
 111 #
 112 # Revision 1.67  1995/09/20  14:35:19  adam
 113 # Minor changes.
 114 #
 115 # Revision 1.66  1995/08/29  15:30:13  adam
 116 # Work on GRS records.
 117 #
 118 # Revision 1.65  1995/08/24  15:39:09  adam
 119 # Minor changes.
 120 #
 121 # Revision 1.64  1995/08/24  15:33:02  adam
 122 # Minor changes.
 123 #
 124 # Revision 1.63  1995/08/04  13:20:48  adam
 125 # Buttons at the bottom are slightly smaller.
 126 #
 127 # Revision 1.62  1995/08/04  11:32:37  adam
 128 # More work on output queue. Memory related routines moved
 129 # to mem.c
 130 #
 131 # Revision 1.61  1995/07/20  08:09:39  adam
 132 # client.tcl: Targets removed from hotTargets list when targets
 133 #  are removed/modified.
 134 # ir-tcl.c: More work on triggerResourceControl.
 135 #
 136 # Revision 1.60  1995/06/30  16:30:19  adam
 137 # Minor changes.
 138 #
 139 # Revision 1.59  1995/06/29  14:06:25  adam
 140 # Another bug in install fixed. Configure searches for more versions of yaz.
 141 #
 142 # Revision 1.58  1995/06/29  12:34:06  adam
 143 # IrTcl now works with both tk4.0b4/tcl7.4b4 and tk3.6/tcl7.3
 144 #
 145 # Revision 1.57  1995/06/29  09:20:30  adam
 146 # Target entries in cascade menus are sorted.
 147 #
 148 # Revision 1.56  1995/06/27  19:03:48  adam
 149 # Bug fix in do_present in ir-tcl.c: p->set_child member weren't set.
 150 # nextResultSetPosition used instead of setOffset.
 151 #
 152 # Revision 1.55  1995/06/27  17:10:37  adam
 153 # Bug fix: install procedure didn't work on some systems.
 154 # Error turned up when clientrc.tcl was't present.
 155 #
 156 # Revision 1.54  1995/06/27  14:41:03  adam
 157 # Bug fix in search-response. Didn't always observe non-surrogate diagnostics.
 158 #
 159 # Revision 1.53  1995/06/26  12:40:09  adam
 160 # Client defines its own tkerror.
 161 # User may specify 'no preferredRecordSyntax'.
 162 #
 163 # Revision 1.52  1995/06/22  13:14:59  adam
 164 # Feature: SUTRS. Setting getSutrs implemented.
 165 # Work on display formats.
 166 # Preferred record syntax can be set by the user.
 167 #
 168 # Revision 1.51  1995/06/21  11:11:00  adam
 169 # Bug fix: libdir undefined in about-origin.
 170 #
 171 # Revision 1.50  1995/06/21  11:04:48  adam
 172 # Uses GNU autoconf 2.3.
 173 # Install procedure implemented.
 174 # boook bitmaps moved to sub directory bitmaps.
 175 #
 176 # Revision 1.49  1995/06/20  14:16:42  adam
 177 # More work on cancel mechanism.
 178 #
 179 # Revision 1.48  1995/06/20  08:07:23  adam
 180 # New setting: failInfo.
 181 # Working on better cancel mechanism.
 182 #
 183 # Revision 1.47  1995/06/19  14:05:29  adam
 184 # Bug fix: asked for SUTRS.
 185 #
 186 # Revision 1.46  1995/06/19  13:06:06  adam
 187 # New define: IR_TCL_VERSION.
 188 #
 189 # Revision 1.45  1995/06/19  08:08:44  adam
 190 # client.tcl: hotTargets now contain both database and target name.
 191 # ir-tcl.c: setting protocol edited. Errors in callbacks are logged
 192 # by logf(LOG_WARN, ...) calls.
 193 #
 194 # Revision 1.44  1995/06/16  14:55:18  adam
 195 # Book logo mirrored.
 196 #
 197 # Revision 1.43  1995/06/16  14:41:05  adam
 198 # Scan line entries can be copied to a search entry.
 199 #
 200 # Revision 1.42  1995/06/16  12:28:13  adam
 201 # Implemented preferredRecordSyntax.
 202 # Minor changes in diagnostic handling.
 203 # Record list deleted when connection closes.
 204 #
 205 # Revision 1.41  1995/06/14  15:07:59  adam
 206 # Bug fix in cascade-target-list. Uses yaz-version.h.
 207 #
 208 # Revision 1.40  1995/06/14  13:37:17  adam
 209 # Setting recordType implemented.
 210 # Setting implementationVersion implemented.
 211 # Settings implementationId / implementationName edited.
 212 #
 213 # Revision 1.39  1995/06/14  12:16:22  adam
 214 # hotTargets, textWrap and displayFormat saved in clientg.tcl.
 215 #
 216 # Revision 1.38  1995/06/14  07:22:45  adam
 217 # Target definitions can be deleted.
 218 # Listbox used in the query definition dialog.
 219 #
 220 # Revision 1.37  1995/06/13  14:37:59  adam
 221 # Work on query setup.
 222 # Better about origin/target.
 223 # Better presentation formats.
 224 #
 225 # Revision 1.36  1995/06/13  07:42:14  adam
 226 # Bindings removed from text widgets.
 227 #
 228 # Revision 1.35  1995/06/12  15:17:31  adam
 229 # Text widget used in main window (instead of listbox) to support
 230 # better presentation formats.
 231 #
 232 # Revision 1.34  1995/06/12  07:59:07  adam
 233 # More work on geometry handling.
 234 #
 235 # Revision 1.33  1995/06/09  11:17:35  adam
 236 # Start work on geometry management.
 237 #
 238 # Revision 1.32  1995/06/07  09:16:37  adam
 239 # New presentation format.
 240 #
 241 # Revision 1.31  1995/06/06  16:31:09  adam
 242 # Bug fix: target names couldn't contain blanks.
 243 # Bug fix: scan.
 244 #
 245 # Revision 1.30  1995/06/06  11:35:41  adam
 246 # Work on scan. Display of old sets.
 247 #
 248 # Revision 1.29  1995/06/05  14:11:18  adam
 249 # Bug fix in present-more.
 250 #
 251 # Revision 1.28  1995/06/02  14:52:13  adam
 252 # Minor changes really.
 253 #
 254 # Revision 1.27  1995/06/02  14:29:42  adam
 255 # Work on scan interface - up/down buttons.
 256 #
 257 # Revision 1.26  1995/06/01  16:36:46  adam
 258 # About buttons. Minor bug fixes.
 259 #
 260 # Revision 1.25  1995/05/31  13:09:57  adam
 261 # Client searches/presents may be interrupted.
 262 # New moving book-logo.
 263 #
 264 # Revision 1.24  1995/05/31  08:36:24  adam
 265 # Bug fix in client.tcl: didn't save options on clientrc.tcl.
 266 # New method: referenceId. More work on scan.
 267 #
 268 # Revision 1.23  1995/05/29  10:33:41  adam
 269 # README and rename of startup script.
 270 #
 271 # Revision 1.22  1995/05/26  11:44:09  adam
 272 # Bugs fixed. More work on MARC utilities and queries. Test
 273 # client is up-to-date again.
 274 #
 275 # Revision 1.21  1995/05/11  15:34:46  adam
 276 # Scan request changed a bit. This version works with RLG.
 277 #
 278 # Revision 1.20  1995/04/21  16:31:57  adam
 279 # New radiobutton: protocol (z39v2/SR).
 280 #
 281 # Revision 1.19  1995/04/18  16:11:50  adam
 282 # First version of graphical Scan. Some work on query-by-form.
 283 #
 284 # Revision 1.18  1995/04/10  10:50:22  adam
 285 # Result-set name defaults to suffix of ir-set name.
 286 # Started working on scan. Not finished at this point.
 287 #
 288 # Revision 1.17  1995/03/31  09:34:57  adam
 289 # Search-button disabled when there is no connection.
 290 #
 291 # Revision 1.16  1995/03/31  08:56:36  adam
 292 # New button "Search".
 293 #
 294 # Revision 1.15  1995/03/28  12:45:22  adam
 295 # New ir method failback: called on disconnect/protocol error.
 296 # New ir set/get method: protocol: SR / Z3950.
 297 # Simple popup and disconnect when failback is invoked.
 298 #
 299 # Revision 1.14  1995/03/22  16:07:55  adam
 300 # Minor changes.
 301 #
 302 # Revision 1.13  1995/03/21  17:27:26  adam
 303 # Short-hand keys in setup.
 304 #
 305 # Revision 1.12  1995/03/21  13:41:03  adam
 306 # Comstack cs_create not used too often. Non-blocking connect.
 307 #
 308 # Revision 1.11  1995/03/21  10:39:06  adam
 309 # Diagnostic error message displayed with tkerror.
 310 #
 311 # Revision 1.10  1995/03/20  15:24:06  adam
 312 # Diagnostic records saved on searchResponse.
 313 #
 314 # Revision 1.9  1995/03/17  18:26:16  adam
 315 # Non-blocking i/o used now. Database names popup as cascade items.
 316 #
 317 # Revision 1.8  1995/03/17  15:45:00  adam
 318 # Improved target/database setup.
 319 #
 320 # Revision 1.7  1995/03/16  17:54:03  adam
 321 # Minor changes really.
 322 #
 323 # Revision 1.6  1995/03/15  19:10:20  adam
 324 # Database setup in protocol-setup (rather target setup).
 325 #
 326 # Revision 1.5  1995/03/15  13:59:23  adam
 327 # Minor changes.
 328 #
 329 # Revision 1.4  1995/03/14  17:32:29  adam
 330 # Presentation of full Marc record in popup window.
 331 #
 332 # Revision 1.3  1995/03/12  19:31:52  adam
 333 # Pattern matching implemented when retrieving MARC records. More
 334 # diagnostic functions.
 335 #
 336 # Revision 1.2  1995/03/10  18:00:15  adam
 337 # Actual presentation in line-by-line format. RPN query support.
 338 #
 339 # Revision 1.1  1995/03/09  16:15:07  adam
 340 # First presentRequest attempts. Hot-target list.
 341 #
 342 #
 343
 344 # Procedure tk4 is defined - returns 0 if tk 3.6 - returns 1 otherwise
 345 if {$tk_version == "3.6"} {
 346     proc tk4 {} {
 347         return 0
 348     }
 349 } else {
 350     proc tk4 {} {
 351         return 1
 352     }
 353 }
 354
 355 # The following two procedures deals with menu entries. The interface
 356 # changed from Tk 3.6 to 4.X
 357
 358 # Procedure configure-enable-e {w n}
 359 #  w   is a menu
 360 #  n   menu entry number (0 is first entry)
 361 # Enables menu entry
 362
 363 # Procedure configure-disable-e {w n}
 364 #  w   is a menu
 365 #  n   menu entry number (0 is first entry)
 366 # Disables menu entry
 367
 368 if {[tk4]} {
 369     proc configure-enable-e {w n} {
 370         incr n
 371         $w entryconfigure $n -state normal
 372     }
 373     proc configure-disable-e {w n} {
 374         incr n
 375         $w entryconfigure $n -state disabled
 376     }
 377     set noFocus [list -takefocus 0]
 378 } else {
 379     proc configure-enable-e {w n} {
 380         $w enable $n
 381     }
 382     proc configure-disable-e {w n} {
 383         $w disable $n
 384     }
 385     set noFocus {}
 386 }
 387
 388 # Define dummy clock function if it is not there.
 389 if {[catch {clock seconds}]} {
 390     proc clock {args} {
 391         return {}
 392     }
 393 }
 394 # Set monoFlag to 1 if screen is known not to support colors; otherwise
 395 #  set monoFlag to 0
 396 if {![tk4]} {
 397     if {[tk colormodel .] == "color"} {
 398         set monoFlag 0
 399     } else {
 400         set monoFlag 1
 401     }
 402 } else {
 403     set monoFlag 0
 404 }
 405
 406 # Define libdir to the IrTcl configuration directory.
 407 # In the line below LIBDIR will be modified during 'make install'.
 408 set libdir LIBDIR
 409
 410 # If the bitmaps sub directory is present with a bitmap we assume
 411 # the client is run from the source directory in which case we
 412 # set libdir the current directory.
 413 if {[file readable bitmaps/book2]} {
 414     set libdir .
 415 }
 416
 417 # Make a final check to see if libdir was set ok.
 418 if {! [file readable ${libdir}/bitmaps/book2]} {
 419     puts "Cannot locate system files in ${libdir}. You must either run this"
 420     puts "program from the source directory root of ir-tcl or you must assure"
 421     puts "that it is installed - normally in /usr/local/lib/irtcl"
 422     exit 1
 423 }
 424
 425 # Initialize a lot of globals.
 426 set hotTargets {}
 427 set hotInfo {}
 428 set busy 0
 429
 430 # profile: associative array with target profiles.
 431 #indx exp description
 432 #
 433 #   0  T  Target description
 434 #   1     Host
 435 #   2     Port
 436 #   3     Authentication
 437 #   4     Maximum Record Size
 438 #   5     Preferred Messages Size
 439 #   6     Comstack
 440 #   7  D  Databases available
 441 #   8  T  Result Sets support
 442 #   9     RPN-Query support
 443 #  10     CCL-Query support
 444 #  11     Protocol (Z39/SR)
 445 #  12     Window Number
 446 #  13     LSLB  Large Set Lower Bound
 447 #  14     SSUB  Small Set Upper Bound
 448 #  15     MSPN  Medium Set Present Number
 449 #  16     Present Chunk - number of records to fetch in each present
 450 #  17     Time of first define
 451 #  18     Time of last init
 452 #  19     Time of last explain
 453 #  20  T  Name in TargetInfo
 454 #  21  T  Recent News
 455 #  22  T  Max Result Sets
 456 #  23  T  Max Result Size
 457 #  24  T  Max Terms
 458 #  25  D  List of database info records
 459 #  26  T  Multiple Databases
 460 #  27  T  Welcome message
 461 #
 462 #
 463 # Legend:
 464 #  T  TargetInfo explain
 465 #  D  DatabaseInfo explain
 466
 467 set profile(Default) {{} {} {210} {} 50000 30000 tcpip {} 1 {} {} Z39 1 2 0 0 4}
 468 set hostid Default
 469 set settingsChanged 0
 470 set setNo 0
 471 set setNoLast 0
 472 set cancelFlag 0
 473 set scanEnable 0
 474 set displayFormat 1
 475 set popupMarcdf 0
 476 set textWrap word
 477 set recordSyntax None
 478 set elementSetNames None
 479 set delayRequest {}
 480 set debugMode 0
 481
 482 set queryTypes {Simple}
 483 set queryButtons { { {I 0} {I 1} {I 2} } }
 484 set queryInfo { { {Title {1=4 4=1}} {Author {1=1}} \
 485         {Subject {1=21}} {Any {1=1016}} } }
 486 wm minsize . 0 0
 487
 488 set setOffset 0
 489 set setMax 0
 490
 491 # Procedure tkerror {err}
 492 #   err   error message
 493 # Override the Tk error handler function.
 494 proc tkerror err {
 495     set w .tkerrorw
 496
 497     if {[winfo exists $w]} {
 498         destroy $w
 499     }
 500     toplevel $w
 501     wm title $w "Error"
 502
 503     place-force $w .
 504     top-down-window $w
 505
 506     label $w.top.b -bitmap error
 507     message $w.top.t -aspect 300 -text "Error: $err" \
 508             -font -Adobe-Helvetica-Bold-R-Normal-*-180-*
 509     pack $w.top.b $w.top.t -side left -padx 10 -pady 10
 510
 511     bottom-buttons $w [list {Close} [list destroy $w]] 1
 512 }
 513
 514 # Read tag set file (if present)
 515 if {[file readable "${libdir}/tagsets.tcl"]} {
 516     source "${libdir}/tagsets.tcl"
 517 }
 518
 519 # Read the global configuration file.
 520 if {[file readable "clientrc.tcl"]} {
 521     source "clientrc.tcl"
 522 } elseif {[file readable "${libdir}/clientrc.tcl"]} {
 523     source "${libdir}/clientrc.tcl"
 524 }
 525
 526 # Make old definitions up-to-date.
 527 foreach n [array names profile] {
 528     set l [llength $profile($n)]
 529     while {$l < 29} {
 530         lappend profile($n) {}
 531         incr l
 532     }
 533 }
 534
 535 # Read the user configuration file.
 536 if {[file readable "~/.clientrc.tcl"]} {
 537     source "~/.clientrc.tcl"
 538 }
 539
 540 # These globals describe the current query type. They are set to the
 541 # first query type.
 542 set queryButtonsFind [lindex $queryButtons 0]
 543 set queryInfoFind [lindex $queryInfo 0]
 544
 545 # Procedure read-formats
 546 # Read all Tcl source files in the subdirectory 'formats'.
 547 # The name of each source will correspond to a display format.
 548 proc read-formats {} {
 549     global displayFormats
 550     global libdir
 551
 552     set oldDir [pwd]
 553     cd ${libdir}/formats
 554     set formats [glob {*.[tT][cC][lL]}]
 555     foreach f $formats {
 556         if {[file readable $f]} {
 557             source $f
 558             set l [string length $f]
 559             set f [string tolower [string range $f 0 [expr $l - 5]]]
 560             lappend displayFormats $f
 561         }
 562     }
 563     cd $oldDir
 564 }
 565
 566 # Procedure set-wrap {m}
 567 #  m    boolean wrap mode
 568 # Handler to enable/disable text wrap in the main record window
 569 proc set-wrap {m} {
 570     global textWrap
 571
 572     set textWrap $m
 573     .data.record configure -wrap $m
 574 }
 575
 576 # Procedure dputs {m}
 577 #  m    string to be printed
 578 # puts utility for debugging.
 579 proc dputs {m} {
 580     global debugMode
 581     if {$debugMode} {
 582         puts $m
 583     }
 584 }
 585
 586 # Procedure apduDump {}
 587 # Logs BER dump of last APDU in window if debugMode is true.
 588 proc apduDump {} {
 589     global debugMode
 590
 591     set w .apdu
 592
 593     if {$debugMode == 0} return
 594     set x [z39 apduInfo]
 595
 596     set offset [lindex $x 1]
 597     set length [lindex $x 0]
 598
 599     if {![winfo exists $w]} {
 600         catch {destroy $w}
 601         toplevelG $w
 602
 603         wm title $w "APDU information"
 604
 605         wm minsize $w 0 0
 606
 607         top-down-window $w
 608
 609         text $w.top.t -font fixed -width 60 -height 12 -wrap word \
 610                 -relief flat -borderwidth 0 -yscrollcommand [list $w.top.s set]
 611         scrollbar $w.top.s -command [list $w.top.t yview]
 612
 613         pack $w.top.s -side right -fill y
 614         pack $w.top.t -expand yes -fill both
 615
 616         bottom-buttons $w [list {Close} [list destroy $w]] 0
 617     }
 618     $w.top.t insert end "Length: ${length}\n"
 619     if {$offset != -1} {
 620         $w.top.t insert end "Offset: ${offset}\n"
 621     }
 622     $w.top.t insert end [lindex $x 2]
 623     $w.top.t insert end "---------------------------------\n"
 624
 625 }
 626
 627 # Procedure set-display-format {f}
 628 #  f    display format
 629 # Reformats main record window to use display format given by f
 630 proc set-display-format {f} {
 631     global displayFormat
 632     global setNo
 633     global busy
 634
 635     set displayFormat $f
 636     if {$setNo == 0} {
 637         return
 638     }
 639     if {!$busy} {
 640         .bot.a.status configure -text "Reformatting"
 641     }
 642     update idletasks
 643     add-title-lines -1 10000 1
 644 }
 645
 646 # Procedure initBindings
 647 # Disables various default bindings for Text and Listbox widgets.
 648 proc initBindings {} {
 649     global TextBinding
 650
 651     foreach e [bind Text] {
 652         set TextBinding($e) [bind Text $e]
 653         bind Text $e {}
 654     }
 655     set w Listbox
 656     bind $w <B1-Motion> {}
 657     bind $w <Shift-B1-Motion> {}
 658
 659     set w Entry
 660 }
 661
 662 # Procedure TextEditable
 663 # Apply "standard" events to a text widget. It should be editable now.
 664 proc TextEditable {w} {
 665     global TextBinding
 666
 667     foreach e [array names TextBinding] {
 668         bind $w $e $TextBinding($e)
 669     }
 670 }
 671
 672 # Procedure post-menu {wbutton wmenu}
 673 #   wbutton    button widget
 674 #   wmenu      menu widget
 675 # Post menu near button. Note: not used.
 676 proc post-menu {wbutton wmenu} {
 677     $wmenu activate none
 678     focus $wmenu
 679     $wmenu post [winfo rootx $wbutton] \
 680             [expr [winfo rooty $wbutton]+[winfo height $wbutton]]
 681
 682 }
 683
 684 # Procedure destroyGW {w}
 685 #   w     top level widget
 686 # Saves geometry of widget w in windowGeometry array. This
 687 # Procedure is used to save current geometry of a window before
 688 # it is destroyed.
 689 # See also topLevelG.
 690 proc destroyGW {w} {
 691     global windowGeometry
 692     catch {set windowGeometry($w) [wm geometry $w]}
 693 }
 694
 695 # Procedure topLevelG
 696 #   w     top level widget
 697 # Makes a new top level widget named w; sets geometry of window if it
 698 # exists in windowGeometry array. The destroyGW procedure is set
 699 # to be called when the Destroy event occurs.
 700 proc toplevelG {w} {
 701     global windowGeometry
 702
 703     toplevel $w
 704     if {[info exists windowGeometry($w)]} {
 705         set g $windowGeometry($w)
 706         if {$g != ""} {
 707             wm geometry $w $g
 708         }
 709     }
 710     bind $w <Destroy> [list destroyGW $w]
 711 }
 712
 713 # Procedure top-down-window {w}
 714 #  w    window (possibly top level)
 715 # Makes two frames inside w called top and bot.
 716 proc top-down-window {w} {
 717     frame $w.top -relief raised -border 1
 718     frame $w.bot -relief raised -border 1
 719
 720     pack  $w.top -side top -fill both -expand yes
 721     pack  $w.bot -fill both
 722 }
 723
 724 # Procedure top-down-ok-cancel {w ok-action g}
 725 #  w          top level widget with $w.bot-frame
 726 #  ok-action  ok script
 727 #  g          grab flag
 728 # Makes two buttons in the bot frame called Ok and Cancel. The
 729 # ok-action is executed if Ok is pressed. If Cancel is activated
 730 # The window is destroyed. If g is true a grab is performed on the
 731 # window and the procedure waits until the window is destroyed.
 732 proc top-down-ok-cancel {w ok-action g} {
 733     frame $w.bot.left -relief sunken -border 1
 734     pack $w.bot.left -side left -expand yes -ipadx 2 -ipady 2 -padx 1 -pady 1
 735     button $w.bot.left.ok -width 4 -text {Ok} \
 736             -command ${ok-action}
 737     pack $w.bot.left.ok -expand yes -ipadx 1 -ipady 1 -padx 2 -pady 2
 738     button $w.bot.cancel -width 5 -text {Cancel} \
 739             -command [list destroy $w]
 740     pack $w.bot.cancel -side left -expand yes
 741
 742     if {$g} {
 743         grab $w
 744         tkwait window $w
 745     }
 746 }
 747
 748 # Procedure bottom-buttons {w buttonList g}
 749 #  w          top level widget with $w.bot-frame
 750 #  buttonList button specifications
 751 #  g          grab flag
 752 # Makes a list of buttons in the $w.bot frame. The buttonList is a list
 753 # of button specifications. Each button specification consists of two
 754 # items; the first item is button label name; the second item is a script
 755 # of be executed when that button is executed. A grab is performed if g
 756 # is true and it waits for the window to be destroyed.
 757 proc bottom-buttons {w buttonList g} {
 758     set i 0
 759     set l [llength $buttonList]
 760
 761     frame $w.bot.$i -relief sunken -border 1
 762     pack $w.bot.$i -side left -expand yes -padx 2 -pady 2
 763     button $w.bot.$i.ok -text [lindex $buttonList $i] \
 764             -command [lindex $buttonList [expr $i+1]]
 765     pack $w.bot.$i.ok -expand yes -padx 2 -pady 2 -side left
 766
 767     incr i 2
 768     while {$i < $l} {
 769         button $w.bot.$i -text [lindex $buttonList $i] \
 770                 -command [lindex $buttonList [expr $i+1]]
 771         pack $w.bot.$i -expand yes -padx 2 -pady 2 -side left
 772         incr i 2
 773     }
 774     if {$g} {
 775         # Grab ...
 776         grab $w
 777         tkwait window $w
 778     }
 779 }
 780
 781 # Procedure cancel-operation
 782 # This handler is invoked when the user wishes to cancel an operation.
 783 # If the system is currently busy a "Cancel" will be displayed in the
 784 # status area and the cancelFlag is set to true indicating that future
 785 # responses from the target should be ignored. The system is no longer
 786 # when this procedure exists.
 787 proc cancel-operation {} {
 788     global cancelFlag
 789     global busy
 790     global delayRequest
 791
 792     if {$busy} {
 793         set cancelFlag 1
 794         set delayRequest {}
 795         show-status Cancel 0 1
 796     }
 797 }
 798
 799 # Procedure show-target {target base}
 800 #  target     name of target
 801 #  base       name of database
 802 # Displays target name and database name in the target status area.
 803 proc show-target {target base} {
 804     global profile
 805
 806     if {![string length $target]} {
 807         .bot.a.target configure -text ""
 808         return
 809     }
 810     if {![string length $base]} {
 811          .bot.a.target configure -text "$target"
 812     } else {
 813          .bot.a.target configure -text "$target - $base"
 814     }
 815 }
 816
 817 # Procedure show-logo {v1}
 818 #  v1    integer level
 819 # This procedure maintains the book logo in the bottom of the screen.
 820 # It is invoked only once during initialization of windows, etc., and
 821 # by itself. The global 'busy' variable determines whether the logo is
 822 # moving or not.
 823 proc show-logo {v1} {
 824     global busy
 825     global libdir
 826
 827     if {$busy != 0} {
 828         incr v1
 829         if {$v1==10} {
 830             set v1 1
 831         }
 832         .bot.logo configure -bitmap @${libdir}/bitmaps/book${v1}
 833         after 140 [list show-logo $v1]
 834         return
 835     }
 836     while {1} {
 837         .bot.logo configure -bitmap @${libdir}/bitmaps/book1
 838         tkwait variable busy
 839         if {$busy} {
 840             show-logo 1
 841             return
 842         }
 843     }
 844 }
 845
 846 # Procedure show-status {status b sb}
 847 #  status     status message string
 848 #  b          busy indicator
 849 #  sb         search busy indicator
 850 # Display status information according to 'status' and sets the global
 851 # busy flag 'busy' to b if b is non-empty. If sb is non-empty it indicates
 852 # whether service buttons should be enabled or disabled.
 853 proc show-status {status b sb} {
 854     global busy
 855     global scanEnable
 856     global setOffset
 857     global setMax
 858     global setNo
 859
 860     .bot.a.status configure -text "$status"
 861     if {$b == 1} {
 862         if {$busy == 0} {set busy 1}
 863     } else {
 864         set busy 0
 865     }
 866     if {$sb == {}} {
 867         return
 868     }
 869     if {$sb} {
 870         .top.service configure -state normal
 871         .mid.search configure -state normal
 872         if {$scanEnable} {
 873             .mid.scan configure -state normal
 874         } else {
 875             configure-disable-e .top.service.m 3
 876         }
 877         if {$setNo == 0} {
 878             configure-disable-e .top.service.m 1
 879         } elseif {[z39.$setNo nextResultSetPosition] > 0 &&
 880             [z39.$setNo nextResultSetPosition] <= [z39.$setNo resultCount]} {
 881             configure-enable-e .top.service.m 1
 882             .mid.present configure -state normal
 883         } else {
 884             configure-disable-e .top.service.m 1
 885             .mid.present configure -state disabled
 886         }
 887         if {[winfo exists .scan-window]} {
 888             .scan-window.bot.2 configure -state normal
 889             .scan-window.bot.4 configure -state normal
 890         }
 891     } else {
 892         .top.service configure -state disabled
 893         .mid.search configure -state disabled
 894         .mid.scan configure -state disabled
 895         .mid.present configure -state disabled
 896
 897         if {[winfo exists .scan-window]} {
 898             .scan-window.bot.2 configure -state disabled
 899             .scan-window.bot.4 configure -state disabled
 900         }
 901     }
 902 }
 903
 904 # Procedure show-message {msg}
 905 #  msg    message string
 906 # Sets message the bottom of the screen to msg.
 907 proc show-message {msg} {
 908     .bot.a.message configure -text "$msg"
 909 }
 910
 911 # Procedure insertWithTags {w text args}
 912 #  w      text widget
 913 #  text   string to be inserted
 914 #  args   list of tags
 915 # Inserts text at the insertion point in widget w. The text is tagged
 916 # with the tags in args.
 917 proc insertWithTags {w text args} {
 918     set start [$w index insert]
 919     $w insert insert $text
 920     foreach tag [$w tag names $start] {
 921         $w tag remove $tag $start insert
 922     }
 923     foreach i $args {
 924         $w tag add $i $start insert
 925     }
 926 }
 927
 928 # Procedure popup-license
 929 # Displays LICENSE information.
 930 proc popup-license {} {
 931     global libdir
 932     set w .popup-licence
 933     toplevel $w
 934
 935     wm title $w "License"
 936
 937     wm minsize $w 0 0
 938
 939     top-down-window $w
 940
 941     text $w.top.t -width 80 -height 10 -wrap word -relief flat -borderwidth 0 \
 942         -font fixed -yscrollcommand [list $w.top.s set]
 943     scrollbar $w.top.s -command [list $w.top.t yview]
 944
 945     pack $w.top.s -side right -fill y
 946     pack $w.top.t -expand yes -fill both
 947
 948     if {[file readable "${libdir}/LICENSE"]} {
 949         set f [open "${libdir}/LICENSE" r]
 950         while {[gets $f buf] != -1} {
 951             $w.top.t insert end $buf
 952             $w.top.t insert end "\n"
 953         }
 954         close $f
 955     }
 956     bottom-buttons $w [list {Close} [list destroy $w]] 1
 957 }
 958
 959 # Procedure about-target
 960 # Displays various information about the current target, such
 961 # as implementation-name, implementation-id, etc.
 962 proc about-target {} {
 963     set w .about-target-w
 964     global hostid
 965
 966     toplevel $w
 967
 968     wm title $w "About target"
 969     place-force $w .
 970     top-down-window $w
 971
 972     frame $w.top.a -relief ridge -border 2
 973     frame $w.top.p -relief ridge -border 2
 974
 975     pack $w.top.a $w.top.p -side top -fill x
 976
 977     label $w.top.a.about -text "About"
 978     label $w.top.a.irtcl -text $hostid \
 979             -font -Adobe-Helvetica-Bold-R-Normal-*-240-*
 980     pack $w.top.a.about $w.top.a.irtcl -side top
 981
 982     set i [z39 targetImplementationName]
 983     label $w.top.p.in -text "Implementation name: $i"
 984     set i [z39 targetImplementationId]
 985     label $w.top.p.ii -text "Implementation id: $i"
 986     set i [z39 targetImplementationVersion]
 987     label $w.top.p.iv -text "Implementation version: $i"
 988     set i [z39 options]
 989     label $w.top.p.op -text "Protocol options: $i"
 990
 991     pack $w.top.p.in $w.top.p.ii $w.top.p.iv $w.top.p.op -side top -anchor nw
 992
 993     bottom-buttons $w [list {Close} [list destroy $w]] 1
 994 }
 995
 996 # Procedure about-origin-logo {n}
 997 #   n    integer level
 998 # Displays book logo in the .about-origin-w widget
 999 proc about-origin-logo {n} {
1000     global libdir
1001     set w .about-origin-w
1002     if {![winfo exists $w]} {
1003         return
1004     }
1005     incr n
1006     if {$n==10} {
1007         set n 1
1008     }
1009     $w.top.a.logo configure -bitmap @${libdir}/bitmaps/book$n
1010     after 140 [list about-origin-logo $n]
1011 }
1012
1013 # Procedure about-origin
1014 # Display various information about origin (this client).
1015 proc about-origin {} {
1016     set w .about-origin-w
1017     global libdir
1018     global tk_version
1019
1020     if {[winfo exists $w]} {
1021         destroy $w
1022     }
1023     toplevel $w
1024
1025     wm title $w "About IrTcl"
1026     place-force $w .
1027     top-down-window $w
1028
1029     frame $w.top.a -relief ridge -border 2
1030     frame $w.top.p -relief ridge -border 2
1031
1032     pack $w.top.a $w.top.p -side top -fill x
1033
1034     label $w.top.a.irtcl -text "IrTcl" \
1035             -font -Adobe-Helvetica-Bold-R-Normal-*-240-*
1036     label $w.top.a.logo -bitmap @${libdir}/bitmaps/book1
1037     pack $w.top.a.irtcl $w.top.a.logo -side left -expand yes
1038
1039     set i unknown
1040     catch {set i [z39 implementationName]}
1041     label $w.top.p.in -text "Implementation name: $i"
1042     catch {set i [z39 implementationId]}
1043     label $w.top.p.ii -text "Implementation id: $i"
1044     catch {set i [z39 implementationVersion]}
1045     label $w.top.p.iv -text "Implementation version: $i"
1046     set i $tk_version
1047     label $w.top.p.tk -text "Tk version: $i"
1048
1049     pack $w.top.p.in $w.top.p.ii $w.top.p.iv $w.top.p.tk -side top -anchor nw
1050
1051     about-origin-logo 1
1052     bottom-buttons $w [list {Close} [list destroy $w] \
1053                             {License} [list popup-license]] 0
1054 }
1055
1056 # Procedure popup-marc {sno no b df}
1057 #  sno     result set number
1058 #  no      record position number
1059 #  b       popup window number
1060 #  df      display format
1061 # Displays record in set $sno at position $no in window .full-marc$b.
1062 # The global variable $popupMarcdf holds the current format method.
1063 proc popup-marc {sno no b df} {
1064     global displayFormats
1065     global popupMarcdf
1066
1067     if {[z39.$sno type $no] != "DB"} {
1068         return
1069     }
1070     if {$b == -1} {
1071         set b 0
1072         while {[winfo exists .full-marc$b]} {
1073             incr b
1074         }
1075     }
1076     set df $popupMarcdf
1077     set w .full-marc$b
1078     if {![winfo exists $w]} {
1079         toplevelG $w
1080
1081         wm minsize $w 0 0
1082
1083         frame $w.top -relief raised -border 1
1084         frame $w.bot -relief raised -border 1
1085
1086         pack  $w.top -side top -fill both -expand yes
1087         pack  $w.bot -fill both
1088
1089         text $w.top.record -width 60 -height 5 -wrap word -relief flat \
1090                 -borderwidth 0 -font fixed -yscrollcommand [list $w.top.s set]
1091         scrollbar $w.top.s -command [list $w.top.record yview]
1092
1093         global monoFlag
1094         if {! $monoFlag} {
1095             $w.top.record tag configure marc-tag -foreground blue
1096             $w.top.record tag configure marc-id -foreground red
1097         } else {
1098             $w.top.record tag configure marc-tag -foreground black
1099             $w.top.record tag configure marc-id -foreground black
1100         }
1101         $w.top.record tag configure marc-data -foreground black
1102         $w.top.record tag configure marc-head \
1103                 -font -Adobe-Times-Medium-R-Normal-*-180-* \
1104                 -background black -foreground white
1105
1106         $w.top.record tag configure marc-pref \
1107                 -font -Adobe-Times-Medium-R-Normal-*-180-* \
1108                 -foreground blue
1109         $w.top.record tag configure marc-text \
1110                 -font -Adobe-Times-Medium-R-Normal-*-180-* \
1111                 -foreground black
1112         $w.top.record tag configure marc-it \
1113                 -font -Adobe-Times-Medium-I-Normal-*-180-* \
1114                 -foreground black
1115
1116         pack $w.top.s -side right -fill y
1117         pack $w.top.record -expand yes -fill both
1118
1119         bottom-buttons $w [list \
1120                 {Close} [list destroy $w] \
1121                 {Prev} {} \
1122                 {Next} {} \
1123                 {Duplicate} {}] 0
1124         menubutton $w.bot.formats -text "Format" -menu $w.bot.formats.m \
1125                 -relief raised
1126         menu $w.bot.formats.m
1127         pack $w.bot.formats -expand yes -ipadx 2 -ipady 2 \
1128                 -padx 3 -pady 3 -side left
1129     } else {
1130         $w.bot.formats.m delete 0 last
1131     }
1132     set i 0
1133     foreach f $displayFormats {
1134         $w.bot.formats.m add radiobutton -label $f \
1135                 -variable popupMarcdf -value $i \
1136                 -command [list popup-marc $sno $no $b 0]
1137         incr i
1138     }
1139     $w.top.record delete 0.0 end
1140     set recordType [z39.$sno recordType $no]
1141     wm title $w "$recordType record #$no"
1142
1143     $w.bot.2 configure -command \
1144             [list popup-marc $sno [expr $no-1] $b $df]
1145     $w.bot.4 configure -command \
1146             [list popup-marc $sno [expr $no+1] $b $df]
1147     if {$no == 1} {
1148         $w.bot.2 configure -state disabled
1149     } else {
1150         $w.bot.2 configure -state normal
1151     }
1152     if {[z39.$sno type [expr $no+1]] != "DB"} {
1153         $w.bot.4 configure -state disabled
1154     } else {
1155         $w.bot.4 configure -state normal
1156     }
1157     $w.bot.6 configure -command [list popup-marc $sno $no -1 0]
1158     set ffunc [lindex $displayFormats $df]
1159     set ffunc "display-$ffunc"
1160
1161     $ffunc $sno $no $w.top.record 0
1162 }
1163
1164 # Procedure update-target-hotlist {target base}
1165 #  target     current target name
1166 #  base       current database name
1167 # Updates the global $hotTargets so that $target and $base are
1168 # moved to the front, i.e. they become the number 1 target/base.
1169 # The target menu is updated by a call to set-target-hotlist.
1170 proc update-target-hotlist {target base} {
1171     global hotTargets
1172
1173     set olen [llength $hotTargets]
1174     set i 0
1175     foreach e $hotTargets {
1176         if {$target == [lindex $e 0] && $base == [lindex $e 1]} {
1177             set hotTargets [lreplace $hotTargets $i $i]
1178             break
1179         }
1180         incr i
1181     }
1182     set hotTargets [linsert $hotTargets 0 [list $target $base]]
1183     set-target-hotlist $olen
1184 }
1185
1186 # Procedure delete-target-hotlist {target}
1187 #  target    target to be deleted
1188 # Updates the global $hotTargets so that $target is removed.
1189 # The target menu is updated by a call to set-target-hotlist.
1190 proc delete-target-hotlist {target} {
1191     global hotTargets
1192
1193     set olen [llength $hotTargets]
1194     set i 0
1195     foreach e $hotTargets {
1196         if {$target == [lindex $e 0]} {
1197             set hotTargets [lreplace $hotTargets $i $i]
1198         }
1199         incr i
1200     }
1201     set-target-hotlist $olen
1202 }
1203
1204 # Procedure set-target-hotlist {olen}
1205 #  olen     number of hot target entries to be deleted from menu
1206 # Updates the target menu with the targets with the first 8 entries
1207 # in the $hotTargets global.
1208 proc set-target-hotlist {olen} {
1209     global hotTargets
1210
1211     if {$olen > 0} {
1212         if {[tk4]} {
1213             .top.target.m delete 7 [expr 7+$olen]
1214         } else {
1215             .top.target.m delete 6 [expr 6+$olen]
1216         }
1217     }
1218     set i 1
1219     foreach e $hotTargets {
1220         set target [lindex $e 0]
1221         set base [lindex $e 1]
1222         if {![string length $base]} {
1223             .top.target.m add command -label "$i $target" -command \
1224                 [list reopen-target $target {}]
1225         } else {
1226             .top.target.m add command -label "$i $target - $base" -command \
1227                 [list reopen-target $target $base]
1228         }
1229         incr i
1230         if {$i > 8} {
1231              break
1232         }
1233     }
1234 }
1235
1236 # Procedure reopen-target {target base}
1237 #  target    target to be opened
1238 #  base      base to be used
1239 # Closes connection with current target and opens a new connection
1240 # with $target and database $base.
1241 proc reopen-target {target base} {
1242     close-target
1243     open-target $target $base
1244     update-target-hotlist $target $base
1245 }
1246
1247 # Procedure define-target-action
1248 # Prepares the setup of a new target. The name of the target
1249 # is read from the dialog .target-define dialog (procedure
1250 # define-target-dialog) and the target definition window is displayed by
1251 # a call to protocol-setup.
1252 proc define-target-action {} {
1253     global profile
1254
1255     set target [.target-define.top.target.entry get]
1256     if {![string length $target]} {
1257         return
1258     }
1259     foreach n [array names profile] {
1260         if {$n == $target} {
1261             destroy .target-define
1262             protocol-setup $n
1263             return
1264         }
1265     }
1266     set seq [lindex $profile(Default) 12]
1267     dputs "seq=${seq}"
1268     dputs $profile(Default)
1269     set profile($target) $profile(Default)
1270     set profile(Default) [lreplace $profile(Default) 12 12 [incr seq]]
1271
1272     protocol-setup $target
1273     destroy .target-define
1274 }
1275
1276 # Procedure fail-response {target}
1277 #  target   current target
1278 # Error handler (IrTcl failback) that takes care of serious protocol
1279 # errors, connection lost, etc.
1280 proc fail-response {target} {
1281     global debugMode
1282
1283     set c [lindex [z39 failInfo] 0]
1284     set m [lindex [z39 failInfo] 1]
1285     if {$c == 4 || $c == 5} {
1286         set debugMode 1
1287         apduDump
1288     }
1289     close-target
1290     tkerror "$m ($c)"
1291 }
1292
1293 # Procedure connect-response {target base}
1294 #  target   current target
1295 #  base     current database
1296 # IrTcl connect response handler.
1297 proc connect-response {target base} {
1298     dputs "connect-response"
1299     init-request $target $base
1300 }
1301
1302 # Procedure open-target {target base}
1303 #  target   target to be opened
1304 #  base     database to be used
1305 # Opens a new connection with $target/$base.
1306 proc open-target {target base} {
1307     global profile
1308     global hostid
1309     global presentChunk
1310
1311     set desc [lindex $profile($target) 0]
1312     if {[string length $desc]} {
1313         .data.record insert end $desc
1314     } else {
1315         .data.record insert end $target
1316     }
1317     .data.record insert end "\n\n"
1318
1319     z39 disconnect
1320     z39 comstack [lindex $profile($target) 6]
1321     z39 protocol [lindex $profile($target) 11]
1322     eval z39 idAuthentication [lindex $profile($target) 3]
1323     z39 maximumRecordSize [lindex $profile($target) 4]
1324     z39 preferredMessageSize [lindex $profile($target) 5]
1325     dputs "maximumRecordSize=[z39 maximumRecordSize]"
1326     dputs "preferredMessageSize=[z39 preferredMessageSize]"
1327     show-status Connecting 1 0
1328     set x [lindex $profile($target) 13]
1329     if {![string length $x]} {
1330         set x 2
1331     }
1332     z39 largeSetLowerBound $x
1333
1334     set x [lindex $profile($target) 14]
1335     if {![string length $x]} {
1336         set x 0
1337     }
1338     z39 smallSetUpperBound $x
1339
1340     set x [lindex $profile($target) 15]
1341     if {![string length $x]} {
1342         set x 0
1343     }
1344     z39 mediumSetPresentNumber $x
1345
1346     set presentChunk [lindex $profile($target) 16]
1347     if {![string length $presentChunk]} {
1348         set presentChunk 4
1349     }
1350
1351     z39 failback [list fail-response $target]
1352     z39 callback [list connect-response $target $base]
1353     show-target $target $base
1354     update idletasks
1355     set err [catch {
1356         z39 connect [lindex $profile($target) 1]:[lindex $profile($target) 2]
1357         } errorMessage]
1358     if {$err} {
1359         set hostid Default
1360         tkerror $errorMessage
1361         show-status "Not connected" 0 {}
1362         show-target {} {}
1363         return
1364     }
1365     set hostid $target
1366     configure-disable-e .top.target.m 0
1367     configure-enable-e .top.target.m 1
1368     configure-enable-e .top.target.m 2
1369 }
1370
1371 # Procedure close-target
1372 # Shuts down the connection with current target.
1373 proc close-target {} {
1374     global hostid
1375     global cancelFlag
1376     global setNo
1377     global setNoLast
1378
1379     set cancelFlag 0
1380     set setNo 0
1381     set setNoLast 0
1382     .bot.a.set configure -text ""
1383     set hostid Default
1384     z39 disconnect
1385     show-target {} {}
1386     show-status {Not connected} 0 0
1387     init-title-lines
1388     show-message {}
1389     configure-disable-e .top.target.m 1
1390     configure-disable-e .top.target.m 2
1391     if {[tk4]} {
1392         .top.rset.m delete 2 last
1393     } else {
1394         .top.rset.m delete 1 last
1395     }
1396     .top.rset.m add separator
1397     configure-enable-e .top.target.m 0
1398 }
1399
1400 # Procedure load-set-action
1401 # Loads records from a file. The filename is read from the entry
1402 # .load-set.filename.entry (see function load-set)
1403 proc load-set-action {} {
1404     global setNoLast
1405
1406     incr setNoLast
1407     ir-set z39.$setNoLast z39
1408
1409     set fname [.load-set.top.filename.entry get]
1410     destroy .load-set
1411     if {$fname != ""} {
1412         show-status Loading 1 {}
1413         update
1414         z39.$setNoLast loadFile $fname
1415
1416         set no [z39.$setNoLast numberOfRecordsReturned]
1417         add-title-lines $setNoLast $no 1
1418     }
1419     set l [format "%-4d %7d" $setNoLast $no]
1420     .top.rset.m add command -label $l \
1421             -command [list add-title-lines $setNoLast 10000 1]
1422     show-status Ready 0 {}
1423 }
1424
1425 # Procedure load-set
1426 # Dialog that asks for a filename with records to be loaded
1427 # into a result set.
1428 proc load-set {} {
1429     set w .load-set
1430     toplevel $w
1431     set oldFocus [focus]
1432     place-force $w .
1433     top-down-window $w
1434
1435     frame $w.top.filename
1436     pack $w.top.filename -side top -anchor e -pady 2
1437
1438     entry-fields $w.top {filename} \
1439             {{Filename:}} \
1440             {load-set-action} {destroy .load-set}
1441
1442     top-down-ok-cancel $w {load-set-action} 1
1443     focus $oldFocus
1444 }
1445
1446 # Procedure init-request
1447 # Sends an initialize request to the target. This procedure is called
1448 # when a connect has been established.
1449 proc init-request {target base} {
1450     global cancelFlag
1451
1452     if {$cancelFlag} {
1453         close-target
1454         return
1455     }
1456     z39 callback [list init-response $target $base]
1457     show-status Initializing 1 {}
1458     set err [catch {z39 init} errorMessage]
1459     if {$err} {
1460         tkerror $errorMessage
1461         show-status Ready 0 {}
1462     }
1463 }
1464
1465 # Procedure init-response
1466 # Handles and incoming init-response. The service buttons
1467 # are enabled. The global $scanEnable indicates whether the target
1468 # supports scan.
1469 proc init-response {target base} {
1470     global cancelFlag profile
1471     global scanEnable settingsChanged
1472
1473     dputs {init-response}
1474     apduDump
1475     if {$cancelFlag} {
1476         close-target
1477         return
1478     }
1479     if {![z39 initResult]} {
1480         set u [z39 userInformationField]
1481         close-target
1482         tkerror "Connection rejected by target: $u"
1483     } else {
1484         explain-check $target [list ready-response $base]
1485     }
1486 }
1487
1488 # Procedure explain-check
1489 # Stub function to check explain. May be overwritten later.
1490 proc explain-check {target response} {
1491     eval $response [list $target]
1492 }
1493
1494 # Procedure ready-response
1495 # Called after a target has been initialized and, possibly, explained
1496 proc ready-response {base target} {
1497     global profile settingsChanged scanEnable
1498
1499     if {![string length $base]} {
1500         set base [lindex [lindex $profile($target) 7] 0]
1501     }
1502     if {![string length $base]} {
1503         set base Default
1504     }
1505     z39 databaseNames $base
1506     set profile($target) [lreplace $profile($target) 18 18 [clock seconds]]
1507     set settingsChanged 1
1508     if {[lsearch [z39 options] scan] >= 0} {
1509         set scanEnable 1
1510     } else {
1511         set scanEnable 0
1512     }
1513     cascade-dblist $target $base
1514     show-target $target $base
1515     show-message {}
1516     show-status Ready 0 1
1517
1518     .data.record insert end [lindex $profile($target) 27]
1519     .data.record insert end "\n"
1520     set data [lindex $profile($target) 21]
1521     if {[string length $data]} {
1522         .data.record insert end "News:\n"
1523         .data.record insert end "$data\n"
1524     }
1525 }
1526
1527 # Procedure search-request
1528 #  bflag     flag to indicate if this procedure calls itself
1529 # Performs a search. If $busy is 1, the search-request is performed
1530 # at a later time (when another response arrives). This procedure
1531 # sets many search-related Z39-settings. The global $setNo is set
1532 # to the result set number (z39.$setNo).
1533 proc search-request {bflag} {
1534     global setNo
1535     global setNoLast
1536     global profile
1537     global hostid
1538     global busy
1539     global cancelFlag
1540     global delayRequest
1541     global recordSyntax
1542     global elementSetNames
1543
1544     set target $hostid
1545
1546     if {![string length [z39 connect]]} {
1547         return
1548     }
1549     dputs "search-request"
1550     show-message {}
1551     if {!$bflag && $busy} {
1552         dputs "busy: search-request ignored"
1553         return
1554     }
1555     if {$cancelFlag} {
1556         dputs "cancelFlag"
1557         show-status Searching 1 0
1558         set delayRequest {search-request 1}
1559         return
1560     }
1561     set delayRequest {}
1562
1563     set query [index-query]
1564     if {![string length $query]} {
1565         return
1566     }
1567     incr setNoLast
1568     set setNo $setNoLast
1569     ir-set z39.$setNo z39
1570
1571     if {[lindex $profile($target) 10] == 1} {
1572         z39.$setNo setName $setNo
1573         dputs "setName=${setNo}"
1574     } else {
1575         z39.$setNo setName Default
1576         dputs "setName=Default"
1577     }
1578     if {[lindex $profile($target) 8] == 1} {
1579         z39.$setNo queryType rpn
1580     }
1581     if {[lindex $profile($target) 9] == 1} {
1582         z39.$setNo queryType ccl
1583     }
1584     dputs Setting
1585     dputs $recordSyntax
1586     if {![string compare $recordSyntax None]} {
1587         z39.$setNo preferredRecordSyntax {}
1588     } else {
1589         z39.$setNo preferredRecordSyntax $recordSyntax
1590     }
1591     if {![string compare $elementSetNames None]} {
1592         z39.$setNo elementSetNames {}
1593         z39.$setNo smallSetElementSetNames {}
1594         z39.$setNo mediumSetElementSetNames {}
1595     } else {
1596         z39.$setNo elementSetNames $elementSetNames
1597         z39.$setNo smallSetElementSetNames $elementSetNames
1598         z39.$setNo mediumSetElementSetNames $elementSetNames
1599     }
1600     z39 callback {search-response}
1601     z39.$setNo search $query
1602     show-status Searching 1 0
1603 }
1604
1605 # Procedure scan-copy {y entry}
1606 #  y       y-position of mouse pointer
1607 #  entry   a search entry in the top
1608 # Copies the term in the list nearest $y to the query entry specified
1609 # by $entry
1610 proc scan-copy {y entry} {
1611     set w .scan-window
1612     set no [$w.top.list nearest $y]
1613     dputs "no=$no"
1614     .lines.$entry.e delete 0 end
1615     .lines.$entry.e insert 0 [string range [$w.top.list get $no] 8 end]
1616 }
1617
1618 # Procedure scan-request
1619 # Performs a scan on term "0" with the current attributes in entry
1620 # specified by the global $curIndexEntry.
1621 proc scan-request {} {
1622     set w .scan-window
1623
1624     global profile
1625     global hostid
1626     global scanView
1627     global scanTerm
1628     global curIndexEntry
1629     global queryButtonsFind
1630     global queryInfoFind
1631     global cancelFlag
1632     global delayRequest
1633
1634     dputs "scan-request"
1635     if {$cancelFlag} {
1636         dputs "cancelFlag"
1637         show-status Scanning 1 0
1638         set delayRequest scan-request
1639         return
1640     }
1641     set delayRequest {}
1642
1643     set target $hostid
1644     set scanView 0
1645     set scanTerm {}
1646
1647     set b [lindex $queryButtonsFind $curIndexEntry]
1648     set attr {}
1649     foreach a [lrange [lindex $queryInfoFind [lindex $b 1]] 1 end] {
1650         set attr "@attr $a $attr"
1651     }
1652     set title [lindex [lindex $queryInfoFind [lindex $b 1]] 0]
1653     ir-scan z39.scan z39
1654
1655     if {![winfo exists $w]} {
1656         toplevelG $w
1657
1658         wm minsize $w 0 0
1659
1660         top-down-window $w
1661
1662         entry $w.top.entry -relief sunken
1663         pack $w.top.entry -fill x -padx 4 -pady 2
1664         bind $w.top.entry <KeyRelease> [list scan-term-h $attr]
1665         listbox $w.top.list -yscrollcommand [list $w.top.scroll set] \
1666                 -font fixed
1667         scrollbar $w.top.scroll -orient vertical -border 1
1668         pack $w.top.list -side left -fill both -expand yes
1669         pack $w.top.scroll -side right -fill y
1670         $w.top.scroll config -command [list $w.top.list yview]
1671
1672         bottom-buttons $w [list {Close} [list destroy $w] \
1673                 {Up} [list scan-up $attr] \
1674                 {Down} [list scan-down $attr]] 0
1675         bind $w.top.list <Up> [list scan-up $attr]
1676         bind $w.top.list <Down> [list scan-down $attr]
1677         focus $w.top.entry
1678     }
1679     bind $w.top.list <Double-Button-1> [list scan-copy %y $curIndexEntry]
1680     wm title $w "Scan $title"
1681
1682     z39 callback [list scan-response $attr 0 35]
1683     z39.scan numberOfTermsRequested 5
1684     z39.scan preferredPositionInResponse 1
1685     z39.scan scan "${attr} 0"
1686
1687     show-status Scanning 1 0
1688 }
1689
1690 # Procedure scan-term-h {attr}
1691 # attr    attribute specification
1692 # This procedure is called whenever a key is released in the entry in the
1693 # scan window (.scan-window). A scan is then initiated with the new contents
1694 # of the entry as the starting term.
1695 proc scan-term-h {attr} {
1696     global busy
1697     global scanTerm
1698
1699     if {$busy} {
1700         return
1701     }
1702     set w .scan-window
1703     set nScanTerm [$w.top.entry get]
1704     if {$nScanTerm == $scanTerm} {
1705         return
1706     }
1707     set scanTerm $nScanTerm
1708     z39 callback [list scan-response $attr 0 35]
1709     z39.scan numberOfTermsRequested 5
1710     z39.scan preferredPositionInResponse 1
1711     dputs "${attr} \{${scanTerm}\}"
1712     if {![string length $scanTerm]} {
1713         z39.scan scan "${attr} 0"
1714     } else {
1715         z39.scan scan "${attr} \{${scanTerm}\}"
1716     }
1717     show-status Scanning 1 0
1718 }
1719
1720 # Procedure scan-response {attr start toget}
1721 #  attr   attribute specification
1722 #  start  position of first term in the response
1723 #  toget  number of total terms to get
1724 # This procedure handles all scan-responses. $start specifies the list
1725 # entry number of the first incoming term. The $toget indicates the total
1726 # number of terms to be retrieved from the target. The $toget may be
1727 # negative in which case, scan is performed 'backwards' (- $toget is
1728 # the total number of terms in this case). This procedure usually calls
1729 # itself several times in order to get small scan-term-list chunks.
1730 proc scan-response {attr start toget} {
1731     global cancelFlag
1732     global delayRequest
1733     global scanTerm
1734     global scanView
1735
1736     set w .scan-window
1737     dputs "In scan-response"
1738     apduDump
1739     set m [z39.scan numberOfEntriesReturned]
1740     dputs $m
1741     dputs attr=$attr
1742     dputs start=$start
1743     dputs toget=$toget
1744
1745     if {![winfo exists .scan-window]} {
1746         if {$cancelFlag} {
1747             set cancelFlag 0
1748             dputs "Handling cancel"
1749             if {$delayRequest != ""} {
1750                 eval $delayRequest
1751             }
1752             return
1753         }
1754         show-status Ready 0 1
1755         return
1756     }
1757     set nScanTerm [$w.top.entry get]
1758     if {$nScanTerm != $scanTerm} {
1759         z39 callback [list scan-response $attr 0 35]
1760         z39.scan numberOfTermsRequested 5
1761         z39.scan preferredPositionInResponse 1
1762         set scanTerm $nScanTerm
1763         dputs "${attr} \{${scanTerm}\}"
1764         if {![string length $scanTerm]} {
1765             z39.scan scan "${attr} 0"
1766         } else {
1767             z39.scan scan "${attr} \{${scanTerm}\}"
1768         }
1769         show-status Scanning 1 0
1770         return
1771     }
1772     set status [z39.scan scanStatus]
1773     if {$status == 6} {
1774         tkerror "Scan fail"
1775         show-status Ready 0 1
1776         set cancelFlag 0
1777         return
1778     }
1779     if {$toget < 0} {
1780         for {set i 0} {$i < $m} {incr i} {
1781             set term [lindex [z39.scan scanLine $i] 1]
1782             set nostr [format " %-6d" [lindex [z39.scan scanLine $i] 2]]
1783             $w.top.list insert $i "$nostr $term"
1784         }
1785         incr scanView $m
1786         $w.top.list yview $scanView
1787     } else {
1788         $w.top.list delete $start end
1789         for {set i 0} {$i < $m} {incr i} {
1790             set term [lindex [z39.scan scanLine $i] 1]
1791             set nostr [format " %-6d" [lindex [z39.scan scanLine $i] 2]]
1792             $w.top.list insert end "$nostr $term"
1793         }
1794     }
1795     if {$cancelFlag} {
1796         dputs "Handling cancel"
1797         set cancelFlag 0
1798         if {$delayRequest != ""} {
1799             eval $delayRequest
1800         }
1801         return
1802     }
1803     set delayRequest {}
1804     if {$toget > 0 && $m > 1 && $m < $toget} {
1805         set ntoget [expr $toget - $m + 1]
1806         dputs ntoget=$ntoget
1807         z39 callback [list scan-response $attr [expr $start + $m - 1] $ntoget]
1808         set q $term
1809         dputs "down continue: $q"
1810         if {$ntoget > 10} {
1811             z39.scan numberOfTermsRequested 10
1812         } else {
1813             z39.scan numberOfTermsRequested $ntoget
1814         }
1815         z39.scan preferredPositionInResponse 1
1816         dputs "${attr} \{$q\}"
1817         z39.scan scan "${attr} \{$q\}"
1818         return
1819     }
1820     if {$toget < 0 && $m > 1 && $m < [expr - $toget]} {
1821         set ntoget [expr - $toget - $m]
1822         dputs ntoget=$ntoget
1823         z39 callback [list scan-response $attr 0 -$ntoget]
1824         set q [string range [$w.top.list get 0] 8 end]
1825         dputs "up continue: $q"
1826         if {$ntoget > 10} {
1827             z39.scan numberOfTermsRequested 10
1828             z39.scan preferredPositionInResponse 11
1829         } else {
1830             z39.scan numberOfTermsRequested $ntoget
1831             z39.scan preferredPositionInResponse [incr ntoget]
1832         }
1833         dputs "${attr} \{$q\}"
1834         z39.scan scan "${attr} \{$q\}"
1835         return
1836     }
1837     show-status Ready 0 1
1838 }
1839
1840 # Procedure scan-down {attr}
1841 #  attr   attribute specification
1842 # This procedure is called when the user hits the Down button the scan
1843 # window. A new scan is initiated with a positive $toget passed to the
1844 # scan-response handler.
1845 proc scan-down {attr} {
1846     global scanView
1847     global cancelFlag
1848     global delayRequest
1849
1850     dputs {scan-down}
1851     if {$cancelFlag} {
1852         dputs "cancelFlag"
1853         show-status {Scanning down} 1 0
1854         set delayRequest [list scan-down $attr]
1855         return
1856     }
1857     set delayRequest {}
1858
1859     set w .scan-window
1860     set scanView [expr $scanView + 5]
1861     set s [$w.top.list size]
1862     if {$scanView > $s} {
1863         z39 callback [list scan-response $attr [expr $s - 1] 25]
1864         set q [string range [$w.top.list get [expr $s - 1]] 8 end]
1865         dputs "down: $q"
1866         z39.scan numberOfTermsRequested 10
1867         z39.scan preferredPositionInResponse 1
1868         show-status Scanning 1 0
1869         dputs "${attr} \{$q\}"
1870         z39.scan scan "${attr} \{$q\}"
1871         return
1872     }
1873     $w.top.list yview $scanView
1874 }
1875
1876 # Procedure scan-up {attr}
1877 #  attr   attribute specification
1878 # This procedure is called when the user hits the Up button the scan
1879 # window. A new scan is initiated with a negative $toget passed to the
1880 # scan-response handler.
1881 proc scan-up {attr} {
1882     global scanView
1883     global cancelFlag
1884     global delayRequest
1885
1886     dputs {scan-up}
1887     if {$cancelFlag} {
1888         dputs "cancelFlag"
1889         show-status Scanning 1 0
1890         set delayRequest [list scan-up $attr]
1891         return
1892     }
1893     set delayRequest {}
1894
1895     set w .scan-window
1896     set scanView [expr $scanView - 5]
1897     if {$scanView < 0} {
1898         z39 callback [list scan-response $attr 0 -25]
1899         set q [string range [$w.top.list get 0] 8 end]
1900         dputs "up: $q"
1901         z39.scan numberOfTermsRequested 10
1902         z39.scan preferredPositionInResponse 11
1903         show-status Scanning 1 0
1904         z39.scan scan "${attr} \{$q\}"
1905         return
1906     }
1907     $w.top.list yview $scanView
1908 }
1909
1910 # Procedure search-response
1911 # This procedure handles search-responses. If the search is successful
1912 # this procedure will try to retrieve a total of 20 records from the target;
1913 # however not more than $presentChunk records at a time. This procedure
1914 # affects the following globals:
1915 #   $setOffset        current record position offset
1916 #   $setMax           total number of records to be retrieved
1917 proc search-response {} {
1918     global setNo
1919     global setOffset
1920     global setMax
1921     global cancelFlag
1922     global busy
1923     global delayRequest
1924     global presentChunk
1925
1926     apduDump
1927     dputs "In search-response"
1928     if {$cancelFlag} {
1929         dputs "Handling cancel"
1930         set cancelFlag 0
1931         if {$delayRequest != ""} {
1932             eval $delayRequest
1933         }
1934         return
1935     }
1936     set setOffset 0
1937     set delayRequest {}
1938     init-title-lines
1939     set setMax [z39.$setNo resultCount]
1940     show-status Ready 0 1
1941     set status [z39.$setNo responseStatus]
1942     if {![string compare [lindex $status 0] NSD]} {
1943         z39.$setNo nextResultSetPosition 0
1944         set code [lindex $status 1]
1945         set msg [lindex $status 2]
1946         set addinfo [lindex $status 3]
1947         tkerror "NSD$code: $msg: $addinfo"
1948         dputs "xxxxxxxxxxxxxxx"
1949         return
1950     }
1951     show-message "${setMax} hits"
1952     if {$setMax == 0} {
1953         return
1954     }
1955     set setOffset 1
1956     show-status Ready 0 1
1957     set l [format "%-4d %7d" $setNo $setMax]
1958     .top.rset.m add command -label $l \
1959             -command [list recall-set $setNo]
1960     if {$setMax > 20} {
1961         set setMax 20
1962     }
1963     set no [z39.$setNo numberOfRecordsReturned]
1964     dputs "Returned $no records, setOffset $setOffset"
1965     add-title-lines $setNo $no $setOffset
1966     set setOffset [expr $setOffset + $no]
1967
1968     set toGet [expr $setMax - $setOffset + 1]
1969     if {$toGet > 0} {
1970         if {$setOffset == 1} {
1971             set toGet 1
1972         } elseif {$toGet > $presentChunk} {
1973             set toGet $presentChunk
1974         }
1975         z39 callback {present-response}
1976         z39.$setNo present $setOffset $toGet
1977         show-status Retrieving 1 0
1978     }
1979 }
1980
1981 # Procedure present-more {number}
1982 #  number      number of records to be retrieved
1983 # This procedure starts a present-request. The $number variable indicates
1984 # the total number of records to be retrieved. The global $presentChunk
1985 # specifies the number of records to be retrieved at a time. If $number
1986 # is the empty string all remaining records in the result set are
1987 # retrieved.
1988 proc present-more {number} {
1989     global setNo
1990     global setOffset
1991     global setMax
1992     global busy
1993     global cancelFlag
1994     global delayRequest
1995     global presentChunk
1996
1997     dputs "present-more"
1998     if {$cancelFlag} {
1999         show-status Retrieving 1 0
2000         set delayRequest "present-more $number"
2001         return
2002     }
2003     set delayRequest {}
2004
2005     if {$setNo == 0} {
2006         dputs "setNo=$setNo"
2007         return
2008     }
2009     set setOffset [z39.$setNo nextResultSetPosition]
2010     dputs "setOffest=${setOffset}"
2011     dputs "setNo=${setNo}"
2012     set max [z39.$setNo resultCount]
2013     if {$max < $setOffset} {
2014         dputs "max=$max"
2015         dputs "setOffset=$setOffset"
2016         show-status Ready 0 1
2017         return
2018     }
2019     if {![string length $number]} {
2020         set setMax $max
2021     } else {
2022         incr setMax $number
2023         if {$setMax > $max} {
2024             set setMax $max
2025         }
2026     }
2027     z39 callback {present-response}
2028
2029     set toGet [expr $setMax - $setOffset + 1]
2030     if {$toGet <= 0} {
2031         return
2032     }
2033     if {$toGet > $presentChunk} {
2034         set toGet $presentChunk
2035     }
2036     z39.$setNo present $setOffset $toGet
2037     show-status Retrieving 1 0
2038 }
2039
2040 # Procedure init-title-lines
2041 # Utility that cleans the main record window.
2042 proc init-title-lines {} {
2043     .data.record delete 0.0 end
2044 }
2045
2046 # Procedure recall-set {setno}
2047 #  setno    Set number to recall
2048 proc recall-set {setno} {
2049     add-title-lines $setno 10000 1
2050 }
2051
2052 # Procedure add-title-lines {setno no offset}
2053 #  setno    Set number
2054 #  no       Number of records
2055 #  offset   Starting offset
2056 # This procedure displays the records $offset .. $offset+$no-1 in result
2057 # set $setno in the main record window by using the display format in the
2058 # global $displayFormat
2059 proc add-title-lines {setno no offset} {
2060     global displayFormats
2061     global displayFormat
2062     global setNo
2063     global busy
2064
2065     dputs "add-title-lines offset=${offset} no=${no}"
2066     if {$setno != -1} {
2067         set setNo $setno
2068     } else {
2069         set setno $setNo
2070     }
2071     if {$offset == 1} {
2072         .bot.a.set configure -text $setno
2073         .data.record delete 0.0 end
2074     }
2075     set ffunc [lindex $displayFormats $displayFormat]
2076     dputs "ffunc=$ffunc"
2077     set ffunc "display-$ffunc"
2078     for {set i 0} {$i < $no} {incr i} {
2079         set o [expr $i + $offset]
2080         set type [z39.$setno type $o]
2081         if {![string length $type]} {
2082             dputs "no more at $o"
2083             break
2084         }
2085         .data.record tag bind r$o <Any-Enter> {}
2086         .data.record tag bind r$o <Any-Leave> {}
2087         set insert0 [.data.record index insert]
2088         $ffunc $setno $o .data.record 1
2089         .data.record tag add r$o $insert0 insert
2090         .data.record tag bind r$o <1> \
2091                 [list popup-marc $setno $o 0 0]
2092         update idletasks
2093     }
2094     if {!$busy} {
2095         show-status Ready 0 1
2096     }
2097 }
2098
2099 # Procedure present-response
2100 # Present-response handler. The incoming records are displayed and a new
2101 # present request is performed until all records ($setMax) is returned
2102 # from the target.
2103 proc present-response {} {
2104     global setNo
2105     global setOffset
2106     global setMax
2107     global cancelFlag
2108     global delayRequest
2109     global presentChunk
2110
2111     dputs "In present-response"
2112     apduDump
2113     set no [z39.$setNo numberOfRecordsReturned]
2114     dputs "Returned $no records, setOffset $setOffset"
2115     add-title-lines $setNo $no $setOffset
2116     set setOffset [expr $setOffset + $no]
2117     if {$cancelFlag} {
2118         dputs "Handling cancel"
2119         set cancelFlag 0
2120         if {$delayRequest != ""} {
2121             eval $delayRequest
2122         }
2123         return
2124     }
2125     set status [z39.$setNo responseStatus]
2126     if {![string compare [lindex $status 0] NSD]} {
2127         show-status Ready 0 1
2128         set code [lindex $status 1]
2129         set msg [lindex $status 2]
2130         set addinfo [lindex $status 3]
2131         tkerror "NSD$code: $msg: $addinfo"
2132         return
2133     }
2134     if {$no > 0 && $setOffset <= $setMax} {
2135         dputs "present-request from ${setOffset}"
2136         set toGet [expr $setMax - $setOffset + 1]
2137         if {$toGet > $presentChunk} {
2138             set toGet $presentChunk
2139         }
2140         z39.$setNo present $setOffset $toGet
2141     } else {
2142         show-status Ready 0 1
2143     }
2144 }
2145
2146 # Procedure left-cursor {w}
2147 #  w    entry widget
2148 # Tries to move the cursor left in entry window $w
2149 proc left-cursor {w} {
2150     set i [$w index insert]
2151     if {$i > 0} {
2152         incr i -1
2153         $w icursor $i
2154     }
2155     dputs left
2156 }
2157
2158 # Procedure right-cursor {w}
2159 #  w    entry widget
2160 # Tries to move the cursor right in entry window $w
2161 proc right-cursor {w} {
2162     set i [$w index insert]
2163     incr i
2164     dputs right
2165     $w icursor $i
2166 }
2167
2168 # Procedure bind-fields {list returnAction escapeAction}
2169 #  list          list of entry widgets
2170 #  returnAction  return script
2171 #  escapeAction  escape script
2172 # Each widget in list are assigned bindings for <Tab>, <Left>, <Right>,
2173 # <Return> and <Escape>.
2174 proc bind-fields {list returnAction escapeAction} {
2175     set max [expr [llength $list]-1]
2176     for {set i 0} {$i < $max} {incr i} {
2177         bind [lindex $list $i] <Return> $returnAction
2178         bind [lindex $list $i] <Escape> $escapeAction
2179         if {![tk4]} {
2180             bind [lindex $list $i] <Tab> \
2181                     [list focus [lindex $list [expr $i+1]]]
2182             bind [lindex $list $i] <Left> \
2183                     [list left-cursor [lindex $list $i]]
2184             bind [lindex $list $i] <Right> \
2185                     [list right-cursor [lindex $list $i]]
2186         }
2187     }
2188     bind [lindex $list $i] <Return> $returnAction
2189     bind [lindex $list $i] <Escape> $escapeAction
2190     if {![tk4]} {
2191         bind [lindex $list $i] <Tab>  [list focus [lindex $list 0]]
2192         bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
2193         bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
2194     }
2195     focus [lindex $list 0]
2196 }
2197
2198 # Procedure entry-fields {parent list tlist returnAction escapeAction}
2199 #  list          list of frame widgets
2200 #  tlist         list of text to be used as lead of each entry
2201 #  returnAction  return script
2202 #  escapeAction  escape script
2203 # Makes label and entry widgets in each widget in $list.
2204 proc entry-fields {parent list tlist returnAction escapeAction} {
2205     set alist {}
2206     set i 0
2207     foreach field $list {
2208         set label ${parent}.${field}.label
2209         set entry ${parent}.${field}.entry
2210         label $label -text [lindex $tlist $i] -anchor e
2211         entry $entry -width 32 -relief sunken
2212         pack $label -side left
2213         pack $entry -side right
2214         lappend alist $entry
2215         incr i
2216     }
2217     bind-fields $alist $returnAction $escapeAction
2218 }
2219
2220 # Procedure define-target-dialog
2221 # Dialog that asks for new target to be defined.
2222 proc define-target-dialog {} {
2223     set w .target-define
2224
2225     toplevel $w
2226     place-force $w .
2227     top-down-window $w
2228     frame $w.top.target
2229     pack $w.top.target \
2230             -side top -anchor e -pady 2
2231     entry-fields $w.top {target} \
2232             {{Target:}} \
2233             {define-target-action} {destroy .target-define}
2234     top-down-ok-cancel $w {define-target-action} 1
2235 }
2236
2237 # Procedure protocol-setup-delete
2238 # This procedure is invoked when the user tries to delete a target
2239 # definition. If user is sure, the target definition is deleted.
2240 proc protocol-setup-delete {target w} {
2241     global profile
2242     global settingsChanged
2243
2244     set a [alert "Are you sure you want to delete the target \
2245 definition $target ?"]
2246     if {$a} {
2247         destroy $w
2248         unset profile($target)
2249         set settingsChanged 1
2250         cascade-target-list
2251         delete-target-hotlist $target
2252     }
2253 }
2254
2255 # Procedure protocol-setup-action {target w}
2256 # target     target to be defined
2257 # w          target definition toplevel widget
2258 # This procedure reads all appropriate globals and makes a new/modified
2259 # profile for the target. The global array $targetS contains most of the
2260 # information the user may modify.
2261 proc protocol-setup-action {target w} {
2262     global profile
2263     global settingsChanged
2264     global targetS
2265
2266     set dataBases {}
2267     set settingsChanged 1
2268     set len [$w.top.databases.list size]
2269     for {set i 0} {$i < $len} {incr i} {
2270         lappend dataBases [$w.top.databases.list get $i]
2271     }
2272     set wno [lindex $profile($target) 12]
2273     set timedef [lindex $profile($target) 17]
2274     if {![string length $timedef]} {
2275         set timedef [clock seconds]
2276     }
2277
2278     set idauth [$w.top.idAuthentication.entry get]
2279
2280     set profile($target) [list [$w.top.description.entry get] \
2281             [$w.top.host.entry get] \
2282             [$w.top.port.entry get] \
2283             $idauth \
2284             $targetS($target,MRS) \
2285             $targetS($target,PMS) \
2286             $targetS($target,csType) \
2287             $dataBases \
2288             $targetS($target,RPN) \
2289             $targetS($target,CCL) \
2290             $targetS($target,ResultSets) \
2291             $targetS($target,protocolType) \
2292             $wno \
2293             $targetS($target,LSLB) \
2294             $targetS($target,SSUB) \
2295             $targetS($target,MSPN) \
2296             $targetS($target,presentChunk) \
2297             $timedef \
2298             {} \
2299             {} ]
2300
2301     cascade-target-list
2302     delete-target-hotlist $target
2303     dputs $profile($target)
2304     destroy $w
2305 }
2306
2307 # Procedure place-force {window parent}
2308 #  window      new top level widget
2309 #  parent      parent widget used as base
2310 # Sets geometry of $window relative to $parent window.
2311 proc place-force {window parent} {
2312     set g [wm geometry $parent]
2313
2314     set p1 [string first + $g]
2315     set p2 [string last + $g]
2316
2317     set x [expr 40+[string range $g [expr $p1 +1] [expr $p2 -1]]]
2318     set y [expr 60+[string range $g [expr $p2 +1] end]]
2319     wm geometry $window +${x}+${y}
2320 }
2321
2322 # Procedure add-database-action {target w}
2323 #  target      target to be defined
2324 #  w           top level widget for the target definition
2325 # Adds the contents of .database-select.top.database.entry to list of
2326 # databases.
2327 proc add-database-action {target w} {
2328     global profile
2329
2330     $w.top.databases.list insert end \
2331             [.database-select.top.database.entry get]
2332     destroy .database-select
2333 }
2334
2335 # Procedure add-database {target wp}
2336 #  target      target to be defined
2337 #  wp          top level widget for the target definition
2338 # Makes a dialog in which the user enters new database
2339 proc add-database {target wp} {
2340     global profile
2341
2342     set w .database-select
2343     toplevel $w
2344     set oldFocus [focus]
2345
2346     place-force $w $wp
2347
2348     top-down-window $w
2349
2350     frame $w.top.database
2351
2352     pack $w.top.database -side top -anchor e -pady 2
2353
2354     entry-fields $w.top {database} \
2355             {{Database to add:}} \
2356             [list add-database-action $target $wp] {destroy .database-select}
2357
2358     top-down-ok-cancel $w [list add-database-action $target $wp] 1
2359     focus $oldFocus
2360 }
2361
2362
2363 # Procedure delete-database {target w}
2364 #  target     target to be defined
2365 #  w          top level widget for the target definition
2366 # Asks the user if he/she really wishes to delete a database and removes
2367 # the database from the database-list if requested.
2368 proc delete-database {target w} {
2369     global profile
2370
2371     set l {}
2372     foreach i [$w.top.databases.list curselection] {
2373         set b [$w.top.databases.list get $i]
2374         set l "$l $b"
2375     }
2376     set a [alert "Are you sure you want to remove the database(s)${l}?"]
2377     if {$a} {
2378         foreach i [lsort -decreasing \
2379                 [$w.top.databases.list curselection]] {
2380             $w.top.databases.list delete $i
2381         }
2382     }
2383 }
2384
2385 # Procedure protocol-setup {target}
2386 #  target     target to be defined
2387 # Makes a dialog in which the user may modify/view a target definition
2388 # (profile). The $targetS - array holds the initial definition of the
2389 # target.
2390 proc protocol-setup {target} {
2391     global profile
2392     global targetS
2393
2394     set bno 0
2395     while {[winfo exists .setup-$bno]} {
2396         incr bno
2397     }
2398     set w .setup-$bno
2399
2400     toplevelG $w
2401
2402     wm title $w "Setup $target"
2403
2404     top-down-window $w
2405
2406     if {![string length $target]} {
2407         set target Default
2408     }
2409     dputs target
2410     dputs $profile($target)
2411
2412     frame $w.top.description
2413     frame $w.top.host
2414     frame $w.top.port
2415     frame $w.top.idAuthentication
2416
2417     frame $w.top.cs-type -relief ridge -border 2
2418     frame $w.top.protocol -relief ridge -border 2
2419     frame $w.top.query -relief ridge -border 2
2420     frame $w.top.databases -relief ridge -border 2
2421
2422     # Maximum/preferred/idAuth ...
2423     pack $w.top.description $w.top.host $w.top.port \
2424             $w.top.idAuthentication -side top -anchor e -pady 2
2425
2426     entry-fields $w.top {description host port idAuthentication } \
2427             {{Description:} {Host:} {Port:} {Id Authentication:}} \
2428             [list protocol-setup-action $target $w] [list destroy $w]
2429
2430     foreach sub {description host port idAuthentication} {
2431         dputs $sub
2432         bind $w.top.$sub.entry <Control-a> [list add-database $target $w]
2433         bind $w.top.$sub.entry <Control-d> [list delete-database $target $w]
2434     }
2435     $w.top.description.entry insert 0 [lindex $profile($target) 0]
2436     $w.top.host.entry insert 0 [lindex $profile($target) 1]
2437     $w.top.port.entry insert 0 [lindex $profile($target) 2]
2438     $w.top.idAuthentication.entry insert 0 [lindex $profile($target) 3]
2439     set targetS($target,csType) [lindex $profile($target) 6]
2440     set targetS($target,RPN) [lindex $profile($target) 8]
2441     set targetS($target,CCL) [lindex $profile($target) 9]
2442     set targetS($target,ResultSets) [lindex $profile($target) 10]
2443     set targetS($target,protocolType) [lindex $profile($target) 11]
2444     if {![string length $targetS($target,protocolType)]} {
2445         set targetS($target,protocolType) Z39
2446     }
2447     set targetS($target,LSLB) [lindex $profile($target) 13]
2448     set targetS($target,SSUB) [lindex $profile($target) 14]
2449     set targetS($target,MSPN) [lindex $profile($target) 15]
2450     set targetS($target,presentChunk) [lindex $profile($target) 16]
2451     set targetS($target,MRS) [lindex $profile($target) 4]
2452     set targetS($target,PMS) [lindex $profile($target) 5]
2453
2454     # Databases ....
2455     pack $w.top.databases -side left -pady 2 -padx 2 -expand yes -fill both
2456
2457     label $w.top.databases.label -text "Databases"
2458     button $w.top.databases.add -text Add \
2459             -command [list add-database $target $w]
2460     button $w.top.databases.delete -text Delete \
2461             -command [list delete-database $target $w]
2462     if {! [tk4]} {
2463         listbox $w.top.databases.list -geometry 14x6 \
2464                 -yscrollcommand "$w.top.databases.scroll set"
2465     } else {
2466         listbox $w.top.databases.list -width 14 -height 5\
2467                 -yscrollcommand "$w.top.databases.scroll set"
2468     }
2469     scrollbar $w.top.databases.scroll -orient vertical -border 1
2470     pack $w.top.databases.label -side top -fill x \
2471             -padx 2 -pady 2
2472     pack $w.top.databases.add $w.top.databases.delete -side top -fill x \
2473             -padx 2 -pady 2
2474     pack $w.top.databases.list -side left -fill both -expand yes \
2475             -padx 2 -pady 2
2476     pack $w.top.databases.scroll -side right -fill y \
2477             -padx 2 -pady 2
2478     $w.top.databases.scroll config -command "$w.top.databases.list yview"
2479
2480     foreach b [lindex $profile($target) 7] {
2481         $w.top.databases.list insert end $b
2482     }
2483
2484     # Transport ...
2485     pack $w.top.cs-type -pady 2 -padx 2 -side top -fill x
2486
2487     label $w.top.cs-type.label -text "Transport"
2488     radiobutton $w.top.cs-type.tcpip -text "TCP/IP" -anchor w \
2489             -variable targetS($target,csType) -value tcpip
2490     radiobutton $w.top.cs-type.mosi -text "MOSI" -anchor w\
2491             -variable targetS($target,csType) -value mosi
2492
2493     pack $w.top.cs-type.label $w.top.cs-type.tcpip $w.top.cs-type.mosi \
2494             -padx 2 -side top -fill x
2495
2496     # Protocol ...
2497     pack $w.top.protocol -pady 2 -padx 2 -side top -fill x
2498
2499     label $w.top.protocol.label -text "Protocol"
2500     radiobutton $w.top.protocol.z39v2 -text "Z39.50" -anchor w \
2501             -variable targetS($target,protocolType) -value Z39
2502     radiobutton $w.top.protocol.sr -text "SR" -anchor w \
2503             -variable targetS($target,protocolType) -value SR
2504
2505     pack $w.top.protocol.label $w.top.protocol.z39v2 $w.top.protocol.sr \
2506             -padx 2 -side top -fill x
2507
2508     # Query ...
2509     pack $w.top.query -pady 2 -padx 2 -side top -fill x
2510
2511     label $w.top.query.label -text "Query support"
2512     checkbutton $w.top.query.c1 -text "RPN query" -anchor w \
2513             -variable targetS($target,RPN)
2514     checkbutton $w.top.query.c2 -text "CCL query" -anchor w \
2515             -variable targetS($target,CCL)
2516     checkbutton $w.top.query.c3 -text "Result sets" -anchor w \
2517             -variable targetS($target,ResultSets)
2518
2519     pack $w.top.query.label -side top
2520     pack $w.top.query.c1 $w.top.query.c2 $w.top.query.c3 \
2521             -padx 2 -side top -fill x
2522
2523     # Ok-cancel
2524     bottom-buttons $w [list {Ok} [list protocol-setup-action $target $w] \
2525             {Delete} [list protocol-setup-delete $target $w] \
2526             {Advanced} [list advanced-setup $target $bno] \
2527             {Cancel} [list destroy $w]] 0
2528 }
2529
2530 # Procedure advanced-setup {target b}
2531 #  target     target to be defined
2532 #  b          window number of target top level
2533 # Makes a dialog in which the user may modify/view advanced settings
2534 # of a target definition (profile).
2535 proc advanced-setup {target b} {
2536     global profile
2537     global targetS
2538
2539     set w .advanced-setup-$b
2540
2541     toplevelG $w
2542
2543     wm title $w "Advanced setup $target"
2544
2545     top-down-window $w
2546
2547     if {![string length $target]} {
2548         set target Default
2549     }
2550     dputs target
2551
2552     frame $w.top.largeSetLowerBound
2553     frame $w.top.smallSetUpperBound
2554     frame $w.top.mediumSetPresentNumber
2555     frame $w.top.presentChunk
2556     frame $w.top.maximumRecordSize
2557     frame $w.top.preferredMessageSize
2558
2559     pack $w.top.largeSetLowerBound $w.top.smallSetUpperBound \
2560             $w.top.mediumSetPresentNumber $w.top.presentChunk \
2561             $w.top.maximumRecordSize $w.top.preferredMessageSize \
2562             -side top -anchor e -pady 2
2563
2564     entry-fields $w.top {largeSetLowerBound smallSetUpperBound \
2565             mediumSetPresentNumber presentChunk maximumRecordSize \
2566             preferredMessageSize} \
2567             {{Large Set Lower Bound:} {Small Set Upper Bound:} \
2568             {Medium Set Present Number:} {Present Chunk:} \
2569             {Maximum Record Size:} {Preferred Message Size:}} \
2570             [list advanced-setup-action $target $b] [list destroy $w]
2571
2572     $w.top.largeSetLowerBound.entry insert 0 $targetS($target,LSLB)
2573     $w.top.smallSetUpperBound.entry insert 0 $targetS($target,SSUB)
2574     $w.top.mediumSetPresentNumber.entry insert 0 $targetS($target,MSPN)
2575     $w.top.presentChunk.entry insert 0 $targetS($target,presentChunk)
2576     $w.top.maximumRecordSize.entry insert 0 $targetS($target,MRS)
2577     $w.top.preferredMessageSize.entry insert 0 $targetS($target,PMS)
2578
2579     bottom-buttons $w [list {Ok} [list advanced-setup-action $target $b] \
2580             {Cancel} [list destroy $w]] 0
2581 }
2582
2583 # Procedure advanced-setup-action {target b}
2584 #  target     target to be defined
2585 #  b          window number of target top level
2586 # This procedure is called when the user hits Ok in the advanced target
2587 # setup dialog. The temporary result is stored in the $targetS - array.
2588 proc advanced-setup-action {target b} {
2589     set w .advanced-setup-$b
2590     global targetS
2591
2592     set targetS($target,LSLB) [$w.top.largeSetLowerBound.entry get]
2593     set targetS($target,SSUB) [$w.top.smallSetUpperBound.entry get]
2594     set targetS($target,MSPN) [$w.top.mediumSetPresentNumber.entry get]
2595     set targetS($target,presentChunk) [$w.top.presentChunk.entry get]
2596     set targetS($target,MRS) [$w.top.maximumRecordSize.entry get]
2597     set targetS($target,PMS) [$w.top.preferredMessageSize.entry get]
2598
2599     dputs "advanced-setup-action"
2600     destroy $w
2601 }
2602
2603 # Procedure database-select-action
2604 # Called when the user commits a database select change. See procedure
2605 # database-select.
2606 proc database-select-action {} {
2607     set w .database-select.top
2608     set b {}
2609     foreach indx [$w.databases.list curselection] {
2610         lappend b [$w.databases.list get $indx]
2611     }
2612     if {$b != ""} {
2613         z39 databaseNames $b
2614     }
2615     destroy .database-select
2616 }
2617
2618 # Procedure database-select
2619 # Makes a dialog in which the user may select a database
2620 proc database-select {} {
2621     set w .database-select
2622     global profile
2623     global hostid
2624
2625     toplevel $w
2626     set oldFocus [focus]
2627     place-force $w .
2628
2629     top-down-window $w
2630
2631     frame $w.top.databases -relief ridge -border 2
2632
2633     pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill x
2634
2635     label $w.top.databases.label -text "List"
2636     listbox $w.top.databases.list -width 20 -height 6 \
2637             -yscrollcommand "$w.top.databases.scroll set"
2638     scrollbar $w.top.databases.scroll -orient vertical -border 1
2639     pack $w.top.databases.label -side top -fill x \
2640             -padx 2 -pady 2
2641     pack $w.top.databases.list -side left -fill both -expand yes \
2642             -padx 2 -pady 2
2643     pack $w.top.databases.scroll -side right -fill y \
2644             -padx 2 -pady 2
2645     $w.top.databases.scroll config -command "$w.top.databases.list yview"
2646
2647     foreach b [lindex $profile($hostid) 7] {
2648         $w.top.databases.list insert end $b
2649     }
2650     top-down-ok-cancel $w {database-select-action} 1
2651     focus $oldFocus
2652 }
2653
2654 # Procedure cascase-dblist-select
2655 proc cascade-dblist-select {target db} {
2656     show-target $target $db
2657     z39 databaseNames $db
2658 }
2659
2660 # Procedure cascade-dblist
2661 # Makes the Service/database list with proper databases for the target
2662 proc cascade-dblist {target base} {
2663     global profile
2664
2665     set w .top.service.m.dblist
2666     $w delete 0 200
2667     foreach db [lindex $profile($target) 7] {
2668         $w add command -label $db \
2669                 -command [list cascade-dblist-select $target $db]
2670     }
2671 }
2672
2673 # Procedure cascade-target-list
2674 # Makes all target/databases available in the Target|Connect
2675 # menu as well as all targets in the Target|Setup menu.
2676 # This procedure is called whenever target definitions occur.
2677 proc cascade-target-list {} {
2678     global profile
2679
2680     foreach sub [winfo children .top.target.m.clist] {
2681         destroy $sub
2682     }
2683     .top.target.m.clist delete 0 last
2684     foreach n [lsort [array names profile]] {
2685         if {$n != "Default"} {
2686             set nl [lindex $profile($n) 12]
2687             if {[llength [lindex $profile($n) 7]] > 1} {
2688                 .top.target.m.clist add cascade -label $n \
2689                         -menu .top.target.m.clist.$nl
2690                 menu .top.target.m.clist.$nl
2691                 foreach b [lindex $profile($n) 7] {
2692                     .top.target.m.clist.$nl add command -label $b \
2693                             -command [list reopen-target $n $b]
2694                 }
2695             } else {
2696                 .top.target.m.clist add command -label $n \
2697                         -command [list reopen-target $n {}]
2698             }
2699         }
2700     }
2701     .top.target.m.slist delete 0 last
2702     foreach n [lsort [array names profile]] {
2703         .top.target.m.slist add command -label $n \
2704                 -command [list protocol-setup $n]
2705     }
2706 }
2707
2708 # Procedure query-select {i}
2709 #  i       Query type number (integer)
2710 # This procedure is called when the user selects a Query type. The current
2711 # query type information given by the globals $queryButtonsFind and
2712 # $queryInfoFind are affected by this operation.
2713 proc query-select {i} {
2714     global queryButtonsFind
2715     global queryInfoFind
2716     global queryButtons
2717     global queryInfo
2718
2719     set queryInfoFind [lindex $queryInfo $i]
2720     set queryButtonsFind [lindex $queryButtons $i]
2721
2722     index-lines .lines 1 $queryButtonsFind $queryInfoFind activate-index
2723 }
2724
2725 # Procedure query-new-action
2726 # Commits a new query type definition by extending the globals
2727 # $queryTypes, $queryButtons and $queryInfo.
2728 proc query-new-action {} {
2729     global queryTypes
2730     global queryButtons
2731     global queryInfo
2732     global settingsChanged
2733
2734     set settingsChanged 1
2735     lappend queryTypes [.query-new.top.index.entry get]
2736     lappend queryButtons {}
2737     lappend queryInfo {}
2738
2739     destroy .query-new
2740     cascade-query-list
2741 }
2742
2743 # Procedure query-new
2744 # Makes a dialog in which the user is requested to enter the name of a
2745 # new query type.
2746 proc query-new {} {
2747     set w .query-new
2748
2749     toplevel $w
2750     set oldFocus [focus]
2751     place-force $w .
2752     top-down-window $w
2753     frame $w.top.index
2754     pack $w.top.index \
2755             -side top -anchor e -pady 2
2756     entry-fields $w.top index \
2757             {{Query Name:}} \
2758             query-new-action {destroy .query-new}
2759     top-down-ok-cancel $w query-new-action 1
2760     focus $oldFocus
2761 }
2762
2763 # Procedure query-delete-action {queryNo}
2764 #  queryNo     query type number (integer)
2765 # Procedure that deletes the query type specified by $queryNo.
2766 proc query-delete-action {queryNo} {
2767     global queryTypes
2768     global queryButtons
2769     global queryInfo
2770     global settingsChanged
2771
2772     set settingsChanged 1
2773
2774     set queryTypes [lreplace $queryTypes $queryNo $queryNo]
2775     set queryButtons [lreplace $queryButtons $queryNo $queryNo]
2776     set queryInfo [lreplace $queryInfo $queryNo $queryNo]
2777     destroy .query-delete
2778     cascade-query-list
2779 }
2780
2781 # Procedure query-delete {queryNo}
2782 #  queryNo     query type number (integer)
2783 # Asks if the user really want to delete a given query type; calls
2784 # query-delete-action if 'yes'.
2785 proc query-delete {queryNo} {
2786     global queryTypes
2787
2788     set w .query-delete
2789
2790     toplevel $w
2791     place-force $w .
2792     top-down-window $w
2793     set n [lindex $queryTypes $queryNo]
2794
2795     label $w.top.warning -bitmap warning
2796     message $w.top.quest -text "Are you sure you want to delete the \
2797 query type $n ?"  -aspect 300
2798     pack $w.top.warning $w.top.quest -side left -expand yes -padx 10 -pady 5
2799     bottom-buttons $w [list {Ok} [list query-delete-action $queryNo] \
2800                             {Cancel} [list destroy $w]] 1
2801 }
2802
2803 # Procedure cascade-query-list
2804 # Updates the enties below Options|Query to list all query types.
2805 proc cascade-query-list {} {
2806     global queryTypes
2807     set w .top.options.m.query
2808
2809     set i 0
2810     $w.slist delete 0 last
2811     foreach n $queryTypes {
2812         $w.slist add command -label $n -command [list query-setup $i]
2813         incr i
2814     }
2815
2816     set i 0
2817     $w.clist delete 0 last
2818     foreach n $queryTypes {
2819         $w.clist add command -label $n -command [list query-select $i]
2820         incr i
2821     }
2822     set i 0
2823     $w.dlist delete 0 last
2824     foreach n $queryTypes {
2825         $w.dlist add command -label $n -command [list query-delete $i]
2826         incr i
2827     }
2828 }
2829
2830 # Procedure save-geometry
2831 # This procedure saves the per-user related settings in ~/.clientrc.tcl.
2832 # The geometry information stored in the global array $windowGeometry is
2833 # saved. Also a few other user settings, such as current display format, are
2834 # saved.
2835 proc save-geometry {} {
2836     global windowGeometry
2837     global hotTargets
2838     global textWrap
2839     global displayFormat
2840     global popupMarcdf
2841     global recordSyntax
2842     global elementSetNames
2843     global hostid
2844
2845     set windowGeometry(.) [wm geometry .]
2846
2847     if {[catch {set f [open ~/.clientrc.tcl w]}]} {
2848         return
2849     }
2850     if {$hostid != "Default"} {
2851         puts $f "set hostid \{$hostid\}"
2852         set b [z39 databaseNames]
2853         puts $f "set hostbase $b"
2854     }
2855     puts $f "set hotTargets \{ $hotTargets \}"
2856     puts $f "set textWrap $textWrap"
2857     puts $f "set displayFormat $displayFormat"
2858     puts $f "set popupMarcdf $popupMarcdf"
2859     puts $f "set recordSyntax $recordSyntax"
2860     puts $f "set elementSetNames $elementSetNames"
2861     foreach n [array names windowGeometry] {
2862         puts -nonewline $f "set \{windowGeometry($n)\} \{"
2863         puts -nonewline $f $windowGeometry($n)
2864         puts $f "\}"
2865     }
2866     close $f
2867 }
2868
2869 # Procedure save-settings
2870 # This procedure saves the per-host related settings clientrc.tcl which
2871 # is normally kept in the directory /usr/local/lib/irtcl.
2872 # All query types and target defintion profiles are saved.
2873 proc save-settings {} {
2874     global profile
2875     global libdir
2876     global settingsChanged
2877     global queryTypes
2878     global queryButtons
2879     global queryInfo
2880
2881     if {[file exists clientrc.tcl]} {
2882         set f [open "clientrc.tcl" w]
2883     } elseif {![file writable "${libdir}/clientrc.tcl"]} {
2884         set a [alert "Cannot open ${libdir}/clientrc.tcl for writing. Do you \
2885                 wish to save clientrc.tcl in the current directory instead?"]
2886         if {! $a} {
2887             return
2888         }
2889         set f [open "clientrc.tcl" w]
2890     } else {
2891         set f [open "${libdir}/clientrc.tcl" w]
2892     }
2893     puts $f "# Setup file"
2894
2895     foreach n [array names profile] {
2896
2897         puts -nonewline $f "set \{profile($n)\} \{"
2898         puts -nonewline $f $profile($n)
2899         puts $f "\}"
2900         puts $f {}
2901     }
2902     puts -nonewline $f "set queryTypes \{"
2903     puts -nonewline $f $queryTypes
2904     puts $f "\}"
2905
2906     puts -nonewline $f "set queryButtons \{"
2907     puts -nonewline $f $queryButtons
2908     puts $f "\}"
2909
2910     puts -nonewline $f "set queryInfo \{"
2911     puts -nonewline $f $queryInfo
2912     puts $f "\}"
2913     close $f
2914     set settingsChanged 0
2915 }
2916
2917 # Procedure alert {ask}
2918 #  ask    prompt string
2919 # Makes a grabbed dialog in which the user is requested to answer
2920 # "Ok" or "Cancel". This procedure returns 1 if the user hits "Ok"; 0
2921 # otherwise.
2922 proc alert {ask} {
2923     set w .alert
2924
2925     global alertAnswer
2926
2927     toplevel $w
2928     set oldFocus [focus]
2929     place-force $w .
2930     top-down-window $w
2931
2932     label $w.top.warning -bitmap warning
2933     message $w.top.message -text $ask -aspect 300 \
2934             -font -Adobe-Times-Medium-R-Normal-*-180-*
2935
2936     pack $w.top.warning $w.top.message -side left -pady 5 -padx 10 -expand yes
2937
2938     set alertAnswer 0
2939     top-down-ok-cancel $w {alert-action} 1
2940     focus $oldFocus
2941     return $alertAnswer
2942 }
2943
2944 # Procedure alert-action
2945 # Called when the user hits "Ok" in the .alert-window.
2946 proc alert-action {} {
2947     global alertAnswer
2948     set alertAnswer 1
2949     destroy .alert
2950 }
2951
2952 # Procedure exit-action
2953 # This procedure is called if the user exists the application
2954 proc exit-action {} {
2955     global settingsChanged
2956
2957     if {$settingsChanged} {
2958         save-settings
2959     }
2960     save-geometry
2961     exit 0
2962 }
2963
2964 # Procedure listbuttonaction {w name h user i}
2965 #  w       menubutton widget
2966 #  name    name information
2967 #  h       handler to be invoked
2968 #  user    user information to be passed to handler $h
2969 #  i       index passed as second argument to handler $h
2970 # Utility function to emulate a listbutton. Called when the user
2971 # Modifies the listbutton. See procedure listbuttonx.
2972 proc listbuttonaction {w name h user i} {
2973     $w configure -text [lindex $name 0]
2974     $h [lindex $name 1] $user $i
2975 }
2976
2977 # Procedure listbuttonx {button no names handle user}
2978 #  button  menubutton widget
2979 #  no      initial value index (integer)
2980 #  names   list of name entries. The first entry in each name
2981 #          entry is the actual name
2982 #  handle  user function to be called when the listbutton changes
2983 #          its value
2984 #  user    user argument to the $handle function
2985 # Makes an extended listbutton.
2986 proc listbuttonx {button no names handle user} {
2987     if {[winfo exists $button]} {
2988         $button configure -text [lindex [lindex $names $no] 0]
2989         ${button}.m delete 0 last
2990     } else {
2991         menubutton $button -text [lindex [lindex $names $no] 0] \
2992                 -width 10 -menu ${button}.m -relief raised -border 1
2993         menu ${button}.m
2994         if {[tk4]} {
2995             ${button}.m configure -tearoff off
2996         }
2997     }
2998     set i 0
2999     foreach name $names {
3000         ${button}.m add command -label [lindex $name 0] \
3001                 -command [list listbuttonaction ${button} $name \
3002                 $handle $user $i]
3003         incr i
3004     }
3005 }
3006
3007 # Procedure listbutton {button no names}
3008 #  button  menubutton widget
3009 #  no      initial value index (integer)
3010 #  names   list of possible values.
3011 # Makes a listbutton. The functionality is emulated by the use menubutton-
3012 # and menu widgets.
3013 proc listbutton {button no names} {
3014     menubutton $button -text [lindex $names $no] -width 10 -menu ${button}.m \
3015             -relief raised -border 1
3016     menu ${button}.m
3017     if {[tk4]} {
3018         ${button}.m configure -tearoff off
3019     }
3020     foreach name $names {
3021         ${button}.m add command -label $name \
3022                 -command [list ${button} configure -text $name]
3023     }
3024 }
3025
3026 # Procedure listbuttonv-action {button var names i}
3027 #  button   menubutton widget
3028 #  var      global variable to be affected
3029 #  names    list of possible names and values
3030 # This procedure is called when the user alters a menu created by the
3031 # listbuttonv procedure. The global variable $var is updated.
3032 proc listbuttonv-action {button var names i} {
3033     global $var
3034
3035     set $var [lindex $names [expr $i+1]]
3036     $button configure -text [lindex $names $i]
3037 }
3038
3039 # Procedure listbuttonv {button var names}
3040 #  button   menubutton widget
3041 #  var      global variable to be affected
3042 #  names    List of name/value pairs, i.e. {n1 v1 n2 v2 ...}.
3043 # This procedure emulates a listbutton by means of menu/menubutton widgets.
3044 # The global variable $var is automatically updated and set to one of the
3045 # values v1, v2, ...
3046 proc listbuttonv {button var names} {
3047     global $var
3048
3049     set n "-"
3050     eval "set val $$var"
3051     set l [llength $names]
3052     for {set i 1} {$i < $l} {incr i 2} {
3053         if {$val == [lindex $names $i]} {
3054             incr i -1
3055             set n [lindex $names $i]
3056             break
3057         }
3058     }
3059     if {[winfo exists $button]} {
3060         $button configure -text $n
3061         return
3062     }
3063     menubutton $button -text $n -menu ${button}.m \
3064             -relief raised -border 1
3065     menu ${button}.m
3066     if {[tk4]} {
3067         ${button}.m configure -tearoff off
3068     }
3069     for {set i 0} {$i < $l} {incr i 2} {
3070         ${button}.m add command -label [lindex $names $i] \
3071                 -command [list listbuttonv-action $button $var $names $i]
3072     }
3073 }
3074
3075 # Procedure query-add-index-action {queryNo}
3076 #  queryNo       query type number (integer)
3077 # Handler that makes a new query index.
3078 proc query-add-index-action {queryNo} {
3079     set w .query-setup
3080
3081     global queryInfoTmp
3082     global queryButtonsTmp
3083
3084     set newI [.query-add-index.top.index.entry get]
3085     lappend queryInfoTmp [list $newI {}]
3086     $w.top.index.list insert end $newI
3087     destroy .query-add-index
3088     #destroy $w.top.lines
3089     #frame $w.top.lines -relief ridge -border 2
3090     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
3091     #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
3092 }
3093
3094 # Procedure query-add-line
3095 #  queryNo      query type number (integer)
3096 # Handler that adds new query line.
3097 proc query-add-line {queryNo} {
3098     set w .query-setup
3099
3100     global queryInfoTmp
3101     global queryButtonsTmp
3102
3103     lappend queryButtonsTmp {I 0}
3104
3105     #destroy $w.top.lines
3106     #frame $w.top.lines -relief ridge -border 2
3107     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
3108     #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
3109 }
3110
3111 # Procedure query-del-line
3112 #  queryNo      query type number (integer)
3113 # Handler that removes query line.
3114 proc query-del-line {queryNo} {
3115     set w .query-setup
3116
3117     global queryInfoTmp
3118     global queryButtonsTmp
3119
3120     set l [llength $queryButtonsTmp]
3121     if {$l <= 0} {
3122         return
3123     }
3124     incr l -1
3125     set queryButtonsTmp [lreplace $queryButtonsTmp $l $l]
3126     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
3127 }
3128
3129 # Procedure query-add-index
3130 #  queryNo      query type number (integer)
3131 # Handler that adds new query index.
3132 proc query-add-index {queryNo} {
3133     set w .query-add-index
3134
3135     toplevel $w
3136     set oldFocus [focus]
3137     place-force $w .query-setup
3138     top-down-window $w
3139     frame $w.top.index
3140     pack $w.top.index \
3141             -side top -anchor e -pady 2
3142     entry-fields $w.top {index} \
3143             {{Index Name:}} \
3144             [list query-add-index-action $queryNo] [list destroy $w]
3145     top-down-ok-cancel $w [list query-add-index-action $queryNo] 1
3146     focus $oldFocus
3147 }
3148
3149 # Procedure query-setup-action
3150 #  queryNo      query type number (integer)
3151 # Handler that updates the query information database stored in the
3152 # globals $queryInfo and $queryButtons. This procedure is executed when
3153 # the user commits the query setup changes by pressing button "Ok".
3154 proc query-setup-action {queryNo} {
3155     global queryButtons
3156     global queryInfo
3157     global queryButtonsTmp
3158     global queryInfoTmp
3159     global queryButtonsFind
3160     global queryInfoFind
3161
3162     global settingsChanged
3163
3164     set settingsChanged 1
3165
3166     set queryInfo [lreplace $queryInfo $queryNo $queryNo \
3167             $queryInfoTmp]
3168     set queryButtons [lreplace $queryButtons $queryNo $queryNo \
3169             $queryButtonsTmp]
3170     set queryInfoFind $queryInfoTmp
3171     set queryButtonsFind $queryButtonsTmp
3172
3173     destroy .query-setup
3174     index-lines .lines 1 $queryButtonsFind $queryInfoFind activate-index
3175 }
3176
3177 # Procedure activate-e-index {value no i}
3178 #   value   menu name
3179 #   no      query index number
3180 #   i       menu index (integer)
3181 # Procedure called when listbutton is activated in the query type edit
3182 # window. The global $queryButtonsTmp is updated in this operation.
3183 proc activate-e-index {value no i} {
3184     global queryButtonsTmp
3185     global queryIndexTmp
3186
3187     set queryButtonsTmp [lreplace $queryButtonsTmp $no $no [list I $i]]
3188     dputs $queryButtonsTmp
3189     set queryIndexTmp $i
3190 }
3191
3192 # Procedure activate-index {value no i}
3193 #   value   menu name
3194 #   no      query index number
3195 #   i       menu index (integer)
3196 # Procedure called when listbutton is activated in the main query
3197 # window. The global $queryButtonsFind is updated in this operation.
3198 proc activate-index {value no i} {
3199     global queryButtonsFind
3200
3201     set queryButtonsFind [lreplace $queryButtonsFind $no $no [list I $i]]
3202
3203     dputs "queryButtonsFind $queryButtonsFind"
3204 }
3205
3206 # Procedure update-attr
3207 # This procedure creates listbuttons for all bib-1 attributes except
3208 # the use-attribute in the .index-setup window.
3209 # The globals $relationTmpValue, $positionTmpValue, $structureTmpValue,
3210 # $truncationTmpValue and $completenessTmpValue are maintainted by the
3211 # listbuttons.
3212 proc update-attr {} {
3213     set w .index-setup
3214     listbuttonv $w.top.relation.b relationTmpValue\
3215             {{None} 0 {Less than} 1 {Greater than or equal} 2 {Equal} 3 \
3216             {Greater than or equal} 4 {Greater than} 5 {Not equal} 6 \
3217             {Phonetic} 100 {Stem} 101 {Relevance} 102 {AlwaysMatches} 103}
3218     listbuttonv $w.top.position.b positionTmpValue {{None} 0 \
3219             {First in field} 1 {First in subfield} 2 {Any position in field} 3}
3220     listbuttonv $w.top.structure.b structureTmpValue {{None} 0 {Phrase} 1 \
3221             {Word} 2 {Key} 3 {Year} 4 {Date (norm)} 5 {Word list}  6 \
3222             {Date (un-norm)} 100 {Name (norm)} 101 {Date (un-norm)} 102 \
3223             {Structure} 103 {urx} 104 {free-form} 105 {doc-text} 106 \
3224             {local-number} 107 {string} 108 {numeric string} 109}
3225     listbuttonv $w.top.truncation.b truncationTmpValue {{Auto} 0 {Right} 1 \
3226             {Left} 2 {Left and right} 3 {No truncation} 100 \
3227             {Process #} 101 {Re-1} 102 {Re-2} 103}
3228     listbuttonv $w.top.completeness.b completenessTmpValue {{None} 0 \
3229             {Incomplete subfield} 1 {Complete subfield} 2 {Complete field} 3}
3230 }
3231
3232 # Procedure use-attr {init}
3233 #  init      init flag
3234 # This procedure creates a listbox with several Bib-1 use attributes.
3235 # If $init is 1 the listbox is created with the attributes. If $init
3236 # is 0 the current selection of the listbox is read and the global
3237 # $useTmpValue is set to the current use-value.
3238 proc use-attr {init} {
3239     set attr {
3240         {None}                           0
3241         {Personal name}                  1
3242         {Corporate name}                 2
3243         {Conference name}                3
3244         {Title}                          4
3245         {Title-series}                   5
3246         {Title-uniform}                  6
3247         {ISBN}                           7
3248         {ISSN}                           8
3249         {LC card number}                 9
3250         {BNB card number}                10
3251         {BGF(sic) number}                11
3252         {Local number}                   12
3253         {Dewey classification}           13
3254         {UDC classification}             14
3255         {Bliss classification}           15
3256         {LC call number}                 16
3257         {NLM call number}                17
3258         {NAL call number}                18
3259         {MOS call number}                19
3260         {Local classification}           20
3261         {Subject heading}                21
3262         {Subject-RAMEAU}                 22
3263         {BDI-index-subject}              23
3264         {INSPEC-subject}                 24
3265         {MESH-subject}                   25
3266         {PA-subject}                     26
3267         {LC-subject-heading}             27
3268         {RVM-subject-heading}            28
3269         {Local subject index}            29
3270         {Date}                           30
3271         {Date of publication}            31
3272         {Date of acquisition}            32
3273         {Title-key}                      33
3274         {Title-collective}               34
3275         {Title-parallel}                 35
3276         {Title-cover}                    36
3277         {Title-added-title-page}         37
3278         {Title-caption}                  38
3279         {Title-running}                  39
3280         {Title-spine}                    40
3281         {Title-other-variant}            41
3282         {Title-former}                   42
3283         {Title-abbreviated}              43
3284         {Title-expanded}                 44
3285         {Subject-PRECIS}                 45
3286         {Subject-RSWK}                   46
3287         {Subject-subdivision}            47
3288         {Number-natl-bibliography}       48
3289         {Number-legal-deposit}           49
3290         {Number-govt-publication}        50
3291         {Number-publisher-for-music}     51
3292         {Number-DB}                      52
3293         {Number-local-call}              53
3294         {Code-language}                  54
3295         {Code-geographic-area}           55
3296         {Code-institution}               56
3297         {Name and title}                 57
3298         {Name-geographic}                58
3299         {Place-publication}              59
3300         {CODEN}                          60
3301         {Microform-generation}           61
3302         {Abstract}                       62
3303         {Note}                           63
3304         {Author-title}                 1000
3305         {Record type}                  1001
3306         {Name}                         1002
3307         {Author}                       1003
3308         {Author-name-personal}         1004
3309         {Author-name-corporate}        1005
3310         {Author-name-conference}       1006
3311         {Identifier-standard}          1007
3312         {Subject-LC-children's}        1008
3313         {Subject-name-personal}        1009
3314         {Body of text}                 1010
3315         {Date/time added to database}  1011
3316         {Date/time last modified}      1012
3317         {Authority/format identifier}  1013
3318         {Concept-text}                 1014
3319         {Concept-reference}            1015
3320         {Any}                          1016
3321         {Server choice}                1017
3322         {Publisher}                    1018
3323         {Record source}                1019
3324         {Editor}                       1020
3325         {Bib-level}                    1021
3326         {Geographic class}             1022
3327         {Indexed by}                   1023
3328         {Map scale}                    1024
3329         {Music key}                    1025
3330         {Related periodical}           1026
3331         {Report number}                1027
3332         {Stock number}                 1028
3333         {Thematic number}              1030
3334         {Material type}                1031
3335         {Doc ID}                       1032
3336         {Host item}                    1033
3337         {Content type}                 1034
3338         {Anywhere}                     1035
3339     }
3340     set w .index-setup
3341     global useTmpValue
3342     set l [llength $attr]
3343
3344     if {$init} {
3345         set s 0
3346         set lno 0
3347         for {set i 0} {$i < $l} {incr i} {
3348             $w.top.use.list insert end [lindex $attr $i]
3349             incr i
3350             if {$useTmpValue == [lindex $attr $i]} {
3351                 set s $lno
3352             }
3353             incr lno
3354         }
3355         if {[tk4]} {
3356             $w.top.use.list selection clear 0 end
3357             $w.top.use.list selection set $s $s
3358         } else {
3359             $w.top.use.list select from $s
3360             $w.top.use.list select to $s
3361         }
3362         incr s -3
3363         if {$s < 0} {
3364             set s 0
3365         }
3366         $w.top.use.list yview $s
3367     } else {
3368         set lno [lindex [$w.top.use.list curselection] 0]
3369         set i [expr $lno+$lno+1]
3370         set useTmpValue [lindex $attr $i]
3371         dputs "useTmpValue=$useTmpValue"
3372     }
3373 }
3374
3375 # Procedure index-setup-action {oldAttr queryNo indexNo}
3376 #  oldAttr     original attributes (?)
3377 #  queryNo     query number
3378 #  indexNo     index number
3379 # Commits setup of a query index. The mapping from the index to
3380 # the Bib-1 attributes are handled by this function.
3381 proc index-setup-action {oldAttr queryNo indexNo} {
3382     set attr [lindex $oldAttr 0]
3383
3384     global useTmpValue
3385     global relationTmpValue
3386     global structureTmpValue
3387     global truncationTmpValue
3388     global completenessTmpValue
3389     global positionTmpValue
3390     global queryInfoTmp
3391
3392     use-attr 0
3393
3394     dputs "index-setup-action"
3395     dputs "queryNo $queryNo"
3396     dputs "indexNo $indexNo"
3397     if {$useTmpValue > 0} {
3398         lappend attr "1=$useTmpValue"
3399     }
3400     if {$relationTmpValue > 0} {
3401         lappend attr "2=$relationTmpValue"
3402     }
3403     if {$positionTmpValue > 0} {
3404         lappend attr "3=$positionTmpValue"
3405     }
3406     if {$structureTmpValue > 0} {
3407         lappend attr "4=$structureTmpValue"
3408     }
3409     if {$truncationTmpValue > 0} {
3410         lappend attr "5=$truncationTmpValue"
3411     }
3412     if {$completenessTmpValue > 0} {
3413         lappend attr "6=$completenessTmpValue"
3414     }
3415     dputs "new attr $attr"
3416     set queryInfoTmp [lreplace $queryInfoTmp $indexNo $indexNo $attr]
3417     destroy .index-setup
3418 }
3419
3420 # Procedure index-setup {attr queryNo indexNo}
3421 #  attr        original attributes
3422 #  queryNo     query number
3423 #  indexNo     index number
3424 # Makes a window with settings of a given query index which the user
3425 # may inspect/modify.
3426 proc index-setup {attr queryNo indexNo} {
3427     set w .index-setup
3428
3429     global relationTmpValue
3430     global structureTmpValue
3431     global truncationTmpValue
3432     global completenessTmpValue
3433     global positionTmpValue
3434     global useTmpValue
3435     set relationTmpValue 0
3436     set truncationTmpValue 0
3437     set structureTmpValue 0
3438     set positionTmpValue 0
3439     set completenessTmpValue 0
3440     set useTmpValue 0
3441
3442     catch {destroy $w}
3443     toplevelG $w
3444
3445     set n [lindex $attr 0]
3446     wm title $w "Index setup $n"
3447
3448     top-down-window $w
3449
3450     set len [llength $attr]
3451     for {set i 1} {$i < $len} {incr i} {
3452         set q [lindex $attr $i]
3453         set l [string first = $q]
3454         if {$l > 0} {
3455             set t [string range $q 0 [expr $l - 1]]
3456             set v [string range $q [expr $l + 1] end]
3457             switch $t {
3458                 1
3459                 { set useTmpValue $v }
3460                 2
3461                 { set relationTmpValue $v }
3462                 3
3463                 { set positionTmpValue $v }
3464                 4
3465                 { set structureTmpValue $v }
3466                 5
3467                 { set truncationTmpValue $v }
3468                 6
3469                 { set completenessTmpValue $v }
3470             }
3471         }
3472     }
3473
3474     frame $w.top.use -relief ridge -border 2
3475     frame $w.top.relation -relief ridge -border 2
3476     frame $w.top.position -relief ridge -border 2
3477     frame $w.top.structure -relief ridge -border 2
3478     frame $w.top.truncation -relief ridge -border 2
3479     frame $w.top.completeness -relief ridge -border 2
3480
3481     update-attr
3482
3483     # Use Attributes
3484
3485     pack $w.top.use -side left -pady 6 -padx 6 -fill y
3486
3487     label $w.top.use.label -text "Use"
3488     if {[tk4]} {
3489         listbox $w.top.use.list -width 26 \
3490                 -yscrollcommand "$w.top.use.scroll set"
3491     } else {
3492         listbox $w.top.use.list -geometry 26x10 \
3493                 -yscrollcommand "$w.top.use.scroll set"
3494     }
3495     scrollbar $w.top.use.scroll -orient vertical -border 1
3496     pack $w.top.use.label -side top -fill x \
3497             -padx 2 -pady 2
3498     pack $w.top.use.list -side left -fill both -expand yes \
3499             -padx 2 -pady 2
3500     pack $w.top.use.scroll -side right -fill y \
3501             -padx 2 -pady 2
3502     $w.top.use.scroll config -command "$w.top.use.list yview"
3503
3504     use-attr 1
3505
3506     # Relation Attributes
3507
3508     pack $w.top.relation -pady 6 -padx 6 -side top
3509     label $w.top.relation.label -text "Relation" -width 18
3510
3511     pack $w.top.relation.label $w.top.relation.b -fill x
3512
3513     # Position Attributes
3514
3515     pack $w.top.position -pady 6 -padx 6 -side top
3516     label $w.top.position.label -text "Position" -width 18
3517
3518     pack $w.top.position.label $w.top.position.b -fill x
3519
3520     # Structure Attributes
3521
3522     pack $w.top.structure -pady 6 -padx 6 -side top
3523     label $w.top.structure.label -text "Structure" -width 18
3524
3525     pack $w.top.structure.label $w.top.structure.b -fill x
3526
3527     # Truncation Attributes
3528
3529     pack $w.top.truncation -pady 6 -padx 6 -side top
3530     label $w.top.truncation.label -text "Truncation" -width 18
3531
3532     pack $w.top.truncation.label $w.top.truncation.b -fill x
3533
3534     # Completeness Attributes
3535
3536     pack $w.top.completeness -pady 6 -padx 6 -side top
3537     label $w.top.completeness.label -text "Completeness" -width 18
3538
3539     pack $w.top.completeness.label $w.top.completeness.b -fill x
3540
3541     # Ok-cancel
3542     bottom-buttons $w [list \
3543             {Ok} [list index-setup-action $attr $queryNo $indexNo] \
3544             {Cancel} [list destroy $w]] 0
3545
3546 }
3547
3548 # Procedure query-edit-index {queryNo}
3549 #  queryNo     query number
3550 # Determines if a selection of an index is active. If one is selected
3551 # the index-setup dialog is started.
3552 proc query-edit-index {queryNo} {
3553     global queryInfoTmp
3554     set w .query-setup
3555
3556     set i [lindex [$w.top.index.list curselection] 0]
3557     if {![string length $i]} {
3558         return
3559     }
3560     set attr [lindex $queryInfoTmp $i]
3561     dputs "Editing no $i $attr"
3562     index-setup $attr $queryNo $i
3563 }
3564
3565 # Procedure query-delete-index {queryNo}
3566 #  queryNo     query number
3567 # Determines if a selection of an index is active. If one is selected
3568 # the index is deleted.
3569 proc query-delete-index {queryNo} {
3570     global queryInfoTmp
3571     global queryButtonsTmp
3572     set w .query-setup
3573
3574     set i [lindex [$w.top.index.list curselection] 0]
3575     if {![string length $i]} {
3576         return
3577     }
3578     set queryInfoTmp [lreplace $queryInfoTmp $i $i]
3579     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
3580     $w.top.index.list delete $i
3581 }
3582
3583 # Procedure query-setup {queryNo}
3584 #  queryNo     query number
3585 # Makes a dialog in which a query type an be customized.
3586 proc query-setup {queryNo} {
3587     set w .query-setup
3588
3589     global queryTypes
3590     global queryButtons
3591     global queryInfo
3592     global queryButtonsTmp
3593     global queryInfoTmp
3594     global queryIndexTmp
3595
3596     set queryIndexTmp 0
3597     set queryName [lindex $queryTypes $queryNo]
3598     set queryInfoTmp [lindex $queryInfo $queryNo]
3599     set queryButtonsTmp [lindex $queryButtons $queryNo]
3600
3601     toplevelG $w
3602
3603     wm minsize $w 0 0
3604     wm title $w "Query setup $queryName"
3605
3606     top-down-window $w
3607
3608     frame $w.top.lines -relief ridge -border 2
3609
3610     pack $w.top.lines -side left -pady 6 -padx 6 -fill y
3611
3612     # Index Lines
3613
3614     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
3615
3616     button $w.top.lines.add -text "Add" \
3617             -command [list query-add-line $queryNo]
3618     button $w.top.lines.del -text "Remove" \
3619             -command [list query-del-line $queryNo]
3620
3621     pack $w.top.lines.del -fill x -side bottom
3622     pack $w.top.lines.add -fill x -pady 10 -side bottom
3623
3624     # Indexes
3625
3626     frame $w.top.index -relief ridge -border 2
3627     pack $w.top.index -pady 6 -padx 6 -side right -fill y
3628
3629     listbox $w.top.index.list -yscrollcommand [list $w.top.index.scroll set]
3630     scrollbar $w.top.index.scroll -orient vertical -border 1 \
3631         -command [list $w.top.index.list yview]
3632     bind $w.top.index.list <Double-1> [list query-edit-index $queryNo]
3633
3634     pack $w.top.index.list -side left -fill both -expand yes -padx 2 -pady 2
3635     pack $w.top.index.scroll -side right -fill y -padx 2 -pady 2
3636
3637     if {[tk4]} {
3638         $w.top.index.list selection clear 0 end
3639         $w.top.index.list selection set 0 0
3640     } else {
3641         $w.top.index.list select from 0
3642         $w.top.index.list select to 0
3643     }
3644
3645     foreach x $queryInfoTmp {
3646         $w.top.index.list insert end [lindex $x 0]
3647     }
3648
3649     # Bottom
3650     bottom-buttons $w [list \
3651             Ok [list query-setup-action $queryNo] \
3652             Add [list query-add-index $queryNo] \
3653             Edit [list query-edit-index $queryNo] \
3654             Delete [list query-delete-index $queryNo] \
3655             Cancel [list destroy $w]] 0
3656 }
3657
3658 # Procedure index-clear
3659 # Handler that clears the search entry fields.
3660 proc index-clear {} {
3661     global queryButtonsFind
3662
3663     set i 0
3664     foreach b $queryButtonsFind {
3665         .lines.$i.e delete 0 end
3666         incr i
3667     }
3668 }
3669
3670 # Procedure index-query
3671 # The purpose of this function is to read the user's query and convert
3672 # it to the prefix query that IrTcl/YAZ uses to represent an RPN query.
3673 # Each entry in a search fields takes the form
3674 #    [relOp][?]term[?]
3675 #  Here, relOp is an optional relational operator and one of:
3676 #      >  < >= <=  <>
3677 #    which sets the Bib-1 relation to greater-than, less-than, etc.
3678 #  The ? (question-mark) is also optional. A (?) on left-side indicates
3679 #    left truncation; (?) on right-side indicates right-truncation; (?)
3680 #    on both sides indicates both-left-and-right truncation.
3681 proc index-query {} {
3682     global queryButtonsFind
3683     global queryInfoFind
3684
3685     set i 0
3686     set qs {}
3687
3688     foreach b $queryButtonsFind {
3689         set term [string trim [.lines.$i.e get]]
3690         if {$term != ""} {
3691             set attr [lrange [lindex $queryInfoFind [lindex $b 1]] 1 end]
3692
3693             set relation ""
3694             set len [string length $term]
3695             incr len -1
3696
3697             if {$len > 1} {
3698                 if {[string index $term 0] == ">"} {
3699                     if {[string index $term 1] == "=" } {
3700                         set term [string trim [string range $term 2 $len]]
3701                         set relation 4
3702                     } else {
3703                         set term [string trim [string range $term 1 $len]]
3704                         set relation 5
3705                     }
3706                 } elseif {[string index $term 0] == "<"} {
3707                     if {[string index $term 1] == "=" } {
3708                         set term [string trim [string range $term 2 $len]]
3709                         set relation 2
3710                     } elseif {[string index $term 1] == ">"} {
3711                         set term [string trim [string range $term 2 $len]]
3712                         set relation 6
3713                     } else {
3714                         set term [string trim [string range $term 1 $len]]
3715                         set relation 1
3716                     }
3717                 }
3718             }
3719             set len [string length $term]
3720             incr len -1
3721             set left 0
3722             set right 0
3723             if {[string index $term $len] == "?"} {
3724                 set right 1
3725                 set term [string range $term 0 [expr $len - 1]]
3726             }
3727             if {[string index $term 0] == "?"} {
3728                 set left 1
3729                 set term [string range $term 1 end]
3730             }
3731             set term "\{${term}\}"
3732             if {$right && $left} {
3733                 set term "@attr 5=3 ${term}"
3734             } elseif {$right} {
3735                 set term "@attr 5=1 ${term}"
3736             } elseif {$left} {
3737                 set term "@attr 5=2 ${term}"
3738             }
3739             if {$relation != ""} {
3740                 set term "@attr 2=${relation} ${term}"
3741             }
3742             foreach a $attr {
3743                 set term "@attr $a ${term}"
3744             }
3745             if {$qs != ""} {
3746                 set qs "@and ${qs} ${term}"
3747             } else {
3748                 set qs $term
3749             }
3750         }
3751         incr i
3752     }
3753     dputs "qs=  $qs"
3754     return $qs
3755 }
3756
3757 # Procedure index-focus-in {w i}
3758 #  w    index frame
3759 #  i    index number
3760 # This procedure handles <FocusIn> events. A red border is drawed
3761 # around the active search entry field when tk3.6 is used (tk4.X
3762 # makes a black focus border itself).
3763 proc index-focus-in {w i} {
3764     global curIndexEntry
3765
3766     if {! [tk4]} {
3767         $w.$i configure -background red
3768     }
3769     set curIndexEntry $i
3770 }
3771
3772 # Procedure index-lines {w readOp buttonInfo queryInfo handle}
3773 #  w          search fields entry frame
3774 #  realOp     if true, search-request bindings are bound to the entries.
3775 #  buttonInfo query type button information
3776 #  queryInfo  query type field information
3777 #  handle     handler called a when a 'listbutton' changes its value
3778 # Makes one or more search areas - with listbuttons on the left
3779 # and entries on the right.
3780 proc index-lines {w realOp buttonInfo queryInfo handle} {
3781     set i 0
3782     foreach b $buttonInfo {
3783         if {! [winfo exists $w.$i]} {
3784             if {[tk4]} {
3785                 frame $w.$i -border 0
3786             } else {
3787                 frame $w.$i -background white -border 1
3788             }
3789         }
3790         listbuttonx $w.$i.l [lindex $b 1] $queryInfo $handle $i
3791
3792         if {$realOp} {
3793             if {! [winfo exists $w.$i.e]} {
3794                 entry $w.$i.e -width 32 -relief sunken -border 1
3795                 bind $w.$i.e <FocusIn> [list index-focus-in $w $i]
3796                 bind $w.$i.e <FocusOut> [list $w.$i configure \
3797                         -background white]
3798                 pack $w.$i.l -side left
3799                 pack $w.$i.e -side left -fill x -expand yes
3800                 pack $w.$i -side top -fill x -padx 2 -pady 2
3801                 if {![tk4]} {
3802                     bind $w.$i.e <Left> [list left-cursor $w.$i.e]
3803                     bind $w.$i.e <Right> [list right-cursor $w.$i.e]
3804                 }
3805                 bind $w.$i.e <Return> {search-request 0}
3806             }
3807         } else {
3808             pack $w.$i.l -side left
3809             pack $w.$i -side top -fill x -padx 2 -pady 2
3810         }
3811         incr i
3812     }
3813     set j $i
3814     while {[winfo exists $w.$j]} {
3815         destroy $w.$j
3816         incr j
3817     }
3818     if {! $realOp} {
3819         return
3820     }
3821     if {! [tk4]} {
3822         set j 0
3823         incr i -1
3824         while {$j < $i} {
3825             set k [expr $j+1]
3826             bind $w.$j.e <Tab> "focus $w.$k.e"
3827             set j $k
3828         }
3829     }
3830     if {$i >= 0} {
3831         if {! [tk4]} {
3832             bind $w.$i.e <Tab> "focus $w.0.e"
3833         }
3834         focus $w.0.e
3835     }
3836 }
3837
3838 # Procedure search-fields {w buttondefs}
3839 #  w           search fields entry frame
3840 #  buttondefs  button definitions
3841 # Makes search entry fields and listbuttons.
3842 # Note: This procedure is not used elsewhere. The index-lines
3843 #       procedure is used instead.
3844 proc search-fields {w buttondefs} {
3845     set i 0
3846     foreach buttondef $buttondefs {
3847         frame $w.$i -background white
3848
3849         listbutton $w.$i.l 0 $buttondef
3850         entry $w.$i.e -width 32 -relief sunken
3851
3852         pack $w.$i.l -side left
3853         pack $w.$i.e -side left -fill x -expand yes
3854
3855         pack $w.$i -side top -fill x -padx 2 -pady 2
3856
3857         bind $w.$i.e <Left> [list left-cursor $w.$i.e]
3858         bind $w.$i.e <Right> [list right-cursor $w.$i.e]
3859
3860         incr i
3861     }
3862     set j 0
3863     incr i -1
3864     while {$j < $i} {
3865         set k [expr $j+1]
3866         bind $w.$j.e <Tab> "focus $w.$k.e \n
3867         $w.$k configure -background red \n
3868         $w.$j configure -background white"
3869         set j $k
3870     }
3871     bind $w.$i.e <Tab> "focus $w.0.e \n
3872         $w.0 configure -background red \n
3873         $w.$i configure -background white"
3874     focus $w.0.e
3875     $w.0 configure -background red
3876 }
3877
3878 # Init: The geometry information for the main window is set - either
3879 # to a default value or to the value in windowGeometry(.)
3880 if {[catch {set g $windowGeometry(.)}]} {
3881     wm geometry . 420x340
3882 } else {
3883     wm geometry . $g
3884 }
3885
3886 # Init: Presentation formats are read.
3887 read-formats
3888
3889 # Init: The main window is defined.
3890 frame .top  -border 1 -relief raised
3891 frame .lines  -border 1 -relief raised
3892 frame .mid  -border 1 -relief raised
3893 frame .data -border 1 -relief raised
3894 frame .bot  -border 1 -relief raised
3895 pack .top .lines .mid -side top -fill x
3896 pack .data -side top -fill both -expand yes
3897 pack .bot -fill x
3898
3899 # Init: Definition of File menu.
3900 menubutton .top.file -text File -menu .top.file.m
3901 menu .top.file.m
3902 .top.file.m add command -label {Save settings} -command {save-settings}
3903 .top.file.m add separator
3904 .top.file.m add command -label Exit -command {exit-action}
3905
3906 # Init: Definition of Target menu.
3907 menubutton .top.target -text Target -menu .top.target.m
3908 menu .top.target.m
3909 .top.target.m add cascade -label Connect -menu .top.target.m.clist
3910 .top.target.m add command -label Disconnect -command {close-target}
3911 .top.target.m add command -label About -command {about-target}
3912 .top.target.m add cascade -label Setup -menu .top.target.m.slist
3913 .top.target.m add command -label {Setup new} -command {define-target-dialog}
3914 .top.target.m add separator
3915 set-target-hotlist 0
3916
3917 configure-disable-e .top.target.m 1
3918 configure-disable-e .top.target.m 2
3919
3920 menu .top.target.m.clist
3921 menu .top.target.m.slist
3922 cascade-target-list
3923
3924 # Init: Definition of Service menu.
3925 menubutton .top.service -text Service -menu .top.service.m
3926 menu .top.service.m
3927 .top.service.m add cascade -label Database -menu .top.service.m.dblist
3928 .top.service.m add cascade -label Present -menu .top.service.m.present
3929 menu .top.service.m.present
3930 .top.service.m.present add command -label {10 More} \
3931         -command [list present-more 10]
3932 .top.service.m.present add command -label All \
3933         -command [list present-more {}]
3934 .top.service.m add command -label Search -command {search-request 0}
3935 .top.service.m add command -label Scan -command {scan-request}
3936
3937 .top.service configure -state disabled
3938
3939 menu .top.service.m.dblist
3940
3941 menubutton .top.rset -text Set -menu .top.rset.m
3942 menu .top.rset.m
3943 .top.rset.m add command -label Load -command {load-set}
3944 .top.rset.m add separator
3945
3946 # Init: Definition of the Options menu.
3947 menubutton .top.options -text Options -menu .top.options.m
3948 menu .top.options.m
3949 .top.options.m add cascade -label Query -menu .top.options.m.query
3950 .top.options.m add cascade -label Format -menu .top.options.m.formats
3951 .top.options.m add cascade -label Wrap -menu .top.options.m.wrap
3952 .top.options.m add cascade -label Syntax -menu .top.options.m.syntax
3953 .top.options.m add cascade -label Elements -menu .top.options.m.elements
3954 .top.options.m add radiobutton -label Debug -variable debugMode -value 1
3955
3956 # Init: Definition of the Options|Query menu.
3957 menu .top.options.m.query
3958 .top.options.m.query add cascade -label Select \
3959         -menu .top.options.m.query.clist
3960 .top.options.m.query add cascade -label Edit \
3961         -menu .top.options.m.query.slist
3962 .top.options.m.query add command -label New \
3963         -command {query-new}
3964 .top.options.m.query add cascade -label Delete \
3965         -menu .top.options.m.query.dlist
3966
3967 menu .top.options.m.query.slist
3968 menu .top.options.m.query.clist
3969 menu .top.options.m.query.dlist
3970 cascade-query-list
3971
3972 # Init: Definition of the Options|Formats menu.
3973 menu .top.options.m.formats
3974 set i 0
3975 foreach f $displayFormats {
3976     .top.options.m.formats add radiobutton -label $f -value $i \
3977             -command [list set-display-format $i] -variable displayFormat
3978     incr i
3979 }
3980
3981 # Init: Definition of the Options|Wrap menu.
3982 menu .top.options.m.wrap
3983 .top.options.m.wrap add radiobutton -label Character \
3984         -value char -variable textWrap -command {set-wrap char}
3985 .top.options.m.wrap add radiobutton -label Word \
3986         -value word -variable textWrap -command {set-wrap word}
3987 .top.options.m.wrap add radiobutton -label None \
3988         -value none -variable textWrap -command {set-wrap none}
3989
3990 # Init: Definition of the Options|Syntax menu.
3991 menu .top.options.m.syntax
3992 .top.options.m.syntax add radiobutton -label None \
3993         -value None -variable recordSyntax
3994 .top.options.m.syntax add separator
3995 .top.options.m.syntax add radiobutton -label USMARC \
3996         -value USMARC -variable recordSyntax
3997 .top.options.m.syntax add radiobutton -label UNIMARC \
3998         -value UNIMARC -variable recordSyntax
3999 .top.options.m.syntax add radiobutton -label UKMARC \
4000         -value UKMARC -variable recordSyntax
4001 .top.options.m.syntax add radiobutton -label DANMARC \
4002         -value DANMARC -variable recordSyntax
4003 .top.options.m.syntax add radiobutton -label FINMARC \
4004         -value FINMARC -variable recordSyntax
4005 .top.options.m.syntax add radiobutton -label NORMARC \
4006         -value NORMARC -variable recordSyntax
4007 .top.options.m.syntax add radiobutton -label PICAMARC \
4008         -value PICAMARC -variable recordSyntax
4009 .top.options.m.syntax add separator
4010 .top.options.m.syntax add radiobutton -label SUTRS \
4011         -value SUTRS -variable recordSyntax
4012 .top.options.m.syntax add separator
4013 .top.options.m.syntax add radiobutton -label GRS1 \
4014         -value GRS1 -variable recordSyntax
4015
4016 # Init: Definition of the Options|Elements menu.
4017 menu .top.options.m.elements
4018 .top.options.m.elements add radiobutton -label Unspecified \
4019         -value None -variable elementSetNames
4020 .top.options.m.elements add radiobutton -label Full \
4021         -value F -variable elementSetNames
4022 .top.options.m.elements add radiobutton -label Brief \
4023         -value B -variable elementSetNames
4024
4025 # Init: Definition of Help menu.
4026 menubutton .top.help -text "Help" -menu .top.help.m
4027 menu .top.help.m
4028
4029 .top.help.m add command -label "Help on help" \
4030         -command {tkerror "Help on help not available. Sorry"}
4031 .top.help.m add command -label "About" -command {about-origin}
4032
4033 # Init: Pack menu bar items.
4034 pack .top.file .top.target .top.service .top.rset .top.options -side left
4035 pack .top.help -side right
4036
4037 # Init: Define query area.
4038 index-lines .lines 1 $queryButtonsFind [lindex $queryInfo 0] activate-index
4039
4040 button .mid.search -text Search -command {search-request 0} \
4041         -state disabled
4042 button .mid.scan -text Scan \
4043         -command scan-request -state disabled
4044 button .mid.present -text {Present} -command [list present-more 10] \
4045         -state disabled
4046
4047 button .mid.clear -text Clear -command index-clear
4048 pack .mid.search .mid.scan .mid.present .mid.clear -side left \
4049         -fill y -pady 1
4050
4051 # Init: Define record area in main window.
4052 text .data.record -font fixed -height 2 -width 20 -wrap none -borderwidth 0 \
4053         -relief flat -yscrollcommand [list .data.scroll set] -wrap $textWrap
4054 scrollbar .data.scroll -command [list .data.record yview]
4055 if {[tk4]} {
4056     .data.record configure -takefocus 0
4057     .data.scroll configure -takefocus 0
4058 }
4059
4060 pack .data.scroll -side right -fill y
4061 pack .data.record -expand yes -fill both
4062 initBindings
4063
4064 # Init: Define standards tags. These are used in the display
4065 # format procedures.
4066 if {! $monoFlag} {
4067     .data.record tag configure marc-tag -foreground blue
4068     .data.record tag configure marc-id -foreground red
4069 } else {
4070     .data.record tag configure marc-tag -foreground black
4071     .data.record tag configure marc-id -foreground black
4072 }
4073 .data.record tag configure marc-data -foreground black
4074 .data.record tag configure marc-head \
4075         -font -Adobe-Times-Bold-R-Normal-*-140-* \
4076         -foreground brown -relief raised -borderwidth 1
4077 .data.record tag configure marc-small-head -foreground brown
4078 .data.record tag configure marc-pref \
4079         -font -Adobe-Times-Medium-R-Normal-*-140-* \
4080         -foreground blue
4081 .data.record tag configure marc-text \
4082         -font -Adobe-Times-Medium-R-Normal-*-140-* \
4083         -foreground black
4084 .data.record tag configure marc-it \
4085         -font -Adobe-Times-Medium-I-Normal-*-140-* \
4086         -foreground black
4087
4088 # Init: Define logo.
4089 button .bot.logo -bitmap @${libdir}/bitmaps/book1 -command cancel-operation
4090 if {[tk4]} {
4091     .bot.logo configure -takefocus 0
4092 }
4093 # Init: Define status information fields at the bottom.
4094 frame .bot.a
4095 pack .bot.a -side left -fill x
4096 pack .bot.logo -side right -padx 2 -pady 2 -ipadx 1
4097
4098 message .bot.a.target -text "" -aspect 1000 -border 1
4099
4100 label .bot.a.status -text "Not connected" -width 15 -relief \
4101         sunken -anchor w -border 1
4102 label .bot.a.set -text "" -width 5 -relief \
4103         sunken -anchor w -border 1
4104 label .bot.a.message -text "" -width 15 -relief \
4105         sunken -anchor w -border 1
4106
4107 pack .bot.a.target -side top -anchor nw -padx 2 -pady 2
4108 pack .bot.a.status .bot.a.set .bot.a.message \
4109         -side left -padx 2 -pady 2 -ipadx 1 -ipady 1
4110
4111 # Init: Determine if the IrTcl extension is already there. If
4112 #  not, then dynamically load the IrTcl extension.
4113 if {[catch {ir z39}]} {
4114     set e [info sharedlibextension]
4115     puts -nonewline "Loading irtcl$e ..."
4116     load irtcl$e irtcl
4117     ir z39
4118     puts "ok"
4119 }
4120
4121 if {[file exists ${libdir}/explain.tcl]} {
4122     source ${libdir}/explain.tcl
4123 }
4124
4125 if {[file exists ${libdir}/setup.tcl]} {
4126     source ${libdir}/setup.tcl
4127 }
4128
4129 # Init: Uncomment this line if you wan't to enable logging.
4130 ir-log-init all
4131
4132 # Init: If hostid is a valid target, a new connection will be established
4133 # immediately.
4134 if {[string compare $hostid Default]} {
4135     catch {open-target $hostid $hostbase}
4136 }
4137
4138 # Init: Enable the logo.
4139 show-logo 1
4140