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