client.tcl

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