client.tcl

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