client.tcl

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