client.tcl

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