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