1 # IR toolkit for tcl/tk
3 # See the file LICENSE for details.
4 # Sebastian Hammer, Adam Dickmeiss
7 # Revision 1.37 1995-06-13 14:37:59 adam
9 # Better about origin/target.
10 # Better presentation formats.
12 # Revision 1.36 1995/06/13 07:42:14 adam
13 # Bindings removed from text widgets.
15 # Revision 1.35 1995/06/12 15:17:31 adam
16 # Text widget used in main window (instead of listbox) to support
17 # better presentation formats.
19 # Revision 1.34 1995/06/12 07:59:07 adam
20 # More work on geometry handling.
22 # Revision 1.33 1995/06/09 11:17:35 adam
23 # Start work on geometry management.
25 # Revision 1.32 1995/06/07 09:16:37 adam
26 # New presentation format.
28 # Revision 1.31 1995/06/06 16:31:09 adam
29 # Bug fix: target names couldn't contain blanks.
32 # Revision 1.30 1995/06/06 11:35:41 adam
33 # Work on scan. Display of old sets.
35 # Revision 1.29 1995/06/05 14:11:18 adam
36 # Bug fix in present-more.
38 # Revision 1.28 1995/06/02 14:52:13 adam
39 # Minor changes really.
41 # Revision 1.27 1995/06/02 14:29:42 adam
42 # Work on scan interface - up/down buttons.
44 # Revision 1.26 1995/06/01 16:36:46 adam
45 # About buttons. Minor bug fixes.
47 # Revision 1.25 1995/05/31 13:09:57 adam
48 # Client searches/presents may be interrupted.
49 # New moving book-logo.
51 # Revision 1.24 1995/05/31 08:36:24 adam
52 # Bug fix in client.tcl: didn't save options on clientrc.tcl.
53 # New method: referenceId. More work on scan.
55 # Revision 1.23 1995/05/29 10:33:41 adam
56 # README and rename of startup script.
58 # Revision 1.22 1995/05/26 11:44:09 adam
59 # Bugs fixed. More work on MARC utilities and queries. Test
60 # client is up-to-date again.
62 # Revision 1.21 1995/05/11 15:34:46 adam
63 # Scan request changed a bit. This version works with RLG.
65 # Revision 1.20 1995/04/21 16:31:57 adam
66 # New radiobutton: protocol (z39v2/SR).
68 # Revision 1.19 1995/04/18 16:11:50 adam
69 # First version of graphical Scan. Some work on query-by-form.
71 # Revision 1.18 1995/04/10 10:50:22 adam
72 # Result-set name defaults to suffix of ir-set name.
73 # Started working on scan. Not finished at this point.
75 # Revision 1.17 1995/03/31 09:34:57 adam
76 # Search-button disabled when there is no connection.
78 # Revision 1.16 1995/03/31 08:56:36 adam
79 # New button "Search".
81 # Revision 1.15 1995/03/28 12:45:22 adam
82 # New ir method failback: called on disconnect/protocol error.
83 # New ir set/get method: protocol: SR / Z3950.
84 # Simple popup and disconnect when failback is invoked.
86 # Revision 1.14 1995/03/22 16:07:55 adam
89 # Revision 1.13 1995/03/21 17:27:26 adam
90 # Short-hand keys in setup.
92 # Revision 1.12 1995/03/21 13:41:03 adam
93 # Comstack cs_create not used too often. Non-blocking connect.
95 # Revision 1.11 1995/03/21 10:39:06 adam
96 # Diagnostic error message displayed with tkerror.
98 # Revision 1.10 1995/03/20 15:24:06 adam
99 # Diagnostic records saved on searchResponse.
101 # Revision 1.9 1995/03/17 18:26:16 adam
102 # Non-blocking i/o used now. Database names popup as cascade items.
104 # Revision 1.8 1995/03/17 15:45:00 adam
105 # Improved target/database setup.
107 # Revision 1.7 1995/03/16 17:54:03 adam
108 # Minor changes really.
110 # Revision 1.6 1995/03/15 19:10:20 adam
111 # Database setup in protocol-setup (rather target setup).
113 # Revision 1.5 1995/03/15 13:59:23 adam
116 # Revision 1.4 1995/03/14 17:32:29 adam
117 # Presentation of full Marc record in popup window.
119 # Revision 1.3 1995/03/12 19:31:52 adam
120 # Pattern matching implemented when retrieving MARC records. More
121 # diagnostic functions.
123 # Revision 1.2 1995/03/10 18:00:15 adam
124 # Actual presentation in line-by-line format. RPN query support.
126 # Revision 1.1 1995/03/09 16:15:07 adam
127 # First presentRequest attempts. Hot-target list.
134 set profile(Default) {{} {} {210} {} 16384 8192 tcpip {} 1 {} {} z39v2}
136 set settingsChanged 0
144 set queryTypes {Simple}
145 set queryButtons { { {I 0} {I 1} {I 2} } }
146 set queryInfo { { {Title {1=4 4=1}} {Author {1=1}} \
147 {Subject {1=21}} {Any {1=1016}} } }
150 proc read-formats {} {
151 global displayFormats
152 set formats [glob -nocomplain formats/*.tcl]
155 set l [expr [string length $f] - 5]
156 lappend displayFormats [string range $f 8 $l]
160 proc set-display-format {f} {
168 add-title-lines 0 10000 1
171 proc initBindings {} {
174 bind $w <Double-1> {}
175 bind $w <Triple-1> {}
176 bind $w <B1-Motion> {}
178 bind $w <Shift-B1-Motion> {}
180 bind $w <B2-Motion> {}
181 bind $w <Any-KeyPress> {}
183 bind $w <BackSpace> {}
185 bind $w <Control-h> {}
186 bind $w <Control-d> {}
187 bind $w <Control-v> {}
190 bind $w <B1-Motion> {}
191 bind $w <Shift-B1-Motion> {}
195 global windowGeometry
196 set windowGeometry($w) [wm geometry $w]
199 global windowGeometry
202 if {[info exists windowGeometry($w)]} {
203 set g $windowGeometry($w)
208 bind $w <Destroy> [list destroyGW $w]
211 if {[file readable "clientrc.tcl"]} {
212 source "clientrc.tcl"
215 if {[file readable "clientg.tcl"]} {
219 set queryButtonsFind [lindex $queryButtons 0]
220 set queryInfoFind [lindex $queryInfo 0]
222 proc top-down-window {w} {
223 frame $w.top -relief raised -border 1
224 frame $w.bot -relief raised -border 1
226 pack $w.top -side top -fill both -expand yes
227 pack $w.bot -fill both
230 proc top-down-ok-cancel {w ok-action g} {
231 frame $w.bot.left -relief sunken -border 1
232 pack $w.bot.left -side left -expand yes -ipadx 2 -ipady 2 -padx 5 -pady 5
233 button $w.bot.left.ok -width 6 -text {Ok} \
234 -command ${ok-action}
235 pack $w.bot.left.ok -expand yes -ipadx 2 -ipady 2 -padx 3 -pady 3
236 button $w.bot.cancel -width 6 -text {Cancel} \
237 -command [list destroy $w]
238 pack $w.bot.cancel -side left -expand yes
246 proc bottom-buttons {w buttonList g} {
248 set l [llength $buttonList]
250 frame $w.bot.$i -relief sunken -border 1
251 pack $w.bot.$i -side left -expand yes -padx 5 -pady 5
252 button $w.bot.$i.ok -text [lindex $buttonList $i] \
253 -command [lindex $buttonList [expr $i+1]]
254 pack $w.bot.$i.ok -expand yes -ipadx 3 -ipady 2 -padx 3 -pady 3 -side left
258 button $w.bot.$i -text [lindex $buttonList $i] \
259 -command [lindex $buttonList [expr $i+1]]
260 pack $w.bot.$i -expand yes -ipadx 2 -ipady 2 -padx 3 -pady 3 -side left
270 proc cancel-operation {} {
276 show-status Cancelled 0 {}
280 proc show-target {target} {
281 .bot.a.target configure -text "$target"
284 proc show-logo {v1} {
291 .bot.logo configure -bitmap @book${v1}
292 after 140 [list show-logo $v1]
296 .bot.logo configure -bitmap @book1
305 proc show-status {status b sb} {
309 .bot.a.status configure -text "$status"
311 if {$busy == 0} {set busy 1}
319 .top.service configure -state normal
320 .mid.search configure -state normal
321 .mid.scan configure -state normal
322 .mid.present configure -state normal
323 if {[winfo exists .scan-window]} {
324 .scan-window.bot.2 configure -state normal
325 .scan-window.bot.4 configure -state normal
329 .top.service configure -state disabled
330 .mid.search configure -state disabled
331 .mid.scan configure -state disabled
332 .mid.present configure -state disabled
334 if {[winfo exists .scan-window]} {
335 .scan-window.bot.2 configure -state disabled
336 .scan-window.bot.4 configure -state disabled
342 proc show-message {msg} {
343 .bot.a.message configure -text "$msg"
346 proc insertWithTags {w text args} {
347 set start [$w index insert]
348 $w insert insert $text
349 foreach tag [$w tag names $start] {
350 $w tag remove $tag $start insert
353 $w tag add $i $start insert
357 proc about-target {} {
358 set w .about-target-w
363 wm title $w "About target"
366 frame $w.top.a -relief ridge -border 2
367 frame $w.top.p -relief ridge -border 2
369 pack $w.top.a $w.top.p -side top -fill x
371 label $w.top.a.about -text "About"
372 label $w.top.a.irtcl -text $hostid \
373 -font -Adobe-Helvetica-Bold-R-Normal-*-240-*
374 pack $w.top.a.about $w.top.a.irtcl -side top
376 set i [z39 targetImplementationName]
377 label $w.top.p.in -text "Implementation name: $i"
378 set i [z39 targetImplementationId]
379 label $w.top.p.ii -text "Implementation id: $i"
380 set i [z39 targetImplementationVersion]
381 label $w.top.p.iv -text "Implementation version: $i"
383 label $w.top.p.op -text "Protocol options: $i"
385 pack $w.top.p.in $w.top.p.ii $w.top.p.iv $w.top.p.op -side top -anchor nw
387 bottom-buttons $w [list {Close} [list destroy $w]] 1
390 proc about-origin {} {
391 set w .about-origin-w
395 wm title $w "About IrTcl"
399 frame $w.top.a -relief ridge -border 2
400 frame $w.top.p -relief ridge -border 2
402 pack $w.top.a $w.top.p -side top -fill x
404 label $w.top.a.about -text "About"
405 label $w.top.a.irtcl -text "IrTcl" \
406 -font -Adobe-Helvetica-Bold-R-Normal-*-240-*
407 pack $w.top.a.about $w.top.a.irtcl -side top
409 set i [z39 implementationName]
410 label $w.top.p.in -text "Implementation name: $i"
411 set i [z39 implementationId]
412 label $w.top.p.ii -text "Implementation id: $i"
414 pack $w.top.p.in $w.top.p.ii -side top -anchor nw
416 bottom-buttons $w [list {Close} [list destroy $w]] 1
419 proc popup-marc {sno no b df} {
421 global displayFormats
424 if {[z39.$sno type $no] != "DB"} {
428 set w .full-marc-$fullMarcSeq
433 if {[winfo exists $w]} {
441 frame $w.top -relief raised -border 1
442 frame $w.bot -relief raised -border 1
444 pack $w.top -side top -fill both -expand yes
445 pack $w.bot -fill both
447 text $w.top.record -width 60 -height 5 -wrap word \
448 -yscrollcommand [list $w.top.s set]
449 scrollbar $w.top.s -command [list $w.top.record yview]
451 if {[tk colormodel .] == "color"} {
452 $w.top.record tag configure marc-tag -foreground blue
453 $w.top.record tag configure marc-id -foreground red
455 $w.top.record tag configure marc-tag -foreground black
456 $w.top.record tag configure marc-id -foreground black
458 $w.top.record tag configure marc-data -foreground black
461 $w.top.record delete 0.0 end
462 wm title $w "Record #$no"
464 set ffunc [lindex $displayFormats $df]
465 set ffunc "display-$ffunc"
467 $ffunc $sno $no $w.top.record 0
470 bind $w.top.record <Return> {destroy .full-marc}
472 pack $w.top.s -side right -fill y
473 pack $w.top.record -expand yes -fill both
476 bottom-buttons $w [list \
477 {Close} [list destroy $w] \
478 {Duplicate} [list popup-marc $sno $no 1 $df]] 0
479 menubutton $w.bot.formats -text "Format" -menu $w.bot.formats.m
480 menu $w.bot.formats.m
482 foreach f $displayFormats {
483 $w.bot.formats.m add radiobutton -label $f \
484 -command [list display-$f $sno $no $w.top.record 0]
487 pack $w.bot.formats -expand yes -ipadx 2 -ipady 2 \
488 -padx 3 -pady 3 -side left
490 bottom-buttons $w [list \
491 {Close} [list destroy $w] \
492 {Duplicate} [list popup-marc $sno $no 1 $df]] 0
493 menubutton $w.bot.formats -text "Format" -menu $w.bot.formats.m
494 menu $w.bot.formats.m
496 foreach f $displayFormats {
497 $w.bot.formats.m add radiobutton -label $f \
498 -command [list display-$f $sno $no $w.top.record 0]
501 pack $w.bot.formats -expand yes -ipadx 2 -ipady 2 \
502 -padx 3 -pady 3 -side left
506 foreach f $displayFormats {
507 $w.bot.formats.m entryconfigure $i \
508 -command [list display-$f $sno $no $w.top.record 0]
514 proc update-target-hotlist {target} {
517 set len [llength $hotTargets]
519 .top.target.m delete 6 [expr 6+[llength $hotTargets]]
521 set indx [lsearch $hotTargets $target]
523 set hotTargets [lreplace $hotTargets $indx $indx]
525 set hotTargets [linsert $hotTargets 0 $target]
529 proc set-target-hotlist {} {
533 foreach target $hotTargets {
534 .top.target.m add command -label "$i $target" -command \
535 [list reopen-target $target {}]
543 proc reopen-target {target base} {
545 open-target $target $base
546 update-target-hotlist $target
549 proc define-target-action {} {
552 set target [.target-define.top.target.entry get]
556 update-target-hotlist $target
557 foreach n [array names profile] {
563 set seq [lindex $profile(Default) 12]
565 set profile($target) $profile(Default)
566 set profile(Default) [lreplace $profile(Default) 12 12 [incr seq]]
568 protocol-setup $target
569 destroy .target-define
572 proc fail-response {target} {
574 tkerror "Target connection closed or protocol error"
577 proc connect-response {target} {
578 puts "connect-response"
583 proc open-target {target base} {
588 z39 comstack [lindex $profile($target) 6]
589 z39 idAuthentication [lindex $profile($target) 3]
590 z39 maximumRecordSize [lindex $profile($target) 4]
591 z39 preferredMessageSize [lindex $profile($target) 5]
592 puts -nonewline "maximumRecordSize="
593 puts [z39 maximumRecordSize]
594 puts -nonewline "preferredMessageSize="
595 puts [z39 preferredMessageSize]
596 show-status {Connecting} 0 0
598 z39 databaseNames [lindex [lindex $profile($target) 7] 0]
600 z39 databaseNames $base
602 z39 failback [list fail-response $target]
603 z39 callback [list connect-response $target]
604 z39 connect [lindex $profile($target) 1]:[lindex $profile($target) 2]
605 # z39 options search present scan namedResultSets triggerResourceCtrl
606 show-status {Connecting} 1 {}
608 .top.target.m disable 0
609 .top.target.m enable 1
610 .top.target.m enable 2
613 proc close-target {} {
621 show-status {Not connected} 0 0
623 .top.target.m disable 1
624 .top.target.m disable 2
625 .top.target.m enable 0
628 proc load-set-action {} {
632 ir-set z39.$setNo z39
634 set fname [.load-set.top.filename.entry get]
637 show-status {Loading} 1 {}
638 z39.$setNo loadFile $fname
640 set no [z39.$setNo numberOfRecordsReturned]
641 add-title-lines $setNo $no 1
643 set l [format "%-4d %7d" $setNo $no]
644 .top.rset.m add command -label $l \
645 -command [list add-title-lines $setNo 10000 1]
646 show-status {Ready} 0 {}
659 frame $w.top.filename
661 pack $w.top.filename -side top -anchor e -pady 2
663 entry-fields $w.top {filename} \
665 {load-set-action} {destroy .load-set}
667 top-down-ok-cancel $w {load-set-action} 1
671 proc init-request {} {
679 z39 callback {init-response}
680 show-status {Initializing} 1 {}
684 proc init-response {} {
691 show-status {Ready} 0 1
692 if {![z39 initResult]} {
693 set u [z39 userInformationField]
695 tkerror "Connection rejected by target: $u"
699 proc search-request {} {
709 if {$searchEnable == 0} {
712 set query [index-query]
717 ir-set z39.$setNo z39
719 if {[lindex $profile($target) 10] == 1} {
720 z39.$setNo setName $setNo
721 puts "setName=${setNo}"
723 z39.$setNo setName Default
724 puts "setName=Default"
726 if {[lindex $profile($target) 8] == 1} {
727 z39.$setNo queryType rpn
729 if {[lindex $profile($target) 9] == 1} {
730 z39.$setNo queryType ccl
732 z39 callback {search-response}
733 z39.$setNo search $query
734 show-status {Search} 1 0
737 proc scan-request {} {
745 global queryButtonsFind
752 set b [lindex $queryButtonsFind $curIndexEntry]
754 foreach a [lrange [lindex $queryInfoFind [lindex $b 1]] 1 end] {
755 set attr "@attr $a $attr"
759 if {![winfo exists $w]} {
768 entry $w.top.entry -relief sunken
769 pack $w.top.entry -fill x -padx 4 -pady 2
770 bind $w.top.entry <KeyRelease> [list scan-term-h $attr]
772 listbox $w.top.list -yscrollcommand [list $w.top.scroll set] \
774 scrollbar $w.top.scroll -orient vertical -border 1
775 pack $w.top.list -side left -fill both -expand yes
776 pack $w.top.scroll -side right -fill y
777 $w.top.scroll config -command [list $w.top.list yview]
779 listbox $w.top.list -font fixed -geometry 60x14
780 pack $w.top.list -side left -fill both -expand yes
783 bottom-buttons $w [list {Close} [list destroy $w] \
784 {Up} [list scan-up $attr] \
785 {Down} [list scan-down $attr]] 0
786 bind $w.top.list <Up> [list scan-up $attr]
787 bind $w.top.list <Down> [list scan-down $attr]
789 # bind $w.top <Any-Enter> [list focus $w.top.entry]
791 z39 callback [list scan-response $attr 0 35]
792 z39.scan numberOfTermsRequested 5
793 z39.scan preferredPositionInResponse 1
794 z39.scan scan "${attr} 0"
796 show-status {Scan} 1 0
799 proc scan-term-h {attr} {
807 set nScanTerm [$w.top.entry get]
808 if {$nScanTerm == $scanTerm} {
811 set scanTerm $nScanTerm
812 z39 callback [list scan-response $attr 0 35]
813 z39.scan numberOfTermsRequested 5
814 z39.scan preferredPositionInResponse 1
815 puts "${attr} \{${scanTerm}\}"
816 if {$scanTerm == ""} {
817 z39.scan scan "${attr} 0"
819 z39.scan scan "${attr} \{${scanTerm}\}"
821 show-status {Scan} 1 0
824 proc scan-response {attr start toget} {
830 puts "In scan-response"
831 set m [z39.scan numberOfEntriesReturned]
837 if {![winfo exists .scan-window]} {
838 show-status {Ready} 0 1
842 set nScanTerm [$w.top.entry get]
843 if {$nScanTerm != $scanTerm} {
844 z39 callback [list scan-response $attr 0 35]
845 z39.scan numberOfTermsRequested 5
846 z39.scan preferredPositionInResponse 1
847 set scanTerm $nScanTerm
848 puts "${attr} \{${scanTerm}\}"
849 if {$scanTerm == ""} {
850 z39.scan scan "${attr} 0"
852 z39.scan scan "${attr} \{${scanTerm}\}"
854 show-status {Scan} 1 0
857 set status [z39.scan scanStatus]
860 show-status {Ready} 0 1
865 for {set i 0} {$i < $m} {incr i} {
866 set term [lindex [z39.scan scanLine $i] 1]
867 set nostr [format " %-6d" [lindex [z39.scan scanLine $i] 2]]
868 $w.top.list insert $i "$nostr $term"
871 $w.top.list yview $scanView
873 $w.top.list delete $start end
874 for {set i 0} {$i < $m} {incr i} {
875 set term [lindex [z39.scan scanLine $i] 1]
876 set nostr [format " %-6d" [lindex [z39.scan scanLine $i] 2]]
877 $w.top.list insert end "$nostr $term"
881 show-status {Ready} 0 1
885 if {$toget > 0 && $m > 1 && $m < $toget} {
886 set ntoget [expr $toget - $m + 1]
888 z39 callback [list scan-response $attr [expr $start + $m - 1] $ntoget]
890 puts "down continue: $q"
892 z39.scan numberOfTermsRequested 10
894 z39.scan numberOfTermsRequested $ntoget
896 z39.scan preferredPositionInResponse 1
897 puts "${attr} \{$q\}"
898 z39.scan scan "${attr} \{$q\}"
901 if {$toget < 0 && $m > 1 && $m < [expr - $toget]} {
902 set ntoget [expr - $toget - $m]
904 z39 callback [list scan-response $attr 0 -$ntoget]
905 set q [string range [$w.top.list get 0] 8 end]
906 puts "up continue: $q"
908 z39.scan numberOfTermsRequested 10
909 z39.scan preferredPositionInResponse 11
911 z39.scan numberOfTermsRequested $ntoget
912 z39.scan preferredPositionInResponse [incr ntoget]
914 puts "${attr} \{$q\}"
915 z39.scan scan "${attr} \{$q\}"
918 show-status {Ready} 0 1
921 proc scan-down {attr} {
925 set scanView [expr $scanView + 5]
926 set s [$w.top.list size]
927 if {$scanView > $s} {
928 z39 callback [list scan-response $attr [expr $s - 1] 25]
929 set q [string range [$w.top.list get [expr $s - 1]] 8 end]
931 z39.scan numberOfTermsRequested 10
932 z39.scan preferredPositionInResponse 1
933 show-status {Scan} 1 0
934 puts "${attr} \{$q\}"
935 z39.scan scan "${attr} \{$q\}"
938 $w.top.list yview $scanView
941 proc scan-up {attr} {
945 set scanView [expr $scanView - 5]
947 z39 callback [list scan-response $attr 0 -25]
948 set q [string range [$w.top.list get 0] 8 end]
950 z39.scan numberOfTermsRequested 10
951 z39.scan preferredPositionInResponse 11
952 show-status {Scan} 1 0
953 z39.scan scan "${attr} \{$q\}"
956 $w.top.list yview $scanView
959 proc search-response {} {
966 puts "In search-response"
968 show-status {Ready} 0 1
969 set setMax [z39.$setNo resultCount]
970 show-message "${setMax} hits"
971 set l [format "%-4d %7d" $setNo $setMax]
972 .top.rset.m add command -label $l \
973 -command [list add-title-lines $setNo 10000 1]
975 set status [z39.$setNo responseStatus]
976 if {[lindex $status 0] == "NSD"} {
977 set code [lindex $status 1]
978 set msg [lindex $status 2]
979 set addinfo [lindex $status 3]
980 tkerror "NSD$code: $msg: $addinfo"
992 z39 callback {present-response}
993 z39.$setNo present $setOffset 1
994 show-status {Retrieve} 1 0
997 proc present-more {number} {
1002 puts "setOffset=$setOffset"
1008 set max [z39.$setNo resultCount]
1009 if {$max <= $setOffset} {
1011 puts "setOffset=$setOffset"
1014 if {$number == ""} {
1018 if {$setMax > $max} {
1022 z39 callback {present-response}
1024 set toGet [expr $setMax - $setOffset + 1]
1031 z39.$setNo present $setOffset $toGet
1032 show-status {Retrieve} 1 0
1035 proc init-title-lines {} {
1036 .data.record delete 0.0 end
1039 proc title-press {y setno} {
1040 show-full-marc $setno [expr 1 + [.data.list nearest $y]] 0
1043 proc add-title-lines {setno no offset} {
1044 global displayFormats
1045 global displayFormat
1049 set setno $lastSetNo
1051 set lastSetNo $setno
1054 .bot.a.set configure -text $setno
1055 .data.record delete 0.0 end
1057 set ffunc [lindex $displayFormats $displayFormat]
1058 set ffunc "display-$ffunc"
1059 for {set i 0} {$i < $no} {incr i} {
1060 set o [expr $i + $offset]
1061 set type [z39.$setno type $o]
1065 .data.record tag bind r$o <Any-Enter> {}
1066 .data.record tag bind r$o <Any-Leave> {}
1067 set insert0 [.data.record index insert]
1068 $ffunc $setno $o .data.record 1
1069 .data.record tag add r$o $insert0 insert
1070 .data.record tag bind r$o <1> \
1071 [list popup-marc $setno $o 0 $displayFormat]
1075 proc present-response {} {
1081 puts "In present-response"
1082 set no [z39.$setNo numberOfRecordsReturned]
1083 puts "Returned $no records, setOffset $setOffset"
1084 add-title-lines $setNo $no $setOffset
1085 set setOffset [expr $setOffset + $no]
1086 set status [z39.$setNo responseStatus]
1087 if {[lindex $status 0] == "NSD"} {
1088 show-status {Ready} 0 1
1089 set code [lindex $status 1]
1090 set msg [lindex $status 2]
1091 set addinfo [lindex $status 3]
1092 tkerror "NSD$code: $msg: $addinfo"
1096 show-status {Ready} 0 1
1100 if {$no > 0 && $setOffset <= $setMax} {
1101 puts "present-request from ${setOffset}"
1102 set toGet [expr $setMax - $setOffset + 1]
1106 z39.$setNo present $setOffset $toGet
1108 show-status {Finished} 0 1
1112 proc left-cursor {w} {
1113 set i [$w index insert]
1120 proc right-cursor {w} {
1121 set i [$w index insert]
1126 proc bind-fields {list returnAction escapeAction} {
1127 set max [expr [llength $list]-1]
1128 for {set i 0} {$i < $max} {incr i} {
1129 bind [lindex $list $i] <Return> $returnAction
1130 bind [lindex $list $i] <Escape> $escapeAction
1131 bind [lindex $list $i] <Tab> [list focus [lindex $list [expr $i+1]]]
1132 bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
1133 bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
1135 bind [lindex $list $i] <Return> $returnAction
1136 bind [lindex $list $i] <Escape> $escapeAction
1137 bind [lindex $list $i] <Tab> [list focus [lindex $list 0]]
1138 bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
1139 bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
1140 focus [lindex $list 0]
1143 proc entry-fields {parent list tlist returnAction escapeAction} {
1146 foreach field $list {
1147 set label ${parent}.${field}.label
1148 set entry ${parent}.${field}.entry
1149 label $label -text [lindex $tlist $i] -anchor e
1150 entry $entry -width 32 -relief sunken
1151 pack $label -side left
1152 pack $entry -side right
1153 lappend alist $entry
1156 bind-fields $alist $returnAction $escapeAction
1159 proc define-target-dialog {} {
1160 set w .target-define
1166 pack $w.top.target \
1167 -side top -anchor e -pady 2
1168 entry-fields $w.top {target} \
1170 {define-target-action} {destroy .target-define}
1171 top-down-ok-cancel $w {define-target-action} 1
1174 proc protocol-setup-action {target} {
1177 global protocolRadioType
1178 global settingsChanged
1181 global ResultSetCheck
1183 set wno [lindex $profile($target) 12]
1187 set settingsChanged 1
1188 set len [$w.top.databases.list size]
1189 for {set i 0} {$i < $len} {incr i} {
1190 lappend b [$w.top.databases.list get $i]
1192 set profile($target) [list [$w.top.description.entry get] \
1193 [$w.top.host.entry get] \
1194 [$w.top.port.entry get] \
1195 [$w.top.idAuthentication.entry get] \
1196 [$w.top.maximumRecordSize.entry get] \
1197 [$w.top.preferredMessageSize.entry get] \
1203 $protocolRadioType \
1207 puts $profile($target)
1211 proc place-force {window parent} {
1212 set g [wm geometry $parent]
1214 set p1 [string first + $g]
1215 set p2 [string last + $g]
1217 set x [expr 40+[string range $g [expr $p1 +1] [expr $p2 -1]]]
1218 set y [expr 60+[string range $g [expr $p2 +1] end]]
1219 wm geometry $window +${x}+${y}
1222 proc add-database-action {target} {
1225 set wno [lindex $profile($target) 12]
1228 $w.top.databases.list insert end \
1229 [.database-select.top.database.entry get]
1230 destroy .database-select
1233 proc add-database {target} {
1236 set w .database-select
1238 set oldFocus [focus]
1241 set wno [lindex $profile($target) 12]
1242 place-force $w .setup-${wno}
1246 frame $w.top.database
1248 pack $w.top.database -side top -anchor e -pady 2
1250 entry-fields $w.top {database} \
1251 {{Database to add:}} \
1252 [list add-database-action $target] {destroy .database-select}
1254 top-down-ok-cancel $w [list add-database-action $target] 1
1258 proc delete-database {target} {
1261 set wno [lindex $profile($target) 12]
1264 foreach i [lsort -decreasing \
1265 [$w.top.databases.list curselection]] {
1266 $w.top.databases.list delete $i
1270 proc protocol-setup {target} {
1273 global protocolRadioType
1276 global ResultSetCheck
1278 set wno [lindex $profile($target) 12]
1283 wm title $w "Setup $target"
1287 if {$target == ""} {
1291 puts $profile($target)
1295 frame $w.top.description
1296 frame $w.top.idAuthentication
1297 frame $w.top.maximumRecordSize
1298 frame $w.top.preferredMessageSize
1299 frame $w.top.cs-type -relief ridge -border 2
1300 frame $w.top.protocol -relief ridge -border 2
1301 frame $w.top.query -relief ridge -border 2
1302 frame $w.top.databases -relief ridge -border 2
1304 # Maximum/preferred/idAuth ...
1305 pack $w.top.description $w.top.host $w.top.port \
1306 $w.top.idAuthentication $w.top.maximumRecordSize \
1307 $w.top.preferredMessageSize -side top -anchor e -pady 2
1309 entry-fields $w.top {description host port idAuthentication \
1310 maximumRecordSize preferredMessageSize} \
1311 {{Description:} {Host:} {Port:} {Id Authentication:} \
1312 {Maximum Record Size:} {Preferred Message Size:}} \
1313 [list protocol-setup-action $target] [list destroy $w]
1315 foreach sub {description host port idAuthentication \
1316 maximumRecordSize preferredMessageSize} {
1318 bind $w.top.$sub.entry <Control-a> [list add-database $target]
1319 bind $w.top.$sub.entry <Control-d> [list delete-database $target]
1321 $w.top.description.entry insert 0 [lindex $profile($target) 0]
1322 $w.top.host.entry insert 0 [lindex $profile($target) 1]
1323 $w.top.port.entry insert 0 [lindex $profile($target) 2]
1324 $w.top.idAuthentication.entry insert 0 [lindex $profile($target) 3]
1325 $w.top.maximumRecordSize.entry insert 0 [lindex $profile($target) 4]
1326 $w.top.preferredMessageSize.entry insert 0 [lindex $profile($target) 5]
1327 set csRadioType [lindex $profile($target) 6]
1328 set RPNCheck [lindex $profile($target) 8]
1329 set CCLCheck [lindex $profile($target) 9]
1330 set ResultSetCheck [lindex $profile($target) 10]
1331 set protocolRadioType [lindex $profile($target) 11]
1332 if {$protocolRadioType == ""} {
1333 set protocolRadioType z39v2
1337 pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill both
1339 label $w.top.databases.label -text "Databases"
1340 button $w.top.databases.add -text "Add" \
1341 -command [list add-database $target]
1342 button $w.top.databases.delete -text "Delete" \
1343 -command [list delete-database $target]
1344 listbox $w.top.databases.list -geometry 20x6 \
1345 -yscrollcommand "$w.top.databases.scroll set"
1346 scrollbar $w.top.databases.scroll -orient vertical -border 1
1347 pack $w.top.databases.label -side top -fill x \
1349 pack $w.top.databases.add $w.top.databases.delete -side top -fill x \
1351 pack $w.top.databases.list -side left -fill both -expand yes \
1353 pack $w.top.databases.scroll -side right -fill y \
1355 $w.top.databases.scroll config -command "$w.top.databases.list yview"
1357 foreach b [lindex $profile($target) 7] {
1358 $w.top.databases.list insert end $b
1362 pack $w.top.cs-type -pady 6 -padx 6 -side top -fill x
1364 label $w.top.cs-type.label -text "Transport"
1365 radiobutton $w.top.cs-type.tcpip -text "TCP/IP" -anchor w \
1366 -command {puts tcp/ip} -variable csRadioType -value tcpip
1367 radiobutton $w.top.cs-type.mosi -text "MOSI" -anchor w\
1368 -command {puts mosi} -variable csRadioType -value mosi
1370 pack $w.top.cs-type.label $w.top.cs-type.tcpip $w.top.cs-type.mosi \
1371 -padx 4 -side top -fill x
1374 pack $w.top.protocol -pady 6 -padx 6 -side top -fill x
1376 label $w.top.protocol.label -text "Protocol"
1377 radiobutton $w.top.protocol.z39v2 -text "Z39.50" -anchor w \
1378 -command {puts z39v2} -variable protocolRadioType -value z39v2
1379 radiobutton $w.top.protocol.sr -text "SR" -anchor w \
1380 -command {puts sr} -variable protocolRadioType -value sr
1382 pack $w.top.protocol.label $w.top.protocol.z39v2 $w.top.protocol.sr \
1383 -padx 4 -side top -fill x
1386 pack $w.top.query -pady 6 -padx 6 -side top -fill x
1388 label $w.top.query.label -text "Query support"
1389 checkbutton $w.top.query.c1 -text "RPN query" -anchor w -variable RPNCheck
1390 checkbutton $w.top.query.c2 -text "CCL query" -anchor w -variable CCLCheck
1391 checkbutton $w.top.query.c3 -text "Result sets" -anchor w -variable ResultSetCheck
1393 pack $w.top.query.label -side top
1394 pack $w.top.query.c1 $w.top.query.c2 $w.top.query.c3 \
1395 -padx 4 -side top -fill x
1398 bottom-buttons $w [list {Ok} [list protocol-setup-action $target] \
1399 {Cancel} [list destroy $w]] 0
1402 proc database-select-action {} {
1403 set w .database-select.top
1405 foreach indx [$w.databases.list curselection] {
1406 lappend b [$w.databases.list get $indx]
1409 z39 databaseNames $b
1411 destroy .database-select
1414 proc database-select {} {
1415 set w .database-select
1425 frame $w.top.databases -relief ridge -border 2
1427 pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill x
1429 label $w.top.databases.label -text "List"
1430 listbox $w.top.databases.list -geometry 20x6 \
1431 -yscrollcommand "$w.top.databases.scroll set"
1432 scrollbar $w.top.databases.scroll -orient vertical -border 1
1433 pack $w.top.databases.label -side top -fill x \
1435 pack $w.top.databases.list -side left -fill both -expand yes \
1437 pack $w.top.databases.scroll -side right -fill y \
1439 $w.top.databases.scroll config -command "$w.top.databases.list yview"
1441 foreach b [lindex $profile($hostid) 7] {
1442 $w.top.databases.list insert end $b
1444 top-down-ok-cancel $w {database-select-action} 1
1447 proc cascade-target-list {} {
1450 foreach sub [winfo children .top.target.m.clist] {
1451 puts "deleting $sub"
1454 .top.target.m.clist delete 0 last
1455 foreach n [array names profile] {
1456 if {$n != "Default"} {
1457 set nl [string tolower $n]
1458 if {[llength [lindex $profile($n) 7]] > 1} {
1459 .top.target.m.clist add cascade -label $n \
1460 -menu .top.target.m.clist.$nl
1461 menu .top.target.m.clist.$nl
1462 foreach b [lindex $profile($n) 7] {
1463 .top.target.m.clist.$nl add command -label $b \
1464 -command [list reopen-target $n $b]
1467 .top.target.m.clist add command -label $n \
1468 -command [list reopen-target $n {}]
1472 .top.target.m.slist delete 0 last
1473 foreach n [array names profile] {
1474 if {$n != "Default"} {
1475 .top.target.m.slist add command -label $n \
1476 -command [list protocol-setup $n]
1481 proc query-select {i} {
1482 global queryButtonsFind
1483 global queryInfoFind
1487 set queryInfoFind [lindex $queryInfo $i]
1488 set queryButtonsFind [lindex $queryButtons $i]
1490 index-lines .lines 1 $queryButtonsFind $queryInfoFind activate-index
1493 proc query-new-action {} {
1497 global settingsChanged
1499 set settingsChanged 1
1500 lappend queryTypes [.query-new.top.index.entry get]
1501 lappend queryButtons {}
1502 lappend queryInfo {}
1516 -side top -anchor e -pady 2
1517 entry-fields $w.top {index} \
1519 query-new-action {destroy .query-new}
1520 top-down-ok-cancel $w query-new-action 1
1523 proc cascade-query-list {} {
1525 set w .top.options.m.query
1528 $w.slist delete 0 last
1529 foreach n $queryTypes {
1530 $w.slist add command -label $n -command [list query-setup $i]
1535 $w.clist delete 0 last
1536 foreach n $queryTypes {
1537 $w.clist add command -label $n -command [list query-select $i]
1542 proc save-geometry {} {
1543 global windowGeometry
1545 set windowGeometry(.) [wm geometry .]
1547 set f [open "clientg.tcl" w]
1549 foreach n [array names windowGeometry] {
1550 puts -nonewline $f "set \{windowGeometry($n)\} \{"
1551 puts -nonewline $f $windowGeometry($n)
1557 proc save-settings {} {
1560 global settingsChanged
1565 set f [open "clientrc.tcl" w]
1566 puts $f "# Setup file"
1567 puts $f "set hotTargets \{ $hotTargets \}"
1569 foreach n [array names profile] {
1570 puts -nonewline $f "set \{profile($n)\} \{"
1571 puts -nonewline $f $profile($n)
1574 puts -nonewline $f "set queryTypes \{"
1575 puts -nonewline $f $queryTypes
1578 puts -nonewline $f "set queryButtons \{"
1579 puts -nonewline $f $queryButtons
1582 puts -nonewline $f "set queryInfo \{"
1583 puts -nonewline $f $queryInfo
1586 set settingsChanged 0
1598 message $w.top.message -text $ask
1600 pack $w.top.message -side left -pady 6 -padx 20 -expand yes -fill x
1603 top-down-ok-cancel $w {alert-action} 1
1607 proc alert-action {} {
1613 proc exit-action {} {
1614 global settingsChanged
1616 if {$settingsChanged} {
1617 set a [alert "you havent saved your settings. Do you wish to save?"]
1626 proc listbuttonaction {w name h user i} {
1627 $w configure -text [lindex $name 0]
1628 $h [lindex $name 1] $user $i
1631 proc listbuttonx {button no names handle user} {
1632 if {[winfo exists $button]} {
1633 $button configure -text [lindex [lindex $names $no] 0]
1634 ${button}.m delete 0 last
1636 menubutton $button -text [lindex [lindex $names $no] 0] \
1637 -width 10 -menu ${button}.m -relief raised -border 1
1641 foreach name $names {
1642 ${button}.m add command -label [lindex $name 0] \
1643 -command [list listbuttonaction ${button} $name \
1649 proc listbutton {button no names} {
1650 menubutton $button -text [lindex $names $no] -width 10 -menu ${button}.m \
1651 -relief raised -border 1
1653 foreach name $names {
1654 ${button}.m add command -label $name \
1655 -command [list ${button} configure -text $name]
1659 proc listbuttonv-action {button var names i} {
1662 set $var [lindex $names [expr $i+1]]
1663 $button configure -text [lindex $names $i]
1666 proc listbuttonv {button var names} {
1670 eval "set val $$var"
1671 set l [llength $names]
1672 for {set i 1} {$i < $l} {incr i 2} {
1673 if {$val == [lindex $names $i]} {
1675 set n [lindex $names $i]
1679 if {[winfo exists $button]} {
1680 $button configure -text $n
1683 menubutton $button -text $n -menu ${button}.m \
1684 -relief raised -border 1
1686 for {set i 0} {$i < $l} {incr i 2} {
1687 ${button}.m add command -label [lindex $names $i] \
1688 -command [list listbuttonv-action $button $var $names $i]
1692 proc query-add-index-action {queryNo} {
1696 global queryButtonsTmp
1698 lappend queryInfoTmp [list [.query-add-index.top.index.entry get] {}]
1700 destroy .query-add-index
1701 #destroy $w.top.lines
1702 #frame $w.top.lines -relief ridge -border 2
1703 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1704 #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1707 proc query-add-line {queryNo} {
1711 global queryButtonsTmp
1713 lappend queryButtonsTmp {I 0}
1715 #destroy $w.top.lines
1716 #frame $w.top.lines -relief ridge -border 2
1717 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1718 #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1721 proc query-del-line {queryNo} {
1725 global queryButtonsTmp
1727 set l [llength $queryButtonsTmp]
1732 set queryButtonsTmp [lreplace $queryButtonsTmp $l $l]
1733 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1736 proc query-add-index {queryNo} {
1737 set w .query-add-index
1740 place-force $w .setup-query
1744 -side top -anchor e -pady 2
1745 entry-fields $w.top {index} \
1747 [list query-add-index-action $queryNo] {destroy .query-add-index}
1748 top-down-ok-cancel $w [list query-add-index-action $queryNo] 1
1751 proc query-setup-action {queryNo} {
1754 global queryButtonsTmp
1756 global settingsChanged
1758 set settingsChanged 1
1760 set queryInfo [lreplace $queryInfo $queryNo $queryNo \
1762 set queryButtons [lreplace $queryButtons $queryNo $queryNo \
1764 destroy .setup-query
1767 proc activate-e-index {value no i} {
1768 global queryButtonsTmp
1769 global queryIndexTmp
1771 set queryButtonsTmp [lreplace $queryButtonsTmp $no $no [list I $i]]
1772 puts $queryButtonsTmp
1773 set queryIndexTmp $i
1776 proc activate-index {value no i} {
1777 global queryButtonsFind
1779 set queryButtonsFind [lreplace $queryButtonsFind $no $no [list I $i]]
1781 puts "queryButtonsFind $queryButtonsFind"
1784 proc update-attr {} {
1786 listbuttonv $w.top.relation.b relationTmpValue\
1787 {{None} 0 {Less than} 1 {Greater than or equal} 2 {Equal} 3 \
1788 {Greater than or equal} 4 {Greater than} 5 {Not equal} 6 \
1789 {Phonetic} 100 {Stem} 101 {Relevance} 102 {AlwaysMatches} 103}
1790 listbuttonv $w.top.position.b positionTmpValue {{None} 0 \
1791 {First in field} 1 {First in subfield} 2 {Any position in field} 3}
1792 listbuttonv $w.top.structure.b structureTmpValue {{None} 0 {Phrase} 1 \
1793 {Word} 2 {Key} 3 {Year} 4 {Date (norm)} 5 {Word list} 6 \
1794 {Date (un-norm)} 100 {Name (norm)} 101 {Date (un-norm)} 102 \
1795 {Structure} 103 {urx} 104 {free-form} 105 {doc-text} 106 \
1796 {local-number} 107 {string} 108 {numeric string} 109}
1797 listbuttonv $w.top.truncation.b truncationTmpValue {{Auto} 0 {Right} 1 \
1798 {Left} 2 {Left and right} 3 {No truncation} 100 \
1799 {Process #} 101 {Re-1} 102 {Re-2} 103}
1800 listbuttonv $w.top.completeness.b completenessTmpValue {{None} 0 \
1801 {Incomplete subfield} 1 {Complete subfield} 2 {Complete field} 3}
1804 proc use-attr {init} {
1816 {BNB card number} 10
1817 {BGF(sic) number} 11
1819 {Dewey classification} 13
1820 {UDC classification} 14
1821 {Bliss classification} 15
1823 {NLM call number} 17
1824 {NAL call number} 18
1825 {MOS call number} 19
1826 {Local classification} 20
1827 {Subject heading} 21
1829 {BDI-index-subject} 23
1833 {LC-subject-heading} 27
1834 {RVM-subject-heading} 28
1835 {Local subject index} 29
1837 {Date of publication} 31
1838 {Date of acquisition} 32
1840 {Title-collective} 34
1843 {Title-added-title-page} 37
1847 {Title-other-variant} 41
1849 {Title-abbreviated} 43
1853 {Subject-subdivision} 47
1854 {Number-natl-bibliography} 48
1855 {Number-legal-deposit} 49
1856 {Number-govt-publication} 50
1857 {Number-publisher-for-music} 51
1859 {Number-local-call} 53
1861 {Code-geographic-area} 55
1862 {Code-institution} 56
1864 {Name-geographic} 58
1865 {Place-publication} 59
1867 {Microform-generation} 61
1874 {Author-name-personal} 1004
1875 {Author-name-corporate} 1005
1876 {Author-name-conference} 1006
1877 {Identifier-standard} 1007
1878 {Subject-LC-children's} 1008
1879 {Subject-name-personal} 1009
1881 {Date/time added to database} 1011
1882 {Date/time last modified} 1012
1883 {Authority/format identifier} 1013
1885 {Concept-reference} 1015
1887 {Server choice} 1017
1889 {Record source} 1019
1892 {Geographic class} 1022
1896 {Related periodical} 1026
1897 {Report number} 1027
1899 {Thematic number} 1030
1900 {Material type} 1031
1908 set l [llength $attr]
1913 for {set i 0} {$i < $l} {incr i} {
1914 $w.top.use.list insert end [lindex $attr $i]
1916 if {$useTmpValue == [lindex $attr $i]} {
1921 $w.top.use.list select from $s
1922 $w.top.use.list select to $s
1927 $w.top.use.list yview $s
1929 set lno [lindex [$w.top.use.list curselection] 0]
1930 set i [expr $lno+$lno+1]
1931 set useTmpValue [lindex $attr $i]
1935 proc index-setup-action {oldAttr queryNo indexNo} {
1936 set attr [lindex $oldAttr 0]
1939 global relationTmpValue
1940 global structureTmpValue
1941 global truncationTmpValue
1942 global completenessTmpValue
1943 global positionTmpValue
1948 if {$useTmpValue > 0} {
1949 lappend attr "1=$useTmpValue"
1951 if {$relationTmpValue > 0} {
1952 lappend attr "2=$relationTmpValue"
1954 if {$positionTmpValue > 0} {
1955 lappend attr "3=$positionTmpValue"
1957 if {$structureTmpValue > 0} {
1958 lappend attr "4=$structureTmpValue"
1960 if {$truncationTmpValue > 0} {
1961 lappend attr "5=$truncationTmpValue"
1963 if {$completenessTmpValue > 0} {
1964 lappend attr "6=$completenessTmpValue"
1966 set queryInfoTmp [lreplace $queryInfoTmp $indexNo $indexNo $attr]
1967 destroy .index-setup
1970 proc index-setup {attr queryNo indexNo} {
1973 global relationTmpValue
1974 global structureTmpValue
1975 global truncationTmpValue
1976 global completenessTmpValue
1977 global positionTmpValue
1979 set relationTmpValue 0
1980 set truncationTmpValue 0
1981 set structureTmpValue 0
1982 set positionTmpValue 0
1983 set completenessTmpValue 0
1986 set len [llength $attr]
1987 for {set i 1} {$i < $len} {incr i} {
1988 set q [lindex $attr $i]
1989 set l [string first = $q]
1991 set t [string range $q 0 [expr $l - 1]]
1992 set v [string range $q [expr $l + 1] end]
1995 { set useTmpValue $v }
1997 { set relationTmpValue $v }
1999 { set positionTmpValue $v }
2001 { set structureTmpValue $v }
2003 { set truncationTmpValue $v }
2005 { set completenessTmpValue $v }
2011 set n [lindex $attr 0]
2012 wm title $w "Index setup $n"
2016 frame $w.top.use -relief ridge -border 2
2017 frame $w.top.relation -relief ridge -border 2
2018 frame $w.top.position -relief ridge -border 2
2019 frame $w.top.structure -relief ridge -border 2
2020 frame $w.top.truncation -relief ridge -border 2
2021 frame $w.top.completeness -relief ridge -border 2
2027 pack $w.top.use -side left -pady 6 -padx 6 -fill y
2029 label $w.top.use.label -text "Use"
2030 listbox $w.top.use.list -geometry 26x10 \
2031 -yscrollcommand "$w.top.use.scroll set"
2032 scrollbar $w.top.use.scroll -orient vertical -border 1
2033 pack $w.top.use.label -side top -fill x \
2035 pack $w.top.use.list -side left -fill both -expand yes \
2037 pack $w.top.use.scroll -side right -fill y \
2039 $w.top.use.scroll config -command "$w.top.use.list yview"
2043 # Relation Attributes
2045 pack $w.top.relation -pady 6 -padx 6 -side top
2046 label $w.top.relation.label -text "Relation" -width 18
2048 pack $w.top.relation.label $w.top.relation.b -fill x
2050 # Position Attributes
2052 pack $w.top.position -pady 6 -padx 6 -side top
2053 label $w.top.position.label -text "Position" -width 18
2055 pack $w.top.position.label $w.top.position.b -fill x
2057 # Structure Attributes
2059 pack $w.top.structure -pady 6 -padx 6 -side top
2060 label $w.top.structure.label -text "Structure" -width 18
2062 pack $w.top.structure.label $w.top.structure.b -fill x
2064 # Truncation Attributes
2066 pack $w.top.truncation -pady 6 -padx 6 -side top
2067 label $w.top.truncation.label -text "Truncation" -width 18
2069 pack $w.top.truncation.label $w.top.truncation.b -fill x
2071 # Completeness Attributes
2073 pack $w.top.completeness -pady 6 -padx 6 -side top
2074 label $w.top.completeness.label -text "Completeness" -width 18
2076 pack $w.top.completeness.label $w.top.completeness.b -fill x
2079 bottom-buttons $w [list \
2080 {Ok} [list index-setup-action $attr $queryNo $indexNo] \
2081 {Cancel} [list destroy $w]] 0
2085 proc query-edit-index {queryNo} {
2087 global queryIndexTmp
2089 set attr [lindex $queryInfoTmp $queryIndexTmp]
2090 puts "Editing $attr"
2091 index-setup $attr $queryNo $queryIndexTmp
2094 proc query-setup {queryNo} {
2100 global queryButtonsTmp
2102 global queryIndexTmp
2105 set queryName [lindex $queryTypes $queryNo]
2106 set queryInfoTmp [lindex $queryInfo $queryNo]
2107 set queryButtonsTmp [lindex $queryButtons $queryNo]
2112 wm title $w "Query setup $queryName"
2116 frame $w.top.lines -relief ridge -border 2
2120 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
2122 pack $w.top.lines -side left -pady 6 -padx 6 -fill y
2125 bottom-buttons $w [list \
2126 {Ok} [list query-setup-action $queryNo] \
2127 {Add index} [list query-add-index $queryNo] \
2128 {Edit index} [list query-edit-index $queryNo] \
2129 {Add line} [list query-add-line $queryNo] \
2130 {Delete line} [list query-del-line $queryNo] \
2131 {Cancel} [list destroy $w]] 0
2134 proc index-clear {} {
2135 global queryButtonsFind
2138 foreach b $queryButtonsFind {
2139 .lines.$i.e delete 0 end
2144 proc index-query {} {
2145 global queryButtonsFind
2146 global queryInfoFind
2151 foreach b $queryButtonsFind {
2152 set term [string trim [.lines.$i.e get]]
2154 set attr [lrange [lindex $queryInfoFind [lindex $b 1]] 1 end]
2156 set term "\{${term}\}"
2158 set term "@attr $a ${term}"
2161 set qs "@and ${qs} ${term}"
2172 proc index-focus-in {w i} {
2173 global curIndexEntry
2175 $w.$i configure -background red
2176 set curIndexEntry $i
2179 proc index-lines {w realOp buttonInfo queryInfo handle} {
2181 foreach b $buttonInfo {
2182 if {! [winfo exists $w.$i]} {
2183 frame $w.$i -background white -border 1
2185 listbuttonx $w.$i.l [lindex $b 1] $queryInfo $handle $i
2188 if {! [winfo exists $w.$i.e]} {
2189 entry $w.$i.e -width 32 -relief sunken -border 1
2190 bind $w.$i.e <FocusIn> [list index-focus-in $w $i]
2191 bind $w.$i.e <FocusOut> [list $w.$i configure \
2193 pack $w.$i.l -side left
2194 pack $w.$i.e -side left -fill x -expand yes
2195 pack $w.$i -side top -fill x -padx 2 -pady 2
2196 bind $w.$i.e <Left> [list left-cursor $w.$i.e]
2197 bind $w.$i.e <Right> [list right-cursor $w.$i.e]
2198 bind $w.$i.e <Return> search-request
2201 pack $w.$i.l -side left
2202 pack $w.$i -side top -fill x -padx 2 -pady 2
2207 while {[winfo exists $w.$j]} {
2218 bind $w.$j.e <Tab> "focus $w.$k.e"
2222 bind $w.$i.e <Tab> "focus $w.0.e"
2227 proc search-fields {w buttondefs} {
2229 foreach buttondef $buttondefs {
2230 frame $w.$i -background white
2232 listbutton $w.$i.l 0 $buttondef
2233 entry $w.$i.e -width 32 -relief sunken
2235 pack $w.$i.l -side left
2236 pack $w.$i.e -side left -fill x -expand yes
2238 pack $w.$i -side top -fill x -padx 2 -pady 2
2240 bind $w.$i.e <Left> [list left-cursor $w.$i.e]
2241 bind $w.$i.e <Right> [list right-cursor $w.$i.e]
2249 bind $w.$j.e <Tab> "focus $w.$k.e \n
2250 $w.$k configure -background red \n
2251 $w.$j configure -background white"
2254 bind $w.$i.e <Tab> "focus $w.0.e \n
2255 $w.0 configure -background red \n
2256 $w.$i configure -background white"
2258 $w.0 configure -background red
2261 if {[info exists windowGeometry(.)]} {
2262 set g $windowGeometry(.)
2270 frame .top -border 1 -relief raised
2271 frame .lines -border 1 -relief raised
2272 frame .mid -border 1 -relief raised
2273 frame .data -border 1 -relief raised
2274 frame .bot -border 1 -relief raised
2275 pack .top .lines .mid -side top -fill x
2276 pack .data -side top -fill both -expand yes
2279 menubutton .top.file -text "File" -underline 0 -menu .top.file.m
2281 .top.file.m add command -label "Save settings" -command {save-settings}
2282 .top.file.m add separator
2283 .top.file.m add command -label "Exit" -command {exit-action}
2285 menubutton .top.target -text "Target" -underline 0 -menu .top.target.m
2287 .top.target.m add cascade -label "Connect" -menu .top.target.m.clist
2288 .top.target.m add command -label "Disconnect" -command {close-target}
2289 .top.target.m add command -label "About" -command {about-target}
2290 .top.target.m add cascade -label "Setup" -menu .top.target.m.slist
2291 .top.target.m add command -label "Setup new" -command {define-target-dialog}
2292 .top.target.m add separator
2295 .top.target.m disable 1
2296 .top.target.m disable 2
2298 menu .top.target.m.clist
2299 menu .top.target.m.slist
2302 menubutton .top.service -text "Service" -underline 0 -menu .top.service.m
2304 .top.service.m add command -label "Database" -command {database-select}
2305 .top.service.m add cascade -label "Query type" -menu .top.service.m.querytype
2306 menu .top.service.m.querytype
2307 .top.service.m.querytype add radiobutton -label "RPN"
2308 .top.service.m.querytype add radiobutton -label "CCL"
2309 .top.service.m add cascade -label "Present" -menu .top.service.m.present
2310 menu .top.service.m.present
2311 .top.service.m.present add command -label "More" \
2312 -command [list present-more 10]
2313 .top.service.m.present add command -label "All" \
2314 -command [list present-more {}]
2315 .top.service configure -state disabled
2317 menubutton .top.rset -text "Set" -menu .top.rset.m
2319 .top.rset.m add command -label "Load" -command {load-set}
2320 .top.rset.m add separator
2322 menubutton .top.options -text "Options" -underline 0 -menu .top.options.m
2324 .top.options.m add cascade -label "Query" -menu .top.options.m.query
2325 .top.options.m add cascade -label "Format" -menu .top.options.m.formats
2327 menu .top.options.m.query
2328 .top.options.m.query add cascade -label "Choose query" \
2329 -menu .top.options.m.query.clist
2330 .top.options.m.query add cascade -label "Edit query" \
2331 -menu .top.options.m.query.slist
2332 .top.options.m.query add command -label "Define query" \
2333 -command {query-new}
2335 menu .top.options.m.query.slist
2336 menu .top.options.m.query.clist
2339 menu .top.options.m.formats
2341 foreach f $displayFormats {
2342 .top.options.m.formats add radiobutton -label $f \
2343 -command [list set-display-format $i]
2347 menubutton .top.help -text "Help" -menu .top.help.m
2350 .top.help.m add command -label "Help on help" \
2351 -command {tkerror "Help on help not available. Sorry"}
2352 .top.help.m add command -label "About" -command {about-origin}
2354 pack .top.file .top.target .top.service .top.rset .top.options -side left
2355 pack .top.help -side right
2357 index-lines .lines 1 $queryButtonsFind [lindex $queryInfo 0] activate-index
2359 button .mid.search -width 7 -text {Search} -command search-request \
2361 button .mid.scan -width 7 -text {Scan} \
2362 -command scan-request -state disabled
2363 button .mid.present -width 7 -text {Present} -command [list present-more 10] \
2366 button .mid.clear -width 7 -text {Clear} -command index-clear
2367 pack .mid.search .mid.scan .mid.present .mid.clear -side left \
2368 -fill y -padx 5 -pady 3
2370 text .data.record -height 2 -width 20 -wrap none \
2371 -yscrollcommand [list .data.scroll set]
2372 scrollbar .data.scroll -command [list .data.record yview]
2373 pack .data.scroll -side right -fill y
2374 pack .data.record -expand yes -fill both
2377 if {[tk colormodel .] == "color"} {
2378 .data.record tag configure marc-tag -foreground blue
2379 .data.record tag configure marc-id -foreground red
2381 .data.record tag configure marc-tag -foreground black
2382 .data.record tag configure marc-id -foreground black
2384 .data.record tag configure marc-data -foreground black
2386 button .bot.logo -bitmap @book1 -command cancel-operation
2388 pack .bot.a -side left -fill x
2389 pack .bot.logo -side right -padx 2 -pady 2
2391 message .bot.a.target -text "" -aspect 1000 -border 1
2393 label .bot.a.status -text "Not connected" -width 15 -relief \
2394 sunken -anchor w -border 1
2395 label .bot.a.set -text "" -width 5 -relief \
2396 sunken -anchor w -border 1
2397 label .bot.a.message -text "" -width 15 -relief \
2398 sunken -anchor w -border 1
2400 pack .bot.a.target -side top -anchor nw -padx 2 -pady 2
2401 pack .bot.a.status .bot.a.set .bot.a.message \
2402 -side left -padx 2 -pady 2
2404 #bind . <Any-Enter> {focus .lines.0.e}
2408 #.top.options.m.formats invoke $displayFormat