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