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