client.tcl

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