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