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