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