client.tcl

   1 #
   2 # $Log: client.tcl,v $
   3 # Revision 1.34  1995-06-12 07:59:07  adam
   4 # More work on geometry handling.
   5 #
   6 # Revision 1.33  1995/06/09  11:17:35  adam
   7 # Start work on geometry management.
   8 #
   9 # Revision 1.32  1995/06/07  09:16:37  adam
  10 # New presentation format.
  11 #
  12 # Revision 1.31  1995/06/06  16:31:09  adam
  13 # Bug fix: target names couldn't contain blanks.
  14 # Bug fix: scan.
  15 #
  16 # Revision 1.30  1995/06/06  11:35:41  adam
  17 # Work on scan. Display of old sets.
  18 #
  19 # Revision 1.29  1995/06/05  14:11:18  adam
  20 # Bug fix in present-more.
  21 #
  22 # Revision 1.28  1995/06/02  14:52:13  adam
  23 # Minor changes really.
  24 #
  25 # Revision 1.27  1995/06/02  14:29:42  adam
  26 # Work on scan interface - up/down buttons.
  27 #
  28 # Revision 1.26  1995/06/01  16:36:46  adam
  29 # About buttons. Minor bug fixes.
  30 #
  31 # Revision 1.25  1995/05/31  13:09:57  adam
  32 # Client searches/presents may be interrupted.
  33 # New moving book-logo.
  34 #
  35 # Revision 1.24  1995/05/31  08:36:24  adam
  36 # Bug fix in client.tcl: didn't save options on clientrc.tcl.
  37 # New method: referenceId. More work on scan.
  38 #
  39 # Revision 1.23  1995/05/29  10:33:41  adam
  40 # README and rename of startup script.
  41 #
  42 # Revision 1.22  1995/05/26  11:44:09  adam
  43 # Bugs fixed. More work on MARC utilities and queries. Test
  44 # client is up-to-date again.
  45 #
  46 # Revision 1.21  1995/05/11  15:34:46  adam
  47 # Scan request changed a bit. This version works with RLG.
  48 #
  49 # Revision 1.20  1995/04/21  16:31:57  adam
  50 # New radiobutton: protocol (z39v2/SR).
  51 #
  52 # Revision 1.19  1995/04/18  16:11:50  adam
  53 # First version of graphical Scan. Some work on query-by-form.
  54 #
  55 # Revision 1.18  1995/04/10  10:50:22  adam
  56 # Result-set name defaults to suffix of ir-set name.
  57 # Started working on scan. Not finished at this point.
  58 #
  59 # Revision 1.17  1995/03/31  09:34:57  adam
  60 # Search-button disabled when there is no connection.
  61 #
  62 # Revision 1.16  1995/03/31  08:56:36  adam
  63 # New button "Search".
  64 #
  65 # Revision 1.15  1995/03/28  12:45:22  adam
  66 # New ir method failback: called on disconnect/protocol error.
  67 # New ir set/get method: protocol: SR / Z3950.
  68 # Simple popup and disconnect when failback is invoked.
  69 #
  70 # Revision 1.14  1995/03/22  16:07:55  adam
  71 # Minor changes.
  72 #
  73 # Revision 1.13  1995/03/21  17:27:26  adam
  74 # Short-hand keys in setup.
  75 #
  76 # Revision 1.12  1995/03/21  13:41:03  adam
  77 # Comstack cs_create not used too often. Non-blocking connect.
  78 #
  79 # Revision 1.11  1995/03/21  10:39:06  adam
  80 # Diagnostic error message displayed with tkerror.
  81 #
  82 # Revision 1.10  1995/03/20  15:24:06  adam
  83 # Diagnostic records saved on searchResponse.
  84 #
  85 # Revision 1.9  1995/03/17  18:26:16  adam
  86 # Non-blocking i/o used now. Database names popup as cascade items.
  87 #
  88 # Revision 1.8  1995/03/17  15:45:00  adam
  89 # Improved target/database setup.
  90 #
  91 # Revision 1.7  1995/03/16  17:54:03  adam
  92 # Minor changes really.
  93 #
  94 # Revision 1.6  1995/03/15  19:10:20  adam
  95 # Database setup in protocol-setup (rather target setup).
  96 #
  97 # Revision 1.5  1995/03/15  13:59:23  adam
  98 # Minor changes.
  99 #
 100 # Revision 1.4  1995/03/14  17:32:29  adam
 101 # Presentation of full Marc record in popup window.
 102 #
 103 # Revision 1.3  1995/03/12  19:31:52  adam
 104 # Pattern matching implemented when retrieving MARC records. More
 105 # diagnostic functions.
 106 #
 107 # Revision 1.2  1995/03/10  18:00:15  adam
 108 # Actual presentation in line-by-line format. RPN query support.
 109 #
 110 # Revision 1.1  1995/03/09  16:15:07  adam
 111 # First presentRequest attempts. Hot-target list.
 112 #
 113 #
 114 set hotTargets {}
 115 set hotInfo {}
 116 set busy 0
 117
 118 set profile(Default) {{} {} {210} {} 16384 8192 tcpip {} 1 {} {} z39v2}
 119 set hostid Default
 120 set settingsChanged 0
 121 set setNo 0
 122 set cancelFlag 0
 123 set searchEnable 0
 124 set fullMarcSeq 0
 125 set displayFormat nice
 126
 127 set queryTypes {Simple}
 128 set queryButtons { { {I 0} {I 1} {I 2} } }
 129 set queryInfo { { {Title {1=4}} {Author {1=1}} \
 130         {Subject {1=21}} {Any {1=1016}} } }
 131 wm minsize . 0 0
 132
 133 proc read-formats {} {
 134     global displayFormats
 135     set formats [glob -nocomplain formats/*.tcl]
 136     foreach f $formats {
 137         source $f
 138         set l [expr [string length $f] - 5]
 139         lappend displayFormats [string range $f 8 $l]
 140     }
 141     puts $displayFormats
 142 }
 143
 144 proc destroyG {w} {
 145     global windowGeometry
 146     set windowGeometry($w) [wm geometry $w]
 147     destroy $w
 148 }
 149
 150 proc toplevelG {w} {
 151     global windowGeometry
 152
 153     toplevel $w
 154     if {[info exists windowGeometry($w)]} {
 155         set g $windowGeometry($w)
 156         if {$g != ""} {
 157             wm geometry $w $g
 158         }
 159     }
 160 }
 161
 162
 163 if {[file readable "clientrc.tcl"]} {
 164     source "clientrc.tcl"
 165 }
 166
 167 if {[file readable "clientg.tcl"]} {
 168     source "clientg.tcl"
 169 }
 170
 171 set queryButtonsFind [lindex $queryButtons 0]
 172 set queryInfoFind [lindex $queryInfo 0]
 173
 174 proc top-down-window {w} {
 175     frame $w.top -relief raised -border 1
 176     frame $w.bot -relief raised -border 1
 177
 178     pack  $w.top -side top -fill both -expand yes
 179     pack  $w.bot -fill both
 180 }
 181
 182 proc top-down-ok-cancel {w ok-action g} {
 183     frame $w.bot.left -relief sunken -border 1
 184     pack $w.bot.left -side left -expand yes -ipadx 2 -ipady 2 -padx 5 -pady 5
 185     button $w.bot.left.ok -width 6 -text {Ok} \
 186             -command ${ok-action}
 187     pack $w.bot.left.ok -expand yes -ipadx 2 -ipady 2 -padx 3 -pady 3
 188     button $w.bot.cancel -width 6 -text {Cancel} \
 189             -command [list destroy $w]
 190     pack $w.bot.cancel -side left -expand yes
 191
 192     if {$g} {
 193         grab $w
 194         tkwait window $w
 195     }
 196 }
 197
 198 proc bottom-buttons {w buttonList g} {
 199     set i 0
 200     set l [llength $buttonList]
 201
 202     frame $w.bot.$i -relief sunken -border 1
 203     pack $w.bot.$i -side left -expand yes -padx 5 -pady 5
 204     button $w.bot.$i.ok -text [lindex $buttonList $i] \
 205             -command [lindex $buttonList [expr $i+1]]
 206     pack $w.bot.$i.ok -expand yes -ipadx 2 -ipady 2 -padx 3 -pady 3 -side left
 207
 208     incr i 2
 209     while {$i < $l} {
 210         button $w.bot.$i -text [lindex $buttonList $i] \
 211                 -command [lindex $buttonList [expr $i+1]]
 212         pack $w.bot.$i -expand yes -ipadx 2 -ipady 2 -padx 3 -pady 3 -side left
 213         incr i 2
 214     }
 215     if {$g} {
 216         # Grab ...
 217         grab $w
 218         tkwait window $w
 219     }
 220 }
 221
 222 proc cancel-operation {} {
 223     global cancelFlag
 224     global busy
 225
 226     set cancelFlag 1
 227     if {$busy} {
 228         show-status Cancelled 0 {}
 229     }
 230 }
 231
 232 proc show-target {target} {
 233     .bot.a.target configure -text "$target"
 234 }
 235
 236 proc show-logo {v1} {
 237     global busy
 238     if {$busy != 0} {
 239         incr v1 -1
 240         if {$v1==0} {
 241             set v1 9
 242         }
 243         .bot.logo configure -bitmap @book${v1}
 244         after 140 [list show-logo $v1]
 245         return
 246     }
 247     while {1} {
 248         .bot.logo configure -bitmap @book1
 249         tkwait variable busy
 250         if {$busy} {
 251             show-logo 1
 252             return
 253         }
 254     }
 255 }
 256
 257 proc show-status {status b sb} {
 258     global busy
 259     global searchEnable
 260
 261     .bot.a.status configure -text "$status"
 262     if {$b == 1} {
 263         if {$busy == 0} {set busy 1}
 264     } else {
 265         set busy 0
 266     }
 267     if {$sb == {}} {
 268         return
 269     }
 270     if {$sb} {
 271         .top.service configure -state normal
 272         .mid.search configure -state normal
 273         .mid.scan configure -state normal
 274         .mid.present configure -state normal
 275         if {[winfo exists .scan-window]} {
 276             .scan-window.bot.2 configure -state normal
 277             .scan-window.bot.4 configure -state normal
 278         }
 279         set searchEnable 1
 280     } else {
 281         .top.service configure -state disabled
 282         .mid.search configure -state disabled
 283         .mid.scan configure -state disabled
 284         .mid.present configure -state disabled
 285
 286         if {[winfo exists .scan-window]} {
 287             .scan-window.bot.2 configure -state disabled
 288             .scan-window.bot.4 configure -state disabled
 289         }
 290         set searchEnable 0
 291     }
 292 }
 293
 294 proc show-message {msg} {
 295     .bot.a.message configure -text "$msg"
 296 }
 297
 298 proc insertWithTags {w text args} {
 299     set start [$w index insert]
 300     $w insert insert $text
 301     foreach tag [$w tag names $start] {
 302         $w tag remove $tag $start insert
 303     }
 304     foreach i $args {
 305         $w tag add $i $start insert
 306     }
 307 }
 308
 309 proc about-target {} {
 310     set w .about-target-w
 311
 312     toplevelG $w
 313
 314     wm title $w "About target"
 315     top-down-window $w
 316
 317     set i [z39 targetImplementationName]
 318     label $w.top.in -text "Implementation name: $i"
 319     set i [z39 targetImplementationId]
 320     label $w.top.ii -text "Implementation id: $i"
 321     set i [z39 targetImplementationVersion]
 322     label $w.top.iv -text "Implementation version: $i"
 323     set i [z39 options]
 324     label $w.top.op -text "Protocol options: $i"
 325
 326     pack $w.top.in $w.top.ii $w.top.iv $w.top.op -side top -anchor nw
 327
 328     bottom-buttons $w [list {Close} [list destroyG $w]] 1
 329 }
 330
 331 proc about-origin {} {
 332     set w .about-origin-w
 333
 334     toplevelG $w
 335
 336     wm title $w "About IrTcl"
 337     place-force $w .
 338     top-down-window $w
 339
 340     set i [z39 implementationName]
 341     label $w.top.in -text "Implementation name: $i"
 342     set i [z39 implementationId]
 343     label $w.top.ii -text "Implementation id: $i"
 344
 345     pack $w.top.in $w.top.ii -side top -anchor nw
 346
 347     bottom-buttons $w [list {Close} [list destroyG $w]] 1
 348 }
 349
 350 proc show-full-marc {sno no b} {
 351     global fullMarcSeq
 352     global displayFormat
 353
 354     if {[z39.$sno type $no] != "DB"} {
 355         return
 356     }
 357     if {$b} {
 358         set w .full-marc-$fullMarcSeq
 359         incr fullMarcSeq
 360     } else {
 361         set w .full-marc
 362     }
 363     if {[winfo exists $w]} {
 364         set new 0
 365     } else {
 366
 367         toplevelG $w
 368
 369         wm minsize $w 0 0
 370
 371         frame $w.top -relief raised -border 1
 372         frame $w.bot -relief raised -border 1
 373
 374         pack  $w.top -side top -fill both -expand yes
 375         pack  $w.bot -fill both
 376
 377         text $w.top.record -width 60 -height 5 -wrap word \
 378                 -yscrollcommand [list $w.top.s set]
 379         scrollbar $w.top.s -command [list $w.top.record yview]
 380
 381         set new 1
 382     }
 383     if {[tk colormodel .] == "color"} {
 384         $w.top.record tag configure marc-tag -foreground blue
 385         $w.top.record tag configure marc-id -foreground red
 386     } else {
 387         $w.top.record tag configure marc-tag -foreground black
 388         $w.top.record tag configure marc-id -foreground black
 389     }
 390     $w.top.record tag configure marc-data -foreground black
 391
 392     if {$displayFormat == "nice"} {
 393         display-nice $sno $no $w.top.record
 394     } else {
 395         display-raw $sno $no $w.top.record
 396     }
 397     if {$new} {
 398         bind $w.top.record <Return> {destroy .full-marc}
 399
 400         pack $w.top.s -side right -fill y
 401         pack $w.top.record -expand yes -fill both
 402
 403         if {$b} {
 404             bottom-buttons $w [list \
 405                 {Close} [list destroy $w] \
 406                 {Raw} [list display-raw $sno $no $w.top.record] \
 407                 {Duplicate} [list show-full-marc $sno $no 1]] 0
 408         } else {
 409             bottom-buttons $w [list \
 410                 {Close} [list destroyG $w] \
 411                 {Raw} [list display-raw $sno $no $w.top.record] \
 412                 {Duplicate} [list show-full-marc $sno $no 1]] 0
 413         }
 414
 415     } else {
 416         $w.bot.2 configure -command [list display-raw $sno $no $w.top.record]
 417         $w.bot.4 configure -command [list show-full-marc $sno $no 1]
 418     }
 419 }
 420
 421 proc update-target-hotlist {target} {
 422     global hotTargets
 423
 424     set len [llength $hotTargets]
 425     if {$len > 0} {
 426         .top.target.m delete 6 [expr 6+[llength $hotTargets]]
 427     }
 428     set indx [lsearch $hotTargets $target]
 429     if {$indx >= 0} {
 430         set hotTargets [lreplace $hotTargets $indx $indx]
 431     }
 432     set hotTargets [linsert $hotTargets 0 $target]
 433     set-target-hotlist
 434 }
 435
 436 proc set-target-hotlist {} {
 437     global hotTargets
 438
 439     set i 1
 440     foreach target $hotTargets {
 441         .top.target.m add command -label "$i $target" -command \
 442                 [list reopen-target $target {}]
 443         incr i
 444         if {$i > 8} {
 445              break
 446         }
 447     }
 448 }
 449
 450 proc reopen-target {target base} {
 451     close-target
 452     open-target $target $base
 453     update-target-hotlist $target
 454 }
 455
 456 proc define-target-action {} {
 457     global profile
 458
 459     set target [.target-define.top.target.entry get]
 460     if {$target == ""} {
 461         return
 462     }
 463     update-target-hotlist $target
 464     foreach n [array names profile] {
 465         if {$n == $target} {
 466             protocol-setup $n
 467             return
 468         }
 469     }
 470     set seq [lindex $profile(Default) 12]
 471     puts "seq=${seq}"
 472     set profile($target) $profile(Default)
 473     set profile(Default) [lreplace $profile(Default) 12 12 [incr seq]]
 474
 475     protocol-setup $target
 476     destroy .target-define
 477 }
 478
 479 proc fail-response {target} {
 480     close-target
 481     tkerror "Target connection closed or protocol error"
 482 }
 483
 484 proc connect-response {target} {
 485     puts "connect-response"
 486     show-target $target
 487     init-request
 488 }
 489
 490 proc open-target {target base} {
 491     global profile
 492     global hostid
 493
 494     z39 disconnect
 495     z39 comstack [lindex $profile($target) 6]
 496     z39 idAuthentication [lindex $profile($target) 3]
 497     z39 maximumRecordSize [lindex $profile($target) 4]
 498     z39 preferredMessageSize [lindex $profile($target) 5]
 499     puts -nonewline "maximumRecordSize="
 500     puts [z39 maximumRecordSize]
 501     puts -nonewline "preferredMessageSize="
 502     puts [z39 preferredMessageSize]
 503     show-status {Connecting} 0 0
 504     if {$base == ""} {
 505         z39 databaseNames [lindex [lindex $profile($target) 7] 0]
 506     } else {
 507         z39 databaseNames $base
 508     }
 509     z39 failback [list fail-response $target]
 510     z39 callback [list connect-response $target]
 511     z39 connect [lindex $profile($target) 1]:[lindex $profile($target) 2]
 512 #    z39 options search present scan namedResultSets triggerResourceCtrl
 513     show-status {Connecting} 1 {}
 514     set hostid $target
 515     .top.target.m disable 0
 516     .top.target.m enable 1
 517     .top.target.m enable 2
 518 }
 519
 520 proc close-target {} {
 521     global hostid
 522     global cancelFlag
 523
 524     set cancelFlag 0
 525     set hostid Default
 526     z39 disconnect
 527     show-target {}
 528     show-status {Not connected} 0 0
 529     show-message {}
 530     .top.target.m disable 1
 531     .top.target.m disable 2
 532     .top.target.m enable 0
 533 }
 534
 535 proc load-set-action {} {
 536     global setNo
 537
 538     incr setNo
 539     ir-set z39.$setNo z39
 540
 541     set fname [.load-set.top.filename.entry get]
 542     destroy .load-set
 543     if {$fname != ""} {
 544         show-status {Loading} 1 {}
 545         z39.$setNo loadFile $fname
 546
 547         set no [z39.$setNo numberOfRecordsReturned]
 548         add-title-lines $setNo $no 1
 549     }
 550     set l [format "%-4d %7d" $setNo $no]
 551     .top.rset.m add command -label $l \
 552             -command [list add-title-lines $setNo 10000 1]
 553     show-status {Ready} 0 {}
 554 }
 555
 556 proc load-set {} {
 557     set w .load-set
 558
 559     set oldFocus [focus]
 560     toplevel $w
 561
 562     place-force $w .
 563
 564     top-down-window $w
 565
 566     frame $w.top.filename
 567
 568     pack $w.top.filename -side top -anchor e -pady 2
 569
 570     entry-fields $w.top {filename} \
 571             {{Filename:}} \
 572             {load-set-action} {destroy .load-set}
 573
 574     top-down-ok-cancel $w {load-set-action} 1
 575     focus $oldFocus
 576 }
 577
 578 proc init-request {} {
 579     global setNo
 580     global cancelFlag
 581
 582     if {$cancelFlag} {
 583         close-target
 584         return
 585     }
 586     z39 callback {init-response}
 587     show-status {Initializing} 1 {}
 588     z39 init
 589 }
 590
 591 proc init-response {} {
 592     global cancelFlag
 593
 594     if {$cancelFlag} {
 595         close-target
 596         return
 597     }
 598     show-status {Ready} 0 1
 599     if {![z39 initResult]} {
 600         set u [z39 userInformationField]
 601         close-target
 602         tkerror "Connection rejected by target: $u"
 603     }
 604 }
 605
 606 proc search-request {} {
 607     global setNo
 608     global profile
 609     global hostid
 610     global busy
 611     global cancelFlag
 612     global searchEnable
 613
 614     set target $hostid
 615
 616     if {$searchEnable == 0} {
 617         return
 618     }
 619     set query [index-query]
 620     if {$query==""} {
 621         return
 622     }
 623     incr setNo
 624     ir-set z39.$setNo z39
 625
 626     if {[lindex $profile($target) 10] == 1} {
 627         z39.$setNo setName $setNo
 628         puts "setName=${setNo}"
 629     } else {
 630         z39.$setNo setName Default
 631         puts "setName=Default"
 632     }
 633     if {[lindex $profile($target) 8] == 1} {
 634         z39.$setNo queryType rpn
 635     }
 636     if {[lindex $profile($target) 9] == 1} {
 637         z39.$setNo queryType ccl
 638     }
 639     z39 callback {search-response}
 640     z39.$setNo search $query
 641     show-status {Search} 1 0
 642 }
 643
 644 proc scan-request {attr} {
 645     set w .scan-window
 646
 647     global profile
 648     global hostid
 649     global scanView
 650     global scanTerm
 651
 652     set target $hostid
 653     set scanView 0
 654     set scanTerm {}
 655
 656     ir-scan z39.scan z39
 657
 658     if {![winfo exists $w]} {
 659         toplevelG $w
 660
 661         wm title $w "Scan"
 662
 663         wm minsize $w 0 0
 664
 665         top-down-window $w
 666
 667         entry $w.top.entry -relief sunken
 668         pack $w.top.entry -fill x -padx 4 -pady 2
 669         bind $w.top.entry <KeyRelease> [list scan-term-h $attr]
 670         if {1} {
 671             listbox $w.top.list -yscrollcommand [list $w.top.scroll set] \
 672                     -font fixed
 673             scrollbar $w.top.scroll -orient vertical -border 1
 674             pack $w.top.list -side left -fill both -expand yes
 675             pack $w.top.scroll -side right -fill y
 676             $w.top.scroll config -command [list $w.top.list yview]
 677         } else {
 678             listbox $w.top.list -font fixed -geometry 60x14
 679             pack $w.top.list -side left -fill both -expand yes
 680         }
 681
 682         bottom-buttons $w [list {Close} [list destroyG $w] \
 683                 {Up} [list scan-up $attr] \
 684                 {Down} [list scan-down $attr]] 0
 685         bind $w.top.list <Up> [list scan-up $attr]
 686         bind $w.top.list <Down> [list scan-down $attr]
 687     }
 688     focus $w.top.entry
 689     z39 callback [list scan-response $attr 0 35]
 690     z39.scan numberOfTermsRequested 5
 691     z39.scan preferredPositionInResponse 1
 692     z39.scan scan "${attr} 0"
 693
 694     show-status {Scan} 1 0
 695 }
 696
 697 proc scan-term-h {attr} {
 698     global busy
 699     global scanTerm
 700
 701     if {$busy} {
 702         return
 703     }
 704     set w .scan-window
 705     set nScanTerm [$w.top.entry get]
 706     if {$nScanTerm == $scanTerm} {
 707         return
 708     }
 709     set scanTerm $nScanTerm
 710     z39 callback [list scan-response $attr 0 35]
 711     z39.scan numberOfTermsRequested 5
 712     z39.scan preferredPositionInResponse 1
 713     puts "${attr} \{${scanTerm}\}"
 714     if {$scanTerm == ""} {
 715         z39.scan scan "${attr} 0"
 716     } else {
 717         z39.scan scan "${attr} \{${scanTerm}\}"
 718     }
 719     show-status {Scan} 1 0
 720 }
 721
 722 proc scan-response {attr start toget} {
 723     global cancelFlag
 724     global scanTerm
 725     global scanView
 726
 727     set w .scan-window
 728     puts "In scan-response"
 729     set m [z39.scan numberOfEntriesReturned]
 730     puts $m
 731     puts attr=$attr
 732     puts start=$start
 733     puts toget=$toget
 734
 735     if {![winfo exists .scan-window]} {
 736         show-status {Ready} 0 1
 737         set cancelFlag 0
 738         return
 739     }
 740     set nScanTerm [$w.top.entry get]
 741     if {$nScanTerm != $scanTerm} {
 742         z39 callback [list scan-response $attr 0 35]
 743         z39.scan numberOfTermsRequested 5
 744         z39.scan preferredPositionInResponse 1
 745         set scanTerm $nScanTerm
 746         puts "${attr} \{${scanTerm}\}"
 747         if {$scanTerm == ""} {
 748             z39.scan scan "${attr} 0"
 749         } else {
 750             z39.scan scan "${attr} \{${scanTerm}\}"
 751         }
 752         show-status {Scan} 1 0
 753         return
 754     }
 755     set status [z39.scan scanStatus]
 756     if {$status == 6} {
 757         tkerror "Scan fail"
 758         show-status {Ready} 0 1
 759         set cancelFlag 0
 760         return
 761     }
 762     if {$toget < 0} {
 763         for {set i 0} {$i < $m} {incr i} {
 764             set term [lindex [z39.scan scanLine $i] 1]
 765             set nostr [format " %-6d" [lindex [z39.scan scanLine $i] 2]]
 766             $w.top.list insert $i "$nostr $term"
 767         }
 768         incr scanView $m
 769         $w.top.list yview $scanView
 770     } else {
 771         $w.top.list delete $start end
 772         for {set i 0} {$i < $m} {incr i} {
 773             set term [lindex [z39.scan scanLine $i] 1]
 774             set nostr [format " %-6d" [lindex [z39.scan scanLine $i] 2]]
 775             $w.top.list insert end "$nostr $term"
 776         }
 777     }
 778     if {$cancelFlag} {
 779         show-status {Ready} 0 1
 780         set cancelFlag 0
 781         return
 782     }
 783     if {$toget > 0 && $m > 1 && $m < $toget} {
 784         set ntoget [expr $toget - $m + 1]
 785         puts ntoget=$ntoget
 786         z39 callback [list scan-response $attr [expr $start + $m - 1] $ntoget]
 787         set q $term
 788         puts "down continue: $q"
 789         if {$ntoget > 10} {
 790             z39.scan numberOfTermsRequested 10
 791         } else {
 792             z39.scan numberOfTermsRequested $ntoget
 793         }
 794         z39.scan preferredPositionInResponse 1
 795         puts "${attr} \{$q\}"
 796         z39.scan scan "${attr} \{$q\}"
 797         return
 798     }
 799     if {$toget < 0 && $m > 1 && $m < [expr - $toget]} {
 800         set ntoget [expr - $toget - $m]
 801         puts ntoget=$ntoget
 802         z39 callback [list scan-response $attr 0 -$ntoget]
 803         set q [string range [$w.top.list get 0] 8 end]
 804         puts "up continue: $q"
 805         if {$ntoget > 10} {
 806             z39.scan numberOfTermsRequested 10
 807             z39.scan preferredPositionInResponse 11
 808         } else {
 809             z39.scan numberOfTermsRequested $ntoget
 810             z39.scan preferredPositionInResponse [incr ntoget]
 811         }
 812         puts "${attr} \{$q\}"
 813         z39.scan scan "${attr} \{$q\}"
 814         return
 815     }
 816     show-status {Ready} 0 1
 817 }
 818
 819 proc scan-down {attr} {
 820     global scanView
 821
 822     set w .scan-window
 823     set scanView [expr $scanView + 5]
 824     set s [$w.top.list size]
 825     if {$scanView > $s} {
 826         z39 callback [list scan-response $attr [expr $s - 1] 25]
 827         set q [string range [$w.top.list get [expr $s - 1]] 8 end]
 828         puts "down: $q"
 829         z39.scan numberOfTermsRequested 10
 830         z39.scan preferredPositionInResponse 1
 831         show-status {Scan} 1 0
 832         puts "${attr} \{$q\}"
 833         z39.scan scan "${attr} \{$q\}"
 834         return
 835     }
 836     $w.top.list yview $scanView
 837 }
 838
 839 proc scan-up {attr} {
 840     global scanView
 841
 842     set w .scan-window
 843     set scanView [expr $scanView - 5]
 844     if {$scanView < 0} {
 845         z39 callback [list scan-response $attr 0 -25]
 846         set q [string range [$w.top.list get 0] 8 end]
 847         puts "up: $q"
 848         z39.scan numberOfTermsRequested 10
 849         z39.scan preferredPositionInResponse 11
 850         show-status {Scan} 1 0
 851         z39.scan scan "${attr} \{$q\}"
 852         return
 853     }
 854     $w.top.list yview $scanView
 855 }
 856
 857 proc search-response {} {
 858     global setNo
 859     global setOffset
 860     global setMax
 861     global cancelFlag
 862     global busy
 863
 864     puts "In search-response"
 865     init-title-lines
 866     show-status {Ready} 0 1
 867     set setMax [z39.$setNo resultCount]
 868     show-message "${setMax} hits"
 869     set l [format "%-4d %7d" $setNo $setMax]
 870     .top.rset.m add command -label $l \
 871             -command [list add-title-lines $setNo 10000 1]
 872     if {$setMax <= 0} {
 873         set status [z39.$setNo responseStatus]
 874         if {[lindex $status 0] == "NSD"} {
 875             set code [lindex $status 1]
 876             set msg [lindex $status 2]
 877             set addinfo [lindex $status 3]
 878             tkerror "NSD$code: $msg: $addinfo"
 879         }
 880         return
 881     }
 882     if {$setMax > 20} {
 883         set setMax 20
 884     }
 885     set setOffset 1
 886     if {$cancelFlag} {
 887         set cancelFlag 0
 888         return
 889     }
 890     z39 callback {present-response}
 891     z39.$setNo present $setOffset 1
 892     show-status {Retrieve} 1 0
 893 }
 894
 895 proc present-more {number} {
 896     global setNo
 897     global setOffset
 898     global setMax
 899
 900     puts "setOffset=$setOffset"
 901     puts "present-more"
 902     if {$setNo == 0} {
 903         puts "setNo=$setNo"
 904         return
 905     }
 906     set max [z39.$setNo resultCount]
 907     if {$max <= $setOffset} {
 908         puts "max=$max"
 909         puts "setOffset=$setOffset"
 910         return
 911     }
 912     if {$number == ""} {
 913         set setMax $max
 914     } else {
 915         incr setMax $number
 916         if {$setMax > $max} {
 917             set setMax $max
 918         }
 919     }
 920     z39 callback {present-response}
 921
 922     set toGet [expr $setMax - $setOffset + 1]
 923     if {$toGet <= 0} {
 924         return
 925     }
 926     if {$toGet > 3} {
 927         set toGet 3
 928     }
 929     z39.$setNo present $setOffset $toGet
 930     show-status {Retrieve} 1 0
 931 }
 932
 933 proc init-title-lines {} {
 934     .data.list delete 0 end
 935 }
 936
 937 proc title-press {y setno} {
 938     show-full-marc $setno [expr 1 + [.data.list nearest $y]] 0
 939 }
 940
 941 proc add-title-lines {setno no offset} {
 942     if {$offset == 1} {
 943         .bot.a.set configure -text $setno
 944         .data.list delete 0 end
 945     }
 946     bind .data.list <Double-Button-1> [list title-press %y $setno]
 947     bind .data.list <Button-2> [list title-press %y $setno]
 948     for {set i 0} {$i < $no} {incr i} {
 949         set o [expr $i + $offset]
 950         set type [z39.$setno type $o]
 951         if {$type == "DB"} {
 952             set title [lindex [z39.$setno getMarc $o field 245 * a] 0]
 953             set year  [lindex [z39.$setno getMarc $o field 260 * c] 0]
 954             set nostr [format "%5d" $o]
 955             .data.list insert end "$nostr $title - $year"
 956         } elseif {$type == "SD"} {
 957             set err [lindex [z39.$setno diag $o] 1]
 958             set add [lindex [z39.$setno diag $o] 2]
 959             if {$add != {}} {
 960                 set add " :${add}"
 961             }
 962             .data.list insert end "Error ${err}${add}"
 963         } elseif {$type == ""} {
 964             break
 965         }
 966     }
 967 }
 968
 969 proc present-response {} {
 970     global setNo
 971     global setOffset
 972     global setMax
 973     global cancelFlag
 974
 975     puts "In present-response"
 976     set no [z39.$setNo numberOfRecordsReturned]
 977     puts "Returned $no records, setOffset $setOffset"
 978     add-title-lines $setNo $no $setOffset
 979     set setOffset [expr $setOffset + $no]
 980     set status [z39.$setNo responseStatus]
 981     if {[lindex $status 0] == "NSD"} {
 982         show-status {Ready} 0 1
 983         set code [lindex $status 1]
 984         set msg [lindex $status 2]
 985         set addinfo [lindex $status 3]
 986         tkerror "NSD$code: $msg: $addinfo"
 987         return
 988     }
 989     if {$cancelFlag} {
 990         show-status {Ready} 0 1
 991         set cancelFlag 0
 992         return
 993     }
 994     if {$no > 0 && $setOffset <= $setMax} {
 995         puts "present from ${setOffset}"
 996         set toGet [expr $setMax - $setOffset + 1]
 997         if {$toGet > 3} {
 998             set toGet 3
 999         }
1000         z39.$setNo present $setOffset $toGet
1001     } else {
1002         show-status {Finished} 0 1
1003     }
1004 }
1005
1006 proc left-cursor {w} {
1007     set i [$w index insert]
1008     if {$i > 0} {
1009         incr i -1
1010         $w icursor $i
1011     }
1012 }
1013
1014 proc right-cursor {w} {
1015     set i [$w index insert]
1016     incr i
1017     $w icursor $i
1018 }
1019
1020 proc bind-fields {list returnAction escapeAction} {
1021     set max [expr [llength $list]-1]
1022     for {set i 0} {$i < $max} {incr i} {
1023         bind [lindex $list $i] <Return> $returnAction
1024         bind [lindex $list $i] <Escape> $escapeAction
1025         bind [lindex $list $i] <Tab> [list focus [lindex $list [expr $i+1]]]
1026         bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
1027         bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
1028     }
1029     bind [lindex $list $i] <Return> $returnAction
1030     bind [lindex $list $i] <Escape> $escapeAction
1031     bind [lindex $list $i] <Tab>    [list focus [lindex $list 0]]
1032     bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
1033     bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
1034     focus [lindex $list 0]
1035 }
1036
1037 proc entry-fields {parent list tlist returnAction escapeAction} {
1038     set alist {}
1039     set i 0
1040     foreach field $list {
1041         set label ${parent}.${field}.label
1042         set entry ${parent}.${field}.entry
1043         label $label -text [lindex $tlist $i] -anchor e
1044         entry $entry -width 32 -relief sunken
1045         pack $label -side left
1046         pack $entry -side right
1047         lappend alist $entry
1048         incr i
1049     }
1050     bind-fields $alist $returnAction $escapeAction
1051 }
1052
1053 proc define-target-dialog {} {
1054     set w .target-define
1055
1056     toplevel $w
1057     place-force $w .
1058     top-down-window $w
1059     frame $w.top.target
1060     pack $w.top.target \
1061             -side top -anchor e -pady 2
1062     entry-fields $w.top {target} \
1063             {{Target:}} \
1064             {define-target-action} {destroy .target-define}
1065     top-down-ok-cancel $w {define-target-action} 1
1066 }
1067
1068 proc protocol-setup-action {target} {
1069     global profile
1070     global csRadioType
1071     global protocolRadioType
1072     global settingsChanged
1073     global RPNCheck
1074     global CCLCheck
1075     global ResultSetCheck
1076
1077     set wno [lindex $profile($target) 12]
1078     set w .setup-${wno}
1079
1080     set b {}
1081     set settingsChanged 1
1082     set len [$w.top.databases.list size]
1083     for {set i 0} {$i < $len} {incr i} {
1084         lappend b [$w.top.databases.list get $i]
1085     }
1086     set profile($target) [list [$w.top.description.entry get] \
1087             [$w.top.host.entry get] \
1088             [$w.top.port.entry get] \
1089             [$w.top.idAuthentication.entry get] \
1090             [$w.top.maximumRecordSize.entry get] \
1091             [$w.top.preferredMessageSize.entry get] \
1092             $csRadioType \
1093             $b \
1094             $RPNCheck \
1095             $CCLCheck \
1096             $ResultSetCheck \
1097             $protocolRadioType \
1098             $wno]
1099
1100     cascade-target-list
1101     puts $profile($target)
1102     destroyG $w
1103 }
1104
1105 proc place-force {window parent} {
1106     set g [wm geometry $parent]
1107
1108     set p1 [string first + $g]
1109     set p2 [string last + $g]
1110
1111     set x [expr 40+[string range $g [expr $p1 +1] [expr $p2 -1]]]
1112     set y [expr 60+[string range $g [expr $p2 +1] end]]
1113     wm geometry $window +${x}+${y}
1114 }
1115
1116 proc add-database-action {target} {
1117     global profile
1118
1119     set wno [lindex $profile($target) 12]
1120     set w .setup-${wno}
1121
1122     $w.top.databases.list insert end \
1123             [.database-select.top.database.entry get]
1124     destroy .database-select
1125 }
1126
1127 proc add-database {target} {
1128     global profile
1129
1130     set w .database-select
1131
1132     set oldFocus [focus]
1133     toplevel $w
1134
1135     set wno [lindex $profile($target) 12]
1136     place-force $w .setup-${wno}
1137
1138     top-down-window $w
1139
1140     frame $w.top.database
1141
1142     pack $w.top.database -side top -anchor e -pady 2
1143
1144     entry-fields $w.top {database} \
1145             {{Database to add:}} \
1146             [list add-database-action $target] {destroy .database-select}
1147
1148     top-down-ok-cancel $w [list add-database-action $target] 1
1149     focus $oldFocus
1150 }
1151
1152 proc delete-database {target} {
1153     global profile
1154
1155     set wno [lindex $profile($target) 12]
1156     set w .setup-${wno}
1157
1158     foreach i [lsort -decreasing \
1159             [$w.top.databases.list curselection]] {
1160         $w.top.databases.list delete $i
1161     }
1162 }
1163
1164 proc protocol-setup {target} {
1165     global profile
1166     global csRadioType
1167     global protocolRadioType
1168     global RPNCheck
1169     global CCLCheck
1170     global ResultSetCheck
1171
1172     set wno [lindex $profile($target) 12]
1173     set w .setup-${wno}
1174
1175     toplevelG $w
1176
1177     wm title $w "Setup $target"
1178
1179     top-down-window $w
1180
1181     if {$target == ""} {
1182         set target Default
1183     }
1184     puts target
1185     puts $profile($target)
1186
1187     frame $w.top.host
1188     frame $w.top.port
1189     frame $w.top.description
1190     frame $w.top.idAuthentication
1191     frame $w.top.maximumRecordSize
1192     frame $w.top.preferredMessageSize
1193     frame $w.top.cs-type -relief ridge -border 2
1194     frame $w.top.protocol -relief ridge -border 2
1195     frame $w.top.query -relief ridge -border 2
1196     frame $w.top.databases -relief ridge -border 2
1197
1198     # Maximum/preferred/idAuth ...
1199     pack $w.top.description $w.top.host $w.top.port \
1200             $w.top.idAuthentication $w.top.maximumRecordSize \
1201             $w.top.preferredMessageSize -side top -anchor e -pady 2
1202
1203     entry-fields $w.top {description host port idAuthentication \
1204             maximumRecordSize preferredMessageSize} \
1205             {{Description:} {Host:} {Port:} {Id Authentication:} \
1206             {Maximum Record Size:} {Preferred Message Size:}} \
1207             [list protocol-setup-action $target] [list destroyG $w]
1208
1209     foreach sub {description host port idAuthentication \
1210             maximumRecordSize preferredMessageSize} {
1211         puts $sub
1212         bind $w.top.$sub.entry <Control-a> [list add-database $target]
1213         bind $w.top.$sub.entry <Control-d> [list delete-database $target]
1214     }
1215     $w.top.description.entry insert 0 [lindex $profile($target) 0]
1216     $w.top.host.entry insert 0 [lindex $profile($target) 1]
1217     $w.top.port.entry insert 0 [lindex $profile($target) 2]
1218     $w.top.idAuthentication.entry insert 0 [lindex $profile($target) 3]
1219     $w.top.maximumRecordSize.entry insert 0 [lindex $profile($target) 4]
1220     $w.top.preferredMessageSize.entry insert 0 [lindex $profile($target) 5]
1221     set csRadioType [lindex $profile($target) 6]
1222     set RPNCheck [lindex $profile($target) 8]
1223     set CCLCheck [lindex $profile($target) 9]
1224     set ResultSetCheck [lindex $profile($target) 10]
1225     set protocolRadioType [lindex $profile($target) 11]
1226     if {$protocolRadioType == ""} {
1227         set protocolRadioType z39v2
1228     }
1229
1230     # Databases ....
1231     pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill both
1232
1233     label $w.top.databases.label -text "Databases"
1234     button $w.top.databases.add -text "Add" \
1235             -command [list add-database $target]
1236     button $w.top.databases.delete -text "Delete" \
1237             -command [list delete-database $target]
1238     listbox $w.top.databases.list -geometry 20x6 \
1239             -yscrollcommand "$w.top.databases.scroll set"
1240     scrollbar $w.top.databases.scroll -orient vertical -border 1
1241     pack $w.top.databases.label -side top -fill x \
1242             -padx 2 -pady 2
1243     pack $w.top.databases.add $w.top.databases.delete -side top -fill x \
1244             -padx 2 -pady 2
1245     pack $w.top.databases.list -side left -fill both -expand yes \
1246             -padx 2 -pady 2
1247     pack $w.top.databases.scroll -side right -fill y \
1248             -padx 2 -pady 2
1249     $w.top.databases.scroll config -command "$w.top.databases.list yview"
1250
1251     foreach b [lindex $profile($target) 7] {
1252         $w.top.databases.list insert end $b
1253     }
1254
1255     # Transport ...
1256     pack $w.top.cs-type -pady 6 -padx 6 -side top -fill x
1257
1258     label $w.top.cs-type.label -text "Transport"
1259     radiobutton $w.top.cs-type.tcpip -text "TCP/IP" -anchor w \
1260             -command {puts tcp/ip} -variable csRadioType -value tcpip
1261     radiobutton $w.top.cs-type.mosi -text "MOSI" -anchor w\
1262             -command {puts mosi} -variable csRadioType -value mosi
1263
1264     pack $w.top.cs-type.label $w.top.cs-type.tcpip $w.top.cs-type.mosi \
1265             -padx 4 -side top -fill x
1266
1267     # Protocol ...
1268     pack $w.top.protocol -pady 6 -padx 6 -side top -fill x
1269
1270     label $w.top.protocol.label -text "Protocol"
1271     radiobutton $w.top.protocol.z39v2 -text "Z39.50" -anchor w \
1272             -command {puts z39v2} -variable protocolRadioType -value z39v2
1273     radiobutton $w.top.protocol.sr -text "SR" -anchor w \
1274             -command {puts sr} -variable protocolRadioType -value sr
1275
1276     pack $w.top.protocol.label $w.top.protocol.z39v2 $w.top.protocol.sr \
1277             -padx 4 -side top -fill x
1278
1279     # Query ...
1280     pack $w.top.query -pady 6 -padx 6 -side top -fill x
1281
1282     label $w.top.query.label -text "Query support"
1283     checkbutton $w.top.query.c1 -text "RPN query" -anchor w -variable RPNCheck
1284     checkbutton $w.top.query.c2 -text "CCL query" -anchor w -variable CCLCheck
1285     checkbutton $w.top.query.c3 -text "Result sets" -anchor w -variable ResultSetCheck
1286
1287     pack $w.top.query.label -side top
1288     pack $w.top.query.c1 $w.top.query.c2 $w.top.query.c3 \
1289             -padx 4 -side top -fill x
1290
1291     # Ok-cancel
1292     bottom-buttons $w [list {Ok} [list protocol-setup-action $target] \
1293             {Cancel} [list destroyG $w]] 0
1294 #    top-down-ok-cancel $w [list protocol-setup-action $target] 0
1295 }
1296
1297 proc database-select-action {} {
1298     set w .database-select.top
1299     set b {}
1300     foreach indx [$w.databases.list curselection] {
1301         lappend b [$w.databases.list get $indx]
1302     }
1303     if {$b != ""} {
1304         z39 databaseNames $b
1305     }
1306     destroy .database-select
1307 }
1308
1309 proc database-select {} {
1310     set w .database-select
1311     global profile
1312     global hostid
1313
1314     toplevel $w
1315
1316     place-force $w .
1317
1318     top-down-window $w
1319
1320     frame $w.top.databases -relief ridge -border 2
1321
1322     pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill x
1323
1324     label $w.top.databases.label -text "List"
1325     listbox $w.top.databases.list -geometry 20x6 \
1326             -yscrollcommand "$w.top.databases.scroll set"
1327     scrollbar $w.top.databases.scroll -orient vertical -border 1
1328     pack $w.top.databases.label -side top -fill x \
1329             -padx 2 -pady 2
1330     pack $w.top.databases.list -side left -fill both -expand yes \
1331             -padx 2 -pady 2
1332     pack $w.top.databases.scroll -side right -fill y \
1333             -padx 2 -pady 2
1334     $w.top.databases.scroll config -command "$w.top.databases.list yview"
1335
1336     foreach b [lindex $profile($hostid) 7] {
1337         $w.top.databases.list insert end $b
1338     }
1339     top-down-ok-cancel $w {database-select-action} 1
1340 }
1341
1342 proc cascade-target-list {} {
1343     global profile
1344
1345     foreach sub [winfo children .top.target.m.clist] {
1346         puts "deleting $sub"
1347         destroy $sub
1348     }
1349     .top.target.m.clist delete 0 last
1350     foreach n [array names profile] {
1351         if {$n != "Default"} {
1352             set nl [string tolower $n]
1353             if {[llength [lindex $profile($n) 7]] > 1} {
1354                 .top.target.m.clist add cascade -label $n \
1355                         -menu .top.target.m.clist.$nl
1356                 menu .top.target.m.clist.$nl
1357                 foreach b [lindex $profile($n) 7] {
1358                     .top.target.m.clist.$nl add command -label $b \
1359                             -command [list reopen-target $n $b]
1360                 }
1361             } else {
1362                 .top.target.m.clist add command -label $n \
1363                         -command [list reopen-target $n {}]
1364             }
1365         }
1366     }
1367     .top.target.m.slist delete 0 last
1368     foreach n [array names profile] {
1369         if {$n != "Default"} {
1370             .top.target.m.slist add command -label $n \
1371                     -command [list protocol-setup $n]
1372         }
1373     }
1374 }
1375
1376 proc cascade-query-list {} {
1377     global queryTypes
1378
1379     set i 0
1380     .top.options.m.slist delete 0 last
1381     foreach n $queryTypes {
1382         .top.options.m.slist add command -label $n \
1383                 -command [list query-setup $i]
1384         incr i
1385     }
1386
1387     set i 0
1388     .top.options.m.clist delete 0 last
1389     foreach n $queryTypes {
1390         .top.options.m.clist add command -label $n \
1391                 -command [list query-select $i]
1392         incr i
1393     }
1394 }
1395
1396 proc save-geometry {} {
1397     global windowGeometry
1398
1399     set windowGeometry(.) [wm geometry .]
1400
1401     set f [open "clientg.tcl" w]
1402
1403     foreach n [array names windowGeometry] {
1404         puts -nonewline $f "set \{windowGeometry($n)\} \{"
1405         puts -nonewline $f $windowGeometry($n)
1406         puts $f "\}"
1407     }
1408     close $f
1409 }
1410
1411 proc save-settings {} {
1412     global hotTargets
1413     global profile
1414     global settingsChanged
1415     global queryTypes
1416     global queryButtons
1417     global queryInfo
1418
1419     set f [open "clientrc.tcl" w]
1420     puts $f "# Setup file"
1421     puts $f "set hotTargets \{ $hotTargets \}"
1422
1423     foreach n [array names profile] {
1424         puts -nonewline $f "set \{profile($n)\} \{"
1425         puts -nonewline $f $profile($n)
1426         puts $f "\}"
1427     }
1428     puts -nonewline $f "set queryTypes \{"
1429     puts -nonewline $f $queryTypes
1430     puts $f "\}"
1431
1432     puts -nonewline $f "set queryButtons \{"
1433     puts -nonewline $f $queryButtons
1434     puts $f "\}"
1435
1436     puts -nonewline $f "set queryInfo \{"
1437     puts -nonewline $f $queryInfo
1438     puts $f "\}"
1439     close $f
1440     set settingsChanged 0
1441 }
1442
1443 proc alert {ask} {
1444     set w .alert
1445
1446     global alertAnswer
1447
1448     toplevel $w
1449     place-force $w .
1450     top-down-window $w
1451
1452     message $w.top.message -text $ask
1453
1454     pack $w.top.message -side left -pady 6 -padx 20 -expand yes -fill x
1455
1456     set alertAnswer 0
1457     top-down-ok-cancel $w {alert-action} 1
1458     return $alertAnswer
1459 }
1460
1461 proc alert-action {} {
1462     global alertAnswer
1463     set alertAnswer 1
1464     destroy .alert
1465 }
1466
1467 proc exit-action {} {
1468     global settingsChanged
1469
1470     save-geometry
1471     if {$settingsChanged} {
1472         set a [alert "you havent saved your settings. Do you wish to save?"]
1473         if {$a} {
1474             save-settings
1475         }
1476     }
1477     exit 0
1478 }
1479
1480 proc listbuttonaction {w name h user i} {
1481     $w configure -text [lindex $name 0]
1482     $h [lindex $name 1] $user $i
1483 }
1484
1485 proc listbuttonx {button no names handle user} {
1486     if {[winfo exists $button]} {
1487         $button configure -text [lindex [lindex $names $no] 0]
1488         ${button}.m delete 0 last
1489     } else {
1490         menubutton $button -text [lindex [lindex $names $no] 0] \
1491                 -width 10 -menu ${button}.m -relief raised -border 1
1492         menu ${button}.m
1493     }
1494     set i 0
1495     foreach name $names {
1496         ${button}.m add command -label [lindex $name 0] \
1497                 -command [list listbuttonaction ${button} $name \
1498                 $handle $user $i]
1499         incr i
1500     }
1501 }
1502
1503 proc listbutton {button no names} {
1504     menubutton $button -text [lindex $names $no] -width 10 -menu ${button}.m \
1505             -relief raised -border 1
1506     menu ${button}.m
1507     foreach name $names {
1508         ${button}.m add command -label $name \
1509                 -command [list ${button} configure -text $name]
1510     }
1511 }
1512
1513 proc query-add-index-action {queryNo} {
1514     set w .setup-query-$queryNo
1515
1516     global queryInfoTmp
1517     global queryButtonsTmp
1518
1519     lappend queryInfoTmp [list [.query-add-index.top.index.entry get] {}]
1520
1521     destroy .query-add-index
1522     #destroy $w.top.lines
1523     #frame $w.top.lines -relief ridge -border 2
1524     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1525     #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1526 }
1527
1528 proc query-add-line {queryNo} {
1529     set w .setup-query-$queryNo
1530
1531     global queryInfoTmp
1532     global queryButtonsTmp
1533
1534     lappend queryButtonsTmp {I 0}
1535
1536     #destroy $w.top.lines
1537     #frame $w.top.lines -relief ridge -border 2
1538     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1539     #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1540 }
1541
1542 proc query-del-line {queryNo} {
1543     set w .setup-query-$queryNo
1544
1545     global queryInfoTmp
1546     global queryButtonsTmp
1547
1548     set l [llength $queryButtonsTmp]
1549     if {$l <= 0} {
1550         return
1551     }
1552     incr l -1
1553     set queryButtonsTmp [lreplace $queryButtonsTmp $l $l]
1554     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1555 }
1556
1557 proc query-add-index {queryNo} {
1558     set w .query-add-index
1559
1560     toplevel $w
1561     place-force $w .setup-query-$queryNo
1562     top-down-window $w
1563     frame $w.top.index
1564     pack $w.top.index \
1565             -side top -anchor e -pady 2
1566     entry-fields $w.top {index} \
1567             {{Index Name:}} \
1568             [list query-add-index-action $queryNo] {destroy .query-add-index}
1569     top-down-ok-cancel $w [list query-add-index-action $queryNo] 1
1570 }
1571
1572 proc query-setup-action {queryNo} {
1573     global queryButtons
1574     global queryInfo
1575     global queryButtonsTmp
1576     global queryInfoTmp
1577     global queryButtonsFind
1578     global queryInfoFind
1579
1580     set queryInfo [lreplace $queryInfo $queryNo $queryNo \
1581             $queryInfoTmp]
1582     set queryButtons [lreplace $queryButtons $queryNo $queryNo \
1583             $queryButtonsTmp]
1584     set queryInfoFind $queryInfoTmp
1585     set queryButtonsFind $queryButtonsTmp
1586
1587     puts $queryInfo
1588     puts $queryButtons
1589     destroy .setup-query-$queryNo
1590
1591     index-lines .lines 1 $queryButtonsFind $queryInfoFind activate-index
1592 }
1593
1594 proc activate-e-index {value no i} {
1595     global queryButtonsTmp
1596
1597     puts $queryButtonsTmp
1598     set queryButtonsTmp [lreplace $queryButtonsTmp $no $no [list I $i]]
1599     puts $queryButtonsTmp
1600     puts "value $value"
1601     puts "no $no"
1602     puts "i $i"
1603 }
1604
1605 proc activate-index {value no i} {
1606     global queryButtonsFind
1607
1608     set queryButtonsFind [lreplace $queryButtonsFind $no $no [list I $i]]
1609
1610     puts "queryButtonsFind $queryButtonsFind"
1611     puts "value $value"
1612     puts "no $no"
1613     puts "i $i"
1614 }
1615
1616 proc query-setup {queryNo} {
1617     set w .setup-query-$queryNo
1618     global queryTypes
1619     set queryTypes {Simple}
1620     global queryButtons
1621     global queryInfo
1622     global queryButtonsTmp
1623     global queryInfoTmp
1624
1625     set queryName [lindex $queryTypes $queryNo]
1626     set queryInfoTmp [lindex $queryInfo $queryNo]
1627     set queryButtonsTmp [lindex $queryButtons $queryNo]
1628
1629     #set queryButtons { {I 0 I 1 I 2} }
1630     #set queryInfo { { {Title ti} {Author au} {Subject sh} } }
1631
1632     toplevel $w
1633
1634     wm title $w "Query setup $queryName"
1635     place-force $w .
1636
1637     top-down-window $w
1638
1639     frame $w.top.lines -relief ridge -border 2
1640     frame $w.top.use -relief ridge -border 2
1641     frame $w.top.relation -relief ridge -border 2
1642     frame $w.top.position -relief ridge -border 2
1643     frame $w.top.structure -relief ridge -border 2
1644     frame $w.top.truncation -relief ridge -border 2
1645     frame $w.top.completeness -relief ridge -border 2
1646
1647     # Index Lines
1648
1649     index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1650
1651     pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1652
1653     # Use Attributes
1654     pack $w.top.use -side left -pady 6 -padx 6 -fill y
1655
1656     label $w.top.use.label -text "Use"
1657     listbox $w.top.use.list -geometry 20x10 \
1658             -yscrollcommand "$w.top.use.scroll set"
1659     scrollbar $w.top.use.scroll -orient vertical -border 1
1660     pack $w.top.use.label -side top -fill x \
1661             -padx 2 -pady 2
1662     pack $w.top.use.list -side left -fill both -expand yes \
1663             -padx 2 -pady 2
1664     pack $w.top.use.scroll -side right -fill y \
1665             -padx 2 -pady 2
1666     $w.top.use.scroll config -command "$w.top.use.list yview"
1667
1668     foreach u {{Personal name} {Corporate name}} {
1669         $w.top.use.list insert end $u
1670     }
1671     # Relation Attributes
1672     pack $w.top.relation -pady 6 -padx 6 -side top
1673
1674     label $w.top.relation.label -text "Relation" -width 18
1675
1676     listbutton $w.top.relation.b 0\
1677             {{None} {Less than} {Greater than or equal} \
1678             {Equal} {Greater than or equal} {Greater than} {Not equal} \
1679             {Phonetic} \
1680             {Stem} {Relevance} {AlwaysMatches}}
1681
1682     pack $w.top.relation.label $w.top.relation.b -fill x
1683
1684     # Position Attributes
1685     pack $w.top.position -pady 6 -padx 6 -side top
1686
1687     label $w.top.position.label -text "Position" -width 18
1688
1689     listbutton $w.top.position.b 0 {{None} {First in field} {First in subfield}
1690     {Any position in field}}
1691
1692     pack $w.top.position.label $w.top.position.b -fill x
1693
1694     # Structure Attributes
1695
1696     pack $w.top.structure -pady 6 -padx 6 -side top
1697
1698     label $w.top.structure.label -text "Structure" -width 18
1699
1700     listbutton $w.top.structure.b 0 {{None} {Phrase} {Word} {Key} {Year}
1701     {Date (norm)} {Word list} {Date (un-norm)} {Name (norm)} {Date (un-norm)}
1702     {Structure} {urx} {free-form} {doc-text} {local-number} {string}
1703     {numeric string}}
1704
1705     pack $w.top.structure.label $w.top.structure.b -fill x
1706
1707     # Truncation Attributes
1708
1709     pack $w.top.truncation -pady 6 -padx 6 -side top
1710
1711     label $w.top.truncation.label -text "Truncation" -width 18
1712
1713     listbutton $w.top.truncation.b 0 {{Auto} {Right} {Left} {Left and right} \
1714             {No truncation} {Process #} {Re-1} {Re-2}}
1715     pack $w.top.truncation.label $w.top.truncation.b -fill x
1716
1717     # Completeness Attributes
1718
1719     pack $w.top.completeness -pady 6 -padx 6 -side top
1720
1721     label $w.top.completeness.label -text "Truncation" -width 18
1722
1723     listbutton $w.top.completeness.b 0 {{None} {Incomplete subfield} \
1724             {Complete subfield} {Complete field}}
1725     pack $w.top.completeness.label $w.top.completeness.b -fill x
1726
1727     # Ok-cancel
1728     bottom-buttons $w [list \
1729             {Ok} [list query-setup-action $queryNo] \
1730             {Add index} [list query-add-index $queryNo] \
1731             {Add line} [list query-add-line $queryNo] \
1732             {Delete line} [list query-del-line $queryNo] \
1733             {Cancel} [list destroy $w]] 0
1734 }
1735
1736 proc index-clear {} {
1737     global queryButtonsFind
1738
1739     set i 0
1740     foreach b $queryButtonsFind {
1741         .lines.$i.e delete 0 end
1742         incr i
1743     }
1744 }
1745
1746 proc index-query {} {
1747     global queryButtonsFind
1748     global queryInfoFind
1749
1750     set i 0
1751     set qs {}
1752
1753     foreach b $queryButtonsFind {
1754         set term [string trim [.lines.$i.e get]]
1755         if {$term != ""} {
1756             set attr [lindex [lindex $queryInfoFind [lindex $b 1]] 1]
1757
1758             set term "\{${term}\}"
1759             foreach a $attr {
1760                 set term "@attr $a ${term}"
1761             }
1762             if {$qs != ""} {
1763                 set qs "@and ${qs} ${term}"
1764             } else {
1765                 set qs $term
1766             }
1767         }
1768         incr i
1769     }
1770     puts "qs=  $qs"
1771     return $qs
1772 }
1773
1774 proc index-lines {w realOp buttonInfo queryInfo handle} {
1775     set i 0
1776     foreach b $buttonInfo {
1777         if {! [winfo exists $w.$i]} {
1778             frame $w.$i -background white -border 1
1779         }
1780         listbuttonx $w.$i.l [lindex $b 1] $queryInfo $handle $i
1781
1782         if {$realOp} {
1783             if {! [winfo exists $w.$i.e]} {
1784                 entry $w.$i.e -width 32 -relief sunken -border 1
1785                 bind $w.$i.e <FocusIn> [list $w.$i configure \
1786                         -background red]
1787                 bind $w.$i.e <FocusOut> [list $w.$i configure \
1788                         -background white]
1789                 pack $w.$i.l -side left
1790                 pack $w.$i.e -side left -fill x -expand yes
1791                 pack $w.$i -side top -fill x -padx 2 -pady 2
1792                 bind $w.$i.e <Left> [list left-cursor $w.$i.e]
1793                 bind $w.$i.e <Right> [list right-cursor $w.$i.e]
1794                 bind $w.$i.e <Return> search-request
1795             }
1796         } else {
1797             pack $w.$i.l -side left
1798             pack $w.$i -side top -fill x -padx 2 -pady 2
1799         }
1800         incr i
1801     }
1802     set j $i
1803     while {[winfo exists $w.$j]} {
1804         destroy $w.$j
1805         incr j
1806     }
1807     if {! $realOp} {
1808         return
1809     }
1810     set j 0
1811     incr i -1
1812     while {$j < $i} {
1813         set k [expr $j+1]
1814         bind $w.$j.e <Tab> "focus $w.$k.e"
1815         set j $k
1816     }
1817     if {$i >= 0} {
1818         bind $w.$i.e <Tab> "focus $w.0.e"
1819         focus $w.0.e
1820     }
1821 }
1822
1823 proc search-fields {w buttondefs} {
1824     set i 0
1825     foreach buttondef $buttondefs {
1826         frame $w.$i -background white
1827
1828         listbutton $w.$i.l 0 $buttondef
1829         entry $w.$i.e -width 32 -relief sunken
1830
1831         pack $w.$i.l -side left
1832         pack $w.$i.e -side left -fill x -expand yes
1833
1834         pack $w.$i -side top -fill x -padx 2 -pady 2
1835
1836         bind $w.$i.e <Left> [list left-cursor $w.$i.e]
1837         bind $w.$i.e <Right> [list right-cursor $w.$i.e]
1838
1839         incr i
1840     }
1841     set j 0
1842     incr i -1
1843     while {$j < $i} {
1844         set k [expr $j+1]
1845         bind $w.$j.e <Tab> "focus $w.$k.e \n
1846         $w.$k configure -background red \n
1847         $w.$j configure -background white"
1848         set j $k
1849     }
1850     bind $w.$i.e <Tab> "focus $w.0.e \n
1851         $w.0 configure -background red \n
1852         $w.$i configure -background white"
1853     focus $w.0.e
1854     $w.0 configure -background red
1855 }
1856
1857 if {[info exists windowGeometry(.)]} {
1858     set g $windowGeometry(.)
1859     if {$g != ""} {
1860         wm geometry . $g
1861     }
1862 }
1863
1864 read-formats
1865
1866 frame .top  -border 1 -relief raised
1867 frame .lines  -border 1 -relief raised
1868 frame .mid  -border 1 -relief raised
1869 frame .data -border 1 -relief raised
1870 frame .bot  -border 1 -relief raised
1871 pack .top .lines .mid -side top -fill x
1872 pack .data -side top -fill both -expand yes
1873 pack .bot -fill x
1874
1875 menubutton .top.file -text "File" -underline 0 -menu .top.file.m
1876 menu .top.file.m
1877 .top.file.m add command -label "Save settings" -command {save-settings}
1878 .top.file.m add separator
1879 .top.file.m add command -label "Exit" -command {exit-action}
1880 .top.file.m add separator
1881 .top.file.m add command -label "About" -command {about-origin}
1882
1883 menubutton .top.target -text "Target" -underline 0 -menu .top.target.m
1884 menu .top.target.m
1885 .top.target.m add cascade -label "Connect" -menu .top.target.m.clist
1886 .top.target.m add command -label "Disconnect" -command {close-target}
1887 .top.target.m add command -label "About" -command {about-target}
1888 .top.target.m add cascade -label "Setup" -menu .top.target.m.slist
1889 .top.target.m add command -label "Setup new" -command {define-target-dialog}
1890 .top.target.m add separator
1891 set-target-hotlist
1892
1893 .top.target.m disable 1
1894 .top.target.m disable 2
1895
1896 menu .top.target.m.clist
1897 menu .top.target.m.slist
1898 cascade-target-list
1899
1900 menubutton .top.service -text "Service" -underline 0 -menu .top.service.m
1901 menu .top.service.m
1902 .top.service.m add command -label "Database" -command {database-select}
1903 .top.service.m add cascade -label "Query type" -menu .top.service.m.querytype
1904 menu .top.service.m.querytype
1905 .top.service.m.querytype add radiobutton -label "RPN"
1906 .top.service.m.querytype add radiobutton -label "CCL"
1907 .top.service.m add cascade -label "Present" -menu .top.service.m.present
1908 menu .top.service.m.present
1909 .top.service.m.present add command -label "More" \
1910         -command [list present-more 10]
1911 .top.service.m.present add command -label "All" \
1912         -command [list present-more {}]
1913 .top.service configure -state disabled
1914
1915 menubutton .top.rset -text "Set" -menu .top.rset.m
1916 menu .top.rset.m
1917 .top.rset.m add command -label "Load" -command {load-set}
1918 .top.rset.m add separator
1919
1920 menubutton .top.options -text "Options" -underline 0 -menu .top.options.m
1921 menu .top.options.m
1922 .top.options.m add cascade -label "Choose query" -menu .top.options.m.clist
1923 .top.options.m add command -label "Define query" -command {new-query-dialog}
1924 .top.options.m add cascade -label "Edit query" -menu .top.options.m.slist
1925 menu .top.options.m.clist
1926 menu .top.options.m.slist
1927 cascade-query-list
1928
1929 menubutton .top.help -text "Help" -menu .top.help.m
1930 menu .top.help.m
1931
1932 .top.help.m add command -label "Help on help" \
1933         -command {tkerror "Help on help not available. Sorry"}
1934 .top.help.m add command -label "About" \
1935         -command {tkerror "About not available. Sorry"}
1936
1937 pack .top.file .top.target .top.service .top.rset .top.options -side left
1938 pack .top.help -side right
1939
1940 index-lines .lines 1 $queryButtonsFind [lindex $queryInfo 0] activate-index
1941
1942 button .mid.search -width 7 -text {Search} -command search-request \
1943         -state disabled
1944 button .mid.scan -width 7 -text {Scan} \
1945         -command [list scan-request "@attr 1=4 @attr 5=1 @attr 4=1"] -state disabled
1946 button .mid.present -width 7 -text {Present} -command [list present-more 10] \
1947         -state disabled
1948
1949 button .mid.clear -width 7 -text {Clear} -command index-clear
1950 pack .mid.search .mid.scan .mid.present .mid.clear -side left \
1951         -fill y -padx 5 -pady 3
1952
1953 listbox .data.list -yscrollcommand {.data.scroll set} -font fixed -geometry 20x2
1954 scrollbar .data.scroll -orient vertical -border 1
1955 pack .data.list -side left -fill both -expand yes
1956 pack .data.scroll -side right -fill y
1957 .data.scroll config -command {.data.list yview}
1958
1959 button .bot.logo  -bitmap @book1 -command cancel-operation
1960 frame .bot.a
1961 pack .bot.a -side left -fill x
1962 pack .bot.logo -side right -padx 2 -pady 2
1963
1964 message .bot.a.target -text "" -aspect 1000 -border 1
1965
1966 label .bot.a.status -text "Not connected" -width 15 -relief \
1967         sunken -anchor w -border 1
1968 label .bot.a.set -text "" -width 5 -relief \
1969         sunken -anchor w -border 1
1970 label .bot.a.message -text "" -width 15 -relief \
1971         sunken -anchor w -border 1
1972
1973 pack .bot.a.target -side top -anchor nw -padx 2 -pady 2
1974 pack .bot.a.status .bot.a.set .bot.a.message \
1975         -side left -padx 2 -pady 2
1976
1977 ir z39
1978
1979 show-logo 1
1980