3 # Revision 1.20 1995-04-21 16:31:57 adam
4 # New radiobutton: protocol (z39v2/SR).
6 # Revision 1.19 1995/04/18 16:11:50 adam
7 # First version of graphical Scan. Some work on query-by-form.
9 # Revision 1.18 1995/04/10 10:50:22 adam
10 # Result-set name defaults to suffix of ir-set name.
11 # Started working on scan. Not finished at this point.
13 # Revision 1.17 1995/03/31 09:34:57 adam
14 # Search-button disabled when there is no connection.
16 # Revision 1.16 1995/03/31 08:56:36 adam
17 # New button "Search".
19 # Revision 1.15 1995/03/28 12:45:22 adam
20 # New ir method failback: called on disconnect/protocol error.
21 # New ir set/get method: protocol: SR / Z3950.
22 # Simple popup and disconnect when failback is invoked.
24 # Revision 1.14 1995/03/22 16:07:55 adam
27 # Revision 1.13 1995/03/21 17:27:26 adam
28 # Short-hand keys in setup.
30 # Revision 1.12 1995/03/21 13:41:03 adam
31 # Comstack cs_create not used too often. Non-blocking connect.
33 # Revision 1.11 1995/03/21 10:39:06 adam
34 # Diagnostic error message displayed with tkerror.
36 # Revision 1.10 1995/03/20 15:24:06 adam
37 # Diagnostic records saved on searchResponse.
39 # Revision 1.9 1995/03/17 18:26:16 adam
40 # Non-blocking i/o used now. Database names popup as cascade items.
42 # Revision 1.8 1995/03/17 15:45:00 adam
43 # Improved target/database setup.
45 # Revision 1.7 1995/03/16 17:54:03 adam
46 # Minor changes really.
48 # Revision 1.6 1995/03/15 19:10:20 adam
49 # Database setup in protocol-setup (rather target setup).
51 # Revision 1.5 1995/03/15 13:59:23 adam
54 # Revision 1.4 1995/03/14 17:32:29 adam
55 # Presentation of full Marc record in popup window.
57 # Revision 1.3 1995/03/12 19:31:52 adam
58 # Pattern matching implemented when retrieving MARC records. More
59 # diagnostic functions.
61 # Revision 1.2 1995/03/10 18:00:15 adam
62 # Actual presentation in line-by-line format. RPN query support.
64 # Revision 1.1 1995/03/09 16:15:07 adam
65 # First presentRequest attempts. Hot-target list.
72 set profile(Default) {{} {} {210} {} 16384 8192 tcpip {} 1 {} {} z39v2}
77 set queryTypes {Simple}
78 set queryButtons { { {I 0} {I 1} {I 2} } }
79 set queryInfo { { {Title ti} {Author au} {Subject sh} {Any any} } }
83 if {[file readable "~/.tk-c"]} {
87 set queryButtonsFind [lindex $queryButtons 0]
88 set queryInfoFind [lindex $queryInfo 0]
90 proc top-down-window {w} {
91 frame $w.top -relief raised -border 1
92 frame $w.bot -relief raised -border 1
94 pack $w.top $w.bot -side top -fill both -expand yes
97 proc top-down-ok-cancel {w ok-action g} {
98 frame $w.bot.left -relief sunken -border 1
99 pack $w.bot.left -side left -expand yes -padx 5 -pady 5
100 button $w.bot.left.ok -width 6 -text {Ok} \
101 -command ${ok-action}
102 pack $w.bot.left.ok -expand yes -padx 3 -pady 3
103 button $w.bot.cancel -width 6 -text {Cancel} \
104 -command "destroy $w"
105 pack $w.bot.cancel -side left -expand yes
114 proc top-down-ok-cancelx {w buttonList g} {
116 set l [llength $buttonList]
118 frame $w.bot.$i -relief sunken -border 1
119 pack $w.bot.$i -side left -expand yes -padx 5 -pady 5
120 button $w.bot.$i.ok -text [lindex $buttonList $i] \
121 -command [lindex $buttonList [expr $i+1]]
122 pack $w.bot.$i.ok -expand yes -padx 3 -pady 3 -side left
126 button $w.bot.$i -text [lindex $buttonList $i] \
127 -command [lindex $buttonList [expr $i+1]]
128 pack $w.bot.$i -expand yes -padx 3 -pady 3 -side left
131 button $w.bot.cancel -width 6 -text {Cancel} \
132 -command "destroy $w"
133 pack $w.bot.cancel -side left -expand yes
142 proc show-target {target} {
143 .bot.target configure -text "$target"
146 proc show-busy {v1 v2} {
149 .bot.status configure -fg $v1
150 after 200 [list show-busy $v2 $v1]
154 proc show-status {status b} {
157 .bot.status configure -text "$status"
158 .bot.status configure -fg black
164 # . config -cursor {watch black white}
166 # . config -cursor {top_left_arrow black white}
172 proc show-message {msg} {
173 .bot.message configure -text "$msg"
176 proc insertWithTags {w text args} {
177 set start [$w index insert]
178 $w insert insert $text
179 foreach tag [$w tag names $start] {
180 $w tag remove $tag $start insert
183 $w tag add $i $start insert
187 proc show-full-marc {no} {
192 if {[winfo exists $w]} {
193 $w.top.record delete 0.0 end
199 wm minsize $w 200 200
201 frame $w.top -relief raised -border 1
202 frame $w.bot -relief raised -border 1
204 pack $w.top -side top -fill both -expand yes
205 pack $w.bot -fill both
207 text $w.top.record -width 60 -height 12 -wrap word \
208 -yscrollcommand [list $w.top.s set]
209 scrollbar $w.top.s -command [list $w.top.record yview]
215 set r [z39.$setNo recordMarc $no line * * *]
217 $w.top.record tag configure marc-tag -foreground blue
218 $w.top.record tag configure marc-data -foreground black
219 $w.top.record tag configure marc-id -foreground red
222 set tag [lindex $line 0]
223 set indicator [lindex $line 1]
224 set fields [lindex $line 2]
226 if {$indicator != ""} {
227 insertWithTags $w.top.record "$tag $indicator" marc-tag
229 insertWithTags $w.top.record "$tag " marc-tag
231 foreach field $fields {
232 set id [lindex $field 0]
233 set data [lindex $field 1]
235 insertWithTags $w.top.record " $id " marc-id
237 set start [$w.top.record index insert]
238 insertWithTags $w.top.record $data {}
240 $w.top.record insert end "\n"
243 bind $w <Return> {destroy .full-marc}
245 pack $w.top.s -side right -fill y
246 pack $w.top.record -expand yes -fill both
248 frame $w.bot.left -relief sunken -border 1
249 pack $w.bot.left -side left -expand yes -padx 5 -pady 5
250 button $w.bot.left.close -width 6 -text {Close} \
251 -command {destroy .full-marc}
252 pack $w.bot.left.close -expand yes -padx 3 -pady 3
253 button $w.bot.edit -width 6 -text {Edit} \
254 -command {destroy .full-marc}
255 pack $w.bot.edit -side left -expand yes
259 proc update-target-hotlist {target} {
262 set len [llength $hotTargets]
264 .top.target.m delete 5 [expr 5+[llength $hotTargets]]
266 set indx [lsearch $hotTargets $target]
268 set hotTargets [lreplace $hotTargets $indx $indx]
270 set hotTargets [linsert $hotTargets 0 $target]
274 proc set-target-hotlist {} {
278 foreach target $hotTargets {
279 .top.target.m add command -label "$i $target" -command \
280 "reopen-target $target {}"
288 proc reopen-target {target base} {
290 open-target $target $base
291 update-target-hotlist $target
294 proc define-target-action {} {
297 set target [.target-define.top.target.entry get]
301 update-target-hotlist $target
302 foreach n [array names profile] {
308 set profile($target) $profile(Default)
309 protocol-setup $target
310 destroy .target-define
313 proc fail-response {target} {
315 tkerror "Target connection closed or protocol error"
318 proc connect-response {target} {
319 puts "connect-response"
324 proc open-target {target base} {
329 z39 comstack [lindex $profile($target) 6]
330 # z39 idAuthentication [lindex $profile($target) 3]
331 z39 maximumRecordSize [lindex $profile($target) 4]
332 z39 preferredMessageSize [lindex $profile($target) 5]
333 puts -nonewline "maximumRecordSize="
334 puts [z39 maximumRecordSize]
335 puts -nonewline "preferredMessageSize="
336 puts [z39 preferredMessageSize]
338 z39 databaseNames [lindex [lindex $profile($target) 7] 0]
340 z39 databaseNames $base
342 z39 failback [list fail-response $target]
343 z39 callback [list connect-response $target]
344 z39 connect [lindex $profile($target) 1]:[lindex $profile($target) 2]
345 show-status {Connecting} 1
347 .top.target.m disable 0
348 .top.target.m enable 1
351 proc close-target {} {
357 show-status {Not connected} 0
359 .top.target.m disable 1
360 .top.target.m enable 0
361 .top.search configure -state disabled
362 .mid.search configure -state disabled
363 .mid.scan configure -state disabled
366 proc load-set-action {} {
372 set fname [.load-set.top.filename.entry get]
377 show-status {Loading} 1
378 z39.$setNo loadFile $fname
380 set no [z39.$setNo numberOfRecordsReturned]
381 add-title-lines $setNo $no 1
383 show-status {Ready} 0
396 frame $w.top.filename
398 pack $w.top.filename -side top -anchor e -pady 2
400 entry-fields $w.top {filename} \
402 {load-set-action} {destroy .load-set}
404 top-down-ok-cancel $w {load-set-action} 1
408 proc init-request {} {
411 z39 callback {init-response}
413 show-status {Initializing} 1
416 proc init-response {} {
417 show-status {Ready} 0
418 .top.search configure -state normal
419 .mid.search configure -state normal
420 .mid.scan configure -state normal
423 proc search-request {} {
430 set query [index-query]
438 if {[lindex $profile($target) 10] != ""} {
439 z39.$setNo setName $setNo
441 z39.$setNo setName Default
443 if {[lindex $profile($target) 8] != ""} {
446 if {[lindex $profile($target) 9] != ""} {
449 z39 callback {search-response}
450 z39.$setNo search $query
451 show-status {Search} 1
454 proc scan-request {} {
464 z39 callback {scan-response}
465 if {![winfo exists $w]} {
470 wm minsize $w 200 200
474 listbox $w.top.list -yscrollcommand [list $w.top.scroll set] \
475 -font fixed -geometry 50x14
476 scrollbar $w.top.scroll -orient vertical -border 1
477 pack $w.top.list -side left -fill both -expand yes
478 pack $w.top.scroll -side right -fill y
479 $w.top.scroll config -command [list $w.top.list yview]
481 top-down-ok-cancelx $w [list {Close} [list destroy $w]] 0
488 proc scan-response {} {
490 set m [z39.scan numberOfEntriesReturned]
492 for {set i 0} {$i < $m} {incr i} {
493 set term [lindex [z39.scan scanLine $i] 1]
494 set nostr [format "%7d" [lindex [z39.scan scanLine $i] 2]]
496 $w.top.list insert end "$nostr $term"
498 show-status {Ready} 0
501 proc search-response {} {
507 show-status {Ready} 0
508 show-message "[z39.$setNo resultCount] hits"
509 set setMax [z39.$setNo resultCount]
512 set status [z39.$setNo responseStatus]
513 if {[lindex $status 0] == "NSD"} {
514 set code [lindex $status 1]
515 set msg [lindex $status 2]
516 set addinfo [lindex $status 3]
517 tkerror "NSD$code: $msg: $addinfo"
524 z39 callback {present-response}
526 z39.$setNo present $setOffset $setMax
527 show-status {Retrieve} 1
530 proc present-more {number} {
539 set max [z39.$setNo resultCount]
540 if {$max <= $setMax} {
544 puts "setOffset=$setOffset"
550 z39 callback {present-response}
551 z39.$setNo present $setOffset [expr $setMax - $setOffset + 1]
552 show-status {Retrieve} 1
555 proc init-title-lines {} {
556 .data.list delete 0 end
559 proc add-title-lines {setno no offset} {
560 for {set i 0} {$i < $no} {incr i} {
561 set o [expr $i + $offset]
562 set title [lindex [z39.$setno recordMarc $o field 245 * a] 0]
563 set year [lindex [z39.$setno recordMarc $o field 260 * c] 0]
564 set nostr [format "%5d" $o]
565 .data.list insert end "$nostr $title - $year"
569 proc present-response {} {
574 puts "In present-response"
575 set no [z39.$setNo numberOfRecordsReturned]
576 puts "Returned $no records, setOffset $setOffset"
577 add-title-lines $setNo $no $setOffset
578 set setOffset [expr $setOffset + $no]
579 set status [z39.$setNo responseStatus]
580 if {[lindex $status 0] == "NSD"} {
581 show-status {Ready} 0
582 set code [lindex $status 1]
583 set msg [lindex $status 2]
584 set addinfo [lindex $status 3]
585 tkerror "NSD$code: $msg: $addinfo"
588 if {$no > 0 && $setOffset <= $setMax} {
589 z39.$setNo present $setOffset [expr $setMax - $setOffset + 1]
591 show-status {Finished} 0
595 proc left-cursor {w} {
596 set i [$w index insert]
603 proc right-cursor {w} {
604 set i [$w index insert]
609 proc bind-fields {list returnAction escapeAction} {
610 set max [expr [llength $list]-1]
611 for {set i 0} {$i < $max} {incr i} {
612 bind [lindex $list $i] <Return> $returnAction
613 bind [lindex $list $i] <Escape> $escapeAction
614 bind [lindex $list $i] <Tab> [list focus [lindex $list [expr $i+1]]]
615 bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
616 bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
618 bind [lindex $list $i] <Return> $returnAction
619 bind [lindex $list $i] <Escape> $escapeAction
620 bind [lindex $list $i] <Tab> [list focus [lindex $list 0]]
621 bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
622 bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
623 focus [lindex $list 0]
626 proc entry-fields {parent list tlist returnAction escapeAction} {
629 foreach field $list {
630 set label ${parent}.${field}.label
631 set entry ${parent}.${field}.entry
632 label $label -text [lindex $tlist $i] -anchor e
633 entry $entry -width 32 -relief sunken
634 pack $label -side left
635 pack $entry -side right
639 bind-fields $alist $returnAction $escapeAction
642 proc define-target-dialog {} {
650 -side top -anchor e -pady 2
651 entry-fields $w.top {target} \
653 {define-target-action} {destroy .target-define}
654 top-down-ok-cancel $w {define-target-action} 1
657 proc protocol-setup-action {target} {
660 global protocolRadioType
661 global settingsChanged
664 global ResultSetCheck
666 set w .setup-${target}.top
668 #set w .protocol-setup.top
671 set settingsChanged 1
672 set len [$w.databases.list size]
673 for {set i 0} {$i < $len} {incr i} {
674 lappend b [$w.databases.list get $i]
676 set profile($target) [list [$w.description.entry get] \
677 [$w.host.entry get] \
678 [$w.port.entry get] \
679 [$w.idAuthentication.entry get] \
680 [$w.maximumRecordSize.entry get] \
681 [$w.preferredMessageSize.entry get] \
690 puts $profile($target)
691 destroy .setup-${target}
694 proc place-force {window parent} {
695 set g [wm geometry $parent]
697 set p1 [string first + $g]
698 set p2 [string last + $g]
700 set x [expr 40+[string range $g [expr $p1 +1] [expr $p2 -1]]]
701 set y [expr 60+[string range $g [expr $p2 +1] end]]
702 wm geometry $window +${x}+${y}
705 proc add-database-action {target} {
706 set w .setup-${target}
708 ${w}.top.databases.list insert end \
709 [.database-select.top.database.entry get]
710 destroy .database-select
713 proc add-database {target} {
714 set w .database-select
719 place-force $w .setup-${target}
723 frame $w.top.database
725 pack $w.top.database -side top -anchor e -pady 2
727 entry-fields $w.top {database} \
728 {{Database to add:}} \
729 [list add-database-action $target] {destroy .database-select}
731 top-down-ok-cancel $w [list add-database-action $target] 1
735 proc delete-database {target} {
736 set w .setup-${target}
738 foreach i [lsort -decreasing \
739 [$w.top.databases.list curselection]] {
740 $w.top.databases.list delete $i
744 proc protocol-setup {target} {
749 global protocolRadioType
752 global ResultSetCheck
756 wm title $w "Setup $target"
765 puts $profile($target)
769 frame $w.top.description
770 frame $w.top.idAuthentication
771 frame $w.top.maximumRecordSize
772 frame $w.top.preferredMessageSize
773 frame $w.top.cs-type -relief ridge -border 2
774 frame $w.top.protocol -relief ridge -border 2
775 frame $w.top.query -relief ridge -border 2
776 frame $w.top.databases -relief ridge -border 2
778 # Maximum/preferred/idAuth ...
779 pack $w.top.description $w.top.host $w.top.port \
780 $w.top.idAuthentication $w.top.maximumRecordSize \
781 $w.top.preferredMessageSize -side top -anchor e -pady 2
783 entry-fields $w.top {description host port idAuthentication \
784 maximumRecordSize preferredMessageSize} \
785 {{Description:} {Host:} {Port:} {Id Authentication:} \
786 {Maximum Record Size:} {Preferred Message Size:}} \
787 [list protocol-setup-action $target] [list destroy $w]
789 foreach sub {description host port idAuthentication \
790 maximumRecordSize preferredMessageSize} {
792 bind $w.top.$sub.entry <Control-a> "add-database $target"
793 bind $w.top.$sub.entry <Control-d> "delete-database $target"
795 $w.top.description.entry insert 0 [lindex $profile($target) 0]
796 $w.top.host.entry insert 0 [lindex $profile($target) 1]
797 $w.top.port.entry insert 0 [lindex $profile($target) 2]
798 $w.top.idAuthentication.entry insert 0 [lindex $profile($target) 3]
799 $w.top.maximumRecordSize.entry insert 0 [lindex $profile($target) 4]
800 $w.top.preferredMessageSize.entry insert 0 [lindex $profile($target) 5]
801 set csRadioType [lindex $profile($target) 6]
802 set RPNCheck [lindex $profile($target) 8]
803 set CCLCheck [lindex $profile($target) 9]
804 set ResultSetCheck [lindex $profile($target) 10]
805 set protocolRadioType [lindex $profile($target) 11]
806 if {$protocolRadioType == ""} {
807 set protocolRadioType z39v2
811 pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill both
813 label $w.top.databases.label -text "Databases"
814 button $w.top.databases.add -text "Add" \
815 -command "add-database $target"
816 button $w.top.databases.delete -text "Delete" \
817 -command "delete-database $target"
818 listbox $w.top.databases.list -geometry 20x6 \
819 -yscrollcommand "$w.top.databases.scroll set"
820 scrollbar $w.top.databases.scroll -orient vertical -border 1
821 pack $w.top.databases.label -side top -fill x \
823 pack $w.top.databases.add $w.top.databases.delete -side top -fill x \
825 pack $w.top.databases.list -side left -fill both -expand yes \
827 pack $w.top.databases.scroll -side right -fill y \
829 $w.top.databases.scroll config -command "$w.top.databases.list yview"
831 foreach b [lindex $profile($target) 7] {
832 $w.top.databases.list insert end $b
836 pack $w.top.cs-type -pady 6 -padx 6 -side top -fill x
838 label $w.top.cs-type.label -text "Transport"
839 radiobutton $w.top.cs-type.tcpip -text "TCP/IP" -anchor w \
840 -command {puts tcp/ip} -variable csRadioType -value tcpip
841 radiobutton $w.top.cs-type.mosi -text "MOSI" -anchor w\
842 -command {puts mosi} -variable csRadioType -value mosi
844 pack $w.top.cs-type.label $w.top.cs-type.tcpip $w.top.cs-type.mosi \
845 -padx 4 -side top -fill x
848 pack $w.top.protocol -pady 6 -padx 6 -side top -fill x
850 label $w.top.protocol.label -text "Protocol"
851 radiobutton $w.top.protocol.z39v2 -text "Z39.50" -anchor w \
852 -command {puts z39v2} -variable protocolRadioType -value z39v2
853 radiobutton $w.top.protocol.sr -text "SR" -anchor w \
854 -command {puts sr} -variable protocolRadioType -value sr
856 pack $w.top.protocol.label $w.top.protocol.z39v2 $w.top.protocol.sr \
857 -padx 4 -side top -fill x
860 pack $w.top.query -pady 6 -padx 6 -side top -fill x
862 label $w.top.query.label -text "Query support"
863 checkbutton $w.top.query.c1 -text "RPN query" -anchor w -variable RPNCheck
864 checkbutton $w.top.query.c2 -text "CCL query" -anchor w -variable CCLCheck
865 checkbutton $w.top.query.c3 -text "Result sets" -anchor w -variable ResultSetCheck
867 pack $w.top.query.label -side top
868 pack $w.top.query.c1 $w.top.query.c2 $w.top.query.c3 \
869 -padx 4 -side top -fill x
872 top-down-ok-cancel $w [list protocol-setup-action $target] 0
875 proc database-select-action {} {
876 set w .database-select.top
878 foreach indx [$w.databases.list curselection] {
879 lappend b [$w.databases.list get $indx]
884 destroy .database-select
887 proc database-select {} {
888 set w .database-select
898 frame $w.top.databases -relief ridge -border 2
900 pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill x
902 label $w.top.databases.label -text "List"
903 listbox $w.top.databases.list -geometry 20x6 \
904 -yscrollcommand "$w.top.databases.scroll set"
905 scrollbar $w.top.databases.scroll -orient vertical -border 1
906 pack $w.top.databases.label -side top -fill x \
908 pack $w.top.databases.list -side left -fill both -expand yes \
910 pack $w.top.databases.scroll -side right -fill y \
912 $w.top.databases.scroll config -command "$w.top.databases.list yview"
914 foreach b [lindex $profile($hostid) 7] {
915 $w.top.databases.list insert end $b
917 top-down-ok-cancel $w {database-select-action} 1
920 proc cascade-target-list {} {
923 foreach sub [winfo children .top.target.m.clist] {
927 .top.target.m.clist delete 0 last
928 foreach n [array names profile] {
929 if {$n != "Default"} {
930 set nl [string tolower $n]
931 if {[llength [lindex $profile($n) 7]] > 1} {
932 .top.target.m.clist add cascade -label $n \
933 -menu .top.target.m.clist.$nl
934 menu .top.target.m.clist.$nl
935 foreach b [lindex $profile($n) 7] {
936 .top.target.m.clist.$nl add command -label $b \
937 -command "reopen-target $n $b"
940 .top.target.m.clist add command -label $n \
941 -command "reopen-target $n {}"
945 .top.target.m.slist delete 0 last
946 foreach n [array names profile] {
947 if {$n != "Default"} {
948 .top.target.m.slist add command -label $n \
949 -command "protocol-setup $n"
954 proc cascade-query-list {} {
958 .top.query.m.slist delete 0 last
959 foreach n $queryTypes {
960 .top.query.m.slist add command -label $n \
961 -command [list query-setup $i]
966 .top.query.m.clist delete 0 last
967 foreach n $queryTypes {
968 .top.query.m.clist add command -label $n \
969 -command [list query-select $i]
974 proc save-settings {} {
977 global settingsChanged
982 set f [open "~/.tk-c" w]
983 puts $f "# Setup file"
984 puts $f "set hotTargets \{ $hotTargets \}"
986 foreach n [array names profile] {
987 puts -nonewline $f "set profile($n) \{"
988 puts -nonewline $f $profile($n)
991 puts -nonewline $f "set queryTypes \{"
992 puts -nonewline $f $queryTypes
995 puts -nonewline $f "set queryButtons \{"
996 puts -nonewline $f $queryButtons
999 puts -nonewline $f "set queryInfo \{"
1000 puts -nonewline $f $queryInfo
1004 set settingsChanged 0
1016 message $w.top.message -text $ask
1018 pack $w.top.message -side left -pady 6 -padx 20 -expand yes -fill x
1021 top-down-ok-cancel $w {alert-action} 1
1025 proc alert-action {} {
1031 proc exit-action {} {
1032 global settingsChanged
1034 if {$settingsChanged} {
1035 set a [alert "you havent saved your settings. Do you wish to save?"]
1043 proc listbuttonaction {w name h user i} {
1044 $w configure -text [lindex $name 0]
1045 $h [lindex $name 1] $user $i
1048 proc listbuttonx {button no names handle user} {
1049 if {[winfo exists $button]} {
1050 $button configure -text [lindex [lindex $names $no] 0]
1051 ${button}.m delete 0 last
1053 menubutton $button -text [lindex [lindex $names $no] 0] \
1054 -width 10 -menu ${button}.m -relief raised -border 1
1058 foreach name $names {
1059 ${button}.m add command -label [lindex $name 0] \
1060 -command [list listbuttonaction ${button} $name \
1066 proc listbutton {button no names} {
1067 menubutton $button -text [lindex $names $no] -width 10 -menu ${button}.m \
1068 -relief raised -border 1
1070 foreach name $names {
1071 ${button}.m add command -label $name \
1072 -command [list ${button} configure -text $name]
1076 proc query-add-index-action {queryNo} {
1077 set w .setup-query-$queryNo
1080 global queryButtonsTmp
1082 lappend queryInfoTmp [list [.query-add-index.top.index.entry get] {}]
1084 destroy .query-add-index
1085 #destroy $w.top.lines
1086 #frame $w.top.lines -relief ridge -border 2
1087 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1088 #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1091 proc query-add-line {queryNo} {
1092 set w .setup-query-$queryNo
1095 global queryButtonsTmp
1097 lappend queryButtonsTmp {I 0}
1099 #destroy $w.top.lines
1100 #frame $w.top.lines -relief ridge -border 2
1101 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1102 #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1105 proc query-del-line {queryNo} {
1106 set w .setup-query-$queryNo
1109 global queryButtonsTmp
1111 set l [llength $queryButtonsTmp]
1116 set queryButtonsTmp [lreplace $queryButtonsTmp $l $l]
1117 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1120 proc query-add-index {queryNo} {
1121 set w .query-add-index
1124 place-force $w .setup-query-$queryNo
1128 -side top -anchor e -pady 2
1129 entry-fields $w.top {index} \
1131 [list query-add-index-action $queryNo] {destroy .query-add-index}
1132 top-down-ok-cancel $w [list query-add-index-action $queryNo] 1
1135 proc query-setup-action {queryNo} {
1138 global queryButtonsTmp
1140 global queryButtonsFind
1141 global queryInfoFind
1143 set queryInfo [lreplace $queryInfo $queryNo $queryNo \
1145 set queryButtons [lreplace $queryButtons $queryNo $queryNo \
1147 set queryInfoFind $queryInfoTmp
1148 set queryButtonsFind $queryButtonsTmp
1152 destroy .setup-query-$queryNo
1154 index-lines .lines 1 $queryButtonsFind $queryInfoFind activate-index
1157 proc activate-e-index {value no i} {
1158 global queryButtonsTmp
1160 puts $queryButtonsTmp
1161 set queryButtonsTmp [lreplace $queryButtonsTmp $no $no [list I $i]]
1162 puts $queryButtonsTmp
1168 proc activate-index {value no i} {
1169 global queryButtonsFind
1171 set queryButtonsFind [lreplace $queryButtonsFind $no $no [list I $i]]
1173 puts "queryButtonsFind $queryButtonsFind"
1179 proc query-setup {queryNo} {
1180 set w .setup-query-$queryNo
1182 set queryTypes {Simple}
1185 global queryButtonsTmp
1188 set queryName [lindex $queryTypes $queryNo]
1189 set queryInfoTmp [lindex $queryInfo $queryNo]
1190 set queryButtonsTmp [lindex $queryButtons $queryNo]
1192 #set queryButtons { {I 0 I 1 I 2} }
1193 #set queryInfo { { {Title ti} {Author au} {Subject sh} } }
1197 wm title $w "Query setup $queryName"
1202 frame $w.top.lines -relief ridge -border 2
1203 frame $w.top.use -relief ridge -border 2
1204 frame $w.top.relation -relief ridge -border 2
1205 frame $w.top.position -relief ridge -border 2
1206 frame $w.top.structure -relief ridge -border 2
1207 frame $w.top.truncation -relief ridge -border 2
1208 frame $w.top.completeness -relief ridge -border 2
1212 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1214 pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1217 pack $w.top.use -side left -pady 6 -padx 6 -fill y
1219 label $w.top.use.label -text "Use"
1220 listbox $w.top.use.list -geometry 20x10 \
1221 -yscrollcommand "$w.top.use.scroll set"
1222 scrollbar $w.top.use.scroll -orient vertical -border 1
1223 pack $w.top.use.label -side top -fill x \
1225 pack $w.top.use.list -side left -fill both -expand yes \
1227 pack $w.top.use.scroll -side right -fill y \
1229 $w.top.use.scroll config -command "$w.top.use.list yview"
1231 foreach u {{Personal name} {Corporate name}} {
1232 $w.top.use.list insert end $u
1234 # Relation Attributes
1235 pack $w.top.relation -pady 6 -padx 6 -side top
1237 label $w.top.relation.label -text "Relation" -width 18
1239 listbutton $w.top.relation.b 0\
1240 {{None} {Less than} {Greater than or equal} \
1241 {Equal} {Greater than or equal} {Greater than} {Not equal} \
1243 {Stem} {Relevance} {AlwaysMatches}}
1245 pack $w.top.relation.label $w.top.relation.b -fill x
1247 # Position Attributes
1248 pack $w.top.position -pady 6 -padx 6 -side top
1250 label $w.top.position.label -text "Position" -width 18
1252 listbutton $w.top.position.b 0 {{None} {First in field} {First in subfield}
1253 {Any position in field}}
1255 pack $w.top.position.label $w.top.position.b -fill x
1257 # Structure Attributes
1259 pack $w.top.structure -pady 6 -padx 6 -side top
1261 label $w.top.structure.label -text "Structure" -width 18
1263 listbutton $w.top.structure.b 0 {{None} {Phrase} {Word} {Key} {Year}
1264 {Date (norm)} {Word list} {Date (un-norm)} {Name (norm)} {Date (un-norm)}
1265 {Structure} {urx} {free-form} {doc-text} {local-number} {string}
1268 pack $w.top.structure.label $w.top.structure.b -fill x
1270 # Truncation Attributes
1272 pack $w.top.truncation -pady 6 -padx 6 -side top
1274 label $w.top.truncation.label -text "Truncation" -width 18
1276 listbutton $w.top.truncation.b 0 {{Auto} {Right} {Left} {Left and right} \
1277 {No truncation} {Process #} {Re-1} {Re-2}}
1278 pack $w.top.truncation.label $w.top.truncation.b -fill x
1280 # Completeness Attributes
1282 pack $w.top.completeness -pady 6 -padx 6 -side top
1284 label $w.top.completeness.label -text "Truncation" -width 18
1286 listbutton $w.top.completeness.b 0 {{None} {Incomplete subfield} \
1287 {Complete subfield} {Complete field}}
1288 pack $w.top.completeness.label $w.top.completeness.b -fill x
1291 top-down-ok-cancelx $w [list \
1292 {Ok} [list query-setup-action $queryNo] \
1293 {Add index} [list query-add-index $queryNo] \
1294 {Add line} [list query-add-line $queryNo] \
1295 {Delete line} [list query-del-line $queryNo]] 0
1298 proc index-clear {} {
1299 global queryButtonsFind
1302 foreach b $queryButtonsFind {
1303 .lines.$i.e delete 0 end
1308 proc index-query {} {
1309 global queryButtonsFind
1310 global queryInfoFind
1315 foreach b $queryButtonsFind {
1316 set term [string trim [.lines.$i.e get]]
1318 set attr [lindex [lindex $queryInfoFind [lindex $b 1]] 1]
1323 set qs "${qs}${attr}="
1325 set qs "${qs}(${term})"
1333 proc index-lines {w realOp buttonInfo queryInfo handle} {
1335 foreach b $buttonInfo {
1336 if {! [winfo exists $w.$i]} {
1337 frame $w.$i -background white -border 1
1339 listbuttonx $w.$i.l [lindex $b 1] $queryInfo $handle $i
1342 if {! [winfo exists $w.$i.e]} {
1343 entry $w.$i.e -width 32 -relief sunken -border 1
1344 bind $w.$i.e <FocusIn> [list $w.$i configure \
1346 bind $w.$i.e <FocusOut> [list $w.$i configure \
1348 pack $w.$i.l -side left
1349 pack $w.$i.e -side left -fill x -expand yes
1350 pack $w.$i -side top -fill x -padx 2 -pady 2
1351 bind $w.$i.e <Left> [list left-cursor $w.$i.e]
1352 bind $w.$i.e <Right> [list right-cursor $w.$i.e]
1353 bind $w.$i.e <Return> search-request
1356 pack $w.$i.l -side left
1357 pack $w.$i -side top -fill x -padx 2 -pady 2
1362 while {[winfo exists $w.$j]} {
1373 bind $w.$j.e <Tab> "focus $w.$k.e"
1377 bind $w.$i.e <Tab> "focus $w.0.e"
1382 proc search-fields {w buttondefs} {
1384 foreach buttondef $buttondefs {
1385 frame $w.$i -background white
1387 listbutton $w.$i.l 0 $buttondef
1388 entry $w.$i.e -width 32 -relief sunken
1390 pack $w.$i.l -side left
1391 pack $w.$i.e -side left -fill x -expand yes
1393 pack $w.$i -side top -fill x -padx 2 -pady 2
1395 bind $w.$i.e <Left> [list left-cursor $w.$i.e]
1396 bind $w.$i.e <Right> [list right-cursor $w.$i.e]
1404 bind $w.$j.e <Tab> "focus $w.$k.e \n
1405 $w.$k configure -background red \n
1406 $w.$j configure -background white"
1409 bind $w.$i.e <Tab> "focus $w.0.e \n
1410 $w.0 configure -background red \n
1411 $w.$i configure -background white"
1413 $w.0 configure -background red
1416 frame .top -border 1 -relief raised
1417 frame .lines -border 1 -relief raised
1418 frame .mid -border 1 -relief raised
1419 frame .data -border 1 -relief raised
1420 frame .bot -border 1 -relief raised
1421 pack .top .lines .mid -side top -fill x
1422 pack .data -side top -fill both -expand yes
1425 menubutton .top.file -text "File" -underline 0 -menu .top.file.m
1427 .top.file.m add command -label "Save settings" -command {save-settings}
1428 .top.file.m add command -label "Load Set" -command {load-set}
1429 .top.file.m add separator
1430 .top.file.m add command -label "Exit" -command {exit-action}
1432 menubutton .top.target -text "Target" -underline 0 -menu .top.target.m
1434 .top.target.m add cascade -label "Connect" -menu .top.target.m.clist
1435 .top.target.m add command -label "Disconnect" -command {close-target}
1436 #.top.target.m add command -label "Initialize" -command {init-request}
1437 .top.target.m add cascade -label "Setup" -menu .top.target.m.slist
1438 .top.target.m add command -label "Setup new" -command {define-target-dialog}
1439 .top.target.m add separator
1442 .top.target.m disable 1
1444 menu .top.target.m.clist
1445 menu .top.target.m.slist
1448 menubutton .top.search -text "Search" -underline 0 -menu .top.search.m
1450 .top.search.m add command -label "Database" -command {database-select}
1451 .top.search.m add cascade -label "Query type" -menu .top.search.m.querytype
1452 menu .top.search.m.querytype
1453 .top.search.m.querytype add radiobutton -label "RPN"
1454 .top.search.m.querytype add radiobutton -label "CCL"
1455 .top.search.m add cascade -label "Present" -menu .top.search.m.present
1456 menu .top.search.m.present
1457 .top.search.m.present add command -label "More" -command [list present-more 10]
1458 .top.search.m.present add command -label "All" -command [list present-more {}]
1459 .top.search configure -state disabled
1461 menubutton .top.query -text "Query" -underline 0 -menu .top.query.m
1463 .top.query.m add cascade -label "Choose" -menu .top.query.m.clist
1464 .top.query.m add command -label "Define" -command {new-query-dialog}
1465 .top.query.m add cascade -label "Edit" -menu .top.query.m.slist
1466 menu .top.query.m.clist
1467 menu .top.query.m.slist
1470 menubutton .top.help -text "Help" -menu .top.help.m
1473 .top.help.m add command -label "Help on help" -command {puts "Help on help"}
1474 .top.help.m add command -label "About" -command {puts "About"}
1476 pack .top.file .top.target .top.query .top.search -side left
1477 pack .top.help -side right
1479 index-lines .lines 1 $queryButtonsFind [lindex $queryInfo 0] activate-index
1481 button .mid.search -width 6 -text {Search} -command search-request \
1483 button .mid.scan -width 6 -text {Scan} -command scan-request \
1485 button .mid.clear -width 6 -text {Clear} -command index-clear
1486 pack .mid.search .mid.scan .mid.clear -side left -padx 5 -pady 3
1488 listbox .data.list -yscrollcommand {.data.scroll set} -font fixed
1489 scrollbar .data.scroll -orient vertical -border 1
1490 pack .data.list -side left -fill both -expand yes
1491 pack .data.scroll -side right -fill y
1492 .data.scroll config -command {.data.list yview}
1494 message .bot.target -text "None" -aspect 1000 -relief sunken -border 1
1495 label .bot.status -text "Not connected" -width 12 -relief \
1496 sunken -anchor w -border 1
1497 label .bot.set -textvariable setNo -width 5 -relief \
1498 sunken -anchor w -border 1
1499 label .bot.message -text "" -width 14 -relief \
1500 sunken -anchor w -border 1
1501 pack .bot.target .bot.status .bot.set .bot.message -anchor nw \
1502 -side left -padx 2 -pady 2
1504 bind .data.list <Double-Button-1> {set indx [.data.list nearest %y]
1505 show-full-marc $indx}