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