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