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