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