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