client.tcl

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