1 # IR toolkit for tcl/tk
3 # See the file LICENSE for details.
4 # Sebastian Hammer, Adam Dickmeiss
7 # Revision 1.39 1995-06-14 12:16:22 adam
8 # hotTargets, textWrap and displayFormat saved in clientg.tcl.
10 # Revision 1.38 1995/06/14 07:22:45 adam
11 # Target definitions can be deleted.
12 # Listbox used in the query definition dialog.
14 # Revision 1.37 1995/06/13 14:37:59 adam
15 # Work on query setup.
16 # Better about origin/target.
17 # Better presentation formats.
19 # Revision 1.36 1995/06/13 07:42:14 adam
20 # Bindings removed from text widgets.
22 # Revision 1.35 1995/06/12 15:17:31 adam
23 # Text widget used in main window (instead of listbox) to support
24 # better presentation formats.
26 # Revision 1.34 1995/06/12 07:59:07 adam
27 # More work on geometry handling.
29 # Revision 1.33 1995/06/09 11:17:35 adam
30 # Start work on geometry management.
32 # Revision 1.32 1995/06/07 09:16:37 adam
33 # New presentation format.
35 # Revision 1.31 1995/06/06 16:31:09 adam
36 # Bug fix: target names couldn't contain blanks.
39 # Revision 1.30 1995/06/06 11:35:41 adam
40 # Work on scan. Display of old sets.
42 # Revision 1.29 1995/06/05 14:11:18 adam
43 # Bug fix in present-more.
45 # Revision 1.28 1995/06/02 14:52:13 adam
46 # Minor changes really.
48 # Revision 1.27 1995/06/02 14:29:42 adam
49 # Work on scan interface - up/down buttons.
51 # Revision 1.26 1995/06/01 16:36:46 adam
52 # About buttons. Minor bug fixes.
54 # Revision 1.25 1995/05/31 13:09:57 adam
55 # Client searches/presents may be interrupted.
56 # New moving book-logo.
58 # Revision 1.24 1995/05/31 08:36:24 adam
59 # Bug fix in client.tcl: didn't save options on clientrc.tcl.
60 # New method: referenceId. More work on scan.
62 # Revision 1.23 1995/05/29 10:33:41 adam
63 # README and rename of startup script.
65 # Revision 1.22 1995/05/26 11:44:09 adam
66 # Bugs fixed. More work on MARC utilities and queries. Test
67 # client is up-to-date again.
69 # Revision 1.21 1995/05/11 15:34:46 adam
70 # Scan request changed a bit. This version works with RLG.
72 # Revision 1.20 1995/04/21 16:31:57 adam
73 # New radiobutton: protocol (z39v2/SR).
75 # Revision 1.19 1995/04/18 16:11:50 adam
76 # First version of graphical Scan. Some work on query-by-form.
78 # Revision 1.18 1995/04/10 10:50:22 adam
79 # Result-set name defaults to suffix of ir-set name.
80 # Started working on scan. Not finished at this point.
82 # Revision 1.17 1995/03/31 09:34:57 adam
83 # Search-button disabled when there is no connection.
85 # Revision 1.16 1995/03/31 08:56:36 adam
86 # New button "Search".
88 # Revision 1.15 1995/03/28 12:45:22 adam
89 # New ir method failback: called on disconnect/protocol error.
90 # New ir set/get method: protocol: SR / Z3950.
91 # Simple popup and disconnect when failback is invoked.
93 # Revision 1.14 1995/03/22 16:07:55 adam
96 # Revision 1.13 1995/03/21 17:27:26 adam
97 # Short-hand keys in setup.
99 # Revision 1.12 1995/03/21 13:41:03 adam
100 # Comstack cs_create not used too often. Non-blocking connect.
102 # Revision 1.11 1995/03/21 10:39:06 adam
103 # Diagnostic error message displayed with tkerror.
105 # Revision 1.10 1995/03/20 15:24:06 adam
106 # Diagnostic records saved on searchResponse.
108 # Revision 1.9 1995/03/17 18:26:16 adam
109 # Non-blocking i/o used now. Database names popup as cascade items.
111 # Revision 1.8 1995/03/17 15:45:00 adam
112 # Improved target/database setup.
114 # Revision 1.7 1995/03/16 17:54:03 adam
115 # Minor changes really.
117 # Revision 1.6 1995/03/15 19:10:20 adam
118 # Database setup in protocol-setup (rather target setup).
120 # Revision 1.5 1995/03/15 13:59:23 adam
123 # Revision 1.4 1995/03/14 17:32:29 adam
124 # Presentation of full Marc record in popup window.
126 # Revision 1.3 1995/03/12 19:31:52 adam
127 # Pattern matching implemented when retrieving MARC records. More
128 # diagnostic functions.
130 # Revision 1.2 1995/03/10 18:00:15 adam
131 # Actual presentation in line-by-line format. RPN query support.
133 # Revision 1.1 1995/03/09 16:15:07 adam
134 # First presentRequest attempts. Hot-target list.
143 set profile(Default) {{} {} {210} {} 16384 8192 tcpip {} 1 {} {} z39v2}
145 set settingsChanged 0
154 set queryTypes {Simple}
155 set queryButtons { { {I 0} {I 1} {I 2} } }
156 set queryInfo { { {Title {1=4 4=1}} {Author {1=1}} \
157 {Subject {1=21}} {Any {1=1016}} } }
160 proc read-formats {} {
161 global displayFormats
162 set formats [glob -nocomplain formats/*.tcl]
165 set l [expr [string length $f] - 5]
166 lappend displayFormats [string range $f 8 $l]
174 .data.record configure -wrap $m
177 proc set-display-format {f} {
185 .bot.a.status configure -text "Reformatting"
187 add-title-lines 0 10000 1
188 .bot.a.status configure -text "Done"
191 proc initBindings {} {
194 bind $w <Double-1> {}
195 bind $w <Triple-1> {}
196 bind $w <B1-Motion> {}
198 bind $w <Shift-B1-Motion> {}
200 bind $w <B2-Motion> {}
201 bind $w <Any-KeyPress> {}
203 bind $w <BackSpace> {}
205 bind $w <Control-h> {}
206 bind $w <Control-d> {}
207 bind $w <Control-v> {}
210 bind $w <B1-Motion> {}
211 bind $w <Shift-B1-Motion> {}
215 global windowGeometry
216 set windowGeometry($w) [wm geometry $w]
219 global windowGeometry
222 if {[info exists windowGeometry($w)]} {
223 set g $windowGeometry($w)
228 bind $w <Destroy> [list destroyGW $w]
231 if {[file readable "clientrc.tcl"]} {
232 source "clientrc.tcl"
235 if {[file readable "clientg.tcl"]} {
239 set queryButtonsFind [lindex $queryButtons 0]
240 set queryInfoFind [lindex $queryInfo 0]
242 proc top-down-window {w} {
243 frame $w.top -relief raised -border 1
244 frame $w.bot -relief raised -border 1
246 pack $w.top -side top -fill both -expand yes
247 pack $w.bot -fill both
250 proc top-down-ok-cancel {w ok-action g} {
251 frame $w.bot.left -relief sunken -border 1
252 pack $w.bot.left -side left -expand yes -ipadx 2 -ipady 2 -padx 5 -pady 5
253 button $w.bot.left.ok -width 6 -text {Ok} \
254 -command ${ok-action}
255 pack $w.bot.left.ok -expand yes -ipadx 2 -ipady 2 -padx 3 -pady 3
256 button $w.bot.cancel -width 6 -text {Cancel} \
257 -command [list destroy $w]
258 pack $w.bot.cancel -side left -expand yes
266 proc bottom-buttons {w buttonList g} {
268 set l [llength $buttonList]
270 frame $w.bot.$i -relief sunken -border 1
271 pack $w.bot.$i -side left -expand yes -padx 5 -pady 5
272 button $w.bot.$i.ok -text [lindex $buttonList $i] \
273 -command [lindex $buttonList [expr $i+1]]
274 pack $w.bot.$i.ok -expand yes -ipadx 3 -ipady 2 -padx 3 -pady 3 -side left
278 button $w.bot.$i -text [lindex $buttonList $i] \
279 -command [lindex $buttonList [expr $i+1]]
280 pack $w.bot.$i -expand yes -ipadx 2 -ipady 2 -padx 3 -pady 3 -side left
290 proc cancel-operation {} {
296 show-status Cancelled 0 {}
300 proc show-target {target} {
301 .bot.a.target configure -text "$target"
304 proc show-logo {v1} {
311 .bot.logo configure -bitmap @book${v1}
312 after 140 [list show-logo $v1]
316 .bot.logo configure -bitmap @book1
325 proc show-status {status b sb} {
329 .bot.a.status configure -text "$status"
331 if {$busy == 0} {set busy 1}
339 .top.service configure -state normal
340 .mid.search configure -state normal
341 .mid.scan configure -state normal
342 .mid.present configure -state normal
343 if {[winfo exists .scan-window]} {
344 .scan-window.bot.2 configure -state normal
345 .scan-window.bot.4 configure -state normal
349 .top.service configure -state disabled
350 .mid.search configure -state disabled
351 .mid.scan configure -state disabled
352 .mid.present configure -state disabled
354 if {[winfo exists .scan-window]} {
355 .scan-window.bot.2 configure -state disabled
356 .scan-window.bot.4 configure -state disabled
362 proc show-message {msg} {
363 .bot.a.message configure -text "$msg"
366 proc insertWithTags {w text args} {
367 set start [$w index insert]
368 $w insert insert $text
369 foreach tag [$w tag names $start] {
370 $w tag remove $tag $start insert
373 $w tag add $i $start insert
377 proc popup-license {} {
381 wm title $w "License"
387 text $w.top.t -width 80 -height 10 -wrap word \
388 -yscrollcommand [list $w.top.s set]
389 scrollbar $w.top.s -command [list $w.top.t yview]
391 pack $w.top.s -side right -fill y
392 pack $w.top.t -expand yes -fill both
394 set f [open "LICENSE" r]
395 while {[gets $f buf] != -1} {
396 $w.top.t insert end $buf
397 $w.top.t insert end "\n"
400 bottom-buttons $w [list {Close} [list destroy $w]] 1
403 proc about-target {} {
404 set w .about-target-w
409 wm title $w "About target"
412 frame $w.top.a -relief ridge -border 2
413 frame $w.top.p -relief ridge -border 2
415 pack $w.top.a $w.top.p -side top -fill x
417 label $w.top.a.about -text "About"
418 label $w.top.a.irtcl -text $hostid \
419 -font -Adobe-Helvetica-Bold-R-Normal-*-240-*
420 pack $w.top.a.about $w.top.a.irtcl -side top
422 set i [z39 targetImplementationName]
423 label $w.top.p.in -text "Implementation name: $i"
424 set i [z39 targetImplementationId]
425 label $w.top.p.ii -text "Implementation id: $i"
426 set i [z39 targetImplementationVersion]
427 label $w.top.p.iv -text "Implementation version: $i"
429 label $w.top.p.op -text "Protocol options: $i"
431 pack $w.top.p.in $w.top.p.ii $w.top.p.iv $w.top.p.op -side top -anchor nw
433 bottom-buttons $w [list {Close} [list destroy $w]] 1
436 proc about-origin-logo {n} {
437 set w .about-origin-w
438 if {![winfo exists $w]} {
445 $w.top.a.logo configure -bitmap @book$n
446 after 140 [list about-origin-logo $n]
449 proc about-origin {} {
450 set w .about-origin-w
452 if {[winfo exists $w]} {
457 wm title $w "About IrTcl"
461 frame $w.top.a -relief ridge -border 2
462 frame $w.top.p -relief ridge -border 2
464 pack $w.top.a $w.top.p -side top -fill x
466 label $w.top.a.irtcl -text "IrTcl" \
467 -font -Adobe-Helvetica-Bold-R-Normal-*-240-*
468 label $w.top.a.logo -bitmap @book1
469 pack $w.top.a.irtcl $w.top.a.logo -side left -expand yes
471 set i [z39 implementationName]
472 label $w.top.p.in -text "Implementation name: $i"
473 set i [z39 implementationId]
474 label $w.top.p.ii -text "Implementation id: $i"
476 pack $w.top.p.in $w.top.p.ii -side top -anchor nw
479 bottom-buttons $w [list {Close} [list destroy $w] \
480 {License} [list popup-license]] 0
483 proc popup-marc {sno no b df} {
485 global displayFormats
488 if {[z39.$sno type $no] != "DB"} {
492 set w .full-marc-$fullMarcSeq
497 if {[info exists popupMarcdf]} {
503 if {[winfo exists $w]} {
511 frame $w.top -relief raised -border 1
512 frame $w.bot -relief raised -border 1
514 pack $w.top -side top -fill both -expand yes
515 pack $w.bot -fill both
517 text $w.top.record -width 60 -height 5 -wrap word \
518 -yscrollcommand [list $w.top.s set]
519 scrollbar $w.top.s -command [list $w.top.record yview]
521 if {[tk colormodel .] == "color"} {
522 $w.top.record tag configure marc-tag -foreground blue
523 $w.top.record tag configure marc-id -foreground red
525 $w.top.record tag configure marc-tag -foreground black
526 $w.top.record tag configure marc-id -foreground black
528 $w.top.record tag configure marc-data -foreground black
531 $w.top.record delete 0.0 end
532 wm title $w "Record #$no"
534 set ffunc [lindex $displayFormats $df]
535 set ffunc "display-$ffunc"
537 $ffunc $sno $no $w.top.record 0
540 bind $w.top.record <Return> {destroy .full-marc}
542 pack $w.top.s -side right -fill y
543 pack $w.top.record -expand yes -fill both
546 bottom-buttons $w [list \
547 {Close} [list destroy $w]] 0
549 bottom-buttons $w [list \
550 {Close} [list destroy $w] \
551 {Duplicate} [list popup-marc $sno $no 1 0]] 0
552 menubutton $w.bot.formats -text "Format" -menu $w.bot.formats.m
553 menu $w.bot.formats.m
555 foreach f $displayFormats {
556 $w.bot.formats.m add radiobutton -label $f \
557 -variable popupMarcdf -value $i \
558 -command [list display-$f $sno $no $w.top.record 0]
561 pack $w.bot.formats -expand yes -ipadx 2 -ipady 2 \
562 -padx 3 -pady 3 -side left
566 foreach f $displayFormats {
567 $w.bot.formats.m entryconfigure $i \
568 -command [list display-$f $sno $no $w.top.record 0]
574 proc update-target-hotlist {target} {
577 set len [llength $hotTargets]
579 .top.target.m delete 6 [expr 6+[llength $hotTargets]]
581 set indx [lsearch $hotTargets $target]
583 set hotTargets [lreplace $hotTargets $indx $indx]
585 set hotTargets [linsert $hotTargets 0 $target]
589 proc set-target-hotlist {} {
593 foreach target $hotTargets {
594 .top.target.m add command -label "$i $target" -command \
595 [list reopen-target $target {}]
603 proc reopen-target {target base} {
605 open-target $target $base
606 update-target-hotlist $target
609 proc define-target-action {} {
612 set target [.target-define.top.target.entry get]
616 update-target-hotlist $target
617 foreach n [array names profile] {
623 set seq [lindex $profile(Default) 12]
625 set profile($target) $profile(Default)
626 set profile(Default) [lreplace $profile(Default) 12 12 [incr seq]]
628 protocol-setup $target
629 destroy .target-define
632 proc fail-response {target} {
634 tkerror "Target connection closed or protocol error"
637 proc connect-response {target} {
638 puts "connect-response"
643 proc open-target {target base} {
648 z39 comstack [lindex $profile($target) 6]
649 z39 idAuthentication [lindex $profile($target) 3]
650 z39 maximumRecordSize [lindex $profile($target) 4]
651 z39 preferredMessageSize [lindex $profile($target) 5]
652 puts -nonewline "maximumRecordSize="
653 puts [z39 maximumRecordSize]
654 puts -nonewline "preferredMessageSize="
655 puts [z39 preferredMessageSize]
656 show-status {Connecting} 0 0
658 z39 databaseNames [lindex [lindex $profile($target) 7] 0]
660 z39 databaseNames $base
662 z39 failback [list fail-response $target]
663 z39 callback [list connect-response $target]
664 z39 connect [lindex $profile($target) 1]:[lindex $profile($target) 2]
665 # z39 options search present scan namedResultSets triggerResourceCtrl
666 show-status {Connecting} 1 {}
668 .top.target.m disable 0
669 .top.target.m enable 1
670 .top.target.m enable 2
673 proc close-target {} {
681 show-status {Not connected} 0 0
683 .top.target.m disable 1
684 .top.target.m disable 2
685 .top.target.m enable 0
688 proc load-set-action {} {
692 ir-set z39.$setNo z39
694 set fname [.load-set.top.filename.entry get]
697 show-status {Loading} 1 {}
699 z39.$setNo loadFile $fname
701 set no [z39.$setNo numberOfRecordsReturned]
702 add-title-lines $setNo $no 1
704 set l [format "%-4d %7d" $setNo $no]
705 .top.rset.m add command -label $l \
706 -command [list add-title-lines $setNo 10000 1]
707 show-status {Ready} 0 {}
719 frame $w.top.filename
720 pack $w.top.filename -side top -anchor e -pady 2
722 entry-fields $w.top {filename} \
724 {load-set-action} {destroy .load-set}
726 top-down-ok-cancel $w {load-set-action} 1
730 proc init-request {} {
738 z39 callback {init-response}
739 show-status {Initializing} 1 {}
743 proc init-response {} {
750 show-status {Ready} 0 1
751 if {![z39 initResult]} {
752 set u [z39 userInformationField]
754 tkerror "Connection rejected by target: $u"
758 proc search-request {} {
768 if {$searchEnable == 0} {
771 set query [index-query]
776 ir-set z39.$setNo z39
778 if {[lindex $profile($target) 10] == 1} {
779 z39.$setNo setName $setNo
780 puts "setName=${setNo}"
782 z39.$setNo setName Default
783 puts "setName=Default"
785 if {[lindex $profile($target) 8] == 1} {
786 z39.$setNo queryType rpn
788 if {[lindex $profile($target) 9] == 1} {
789 z39.$setNo queryType ccl
791 z39 callback {search-response}
792 z39.$setNo search $query
793 show-status {Search} 1 0
796 proc scan-focus {w} {
798 bind $w <Leave> [list focus $oldFocus]
802 proc scan-request {} {
810 global queryButtonsFind
817 set b [lindex $queryButtonsFind $curIndexEntry]
819 foreach a [lrange [lindex $queryInfoFind [lindex $b 1]] 1 end] {
820 set attr "@attr $a $attr"
822 set title [lindex [lindex $queryInfoFind [lindex $b 1]] 0]
825 if {![winfo exists $w]} {
832 entry $w.top.entry -relief sunken
833 pack $w.top.entry -fill x -padx 4 -pady 2
834 bind $w.top.entry <KeyRelease> [list scan-term-h $attr]
836 listbox $w.top.list -yscrollcommand [list $w.top.scroll set] \
838 scrollbar $w.top.scroll -orient vertical -border 1
839 pack $w.top.list -side left -fill both -expand yes
840 pack $w.top.scroll -side right -fill y
841 $w.top.scroll config -command [list $w.top.list yview]
843 listbox $w.top.list -font fixed -geometry 60x14
844 pack $w.top.list -side left -fill both -expand yes
847 bottom-buttons $w [list {Close} [list destroy $w] \
848 {Up} [list scan-up $attr] \
849 {Down} [list scan-down $attr]] 0
850 bind $w.top.list <Up> [list scan-up $attr]
851 bind $w.top.list <Down> [list scan-down $attr]
853 wm title $w "Scan $title"
854 # bind $w.top <Any-Enter> [list scan-focus $w]
856 z39 callback [list scan-response $attr 0 35]
857 z39.scan numberOfTermsRequested 5
858 z39.scan preferredPositionInResponse 1
859 z39.scan scan "${attr} 0"
861 show-status {Scan} 1 0
864 proc scan-term-h {attr} {
872 set nScanTerm [$w.top.entry get]
873 if {$nScanTerm == $scanTerm} {
876 set scanTerm $nScanTerm
877 z39 callback [list scan-response $attr 0 35]
878 z39.scan numberOfTermsRequested 5
879 z39.scan preferredPositionInResponse 1
880 puts "${attr} \{${scanTerm}\}"
881 if {$scanTerm == ""} {
882 z39.scan scan "${attr} 0"
884 z39.scan scan "${attr} \{${scanTerm}\}"
886 show-status {Scan} 1 0
889 proc scan-response {attr start toget} {
895 puts "In scan-response"
896 set m [z39.scan numberOfEntriesReturned]
902 if {![winfo exists .scan-window]} {
903 show-status {Ready} 0 1
907 set nScanTerm [$w.top.entry get]
908 if {$nScanTerm != $scanTerm} {
909 z39 callback [list scan-response $attr 0 35]
910 z39.scan numberOfTermsRequested 5
911 z39.scan preferredPositionInResponse 1
912 set scanTerm $nScanTerm
913 puts "${attr} \{${scanTerm}\}"
914 if {$scanTerm == ""} {
915 z39.scan scan "${attr} 0"
917 z39.scan scan "${attr} \{${scanTerm}\}"
919 show-status {Scan} 1 0
922 set status [z39.scan scanStatus]
925 show-status {Ready} 0 1
930 for {set i 0} {$i < $m} {incr i} {
931 set term [lindex [z39.scan scanLine $i] 1]
932 set nostr [format " %-6d" [lindex [z39.scan scanLine $i] 2]]
933 $w.top.list insert $i "$nostr $term"
936 $w.top.list yview $scanView
938 $w.top.list delete $start end
939 for {set i 0} {$i < $m} {incr i} {
940 set term [lindex [z39.scan scanLine $i] 1]
941 set nostr [format " %-6d" [lindex [z39.scan scanLine $i] 2]]
942 $w.top.list insert end "$nostr $term"
946 show-status {Ready} 0 1
950 if {$toget > 0 && $m > 1 && $m < $toget} {
951 set ntoget [expr $toget - $m + 1]
953 z39 callback [list scan-response $attr [expr $start + $m - 1] $ntoget]
955 puts "down continue: $q"
957 z39.scan numberOfTermsRequested 10
959 z39.scan numberOfTermsRequested $ntoget
961 z39.scan preferredPositionInResponse 1
962 puts "${attr} \{$q\}"
963 z39.scan scan "${attr} \{$q\}"
966 if {$toget < 0 && $m > 1 && $m < [expr - $toget]} {
967 set ntoget [expr - $toget - $m]
969 z39 callback [list scan-response $attr 0 -$ntoget]
970 set q [string range [$w.top.list get 0] 8 end]
971 puts "up continue: $q"
973 z39.scan numberOfTermsRequested 10
974 z39.scan preferredPositionInResponse 11
976 z39.scan numberOfTermsRequested $ntoget
977 z39.scan preferredPositionInResponse [incr ntoget]
979 puts "${attr} \{$q\}"
980 z39.scan scan "${attr} \{$q\}"
983 show-status {Ready} 0 1
986 proc scan-down {attr} {
990 set scanView [expr $scanView + 5]
991 set s [$w.top.list size]
992 if {$scanView > $s} {
993 z39 callback [list scan-response $attr [expr $s - 1] 25]
994 set q [string range [$w.top.list get [expr $s - 1]] 8 end]
996 z39.scan numberOfTermsRequested 10
997 z39.scan preferredPositionInResponse 1
998 show-status {Scan} 1 0
999 puts "${attr} \{$q\}"
1000 z39.scan scan "${attr} \{$q\}"
1003 $w.top.list yview $scanView
1006 proc scan-up {attr} {
1010 set scanView [expr $scanView - 5]
1011 if {$scanView < 0} {
1012 z39 callback [list scan-response $attr 0 -25]
1013 set q [string range [$w.top.list get 0] 8 end]
1015 z39.scan numberOfTermsRequested 10
1016 z39.scan preferredPositionInResponse 11
1017 show-status {Scan} 1 0
1018 z39.scan scan "${attr} \{$q\}"
1021 $w.top.list yview $scanView
1024 proc search-response {} {
1031 puts "In search-response"
1033 show-status {Ready} 0 1
1034 set setMax [z39.$setNo resultCount]
1035 show-message "${setMax} hits"
1036 set l [format "%-4d %7d" $setNo $setMax]
1037 .top.rset.m add command -label $l \
1038 -command [list add-title-lines $setNo 10000 1]
1040 set status [z39.$setNo responseStatus]
1041 if {[lindex $status 0] == "NSD"} {
1042 set code [lindex $status 1]
1043 set msg [lindex $status 2]
1044 set addinfo [lindex $status 3]
1045 tkerror "NSD$code: $msg: $addinfo"
1057 z39 callback {present-response}
1058 z39.$setNo present $setOffset 1
1059 show-status {Retrieve} 1 0
1062 proc present-more {number} {
1067 puts "setOffset=$setOffset"
1073 set max [z39.$setNo resultCount]
1074 if {$max <= $setOffset} {
1076 puts "setOffset=$setOffset"
1079 if {$number == ""} {
1083 if {$setMax > $max} {
1087 z39 callback {present-response}
1089 set toGet [expr $setMax - $setOffset + 1]
1096 z39.$setNo present $setOffset $toGet
1097 show-status {Retrieve} 1 0
1100 proc init-title-lines {} {
1101 .data.record delete 0.0 end
1104 proc title-press {y setno} {
1105 show-full-marc $setno [expr 1 + [.data.list nearest $y]] 0
1108 proc add-title-lines {setno no offset} {
1109 global displayFormats
1110 global displayFormat
1114 set setno $lastSetNo
1116 set lastSetNo $setno
1119 .bot.a.set configure -text $setno
1120 .data.record delete 0.0 end
1122 set ffunc [lindex $displayFormats $displayFormat]
1123 set ffunc "display-$ffunc"
1124 for {set i 0} {$i < $no} {incr i} {
1125 set o [expr $i + $offset]
1126 set type [z39.$setno type $o]
1130 .data.record tag bind r$o <Any-Enter> {}
1131 .data.record tag bind r$o <Any-Leave> {}
1132 set insert0 [.data.record index insert]
1133 $ffunc $setno $o .data.record 1
1134 .data.record tag add r$o $insert0 insert
1135 .data.record tag bind r$o <1> \
1136 [list popup-marc $setno $o 0 0]
1141 proc present-response {} {
1147 puts "In present-response"
1148 set no [z39.$setNo numberOfRecordsReturned]
1149 puts "Returned $no records, setOffset $setOffset"
1150 add-title-lines $setNo $no $setOffset
1151 set setOffset [expr $setOffset + $no]
1152 set status [z39.$setNo responseStatus]
1153 if {[lindex $status 0] == "NSD"} {
1154 show-status {Ready} 0 1
1155 set code [lindex $status 1]
1156 set msg [lindex $status 2]
1157 set addinfo [lindex $status 3]
1158 tkerror "NSD$code: $msg: $addinfo"
1162 show-status {Ready} 0 1
1166 if {$no > 0 && $setOffset <= $setMax} {
1167 puts "present-request from ${setOffset}"
1168 set toGet [expr $setMax - $setOffset + 1]
1172 z39.$setNo present $setOffset $toGet
1174 show-status {Finished} 0 1
1178 proc left-cursor {w} {
1179 set i [$w index insert]
1186 proc right-cursor {w} {
1187 set i [$w index insert]
1192 proc bind-fields {list returnAction escapeAction} {
1193 set max [expr [llength $list]-1]
1194 for {set i 0} {$i < $max} {incr i} {
1195 bind [lindex $list $i] <Return> $returnAction
1196 bind [lindex $list $i] <Escape> $escapeAction
1197 bind [lindex $list $i] <Tab> [list focus [lindex $list [expr $i+1]]]
1198 bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
1199 bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
1201 bind [lindex $list $i] <Return> $returnAction
1202 bind [lindex $list $i] <Escape> $escapeAction
1203 bind [lindex $list $i] <Tab> [list focus [lindex $list 0]]
1204 bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
1205 bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
1206 focus [lindex $list 0]
1209 proc entry-fields {parent list tlist returnAction escapeAction} {
1212 foreach field $list {
1213 set label ${parent}.${field}.label
1214 set entry ${parent}.${field}.entry
1215 label $label -text [lindex $tlist $i] -anchor e
1216 entry $entry -width 32 -relief sunken
1217 pack $label -side left
1218 pack $entry -side right
1219 lappend alist $entry
1222 bind-fields $alist $returnAction $escapeAction
1225 proc define-target-dialog {} {
1226 set w .target-define
1232 pack $w.top.target \
1233 -side top -anchor e -pady 2
1234 entry-fields $w.top {target} \
1236 {define-target-action} {destroy .target-define}
1237 top-down-ok-cancel $w {define-target-action} 1
1240 proc protocol-setup-delete {target} {
1243 set a [alert "Are you you want to delete the target definition $target ?"]
1245 set wno [lindex $profile($target) 12]
1248 unset profile($target)
1253 proc protocol-setup-action {target} {
1256 global protocolRadioType
1257 global settingsChanged
1260 global ResultSetCheck
1262 set wno [lindex $profile($target) 12]
1266 set settingsChanged 1
1267 set len [$w.top.databases.list size]
1268 for {set i 0} {$i < $len} {incr i} {
1269 lappend b [$w.top.databases.list get $i]
1271 set profile($target) [list [$w.top.description.entry get] \
1272 [$w.top.host.entry get] \
1273 [$w.top.port.entry get] \
1274 [$w.top.idAuthentication.entry get] \
1275 [$w.top.maximumRecordSize.entry get] \
1276 [$w.top.preferredMessageSize.entry get] \
1282 $protocolRadioType \
1286 puts $profile($target)
1290 proc place-force {window parent} {
1291 set g [wm geometry $parent]
1293 set p1 [string first + $g]
1294 set p2 [string last + $g]
1296 set x [expr 40+[string range $g [expr $p1 +1] [expr $p2 -1]]]
1297 set y [expr 60+[string range $g [expr $p2 +1] end]]
1298 wm geometry $window +${x}+${y}
1301 proc add-database-action {target} {
1304 set wno [lindex $profile($target) 12]
1307 $w.top.databases.list insert end \
1308 [.database-select.top.database.entry get]
1309 destroy .database-select
1312 proc add-database {target} {
1315 set w .database-select
1317 set oldFocus [focus]
1320 set wno [lindex $profile($target) 12]
1321 place-force $w .setup-${wno}
1325 frame $w.top.database
1327 pack $w.top.database -side top -anchor e -pady 2
1329 entry-fields $w.top {database} \
1330 {{Database to add:}} \
1331 [list add-database-action $target] {destroy .database-select}
1333 top-down-ok-cancel $w [list add-database-action $target] 1
1337 proc delete-database {target} {
1340 set wno [lindex $profile($target) 12]
1343 foreach i [lsort -decreasing \
1344 [$w.top.databases.list curselection]] {
1345 $w.top.databases.list delete $i
1349 proc protocol-setup {target} {
1352 global protocolRadioType
1355 global ResultSetCheck
1357 set wno [lindex $profile($target) 12]
1362 wm title $w "Setup $target"
1366 if {$target == ""} {
1370 puts $profile($target)
1374 frame $w.top.description
1375 frame $w.top.idAuthentication
1376 frame $w.top.maximumRecordSize
1377 frame $w.top.preferredMessageSize
1378 frame $w.top.cs-type -relief ridge -border 2
1379 frame $w.top.protocol -relief ridge -border 2
1380 frame $w.top.query -relief ridge -border 2
1381 frame $w.top.databases -relief ridge -border 2
1383 # Maximum/preferred/idAuth ...
1384 pack $w.top.description $w.top.host $w.top.port \
1385 $w.top.idAuthentication $w.top.maximumRecordSize \
1386 $w.top.preferredMessageSize -side top -anchor e -pady 2
1388 entry-fields $w.top {description host port idAuthentication \
1389 maximumRecordSize preferredMessageSize} \
1390 {{Description:} {Host:} {Port:} {Id Authentication:} \
1391 {Maximum Record Size:} {Preferred Message Size:}} \
1392 [list protocol-setup-action $target] [list destroy $w]
1394 foreach sub {description host port idAuthentication \
1395 maximumRecordSize preferredMessageSize} {
1397 bind $w.top.$sub.entry <Control-a> [list add-database $target]
1398 bind $w.top.$sub.entry <Control-d> [list delete-database $target]
1400 $w.top.description.entry insert 0 [lindex $profile($target) 0]
1401 $w.top.host.entry insert 0 [lindex $profile($target) 1]
1402 $w.top.port.entry insert 0 [lindex $profile($target) 2]
1403 $w.top.idAuthentication.entry insert 0 [lindex $profile($target) 3]
1404 $w.top.maximumRecordSize.entry insert 0 [lindex $profile($target) 4]
1405 $w.top.preferredMessageSize.entry insert 0 [lindex $profile($target) 5]
1406 set csRadioType [lindex $profile($target) 6]
1407 set RPNCheck [lindex $profile($target) 8]
1408 set CCLCheck [lindex $profile($target) 9]
1409 set ResultSetCheck [lindex $profile($target) 10]
1410 set protocolRadioType [lindex $profile($target) 11]
1411 if {$protocolRadioType == ""} {
1412 set protocolRadioType z39v2
1416 pack $w.top.databases -side left -pady 4 -padx 4 -expand yes -fill both
1418 label $w.top.databases.label -text "Databases"
1419 button $w.top.databases.add -text "Add" \
1420 -command [list add-database $target]
1421 button $w.top.databases.delete -text "Delete" \
1422 -command [list delete-database $target]
1423 listbox $w.top.databases.list -geometry 20x6 \
1424 -yscrollcommand "$w.top.databases.scroll set"
1425 scrollbar $w.top.databases.scroll -orient vertical -border 1
1426 pack $w.top.databases.label -side top -fill x \
1428 pack $w.top.databases.add $w.top.databases.delete -side top -fill x \
1430 pack $w.top.databases.list -side left -fill both -expand yes \
1432 pack $w.top.databases.scroll -side right -fill y \
1434 $w.top.databases.scroll config -command "$w.top.databases.list yview"
1436 foreach b [lindex $profile($target) 7] {
1437 $w.top.databases.list insert end $b
1441 pack $w.top.cs-type -pady 4 -padx 4 -side top -fill x
1443 label $w.top.cs-type.label -text "Transport"
1444 radiobutton $w.top.cs-type.tcpip -text "TCP/IP" -anchor w \
1445 -command {puts tcp/ip} -variable csRadioType -value tcpip
1446 radiobutton $w.top.cs-type.mosi -text "MOSI" -anchor w\
1447 -command {puts mosi} -variable csRadioType -value mosi
1449 pack $w.top.cs-type.label $w.top.cs-type.tcpip $w.top.cs-type.mosi \
1450 -padx 4 -side top -fill x
1453 pack $w.top.protocol -pady 4 -padx 4 -side top -fill x
1455 label $w.top.protocol.label -text "Protocol"
1456 radiobutton $w.top.protocol.z39v2 -text "Z39.50" -anchor w \
1457 -command {puts z39v2} -variable protocolRadioType -value z39v2
1458 radiobutton $w.top.protocol.sr -text "SR" -anchor w \
1459 -command {puts sr} -variable protocolRadioType -value sr
1461 pack $w.top.protocol.label $w.top.protocol.z39v2 $w.top.protocol.sr \
1462 -padx 4 -side top -fill x
1465 pack $w.top.query -pady 4 -padx 4 -side top -fill x
1467 label $w.top.query.label -text "Query support"
1468 checkbutton $w.top.query.c1 -text "RPN query" -anchor w -variable RPNCheck
1469 checkbutton $w.top.query.c2 -text "CCL query" -anchor w -variable CCLCheck
1470 checkbutton $w.top.query.c3 -text "Result sets" -anchor w -variable ResultSetCheck
1472 pack $w.top.query.label -side top
1473 pack $w.top.query.c1 $w.top.query.c2 $w.top.query.c3 \
1474 -padx 4 -side top -fill x
1477 bottom-buttons $w [list {Ok} [list protocol-setup-action $target] \
1478 {Delete} [list protocol-setup-delete $target] \
1479 {Cancel} [list destroy $w]] 0
1482 proc database-select-action {} {
1483 set w .database-select.top
1485 foreach indx [$w.databases.list curselection] {
1486 lappend b [$w.databases.list get $indx]
1489 z39 databaseNames $b
1491 destroy .database-select
1494 proc database-select {} {
1495 set w .database-select
1505 frame $w.top.databases -relief ridge -border 2
1507 pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill x
1509 label $w.top.databases.label -text "List"
1510 listbox $w.top.databases.list -geometry 20x6 \
1511 -yscrollcommand "$w.top.databases.scroll set"
1512 scrollbar $w.top.databases.scroll -orient vertical -border 1
1513 pack $w.top.databases.label -side top -fill x \
1515 pack $w.top.databases.list -side left -fill both -expand yes \
1517 pack $w.top.databases.scroll -side right -fill y \
1519 $w.top.databases.scroll config -command "$w.top.databases.list yview"
1521 foreach b [lindex $profile($hostid) 7] {
1522 $w.top.databases.list insert end $b
1524 top-down-ok-cancel $w {database-select-action} 1
1527 proc cascade-target-list {} {
1530 foreach sub [winfo children .top.target.m.clist] {
1533 .top.target.m.clist delete 0 last
1534 foreach n [array names profile] {
1535 if {$n != "Default"} {
1536 set nl [string tolower $n]
1537 if {[llength [lindex $profile($n) 7]] > 1} {
1538 .top.target.m.clist add cascade -label $n \
1539 -menu .top.target.m.clist.$nl
1540 menu .top.target.m.clist.$nl
1541 foreach b [lindex $profile($n) 7] {
1542 .top.target.m.clist.$nl add command -label $b \
1543 -command [list reopen-target $n $b]
1546 .top.target.m.clist add command -label $n \
1547 -command [list reopen-target $n {}]
1551 .top.target.m.slist delete 0 last
1552 foreach n [array names profile] {
1553 if {$n != "Default"} {
1554 .top.target.m.slist add command -label $n \
1555 -command [list protocol-setup $n]
1560 proc query-select {i} {
1561 global queryButtonsFind
1562 global queryInfoFind
1566 set queryInfoFind [lindex $queryInfo $i]
1567 set queryButtonsFind [lindex $queryButtons $i]
1569 index-lines .lines 1 $queryButtonsFind $queryInfoFind activate-index
1572 proc query-new-action {} {
1576 global settingsChanged
1578 set settingsChanged 1
1579 lappend queryTypes [.query-new.top.index.entry get]
1580 lappend queryButtons {}
1581 lappend queryInfo {}
1595 -side top -anchor e -pady 2
1596 entry-fields $w.top index \
1598 query-new-action {destroy .query-new}
1599 top-down-ok-cancel $w query-new-action 1
1602 proc query-delete-action {queryNo} {
1606 global settingsChanged
1608 set settingsChanged 1
1610 set queryTypes [lreplace $queryTypes $queryNo $queryNo]
1611 set queryButtons [lreplace $queryButtons $queryNo $queryNo]
1612 set queryInfo [lreplace $queryInfo $queryNo $queryNo]
1613 destroy .query-delete
1617 proc query-delete {queryNo} {
1625 set n [lindex $queryTypes $queryNo]
1627 label $w.top.warning -bitmap warning
1628 message $w.top.quest -text "Are you sure you want to delete the \
1629 query type $n ?" -aspect 200
1630 pack $w.top.warning $w.top.quest -side left -expand yes -padx 10 -pady 5
1631 bottom-buttons $w [list {Ok} [list query-delete-action $queryNo] \
1632 {Cancel} [list destroy $w]] 1
1635 proc cascade-query-list {} {
1637 set w .top.options.m.query
1640 $w.slist delete 0 last
1641 foreach n $queryTypes {
1642 $w.slist add command -label $n -command [list query-setup $i]
1647 $w.clist delete 0 last
1648 foreach n $queryTypes {
1649 $w.clist add command -label $n -command [list query-select $i]
1653 $w.dlist delete 0 last
1654 foreach n $queryTypes {
1655 $w.dlist add command -label $n -command [list query-delete $i]
1660 proc save-geometry {} {
1661 global windowGeometry
1664 global displayFormat
1666 set windowGeometry(.) [wm geometry .]
1668 set f [open "clientg.tcl" w]
1670 puts $f "set hotTargets \{ $hotTargets \}"
1671 puts $f "set textWrap $textWrap"
1672 puts $f "set displayFormat $displayFormat"
1673 foreach n [array names windowGeometry] {
1674 puts -nonewline $f "set \{windowGeometry($n)\} \{"
1675 puts -nonewline $f $windowGeometry($n)
1681 proc save-settings {} {
1683 global settingsChanged
1688 set f [open "clientrc.tcl" w]
1689 puts $f "# Setup file"
1691 foreach n [array names profile] {
1692 puts -nonewline $f "set \{profile($n)\} \{"
1693 puts -nonewline $f $profile($n)
1696 puts -nonewline $f "set queryTypes \{"
1697 puts -nonewline $f $queryTypes
1700 puts -nonewline $f "set queryButtons \{"
1701 puts -nonewline $f $queryButtons
1704 puts -nonewline $f "set queryInfo \{"
1705 puts -nonewline $f $queryInfo
1708 set settingsChanged 0
1720 label $w.top.warning -bitmap warning
1721 message $w.top.message -text $ask -aspect 200 \
1722 -font -Adobe-Times-Medium-R-Normal-*-180-*
1724 pack $w.top.warning $w.top.message -side left -pady 5 -padx 10 -expand yes
1727 top-down-ok-cancel $w {alert-action} 1
1731 proc alert-action {} {
1737 proc exit-action {} {
1738 global settingsChanged
1740 if {$settingsChanged} {
1741 set a [alert "you havent saved your settings. Do you wish to save?"]
1750 proc listbuttonaction {w name h user i} {
1751 $w configure -text [lindex $name 0]
1752 $h [lindex $name 1] $user $i
1755 proc listbuttonx {button no names handle user} {
1756 if {[winfo exists $button]} {
1757 $button configure -text [lindex [lindex $names $no] 0]
1758 ${button}.m delete 0 last
1760 menubutton $button -text [lindex [lindex $names $no] 0] \
1761 -width 10 -menu ${button}.m -relief raised -border 1
1765 foreach name $names {
1766 ${button}.m add command -label [lindex $name 0] \
1767 -command [list listbuttonaction ${button} $name \
1773 proc listbutton {button no names} {
1774 menubutton $button -text [lindex $names $no] -width 10 -menu ${button}.m \
1775 -relief raised -border 1
1777 foreach name $names {
1778 ${button}.m add command -label $name \
1779 -command [list ${button} configure -text $name]
1783 proc listbuttonv-action {button var names i} {
1786 set $var [lindex $names [expr $i+1]]
1787 $button configure -text [lindex $names $i]
1790 proc listbuttonv {button var names} {
1794 eval "set val $$var"
1795 set l [llength $names]
1796 for {set i 1} {$i < $l} {incr i 2} {
1797 if {$val == [lindex $names $i]} {
1799 set n [lindex $names $i]
1803 if {[winfo exists $button]} {
1804 $button configure -text $n
1807 menubutton $button -text $n -menu ${button}.m \
1808 -relief raised -border 1
1810 for {set i 0} {$i < $l} {incr i 2} {
1811 ${button}.m add command -label [lindex $names $i] \
1812 -command [list listbuttonv-action $button $var $names $i]
1816 proc query-add-index-action {queryNo} {
1820 global queryButtonsTmp
1822 set newI [.query-add-index.top.index.entry get]
1823 lappend queryInfoTmp [list $newI {}]
1824 $w.top.index insert end $newI
1825 destroy .query-add-index
1826 #destroy $w.top.lines
1827 #frame $w.top.lines -relief ridge -border 2
1828 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1829 #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1832 proc query-add-line {queryNo} {
1836 global queryButtonsTmp
1838 lappend queryButtonsTmp {I 0}
1840 #destroy $w.top.lines
1841 #frame $w.top.lines -relief ridge -border 2
1842 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1843 #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1846 proc query-del-line {queryNo} {
1850 global queryButtonsTmp
1852 set l [llength $queryButtonsTmp]
1857 set queryButtonsTmp [lreplace $queryButtonsTmp $l $l]
1858 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1861 proc query-add-index {queryNo} {
1862 set w .query-add-index
1865 place-force $w .query-setup
1869 -side top -anchor e -pady 2
1870 entry-fields $w.top {index} \
1872 [list query-add-index-action $queryNo] [list destroy $w]
1873 top-down-ok-cancel $w [list query-add-index-action $queryNo] 1
1876 proc query-setup-action {queryNo} {
1879 global queryButtonsTmp
1881 global settingsChanged
1883 set settingsChanged 1
1885 set queryInfo [lreplace $queryInfo $queryNo $queryNo \
1887 set queryButtons [lreplace $queryButtons $queryNo $queryNo \
1889 destroy .query-setup
1892 proc activate-e-index {value no i} {
1893 global queryButtonsTmp
1894 global queryIndexTmp
1896 set queryButtonsTmp [lreplace $queryButtonsTmp $no $no [list I $i]]
1897 puts $queryButtonsTmp
1898 set queryIndexTmp $i
1901 proc activate-index {value no i} {
1902 global queryButtonsFind
1904 set queryButtonsFind [lreplace $queryButtonsFind $no $no [list I $i]]
1906 puts "queryButtonsFind $queryButtonsFind"
1909 proc update-attr {} {
1911 listbuttonv $w.top.relation.b relationTmpValue\
1912 {{None} 0 {Less than} 1 {Greater than or equal} 2 {Equal} 3 \
1913 {Greater than or equal} 4 {Greater than} 5 {Not equal} 6 \
1914 {Phonetic} 100 {Stem} 101 {Relevance} 102 {AlwaysMatches} 103}
1915 listbuttonv $w.top.position.b positionTmpValue {{None} 0 \
1916 {First in field} 1 {First in subfield} 2 {Any position in field} 3}
1917 listbuttonv $w.top.structure.b structureTmpValue {{None} 0 {Phrase} 1 \
1918 {Word} 2 {Key} 3 {Year} 4 {Date (norm)} 5 {Word list} 6 \
1919 {Date (un-norm)} 100 {Name (norm)} 101 {Date (un-norm)} 102 \
1920 {Structure} 103 {urx} 104 {free-form} 105 {doc-text} 106 \
1921 {local-number} 107 {string} 108 {numeric string} 109}
1922 listbuttonv $w.top.truncation.b truncationTmpValue {{Auto} 0 {Right} 1 \
1923 {Left} 2 {Left and right} 3 {No truncation} 100 \
1924 {Process #} 101 {Re-1} 102 {Re-2} 103}
1925 listbuttonv $w.top.completeness.b completenessTmpValue {{None} 0 \
1926 {Incomplete subfield} 1 {Complete subfield} 2 {Complete field} 3}
1929 proc use-attr {init} {
1941 {BNB card number} 10
1942 {BGF(sic) number} 11
1944 {Dewey classification} 13
1945 {UDC classification} 14
1946 {Bliss classification} 15
1948 {NLM call number} 17
1949 {NAL call number} 18
1950 {MOS call number} 19
1951 {Local classification} 20
1952 {Subject heading} 21
1954 {BDI-index-subject} 23
1958 {LC-subject-heading} 27
1959 {RVM-subject-heading} 28
1960 {Local subject index} 29
1962 {Date of publication} 31
1963 {Date of acquisition} 32
1965 {Title-collective} 34
1968 {Title-added-title-page} 37
1972 {Title-other-variant} 41
1974 {Title-abbreviated} 43
1978 {Subject-subdivision} 47
1979 {Number-natl-bibliography} 48
1980 {Number-legal-deposit} 49
1981 {Number-govt-publication} 50
1982 {Number-publisher-for-music} 51
1984 {Number-local-call} 53
1986 {Code-geographic-area} 55
1987 {Code-institution} 56
1989 {Name-geographic} 58
1990 {Place-publication} 59
1992 {Microform-generation} 61
1999 {Author-name-personal} 1004
2000 {Author-name-corporate} 1005
2001 {Author-name-conference} 1006
2002 {Identifier-standard} 1007
2003 {Subject-LC-children's} 1008
2004 {Subject-name-personal} 1009
2006 {Date/time added to database} 1011
2007 {Date/time last modified} 1012
2008 {Authority/format identifier} 1013
2010 {Concept-reference} 1015
2012 {Server choice} 1017
2014 {Record source} 1019
2017 {Geographic class} 1022
2021 {Related periodical} 1026
2022 {Report number} 1027
2024 {Thematic number} 1030
2025 {Material type} 1031
2033 set l [llength $attr]
2038 for {set i 0} {$i < $l} {incr i} {
2039 $w.top.use.list insert end [lindex $attr $i]
2041 if {$useTmpValue == [lindex $attr $i]} {
2046 $w.top.use.list select from $s
2047 $w.top.use.list select to $s
2052 $w.top.use.list yview $s
2054 set lno [lindex [$w.top.use.list curselection] 0]
2055 set i [expr $lno+$lno+1]
2056 set useTmpValue [lindex $attr $i]
2057 puts "useTmpValue=$useTmpValue"
2061 proc index-setup-action {oldAttr queryNo indexNo} {
2062 set attr [lindex $oldAttr 0]
2065 global relationTmpValue
2066 global structureTmpValue
2067 global truncationTmpValue
2068 global completenessTmpValue
2069 global positionTmpValue
2074 puts "index-setup-action"
2075 puts "queryNo $queryNo"
2076 puts "indexNo $indexNo"
2077 if {$useTmpValue > 0} {
2078 lappend attr "1=$useTmpValue"
2080 if {$relationTmpValue > 0} {
2081 lappend attr "2=$relationTmpValue"
2083 if {$positionTmpValue > 0} {
2084 lappend attr "3=$positionTmpValue"
2086 if {$structureTmpValue > 0} {
2087 lappend attr "4=$structureTmpValue"
2089 if {$truncationTmpValue > 0} {
2090 lappend attr "5=$truncationTmpValue"
2092 if {$completenessTmpValue > 0} {
2093 lappend attr "6=$completenessTmpValue"
2095 puts "new attr $attr"
2096 set queryInfoTmp [lreplace $queryInfoTmp $indexNo $indexNo $attr]
2097 destroy .index-setup
2100 proc index-setup {attr queryNo indexNo} {
2103 global relationTmpValue
2104 global structureTmpValue
2105 global truncationTmpValue
2106 global completenessTmpValue
2107 global positionTmpValue
2109 set relationTmpValue 0
2110 set truncationTmpValue 0
2111 set structureTmpValue 0
2112 set positionTmpValue 0
2113 set completenessTmpValue 0
2116 set len [llength $attr]
2117 for {set i 1} {$i < $len} {incr i} {
2118 set q [lindex $attr $i]
2119 set l [string first = $q]
2121 set t [string range $q 0 [expr $l - 1]]
2122 set v [string range $q [expr $l + 1] end]
2125 { set useTmpValue $v }
2127 { set relationTmpValue $v }
2129 { set positionTmpValue $v }
2131 { set structureTmpValue $v }
2133 { set truncationTmpValue $v }
2135 { set completenessTmpValue $v }
2139 if {[winfo exists $w]} {
2144 set n [lindex $attr 0]
2145 wm title $w "Index setup $n"
2149 frame $w.top.use -relief ridge -border 2
2150 frame $w.top.relation -relief ridge -border 2
2151 frame $w.top.position -relief ridge -border 2
2152 frame $w.top.structure -relief ridge -border 2
2153 frame $w.top.truncation -relief ridge -border 2
2154 frame $w.top.completeness -relief ridge -border 2
2160 pack $w.top.use -side left -pady 6 -padx 6 -fill y
2162 label $w.top.use.label -text "Use"
2163 listbox $w.top.use.list -geometry 26x10 \
2164 -yscrollcommand "$w.top.use.scroll set"
2165 scrollbar $w.top.use.scroll -orient vertical -border 1
2166 pack $w.top.use.label -side top -fill x \
2168 pack $w.top.use.list -side left -fill both -expand yes \
2170 pack $w.top.use.scroll -side right -fill y \
2172 $w.top.use.scroll config -command "$w.top.use.list yview"
2176 # Relation Attributes
2178 pack $w.top.relation -pady 6 -padx 6 -side top
2179 label $w.top.relation.label -text "Relation" -width 18
2181 pack $w.top.relation.label $w.top.relation.b -fill x
2183 # Position Attributes
2185 pack $w.top.position -pady 6 -padx 6 -side top
2186 label $w.top.position.label -text "Position" -width 18
2188 pack $w.top.position.label $w.top.position.b -fill x
2190 # Structure Attributes
2192 pack $w.top.structure -pady 6 -padx 6 -side top
2193 label $w.top.structure.label -text "Structure" -width 18
2195 pack $w.top.structure.label $w.top.structure.b -fill x
2197 # Truncation Attributes
2199 pack $w.top.truncation -pady 6 -padx 6 -side top
2200 label $w.top.truncation.label -text "Truncation" -width 18
2202 pack $w.top.truncation.label $w.top.truncation.b -fill x
2204 # Completeness Attributes
2206 pack $w.top.completeness -pady 6 -padx 6 -side top
2207 label $w.top.completeness.label -text "Completeness" -width 18
2209 pack $w.top.completeness.label $w.top.completeness.b -fill x
2212 bottom-buttons $w [list \
2213 {Ok} [list index-setup-action $attr $queryNo $indexNo] \
2214 {Cancel} [list destroy $w]] 0
2218 proc query-edit-index {queryNo} {
2222 set i [lindex [$w.top.index.list curselection] 0]
2226 set attr [lindex $queryInfoTmp $i]
2227 puts "Editing no $i $attr"
2228 index-setup $attr $queryNo $i
2231 proc query-delete-index {queryNo} {
2233 global queryButtonsTmp
2236 set i [lindex [$w.top.index.list curselection] 0]
2240 set queryInfoTmp [lreplace $queryInfoTmp $i $i]
2241 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
2242 $w.top.index.list delete $i
2245 proc query-setup {queryNo} {
2251 global queryButtonsTmp
2253 global queryIndexTmp
2256 set queryName [lindex $queryTypes $queryNo]
2257 set queryInfoTmp [lindex $queryInfo $queryNo]
2258 set queryButtonsTmp [lindex $queryButtons $queryNo]
2263 wm title $w "Query setup $queryName"
2267 frame $w.top.lines -relief ridge -border 2
2269 pack $w.top.lines -side left -pady 6 -padx 6 -fill y
2273 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
2275 button $w.top.lines.add -text "Add" \
2276 -command [list query-add-line $queryNo]
2277 button $w.top.lines.del -text "Remove" \
2278 -command [list query-del-line $queryNo]
2280 pack $w.top.lines.del -fill x -side bottom
2281 pack $w.top.lines.add -fill x -pady 10 -side bottom
2285 frame $w.top.index -relief ridge -border 2
2286 pack $w.top.index -pady 6 -padx 6 -side right -fill y
2288 listbox $w.top.index.list -yscrollcommand [list $w.top.index.scroll set]
2289 scrollbar $w.top.index.scroll -orient vertical -border 1 \
2290 -command [list $w.top.index.list yview]
2291 bind $w.top.index.list <2> [list query-edit-index $queryNo]
2293 pack $w.top.index.list -side left -fill both -expand yes -padx 2 -pady 2
2294 pack $w.top.index.scroll -side right -fill y -padx 2 -pady 2
2296 $w.top.index.list select from 0
2297 $w.top.index.list select to 0
2299 foreach x $queryInfoTmp {
2300 $w.top.index.list insert end [lindex $x 0]
2303 bottom-buttons $w [list \
2304 {Ok} [list query-setup-action $queryNo] \
2305 {Add index} [list query-add-index $queryNo] \
2306 {Edit index} [list query-edit-index $queryNo] \
2307 {Delete index} [list query-delete-index $queryNo] \
2308 {Cancel} [list destroy $w]] 0
2311 proc index-clear {} {
2312 global queryButtonsFind
2315 foreach b $queryButtonsFind {
2316 .lines.$i.e delete 0 end
2321 proc index-query {} {
2322 global queryButtonsFind
2323 global queryInfoFind
2328 foreach b $queryButtonsFind {
2329 set term [string trim [.lines.$i.e get]]
2331 set attr [lrange [lindex $queryInfoFind [lindex $b 1]] 1 end]
2333 set term "\{${term}\}"
2335 set term "@attr $a ${term}"
2338 set qs "@and ${qs} ${term}"
2349 proc index-focus-in {w i} {
2350 global curIndexEntry
2352 $w.$i configure -background red
2353 set curIndexEntry $i
2356 proc index-lines {w realOp buttonInfo queryInfo handle} {
2358 foreach b $buttonInfo {
2359 if {! [winfo exists $w.$i]} {
2360 frame $w.$i -background white -border 1
2362 listbuttonx $w.$i.l [lindex $b 1] $queryInfo $handle $i
2365 if {! [winfo exists $w.$i.e]} {
2366 entry $w.$i.e -width 32 -relief sunken -border 1
2367 bind $w.$i.e <FocusIn> [list index-focus-in $w $i]
2368 bind $w.$i.e <FocusOut> [list $w.$i configure \
2370 pack $w.$i.l -side left
2371 pack $w.$i.e -side left -fill x -expand yes
2372 pack $w.$i -side top -fill x -padx 2 -pady 2
2373 bind $w.$i.e <Left> [list left-cursor $w.$i.e]
2374 bind $w.$i.e <Right> [list right-cursor $w.$i.e]
2375 bind $w.$i.e <Return> search-request
2378 pack $w.$i.l -side left
2379 pack $w.$i -side top -fill x -padx 2 -pady 2
2384 while {[winfo exists $w.$j]} {
2395 bind $w.$j.e <Tab> "focus $w.$k.e"
2399 bind $w.$i.e <Tab> "focus $w.0.e"
2404 proc search-fields {w buttondefs} {
2406 foreach buttondef $buttondefs {
2407 frame $w.$i -background white
2409 listbutton $w.$i.l 0 $buttondef
2410 entry $w.$i.e -width 32 -relief sunken
2412 pack $w.$i.l -side left
2413 pack $w.$i.e -side left -fill x -expand yes
2415 pack $w.$i -side top -fill x -padx 2 -pady 2
2417 bind $w.$i.e <Left> [list left-cursor $w.$i.e]
2418 bind $w.$i.e <Right> [list right-cursor $w.$i.e]
2426 bind $w.$j.e <Tab> "focus $w.$k.e \n
2427 $w.$k configure -background red \n
2428 $w.$j configure -background white"
2431 bind $w.$i.e <Tab> "focus $w.0.e \n
2432 $w.0 configure -background red \n
2433 $w.$i configure -background white"
2435 $w.0 configure -background red
2438 if {[info exists windowGeometry(.)]} {
2439 set g $windowGeometry(.)
2447 frame .top -border 1 -relief raised
2448 frame .lines -border 1 -relief raised
2449 frame .mid -border 1 -relief raised
2450 frame .data -border 1 -relief raised
2451 frame .bot -border 1 -relief raised
2452 pack .top .lines .mid -side top -fill x
2453 pack .data -side top -fill both -expand yes
2456 menubutton .top.file -text "File" -underline 0 -menu .top.file.m
2458 .top.file.m add command -label "Save settings" -command {save-settings}
2459 .top.file.m add separator
2460 .top.file.m add command -label "Exit" -command {exit-action}
2462 menubutton .top.target -text "Target" -underline 0 -menu .top.target.m
2464 .top.target.m add cascade -label "Connect" -menu .top.target.m.clist
2465 .top.target.m add command -label "Disconnect" -command {close-target}
2466 .top.target.m add command -label "About" -command {about-target}
2467 .top.target.m add cascade -label "Setup" -menu .top.target.m.slist
2468 .top.target.m add command -label "Setup new" -command {define-target-dialog}
2469 .top.target.m add separator
2472 .top.target.m disable 1
2473 .top.target.m disable 2
2475 menu .top.target.m.clist
2476 menu .top.target.m.slist
2479 menubutton .top.service -text "Service" -underline 0 -menu .top.service.m
2481 .top.service.m add command -label "Database" -command {database-select}
2482 .top.service.m add cascade -label "Present" -menu .top.service.m.present
2483 menu .top.service.m.present
2484 .top.service.m.present add command -label "10 More" \
2485 -command [list present-more 10]
2486 .top.service.m.present add command -label "All" \
2487 -command [list present-more {}]
2488 .top.service.m add command -label "Search" -command {search-request}
2489 .top.service.m add command -label "Scan" -command {scan-request}
2491 .top.service configure -state disabled
2493 menubutton .top.rset -text "Set" -menu .top.rset.m
2495 .top.rset.m add command -label "Load" -command {load-set}
2496 .top.rset.m add separator
2498 menubutton .top.options -text "Options" -underline 0 -menu .top.options.m
2500 .top.options.m add cascade -label "Query" -menu .top.options.m.query
2501 .top.options.m add cascade -label "Format" -menu .top.options.m.formats
2502 .top.options.m add cascade -label "Wrap" -menu .top.options.m.wrap
2504 menu .top.options.m.query
2505 .top.options.m.query add cascade -label "Select" \
2506 -menu .top.options.m.query.clist
2507 .top.options.m.query add cascade -label "Edit" \
2508 -menu .top.options.m.query.slist
2509 .top.options.m.query add command -label "New" \
2510 -command {query-new}
2511 .top.options.m.query add cascade -label "Delete" \
2512 -menu .top.options.m.query.dlist
2514 menu .top.options.m.query.slist
2515 menu .top.options.m.query.clist
2516 menu .top.options.m.query.dlist
2519 menu .top.options.m.formats
2521 foreach f $displayFormats {
2522 .top.options.m.formats add radiobutton -label $f -value $i \
2523 -command [list set-display-format $i] -variable displayFormat
2527 menu .top.options.m.wrap
2528 .top.options.m.wrap add radiobutton -label "Character" \
2529 -value char -variable textWrap -command {set-wrap char}
2530 .top.options.m.wrap add radiobutton -label "Word" \
2531 -value word -variable textWrap -command {set-wrap word}
2532 .top.options.m.wrap add radiobutton -label "None" \
2533 -value none -variable textWrap -command {set-wrap none}
2535 menubutton .top.help -text "Help" -menu .top.help.m
2538 .top.help.m add command -label "Help on help" \
2539 -command {tkerror "Help on help not available. Sorry"}
2540 .top.help.m add command -label "About" -command {about-origin}
2542 pack .top.file .top.target .top.service .top.rset .top.options -side left
2543 pack .top.help -side right
2545 index-lines .lines 1 $queryButtonsFind [lindex $queryInfo 0] activate-index
2547 button .mid.search -width 7 -text {Search} -command search-request \
2549 button .mid.scan -width 7 -text {Scan} \
2550 -command scan-request -state disabled
2551 button .mid.present -width 7 -text {Present} -command [list present-more 10] \
2554 button .mid.clear -width 7 -text {Clear} -command index-clear
2555 pack .mid.search .mid.scan .mid.present .mid.clear -side left \
2556 -fill y -padx 5 -pady 3
2558 text .data.record -height 2 -width 20 -wrap none \
2559 -yscrollcommand [list .data.scroll set] -wrap $textWrap
2560 scrollbar .data.scroll -command [list .data.record yview]
2561 pack .data.scroll -side right -fill y
2562 pack .data.record -expand yes -fill both
2565 if {[tk colormodel .] == "color"} {
2566 .data.record tag configure marc-tag -foreground blue
2567 .data.record tag configure marc-id -foreground red
2569 .data.record tag configure marc-tag -foreground black
2570 .data.record tag configure marc-id -foreground black
2572 .data.record tag configure marc-data -foreground black
2574 button .bot.logo -bitmap @book1 -command cancel-operation
2576 pack .bot.a -side left -fill x
2577 pack .bot.logo -side right -padx 2 -pady 2
2579 message .bot.a.target -text "" -aspect 1000 -border 1
2581 label .bot.a.status -text "Not connected" -width 15 -relief \
2582 sunken -anchor w -border 1
2583 label .bot.a.set -text "" -width 5 -relief \
2584 sunken -anchor w -border 1
2585 label .bot.a.message -text "" -width 15 -relief \
2586 sunken -anchor w -border 1
2588 pack .bot.a.target -side top -anchor nw -padx 2 -pady 2
2589 pack .bot.a.status .bot.a.set .bot.a.message \
2590 -side left -padx 2 -pady 2
2592 #bind . <Any-Enter> {focus .lines.0.e}
2596 #.top.options.m.formats invoke $displayFormat