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