client.tcl

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