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