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