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