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