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