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