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