3 # Revision 1.19 1995-04-18 16:11:50 adam
4 # First version of graphical Scan. Some work on query-by-form.
6 # Revision 1.18 1995/04/10 10:50:22 adam
7 # Result-set name defaults to suffix of ir-set name.
8 # Started working on scan. Not finished at this point.
10 # Revision 1.17 1995/03/31 09:34:57 adam
11 # Search-button disabled when there is no connection.
13 # Revision 1.16 1995/03/31 08:56:36 adam
14 # New button "Search".
16 # Revision 1.15 1995/03/28 12:45:22 adam
17 # New ir method failback: called on disconnect/protocol error.
18 # New ir set/get method: protocol: SR / Z3950.
19 # Simple popup and disconnect when failback is invoked.
21 # Revision 1.14 1995/03/22 16:07:55 adam
24 # Revision 1.13 1995/03/21 17:27:26 adam
25 # Short-hand keys in setup.
27 # Revision 1.12 1995/03/21 13:41:03 adam
28 # Comstack cs_create not used too often. Non-blocking connect.
30 # Revision 1.11 1995/03/21 10:39:06 adam
31 # Diagnostic error message displayed with tkerror.
33 # Revision 1.10 1995/03/20 15:24:06 adam
34 # Diagnostic records saved on searchResponse.
36 # Revision 1.9 1995/03/17 18:26:16 adam
37 # Non-blocking i/o used now. Database names popup as cascade items.
39 # Revision 1.8 1995/03/17 15:45:00 adam
40 # Improved target/database setup.
42 # Revision 1.7 1995/03/16 17:54:03 adam
43 # Minor changes really.
45 # Revision 1.6 1995/03/15 19:10:20 adam
46 # Database setup in protocol-setup (rather target setup).
48 # Revision 1.5 1995/03/15 13:59:23 adam
51 # Revision 1.4 1995/03/14 17:32:29 adam
52 # Presentation of full Marc record in popup window.
54 # Revision 1.3 1995/03/12 19:31:52 adam
55 # Pattern matching implemented when retrieving MARC records. More
56 # diagnostic functions.
58 # Revision 1.2 1995/03/10 18:00:15 adam
59 # Actual presentation in line-by-line format. RPN query support.
61 # Revision 1.1 1995/03/09 16:15:07 adam
62 # First presentRequest attempts. Hot-target list.
69 set profile(Default) {{} {} {210} {} 16384 8192 tcpip {}}
74 set queryTypes {Simple}
75 set queryButtons { { {I 0} {I 1} {I 2} } }
76 set queryInfo { { {Title ti} {Author au} {Subject sh} {Any any} } }
80 if {[file readable "~/.tk-c"]} {
84 set queryButtonsFind [lindex $queryButtons 0]
85 set queryInfoFind [lindex $queryInfo 0]
87 proc top-down-window {w} {
88 frame $w.top -relief raised -border 1
89 frame $w.bot -relief raised -border 1
91 pack $w.top $w.bot -side top -fill both -expand yes
94 proc top-down-ok-cancel {w ok-action g} {
95 frame $w.bot.left -relief sunken -border 1
96 pack $w.bot.left -side left -expand yes -padx 5 -pady 5
97 button $w.bot.left.ok -width 6 -text {Ok} \
99 pack $w.bot.left.ok -expand yes -padx 3 -pady 3
100 button $w.bot.cancel -width 6 -text {Cancel} \
101 -command "destroy $w"
102 pack $w.bot.cancel -side left -expand yes
111 proc top-down-ok-cancelx {w buttonList g} {
113 set l [llength $buttonList]
115 frame $w.bot.$i -relief sunken -border 1
116 pack $w.bot.$i -side left -expand yes -padx 5 -pady 5
117 button $w.bot.$i.ok -text [lindex $buttonList $i] \
118 -command [lindex $buttonList [expr $i+1]]
119 pack $w.bot.$i.ok -expand yes -padx 3 -pady 3 -side left
123 button $w.bot.$i -text [lindex $buttonList $i] \
124 -command [lindex $buttonList [expr $i+1]]
125 pack $w.bot.$i -expand yes -padx 3 -pady 3 -side left
128 button $w.bot.cancel -width 6 -text {Cancel} \
129 -command "destroy $w"
130 pack $w.bot.cancel -side left -expand yes
139 proc show-target {target} {
140 .bot.target configure -text "$target"
143 proc show-busy {v1 v2} {
146 .bot.status configure -fg $v1
147 after 200 [list show-busy $v2 $v1]
151 proc show-status {status b} {
154 .bot.status configure -text "$status"
155 .bot.status configure -fg black
161 # . config -cursor {watch black white}
163 # . config -cursor {top_left_arrow black white}
169 proc show-message {msg} {
170 .bot.message configure -text "$msg"
173 proc insertWithTags {w text args} {
174 set start [$w index insert]
175 $w insert insert $text
176 foreach tag [$w tag names $start] {
177 $w tag remove $tag $start insert
180 $w tag add $i $start insert
184 proc show-full-marc {no} {
189 if {[winfo exists $w]} {
190 $w.top.record delete 0.0 end
196 wm minsize $w 200 200
198 frame $w.top -relief raised -border 1
199 frame $w.bot -relief raised -border 1
201 pack $w.top -side top -fill both -expand yes
202 pack $w.bot -fill both
204 text $w.top.record -width 60 -height 12 -wrap word \
205 -yscrollcommand [list $w.top.s set]
206 scrollbar $w.top.s -command [list $w.top.record yview]
212 set r [z39.$setNo recordMarc $no line * * *]
214 $w.top.record tag configure marc-tag -foreground blue
215 $w.top.record tag configure marc-data -foreground black
216 $w.top.record tag configure marc-id -foreground red
219 set tag [lindex $line 0]
220 set indicator [lindex $line 1]
221 set fields [lindex $line 2]
223 if {$indicator != ""} {
224 insertWithTags $w.top.record "$tag $indicator" marc-tag
226 insertWithTags $w.top.record "$tag " marc-tag
228 foreach field $fields {
229 set id [lindex $field 0]
230 set data [lindex $field 1]
232 insertWithTags $w.top.record " $id " marc-id
234 set start [$w.top.record index insert]
235 insertWithTags $w.top.record $data {}
237 $w.top.record insert end "\n"
240 bind $w <Return> {destroy .full-marc}
242 pack $w.top.s -side right -fill y
243 pack $w.top.record -expand yes -fill both
245 frame $w.bot.left -relief sunken -border 1
246 pack $w.bot.left -side left -expand yes -padx 5 -pady 5
247 button $w.bot.left.close -width 6 -text {Close} \
248 -command {destroy .full-marc}
249 pack $w.bot.left.close -expand yes -padx 3 -pady 3
250 button $w.bot.edit -width 6 -text {Edit} \
251 -command {destroy .full-marc}
252 pack $w.bot.edit -side left -expand yes
256 proc update-target-hotlist {target} {
259 set len [llength $hotTargets]
261 .top.target.m delete 5 [expr 5+[llength $hotTargets]]
263 set indx [lsearch $hotTargets $target]
265 set hotTargets [lreplace $hotTargets $indx $indx]
267 set hotTargets [linsert $hotTargets 0 $target]
271 proc set-target-hotlist {} {
275 foreach target $hotTargets {
276 .top.target.m add command -label "$i $target" -command \
277 "reopen-target $target {}"
285 proc reopen-target {target base} {
287 open-target $target $base
288 update-target-hotlist $target
291 proc define-target-action {} {
294 set target [.target-define.top.target.entry get]
298 update-target-hotlist $target
299 foreach n [array names profile] {
305 set profile($target) $profile(Default)
306 protocol-setup $target
307 destroy .target-define
310 proc fail-response {target} {
312 tkerror "Target connection closed or protocol error"
315 proc connect-response {target} {
316 puts "connect-response"
321 proc open-target {target base} {
326 z39 comstack [lindex $profile($target) 6]
327 # z39 idAuthentication [lindex $profile($target) 3]
328 z39 maximumRecordSize [lindex $profile($target) 4]
329 z39 preferredMessageSize [lindex $profile($target) 5]
330 puts -nonewline "maximumRecordSize="
331 puts [z39 maximumRecordSize]
332 puts -nonewline "preferredMessageSize="
333 puts [z39 preferredMessageSize]
335 z39 databaseNames [lindex [lindex $profile($target) 7] 0]
337 z39 databaseNames $base
339 z39 failback [list fail-response $target]
340 z39 callback [list connect-response $target]
341 z39 connect [lindex $profile($target) 1]:[lindex $profile($target) 2]
342 show-status {Connecting} 1
344 .top.target.m disable 0
345 .top.target.m enable 1
348 proc close-target {} {
354 show-status {Not connected} 0
356 .top.target.m disable 1
357 .top.target.m enable 0
358 .top.search configure -state disabled
359 .mid.search configure -state disabled
360 .mid.scan configure -state disabled
363 proc load-set-action {} {
369 set fname [.load-set.top.filename.entry get]
374 show-status {Loading} 1
375 z39.$setNo loadFile $fname
377 set no [z39.$setNo numberOfRecordsReturned]
378 add-title-lines $setNo $no 1
380 show-status {Ready} 0
393 frame $w.top.filename
395 pack $w.top.filename -side top -anchor e -pady 2
397 entry-fields $w.top {filename} \
399 {load-set-action} {destroy .load-set}
401 top-down-ok-cancel $w {load-set-action} 1
405 proc init-request {} {
408 z39 callback {init-response}
410 show-status {Initializing} 1
413 proc init-response {} {
414 show-status {Ready} 0
415 .top.search configure -state normal
416 .mid.search configure -state normal
417 .mid.scan configure -state normal
420 proc search-request {} {
427 set query [index-query]
435 if {[lindex $profile($target) 10]} {
436 z39.$setNo setName $setNo
438 z39.$setNo setName Default
440 if {[lindex $profile($target) 8]} {
443 if {[lindex $profile($target) 9]} {
446 z39 callback {search-response}
447 z39.$setNo search $query
448 show-status {Search} 1
451 proc scan-request {} {
461 z39 callback {scan-response}
462 if {![winfo exists $w]} {
467 wm minsize $w 200 200
471 listbox $w.top.list -yscrollcommand [list $w.top.scroll set] \
472 -font fixed -geometry 50x14
473 scrollbar $w.top.scroll -orient vertical -border 1
474 pack $w.top.list -side left -fill both -expand yes
475 pack $w.top.scroll -side right -fill y
476 $w.top.scroll config -command [list $w.top.list yview]
478 top-down-ok-cancelx $w [list {Close} [list destroy $w]] 0
485 proc scan-response {} {
487 set m [z39.scan numberOfEntriesReturned]
489 for {set i 0} {$i < $m} {incr i} {
490 set term [lindex [z39.scan scanLine $i] 1]
491 set nostr [format "%7d" [lindex [z39.scan scanLine $i] 2]]
493 $w.top.list insert end "$nostr $term"
495 show-status {Ready} 0
498 proc search-response {} {
504 show-status {Ready} 0
505 show-message "[z39.$setNo resultCount] hits"
506 set setMax [z39.$setNo resultCount]
509 set status [z39.$setNo responseStatus]
510 if {[lindex $status 0] == "NSD"} {
511 set code [lindex $status 1]
512 set msg [lindex $status 2]
513 set addinfo [lindex $status 3]
514 tkerror "NSD$code: $msg: $addinfo"
521 z39 callback {present-response}
523 z39.$setNo present $setOffset $setMax
524 show-status {Retrieve} 1
527 proc present-more {number} {
536 set max [z39.$setNo resultCount]
537 if {$max <= $setMax} {
541 puts "setOffset=$setOffset"
547 z39 callback {present-response}
548 z39.$setNo present $setOffset [expr $setMax - $setOffset + 1]
549 show-status {Retrieve} 1
552 proc init-title-lines {} {
553 .data.list delete 0 end
556 proc add-title-lines {setno no offset} {
557 for {set i 0} {$i < $no} {incr i} {
558 set o [expr $i + $offset]
559 set title [lindex [z39.$setno recordMarc $o field 245 * a] 0]
560 set year [lindex [z39.$setno recordMarc $o field 260 * c] 0]
561 set nostr [format "%5d" $o]
562 .data.list insert end "$nostr $title - $year"
566 proc present-response {} {
571 puts "In present-response"
572 set no [z39.$setNo numberOfRecordsReturned]
573 puts "Returned $no records, setOffset $setOffset"
574 add-title-lines $setNo $no $setOffset
575 set setOffset [expr $setOffset + $no]
576 set status [z39.$setNo responseStatus]
577 if {[lindex $status 0] == "NSD"} {
578 show-status {Ready} 0
579 set code [lindex $status 1]
580 set msg [lindex $status 2]
581 set addinfo [lindex $status 3]
582 tkerror "NSD$code: $msg: $addinfo"
585 if {$no > 0 && $setOffset <= $setMax} {
586 z39.$setNo present $setOffset [expr $setMax - $setOffset + 1]
588 show-status {Finished} 0
592 proc left-cursor {w} {
593 set i [$w index insert]
600 proc right-cursor {w} {
601 set i [$w index insert]
606 proc bind-fields {list returnAction escapeAction} {
607 set max [expr [llength $list]-1]
608 for {set i 0} {$i < $max} {incr i} {
609 bind [lindex $list $i] <Return> $returnAction
610 bind [lindex $list $i] <Escape> $escapeAction
611 bind [lindex $list $i] <Tab> [list focus [lindex $list [expr $i+1]]]
612 bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
613 bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
615 bind [lindex $list $i] <Return> $returnAction
616 bind [lindex $list $i] <Escape> $escapeAction
617 bind [lindex $list $i] <Tab> [list focus [lindex $list 0]]
618 bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
619 bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
620 focus [lindex $list 0]
623 proc entry-fields {parent list tlist returnAction escapeAction} {
626 foreach field $list {
627 set label ${parent}.${field}.label
628 set entry ${parent}.${field}.entry
629 label $label -text [lindex $tlist $i] -anchor e
630 entry $entry -width 32 -relief sunken
631 pack $label -side left
632 pack $entry -side right
636 bind-fields $alist $returnAction $escapeAction
639 proc define-target-dialog {} {
647 -side top -anchor e -pady 2
648 entry-fields $w.top {target} \
650 {define-target-action} {destroy .target-define}
651 top-down-ok-cancel $w {define-target-action} 1
654 proc protocol-setup-action {target} {
657 global settingsChanged
660 global ResultSetCheck
662 set w .setup-${target}.top
664 #set w .protocol-setup.top
667 set settingsChanged 1
668 set len [$w.databases.list size]
669 for {set i 0} {$i < $len} {incr i} {
670 lappend b [$w.databases.list get $i]
672 set profile($target) [list [$w.description.entry get] \
673 [$w.host.entry get] \
674 [$w.port.entry get] \
675 [$w.idAuthentication.entry get] \
676 [$w.maximumRecordSize.entry get] \
677 [$w.preferredMessageSize.entry get] \
685 puts $profile($target)
686 destroy .setup-${target}
689 proc place-force {window parent} {
690 set g [wm geometry $parent]
692 set p1 [string first + $g]
693 set p2 [string last + $g]
695 set x [expr 40+[string range $g [expr $p1 +1] [expr $p2 -1]]]
696 set y [expr 60+[string range $g [expr $p2 +1] end]]
697 wm geometry $window +${x}+${y}
700 proc add-database-action {target} {
701 set w .setup-${target}
703 ${w}.top.databases.list insert end \
704 [.database-select.top.database.entry get]
705 destroy .database-select
708 proc add-database {target} {
709 set w .database-select
714 place-force $w .setup-${target}
718 frame $w.top.database
720 pack $w.top.database -side top -anchor e -pady 2
722 entry-fields $w.top {database} \
723 {{Database to add:}} \
724 [list add-database-action $target] {destroy .database-select}
726 top-down-ok-cancel $w [list add-database-action $target] 1
730 proc delete-database {target} {
731 set w .setup-${target}
733 foreach i [lsort -decreasing \
734 [$w.top.databases.list curselection]] {
735 $w.top.databases.list delete $i
739 proc protocol-setup {target} {
746 global ResultSetCheck
750 wm title $w "Setup $target"
759 puts $profile($target)
763 frame $w.top.description
764 frame $w.top.idAuthentication
765 frame $w.top.maximumRecordSize
766 frame $w.top.preferredMessageSize
767 frame $w.top.cs-type -relief ridge -border 2
768 frame $w.top.query -relief ridge -border 2
769 frame $w.top.databases -relief ridge -border 2
771 # Maximum/preferred/idAuth ...
772 pack $w.top.description $w.top.host $w.top.port \
773 $w.top.idAuthentication $w.top.maximumRecordSize \
774 $w.top.preferredMessageSize -side top -anchor e -pady 2
776 entry-fields $w.top {description host port idAuthentication \
777 maximumRecordSize preferredMessageSize} \
778 {{Description:} {Host:} {Port:} {Id Authentification:} \
779 {Maximum Record Size:} {Preferred Message Size:}} \
780 [list protocol-setup-action $target] [list destroy $w]
782 foreach sub {description host port idAuthentication \
783 maximumRecordSize preferredMessageSize} {
785 bind $w.top.$sub.entry <Control-a> "add-database $target"
786 bind $w.top.$sub.entry <Control-d> "delete-database $target"
788 $w.top.description.entry insert 0 [lindex $profile($target) 0]
789 $w.top.host.entry insert 0 [lindex $profile($target) 1]
790 $w.top.port.entry insert 0 [lindex $profile($target) 2]
791 $w.top.idAuthentication.entry insert 0 [lindex $profile($target) 3]
792 $w.top.maximumRecordSize.entry insert 0 [lindex $profile($target) 4]
793 $w.top.preferredMessageSize.entry insert 0 [lindex $profile($target) 5]
794 set csRadioType [lindex $profile($target) 6]
795 set RPNCheck [lindex $profile($target) 8]
796 set CCLCheck [lindex $profile($target) 9]
797 set ResultSetCheck [lindex $profile($target) 10]
800 pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill x
802 label $w.top.databases.label -text "Databases"
803 button $w.top.databases.add -text "Add" \
804 -command "add-database $target"
805 button $w.top.databases.delete -text "Delete" \
806 -command "delete-database $target"
807 listbox $w.top.databases.list -geometry 20x6 \
808 -yscrollcommand "$w.top.databases.scroll set"
809 scrollbar $w.top.databases.scroll -orient vertical -border 1
810 pack $w.top.databases.label -side top -fill x \
812 pack $w.top.databases.add $w.top.databases.delete -side top -fill x \
814 pack $w.top.databases.list -side left -fill both -expand yes \
816 pack $w.top.databases.scroll -side right -fill y \
818 $w.top.databases.scroll config -command "$w.top.databases.list yview"
820 foreach b [lindex $profile($target) 7] {
821 $w.top.databases.list insert end $b
825 pack $w.top.cs-type -pady 6 -padx 6 -side top
827 label $w.top.cs-type.label -text "Transport"
828 radiobutton $w.top.cs-type.tcpip -text "TCP/IP" \
829 -command {puts tcp/ip} -variable csRadioType -value tcpip
830 radiobutton $w.top.cs-type.mosi -text "MOSI" \
831 -command {puts mosi} -variable csRadioType -value mosi
833 pack $w.top.cs-type.label $w.top.cs-type.tcpip $w.top.cs-type.mosi \
834 -padx 4 -side top -fill x
837 pack $w.top.query -pady 6 -padx 6 -side top
839 label $w.top.query.label -text "Query support" -anchor e
840 checkbutton $w.top.query.c1 -text "RPN query" -variable RPNCheck
841 checkbutton $w.top.query.c2 -text "CCL query" -variable CCLCheck
842 checkbutton $w.top.query.c3 -text "Result sets" -variable ResultSetCheck
844 pack $w.top.query.label -side top
845 pack $w.top.query.c1 $w.top.query.c2 $w.top.query.c3 \
846 -padx 4 -side top -fill x
849 top-down-ok-cancel $w [list protocol-setup-action $target] 0
852 proc database-select-action {} {
853 set w .database-select.top
855 foreach indx [$w.databases.list curselection] {
856 lappend b [$w.databases.list get $indx]
861 destroy .database-select
864 proc database-select {} {
865 set w .database-select
875 frame $w.top.databases -relief ridge -border 2
877 pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill x
879 label $w.top.databases.label -text "List"
880 listbox $w.top.databases.list -geometry 20x6 \
881 -yscrollcommand "$w.top.databases.scroll set"
882 scrollbar $w.top.databases.scroll -orient vertical -border 1
883 pack $w.top.databases.label -side top -fill x \
885 pack $w.top.databases.list -side left -fill both -expand yes \
887 pack $w.top.databases.scroll -side right -fill y \
889 $w.top.databases.scroll config -command "$w.top.databases.list yview"
891 foreach b [lindex $profile($hostid) 7] {
892 $w.top.databases.list insert end $b
894 top-down-ok-cancel $w {database-select-action} 1
897 proc cascade-target-list {} {
900 foreach sub [winfo children .top.target.m.clist] {
904 .top.target.m.clist delete 0 last
905 foreach n [array names profile] {
906 if {$n != "Default"} {
907 set nl [string tolower $n]
908 if {[llength [lindex $profile($n) 7]] > 1} {
909 .top.target.m.clist add cascade -label $n \
910 -menu .top.target.m.clist.$nl
911 menu .top.target.m.clist.$nl
912 foreach b [lindex $profile($n) 7] {
913 .top.target.m.clist.$nl add command -label $b \
914 -command "reopen-target $n $b"
917 .top.target.m.clist add command -label $n \
918 -command "reopen-target $n {}"
922 .top.target.m.slist delete 0 last
923 foreach n [array names profile] {
924 if {$n != "Default"} {
925 .top.target.m.slist add command -label $n \
926 -command "protocol-setup $n"
931 proc cascade-query-list {} {
935 .top.query.m.slist delete 0 last
936 foreach n $queryTypes {
937 .top.query.m.slist add command -label $n \
938 -command [list query-setup $i]
943 .top.query.m.clist delete 0 last
944 foreach n $queryTypes {
945 .top.query.m.clist add command -label $n \
946 -command [list query-select $i]
951 proc save-settings {} {
954 global settingsChanged
959 set f [open "~/.tk-c" w]
960 puts $f "# Setup file"
961 puts $f "set hotTargets \{ $hotTargets \}"
963 foreach n [array names profile] {
964 puts -nonewline $f "set profile($n) \{"
965 puts -nonewline $f $profile($n)
968 puts -nonewline $f "set queryTypes \{"
969 puts -nonewline $f $queryTypes
972 puts -nonewline $f "set queryButtons \{"
973 puts -nonewline $f $queryButtons
976 puts -nonewline $f "set queryInfo \{"
977 puts -nonewline $f $queryInfo
981 set settingsChanged 0
993 message $w.top.message -text $ask
995 pack $w.top.message -side left -pady 6 -padx 20 -expand yes -fill x
998 top-down-ok-cancel $w {alert-action} 1
1002 proc alert-action {} {
1008 proc exit-action {} {
1009 global settingsChanged
1011 if {$settingsChanged} {
1012 set a [alert "you havent saved your settings. Do you wish to save?"]
1020 proc listbuttonaction {w name h user i} {
1021 $w configure -text [lindex $name 0]
1022 $h [lindex $name 1] $user $i
1025 proc listbuttonx {button no names handle user} {
1026 if {[winfo exists $button]} {
1027 $button configure -text [lindex [lindex $names $no] 0]
1028 ${button}.m delete 0 last
1030 menubutton $button -text [lindex [lindex $names $no] 0] \
1031 -width 10 -menu ${button}.m -relief raised -border 1
1035 foreach name $names {
1036 ${button}.m add command -label [lindex $name 0] \
1037 -command [list listbuttonaction ${button} $name \
1043 proc listbutton {button no names} {
1044 menubutton $button -text [lindex $names $no] -width 10 -menu ${button}.m \
1045 -relief raised -border 1
1047 foreach name $names {
1048 ${button}.m add command -label $name \
1049 -command [list ${button} configure -text $name]
1053 proc query-add-index-action {queryNo} {
1054 set w .setup-query-$queryNo
1057 global queryButtonsTmp
1059 lappend queryInfoTmp [list [.query-add-index.top.index.entry get] {}]
1061 destroy .query-add-index
1062 #destroy $w.top.lines
1063 #frame $w.top.lines -relief ridge -border 2
1064 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1065 #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1068 proc query-add-line {queryNo} {
1069 set w .setup-query-$queryNo
1072 global queryButtonsTmp
1074 lappend queryButtonsTmp {I 0}
1076 #destroy $w.top.lines
1077 #frame $w.top.lines -relief ridge -border 2
1078 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1079 #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1082 proc query-del-line {queryNo} {
1083 set w .setup-query-$queryNo
1086 global queryButtonsTmp
1088 set l [llength $queryButtonsTmp]
1093 set queryButtonsTmp [lreplace $queryButtonsTmp $l $l]
1094 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1097 proc query-add-index {queryNo} {
1098 set w .query-add-index
1101 place-force $w .setup-query-$queryNo
1105 -side top -anchor e -pady 2
1106 entry-fields $w.top {index} \
1108 [list query-add-index-action $queryNo] {destroy .query-add-index}
1109 top-down-ok-cancel $w [list query-add-index-action $queryNo] 1
1112 proc query-setup-action {queryNo} {
1115 global queryButtonsTmp
1117 global queryButtonsFind
1118 global queryInfoFind
1120 set queryInfo [lreplace $queryInfo $queryNo $queryNo \
1122 set queryButtons [lreplace $queryButtons $queryNo $queryNo \
1124 set queryInfoFind $queryInfoTmp
1125 set queryButtonsFind $queryButtonsTmp
1129 destroy .setup-query-$queryNo
1131 index-lines .lines 1 $queryButtonsFind $queryInfoFind activate-index
1134 proc activate-e-index {value no i} {
1135 global queryButtonsTmp
1137 puts $queryButtonsTmp
1138 set queryButtonsTmp [lreplace $queryButtonsTmp $no $no [list I $i]]
1139 puts $queryButtonsTmp
1145 proc activate-index {value no i} {
1146 global queryButtonsFind
1148 set queryButtonsFind [lreplace $queryButtonsFind $no $no [list I $i]]
1150 puts "queryButtonsFind $queryButtonsFind"
1156 proc query-setup {queryNo} {
1157 set w .setup-query-$queryNo
1159 set queryTypes {Simple}
1162 global queryButtonsTmp
1165 set queryName [lindex $queryTypes $queryNo]
1166 set queryInfoTmp [lindex $queryInfo $queryNo]
1167 set queryButtonsTmp [lindex $queryButtons $queryNo]
1169 #set queryButtons { {I 0 I 1 I 2} }
1170 #set queryInfo { { {Title ti} {Author au} {Subject sh} } }
1174 wm title $w "Query setup $queryName"
1179 frame $w.top.lines -relief ridge -border 2
1180 frame $w.top.use -relief ridge -border 2
1181 frame $w.top.relation -relief ridge -border 2
1182 frame $w.top.position -relief ridge -border 2
1183 frame $w.top.structure -relief ridge -border 2
1184 frame $w.top.truncation -relief ridge -border 2
1185 frame $w.top.completeness -relief ridge -border 2
1189 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1191 pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1194 pack $w.top.use -side left -pady 6 -padx 6 -fill y
1196 label $w.top.use.label -text "Use"
1197 listbox $w.top.use.list -geometry 20x10 \
1198 -yscrollcommand "$w.top.use.scroll set"
1199 scrollbar $w.top.use.scroll -orient vertical -border 1
1200 pack $w.top.use.label -side top -fill x \
1202 pack $w.top.use.list -side left -fill both -expand yes \
1204 pack $w.top.use.scroll -side right -fill y \
1206 $w.top.use.scroll config -command "$w.top.use.list yview"
1208 foreach u {{Personal name} {Corporate name}} {
1209 $w.top.use.list insert end $u
1211 # Relation Attributes
1212 pack $w.top.relation -pady 6 -padx 6 -side top
1214 label $w.top.relation.label -text "Relation" -width 18
1216 listbutton $w.top.relation.b 0\
1217 {{None} {Less than} {Greater than or equal} \
1218 {Equal} {Greater than or equal} {Greater than} {Not equal} \
1220 {Stem} {Relevance} {AlwaysMatches}}
1222 pack $w.top.relation.label $w.top.relation.b -fill x
1224 # Position Attributes
1225 pack $w.top.position -pady 6 -padx 6 -side top
1227 label $w.top.position.label -text "Position" -width 18
1229 listbutton $w.top.position.b 0 {{None} {First in field} {First in subfield}
1230 {Any position in field}}
1232 pack $w.top.position.label $w.top.position.b -fill x
1234 # Structure Attributes
1236 pack $w.top.structure -pady 6 -padx 6 -side top
1238 label $w.top.structure.label -text "Structure" -width 18
1240 listbutton $w.top.structure.b 0 {{None} {Phrase} {Word} {Key} {Year}
1241 {Date (norm)} {Word list} {Date (un-norm)} {Name (norm)} {Date (un-norm)}
1242 {Structure} {urx} {free-form} {doc-text} {local-number} {string}
1245 pack $w.top.structure.label $w.top.structure.b -fill x
1247 # Truncation Attributes
1249 pack $w.top.truncation -pady 6 -padx 6 -side top
1251 label $w.top.truncation.label -text "Truncation" -width 18
1253 listbutton $w.top.truncation.b 0 {{Auto} {Right} {Left} {Left and right} \
1254 {No truncation} {Process #} {Re-1} {Re-2}}
1255 pack $w.top.truncation.label $w.top.truncation.b -fill x
1257 # Completeness Attributes
1259 pack $w.top.completeness -pady 6 -padx 6 -side top
1261 label $w.top.completeness.label -text "Truncation" -width 18
1263 listbutton $w.top.completeness.b 0 {{None} {Incomplete subfield} \
1264 {Complete subfield} {Complete field}}
1265 pack $w.top.completeness.label $w.top.completeness.b -fill x
1268 top-down-ok-cancelx $w [list \
1269 {Ok} [list query-setup-action $queryNo] \
1270 {Add index} [list query-add-index $queryNo] \
1271 {Add line} [list query-add-line $queryNo] \
1272 {Delete line} [list query-del-line $queryNo]] 0
1275 proc index-clear {} {
1276 global queryButtonsFind
1279 foreach b $queryButtonsFind {
1280 .lines.$i.e delete 0 end
1285 proc index-query {} {
1286 global queryButtonsFind
1287 global queryInfoFind
1292 foreach b $queryButtonsFind {
1293 set term [string trim [.lines.$i.e get]]
1295 set attr [lindex [lindex $queryInfoFind [lindex $b 1]] 1]
1300 set qs "${qs}${attr}="
1302 set qs "${qs}(${term})"
1310 proc index-lines {w realOp buttonInfo queryInfo handle} {
1312 foreach b $buttonInfo {
1313 if {! [winfo exists $w.$i]} {
1314 frame $w.$i -background white -border 1
1316 listbuttonx $w.$i.l [lindex $b 1] $queryInfo $handle $i
1318 if {! [winfo exists $w.$i.e]} {
1320 entry $w.$i.e -width 32 -relief sunken
1322 pack $w.$i.l -side left
1324 pack $w.$i.e -side left -fill x -expand yes
1326 pack $w.$i -side top -fill x -padx 2 -pady 2
1329 bind $w.$i.e <Left> [list left-cursor $w.$i.e]
1330 bind $w.$i.e <Right> [list right-cursor $w.$i.e]
1331 bind $w.$i.e <Return> search-request
1336 while {[winfo exists $w.$j]} {
1347 bind $w.$j.e <Tab> "focus $w.$k.e \n
1348 $w.$k configure -background red \n
1349 $w.$j configure -background white"
1353 bind $w.$i.e <Tab> "focus $w.0.e \n
1354 $w.0 configure -background red \n
1355 $w.$i configure -background white"
1357 $w.0 configure -background red
1361 proc search-fields {w buttondefs} {
1363 foreach buttondef $buttondefs {
1364 frame $w.$i -background white
1366 listbutton $w.$i.l 0 $buttondef
1367 entry $w.$i.e -width 32 -relief sunken
1369 pack $w.$i.l -side left
1370 pack $w.$i.e -side left -fill x -expand yes
1372 pack $w.$i -side top -fill x -padx 2 -pady 2
1374 bind $w.$i.e <Left> [list left-cursor $w.$i.e]
1375 bind $w.$i.e <Right> [list right-cursor $w.$i.e]
1383 bind $w.$j.e <Tab> "focus $w.$k.e \n
1384 $w.$k configure -background red \n
1385 $w.$j configure -background white"
1388 bind $w.$i.e <Tab> "focus $w.0.e \n
1389 $w.0 configure -background red \n
1390 $w.$i configure -background white"
1392 $w.0 configure -background red
1395 frame .top -border 1 -relief raised
1396 frame .lines -border 1 -relief raised
1397 frame .mid -border 1 -relief raised
1398 frame .data -border 1 -relief raised
1399 frame .bot -border 1 -relief raised
1400 pack .top .lines .mid -side top -fill x
1401 pack .data -side top -fill both -expand yes
1404 menubutton .top.file -text "File" -underline 0 -menu .top.file.m
1406 .top.file.m add command -label "Save settings" -command {save-settings}
1407 .top.file.m add command -label "Load Set" -command {load-set}
1408 .top.file.m add separator
1409 .top.file.m add command -label "Exit" -command {exit-action}
1411 menubutton .top.target -text "Target" -underline 0 -menu .top.target.m
1413 .top.target.m add cascade -label "Connect" -menu .top.target.m.clist
1414 .top.target.m add command -label "Disconnect" -command {close-target}
1415 #.top.target.m add command -label "Initialize" -command {init-request}
1416 .top.target.m add cascade -label "Setup" -menu .top.target.m.slist
1417 .top.target.m add command -label "Setup new" -command {define-target-dialog}
1418 .top.target.m add separator
1421 .top.target.m disable 1
1423 menu .top.target.m.clist
1424 menu .top.target.m.slist
1427 menubutton .top.search -text "Search" -underline 0 -menu .top.search.m
1429 .top.search.m add command -label "Database" -command {database-select}
1430 .top.search.m add cascade -label "Query type" -menu .top.search.m.querytype
1431 menu .top.search.m.querytype
1432 .top.search.m.querytype add radiobutton -label "RPN"
1433 .top.search.m.querytype add radiobutton -label "CCL"
1434 .top.search.m add cascade -label "Present" -menu .top.search.m.present
1435 menu .top.search.m.present
1436 .top.search.m.present add command -label "More" -command [list present-more 10]
1437 .top.search.m.present add command -label "All" -command [list present-more {}]
1438 .top.search configure -state disabled
1440 menubutton .top.query -text "Query" -underline 0 -menu .top.query.m
1442 .top.query.m add cascade -label "Choose" -menu .top.query.m.clist
1443 .top.query.m add command -label "Define" -command {new-query-dialog}
1444 .top.query.m add cascade -label "Edit" -menu .top.query.m.slist
1445 menu .top.query.m.clist
1446 menu .top.query.m.slist
1449 menubutton .top.help -text "Help" -menu .top.help.m
1452 .top.help.m add command -label "Help on help" -command {puts "Help on help"}
1453 .top.help.m add command -label "About" -command {puts "About"}
1455 pack .top.file .top.target .top.query .top.search -side left
1456 pack .top.help -side right
1458 index-lines .lines 1 $queryButtonsFind [lindex $queryInfo 0] activate-index
1460 button .mid.search -width 6 -text {Search} -command search-request \
1462 button .mid.scan -width 6 -text {Scan} -command scan-request \
1464 button .mid.clear -width 6 -text {Clear} -command index-clear
1465 pack .mid.search .mid.scan .mid.clear -side left -padx 5 -pady 3
1467 listbox .data.list -yscrollcommand {.data.scroll set} -font fixed
1468 scrollbar .data.scroll -orient vertical -border 1
1469 pack .data.list -side left -fill both -expand yes
1470 pack .data.scroll -side right -fill y
1471 .data.scroll config -command {.data.list yview}
1473 message .bot.target -text "None" -aspect 1000 -relief sunken -border 1
1474 label .bot.status -text "Not connected" -width 12 -relief \
1475 sunken -anchor w -border 1
1476 label .bot.set -textvariable setNo -width 5 -relief \
1477 sunken -anchor w -border 1
1478 label .bot.message -text "" -width 14 -relief \
1479 sunken -anchor w -border 1
1480 pack .bot.target .bot.status .bot.set .bot.message -anchor nw \
1481 -side left -padx 2 -pady 2
1483 bind .data.list <Double-Button-1> {set indx [.data.list nearest %y]
1484 show-full-marc $indx}