client.tcl

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