client.tcl

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