client.tcl

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