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