3 # Revision 1.17 1995-03-31 09:34:57 adam
4 # Search-button disabled when there is no connection.
6 # Revision 1.16 1995/03/31 08:56:36 adam
9 # Revision 1.15 1995/03/28 12:45:22 adam
10 # New ir method failback: called on disconnect/protocol error.
11 # New ir set/get method: protocol: SR / Z3950.
12 # Simple popup and disconnect when failback is invoked.
14 # Revision 1.14 1995/03/22 16:07:55 adam
17 # Revision 1.13 1995/03/21 17:27:26 adam
18 # Short-hand keys in setup.
20 # Revision 1.12 1995/03/21 13:41:03 adam
21 # Comstack cs_create not used too often. Non-blocking connect.
23 # Revision 1.11 1995/03/21 10:39:06 adam
24 # Diagnostic error message displayed with tkerror.
26 # Revision 1.10 1995/03/20 15:24:06 adam
27 # Diagnostic records saved on searchResponse.
29 # Revision 1.9 1995/03/17 18:26:16 adam
30 # Non-blocking i/o used now. Database names popup as cascade items.
32 # Revision 1.8 1995/03/17 15:45:00 adam
33 # Improved target/database setup.
35 # Revision 1.7 1995/03/16 17:54:03 adam
36 # Minor changes really.
38 # Revision 1.6 1995/03/15 19:10:20 adam
39 # Database setup in protocol-setup (rather target setup).
41 # Revision 1.5 1995/03/15 13:59:23 adam
44 # Revision 1.4 1995/03/14 17:32:29 adam
45 # Presentation of full Marc record in popup window.
47 # Revision 1.3 1995/03/12 19:31:52 adam
48 # Pattern matching implemented when retrieving MARC records. More
49 # diagnostic functions.
51 # Revision 1.2 1995/03/10 18:00:15 adam
52 # Actual presentation in line-by-line format. RPN query support.
54 # Revision 1.1 1995/03/09 16:15:07 adam
55 # First presentRequest attempts. Hot-target list.
62 set profile(Default) {{} {} {210} {} 16384 8192 tcpip {}}
69 if {[file readable "~/.tk-c"]} {
73 proc top-down-window {w} {
74 frame $w.top -relief raised -border 1
75 frame $w.bot -relief raised -border 1
77 pack $w.top $w.bot -side top -fill both -expand yes
80 proc top-down-ok-cancel {w ok-action g} {
81 frame $w.bot.left -relief sunken -border 1
82 pack $w.bot.left -side left -expand yes -padx 5 -pady 5
83 button $w.bot.left.ok -width 6 -text {Ok} \
85 pack $w.bot.left.ok -expand yes -padx 3 -pady 3
86 button $w.bot.cancel -width 6 -text {Cancel} \
88 pack $w.bot.cancel -side left -expand yes
97 proc show-target {target} {
98 .bot.target configure -text "$target"
101 proc show-busy {v1 v2} {
104 .bot.status configure -fg $v1
105 after 200 [list show-busy $v2 $v1]
109 proc show-status {status b} {
112 .bot.status configure -text "$status"
113 .bot.status configure -fg black
119 # . config -cursor {watch black white}
121 # . config -cursor {top_left_arrow black white}
127 proc show-message {msg} {
128 .bot.message configure -text "$msg"
131 proc insertWithTags {w text args} {
132 set start [$w index insert]
133 $w insert insert $text
134 foreach tag [$w tag names $start] {
135 $w tag remove $tag $start insert
138 $w tag add $i $start insert
142 proc show-full-marc {no} {
147 if {[winfo exists $w]} {
148 $w.top.record delete 0.0 end
154 wm minsize $w 200 200
156 frame $w.top -relief raised -border 1
157 frame $w.bot -relief raised -border 1
159 pack $w.top -side top -fill both -expand yes
160 pack $w.bot -fill both
162 text $w.top.record -width 60 -height 12 -wrap word \
163 -yscrollcommand [list $w.top.s set]
164 scrollbar $w.top.s -command [list $w.top.record yview]
170 set r [z39.$setNo recordMarc $no line * * *]
172 $w.top.record tag configure marc-tag -foreground blue
173 $w.top.record tag configure marc-data -foreground black
174 $w.top.record tag configure marc-id -foreground red
177 set tag [lindex $line 0]
178 set indicator [lindex $line 1]
179 set fields [lindex $line 2]
181 if {$indicator != ""} {
182 insertWithTags $w.top.record "$tag $indicator" marc-tag
184 insertWithTags $w.top.record "$tag " marc-tag
186 foreach field $fields {
187 set id [lindex $field 0]
188 set data [lindex $field 1]
190 insertWithTags $w.top.record " $id " marc-id
192 set start [$w.top.record index insert]
193 insertWithTags $w.top.record $data {}
195 $w.top.record insert end "\n"
198 bind $w <Return> {destroy .full-marc}
200 pack $w.top.s -side right -fill y
201 pack $w.top.record -expand yes -fill both
203 frame $w.bot.left -relief sunken -border 1
204 pack $w.bot.left -side left -expand yes -padx 5 -pady 5
205 button $w.bot.left.close -width 6 -text {Close} \
206 -command {destroy .full-marc}
207 pack $w.bot.left.close -expand yes -padx 3 -pady 3
208 button $w.bot.edit -width 6 -text {Edit} \
209 -command {destroy .full-marc}
210 pack $w.bot.edit -side left -expand yes
214 proc update-target-hotlist {target} {
217 set len [llength $hotTargets]
219 .top.target.m delete 5 [expr 5+[llength $hotTargets]]
221 set indx [lsearch $hotTargets $target]
223 set hotTargets [lreplace $hotTargets $indx $indx]
225 set hotTargets [linsert $hotTargets 0 $target]
229 proc set-target-hotlist {} {
233 foreach target $hotTargets {
234 .top.target.m add command -label "$i $target" -command \
235 "reopen-target $target {}"
243 proc reopen-target {target base} {
245 open-target $target $base
246 update-target-hotlist $target
249 proc define-target-action {} {
252 set target [.target-define.top.target.entry get]
256 update-target-hotlist $target
257 foreach n [array names profile] {
263 set profile($target) $profile(Default)
264 protocol-setup $target
265 destroy .target-define
268 proc fail-response {target} {
270 tkerror "Target connection closed or protocol error"
273 proc connect-response {target} {
274 puts "connect-response"
279 proc open-target {target base} {
284 z39 comstack [lindex $profile($target) 6]
285 # z39 idAuthentication [lindex $profile($target) 3]
286 z39 maximumRecordSize [lindex $profile($target) 4]
287 z39 preferredMessageSize [lindex $profile($target) 5]
288 puts -nonewline "maximumRecordSize="
289 puts [z39 maximumRecordSize]
290 puts -nonewline "preferredMessageSize="
291 puts [z39 preferredMessageSize]
293 z39 databaseNames [lindex [lindex $profile($target) 7] 0]
295 z39 databaseNames $base
297 z39 failback [list fail-response $target]
298 z39 callback [list connect-response $target]
299 z39 connect [lindex $profile($target) 1]:[lindex $profile($target) 2]
300 show-status {Connecting} 1
302 .top.target.m disable 0
303 .top.target.m enable 1
304 .top.search configure -state normal
307 proc close-target {} {
313 show-status {Not connected} 0
315 .top.target.m disable 1
316 .top.target.m enable 0
317 .top.search configure -state disabled
320 proc load-set-action {} {
326 set fname [.load-set.top.filename.entry get]
331 show-status {Loading} 1
332 z39.$setNo loadFile $fname
334 set no [z39.$setNo numberOfRecordsReturned]
335 add-title-lines $setNo $no 1
337 show-status {Ready} 0
350 frame $w.top.filename
352 pack $w.top.filename -side top -anchor e -pady 2
354 entry-fields $w.top {filename} \
356 {load-set-action} {destroy .load-set}
358 top-down-ok-cancel $w {load-set-action} 1
362 proc init-request {} {
365 z39 callback {init-response}
367 show-status {Initializing} 1
370 proc init-response {} {
371 show-status {Ready} 0
372 bind .mid.searchentry <Return> search-request
373 focus .mid.searchentry
376 proc search-request {} {
386 if {[lindex $profile($target) 10]} {
387 z39.$setNo setName $setNo
389 if {[lindex $profile($target) 8]} {
392 if {[lindex $profile($target) 9]} {
395 z39 callback {search-response}
396 z39.$setNo search [.mid.searchentry get]
397 show-status {Search} 1
400 proc search-response {} {
406 show-status {Ready} 0
407 show-message "[z39.$setNo resultCount] hits"
408 set setMax [z39.$setNo resultCount]
411 set status [z39.$setNo responseStatus]
412 if {[lindex $status 0] == "NSD"} {
413 set code [lindex $status 1]
414 set msg [lindex $status 2]
415 set addinfo [lindex $status 3]
416 tkerror "NSD$code: $msg: $addinfo"
423 z39 callback {present-response}
425 z39.$setNo present $setOffset $setMax
426 show-status {Retrieve} 1
429 proc present-more {number} {
438 set max [z39.$setNo resultCount]
439 if {$max <= $setMax} {
443 puts "setOffset=$setOffset"
449 z39 callback {present-response}
450 z39.$setNo present $setOffset [expr $setMax - $setOffset + 1]
451 show-status {Retrieve} 1
454 proc init-title-lines {} {
455 .data.list delete 0 end
458 proc add-title-lines {setno no offset} {
459 for {set i 0} {$i < $no} {incr i} {
460 set o [expr $i + $offset]
461 set title [lindex [z39.$setno recordMarc $o field 245 * a] 0]
462 set year [lindex [z39.$setno recordMarc $o field 260 * c] 0]
463 set nostr [format "%3d" $o]
464 .data.list insert end "$nostr $title - $year"
468 proc present-response {} {
473 puts "In present-response"
474 set no [z39.$setNo numberOfRecordsReturned]
475 puts "Returned $no records, setOffset $setOffset"
476 add-title-lines $setNo $no $setOffset
477 set setOffset [expr $setOffset + $no]
478 set status [z39.$setNo responseStatus]
479 if {[lindex $status 0] == "NSD"} {
480 show-status {Ready} 0
481 set code [lindex $status 1]
482 set msg [lindex $status 2]
483 set addinfo [lindex $status 3]
484 tkerror "NSD$code: $msg: $addinfo"
487 if {$no > 0 && $setOffset <= $setMax} {
488 z39.$setNo present $setOffset [expr $setMax - $setOffset + 1]
490 show-status {Finished} 0
494 proc left-cursor {w} {
495 set i [$w index insert]
502 proc right-cursor {w} {
503 set i [$w index insert]
508 proc bind-fields {list returnAction escapeAction} {
509 set max [expr [llength $list]-1]
510 for {set i 0} {$i < $max} {incr i} {
511 bind [lindex $list $i] <Return> $returnAction
512 bind [lindex $list $i] <Escape> $escapeAction
513 bind [lindex $list $i] <Tab> [list focus [lindex $list [expr $i+1]]]
514 bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
515 bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
517 bind [lindex $list $i] <Return> $returnAction
518 bind [lindex $list $i] <Escape> $escapeAction
519 bind [lindex $list $i] <Tab> [list focus [lindex $list 0]]
520 bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
521 bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
522 focus [lindex $list 0]
525 proc entry-fields {parent list tlist returnAction escapeAction} {
528 foreach field $list {
529 set label ${parent}.${field}.label
530 set entry ${parent}.${field}.entry
531 label $label -text [lindex $tlist $i] -anchor e
532 entry $entry -width 32 -relief sunken
533 pack $label -side left
534 pack $entry -side right
538 bind-fields $alist $returnAction $escapeAction
541 proc define-target-dialog {} {
553 -side top -anchor e -pady 2
555 entry-fields $w.top {target} \
557 {define-target-action} {destroy .target-define}
559 top-down-ok-cancel $w {define-target-action} 1
562 proc protocol-setup-action {target} {
565 global settingsChanged
568 global ResultSetCheck
570 set w .setup-${target}.top
572 #set w .protocol-setup.top
575 set settingsChanged 1
576 set len [$w.databases.list size]
577 for {set i 0} {$i < $len} {incr i} {
578 lappend b [$w.databases.list get $i]
580 set profile($target) [list [$w.description.entry get] \
581 [$w.host.entry get] \
582 [$w.port.entry get] \
583 [$w.idAuthentication.entry get] \
584 [$w.maximumRecordSize.entry get] \
585 [$w.preferredMessageSize.entry get] \
593 puts $profile($target)
594 destroy .setup-${target}
597 proc place-force {window parent} {
598 set g [wm geometry $parent]
600 set p1 [string first + $g]
601 set p2 [string last + $g]
603 set x [expr 40+[string range $g [expr $p1 +1] [expr $p2 -1]]]
604 set y [expr 60+[string range $g [expr $p2 +1] end]]
605 wm geometry $window +${x}+${y}
608 proc add-database-action {target} {
609 set w .setup-${target}
611 ${w}.top.databases.list insert end \
612 [.database-select.top.database.entry get]
613 destroy .database-select
616 proc add-database {target} {
617 set w .database-select
622 place-force $w .setup-${target}
626 frame $w.top.database
628 pack $w.top.database -side top -anchor e -pady 2
630 entry-fields $w.top {database} \
631 {{Database to add:}} \
632 [list add-database-action $target] {destroy .database-select}
634 top-down-ok-cancel $w [list add-database-action $target] 1
638 proc delete-database {target} {
639 set w .setup-${target}
641 foreach i [lsort -decreasing \
642 [$w.top.databases.list curselection]] {
643 $w.top.databases.list delete $i
647 proc protocol-setup {target} {
654 global ResultSetCheck
658 wm title $w "Setup $target"
667 puts $profile($target)
671 frame $w.top.description
672 frame $w.top.idAuthentication
673 frame $w.top.maximumRecordSize
674 frame $w.top.preferredMessageSize
675 frame $w.top.cs-type -relief ridge -border 2
676 frame $w.top.query -relief ridge -border 2
677 frame $w.top.databases -relief ridge -border 2
679 # Maximum/preferred/idAuth ...
680 pack $w.top.description $w.top.host $w.top.port \
681 $w.top.idAuthentication $w.top.maximumRecordSize \
682 $w.top.preferredMessageSize -side top -anchor e -pady 2
684 entry-fields $w.top {description host port idAuthentication \
685 maximumRecordSize preferredMessageSize} \
686 {{Description:} {Host:} {Port:} {Id Authentification:} \
687 {Maximum Record Size:} {Preferred Message Size:}} \
688 [list protocol-setup-action $target] [list destroy $w]
690 foreach sub {description host port idAuthentication \
691 maximumRecordSize preferredMessageSize} {
693 bind $w.top.$sub.entry <Control-a> "add-database $target"
694 bind $w.top.$sub.entry <Control-d> "delete-database $target"
696 $w.top.description.entry insert 0 [lindex $profile($target) 0]
697 $w.top.host.entry insert 0 [lindex $profile($target) 1]
698 $w.top.port.entry insert 0 [lindex $profile($target) 2]
699 $w.top.idAuthentication.entry insert 0 [lindex $profile($target) 3]
700 $w.top.maximumRecordSize.entry insert 0 [lindex $profile($target) 4]
701 $w.top.preferredMessageSize.entry insert 0 [lindex $profile($target) 5]
702 set csRadioType [lindex $profile($target) 6]
703 set RPNCheck [lindex $profile($target) 8]
704 set CCLCheck [lindex $profile($target) 9]
705 set ResultSetCheck [lindex $profile($target) 10]
708 pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill x
710 label $w.top.databases.label -text "Databases"
711 button $w.top.databases.add -text "Add" \
712 -command "add-database $target"
713 button $w.top.databases.delete -text "Delete" \
714 -command "delete-database $target"
715 listbox $w.top.databases.list -geometry 20x6 \
716 -yscrollcommand "$w.top.databases.scroll set"
717 scrollbar $w.top.databases.scroll -orient vertical -border 1
718 pack $w.top.databases.label -side top -fill x \
720 pack $w.top.databases.add $w.top.databases.delete -side top -fill x \
722 pack $w.top.databases.list -side left -fill both -expand yes \
724 pack $w.top.databases.scroll -side right -fill y \
726 $w.top.databases.scroll config -command "$w.top.databases.list yview"
728 foreach b [lindex $profile($target) 7] {
729 $w.top.databases.list insert end $b
733 pack $w.top.cs-type -pady 6 -padx 6 -side top
735 label $w.top.cs-type.label -text "Transport"
736 radiobutton $w.top.cs-type.tcpip -text "TCP/IP" \
737 -command {puts tcp/ip} -variable csRadioType -value tcpip
738 radiobutton $w.top.cs-type.mosi -text "MOSI" \
739 -command {puts mosi} -variable csRadioType -value mosi
741 pack $w.top.cs-type.label $w.top.cs-type.tcpip $w.top.cs-type.mosi \
742 -padx 4 -side top -fill x
745 pack $w.top.query -pady 6 -padx 6 -side top
747 label $w.top.query.label -text "Query support" -anchor e
748 checkbutton $w.top.query.c1 -text "RPN query" -variable RPNCheck
749 checkbutton $w.top.query.c2 -text "CCL query" -variable CCLCheck
750 checkbutton $w.top.query.c3 -text "Result sets" -variable ResultSetCheck
752 pack $w.top.query.label -side top
753 pack $w.top.query.c1 $w.top.query.c2 $w.top.query.c3 \
754 -padx 4 -side top -fill x
757 top-down-ok-cancel $w [list protocol-setup-action $target] 0
760 proc database-select-action {} {
761 set w .database-select.top
763 foreach indx [$w.databases.list curselection] {
764 lappend b [$w.databases.list get $indx]
769 destroy .database-select
772 proc database-select {} {
773 set w .database-select
783 frame $w.top.databases -relief ridge -border 2
785 pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill x
787 label $w.top.databases.label -text "List"
788 listbox $w.top.databases.list -geometry 20x6 \
789 -yscrollcommand "$w.top.databases.scroll set"
790 scrollbar $w.top.databases.scroll -orient vertical -border 1
791 pack $w.top.databases.label -side top -fill x \
793 pack $w.top.databases.list -side left -fill both -expand yes \
795 pack $w.top.databases.scroll -side right -fill y \
797 $w.top.databases.scroll config -command "$w.top.databases.list yview"
799 foreach b [lindex $profile($hostid) 7] {
800 $w.top.databases.list insert end $b
802 top-down-ok-cancel $w {database-select-action} 1
805 proc cascade-target-list {} {
808 foreach sub [winfo children .top.target.m.clist] {
812 .top.target.m.clist delete 0 last
813 foreach n [array names profile] {
814 if {$n != "Default"} {
815 set nl [string tolower $n]
816 if {[llength [lindex $profile($n) 7]] > 1} {
817 .top.target.m.clist add cascade -label $n \
818 -menu .top.target.m.clist.$nl
819 menu .top.target.m.clist.$nl
820 foreach b [lindex $profile($n) 7] {
821 .top.target.m.clist.$nl add command -label $b \
822 -command "reopen-target $n $b"
825 .top.target.m.clist add command -label $n \
826 -command "reopen-target $n {}"
830 .top.target.m.slist delete 0 last
831 foreach n [array names profile] {
832 if {$n != "Default"} {
833 .top.target.m.slist add command -label $n \
834 -command "protocol-setup $n"
839 proc save-settings {} {
842 global settingsChanged
844 set f [open "~/.tk-c" w]
845 puts $f "# Setup file"
846 puts $f "set hotTargets \{ $hotTargets \}"
848 foreach n [array names profile] {
849 puts -nonewline $f "set profile($n) \{"
850 puts -nonewline $f $profile($n)
854 set settingsChanged 0
866 message $w.top.message -text $ask
868 pack $w.top.message -side left -pady 6 -padx 20 -expand yes -fill x
871 top-down-ok-cancel $w {alert-action} 1
875 proc alert-action {} {
881 proc exit-action {} {
882 global settingsChanged
884 if {$settingsChanged} {
885 set a [alert "you havent saved your settings. Do you wish to save?"]
893 frame .top -border 1 -relief raised
894 frame .mid -border 1 -relief raised
895 frame .data -border 1 -relief raised
896 frame .bot -border 1 -relief raised
897 pack .top .mid -side top -fill x
898 pack .data -side top -fill both -expand yes
901 menubutton .top.file -text "File" -underline 0 -menu .top.file.m
903 .top.file.m add command -label "Save settings" -command {save-settings}
904 .top.file.m add command -label "Load Set" -command {load-set}
905 .top.file.m add separator
906 .top.file.m add command -label "Exit" -command {exit-action}
908 menubutton .top.target -text "Target" -underline 0 -menu .top.target.m
910 .top.target.m add cascade -label "Connect" -menu .top.target.m.clist
911 .top.target.m add command -label "Disconnect" -command {close-target}
912 #.top.target.m add command -label "Initialize" -command {init-request}
913 .top.target.m add cascade -label "Setup" -menu .top.target.m.slist
914 .top.target.m add command -label "Setup new" -command {define-target-dialog}
915 .top.target.m add separator
918 .top.target.m disable 1
920 menu .top.target.m.clist
921 menu .top.target.m.slist
924 menubutton .top.search -text "Search" -underline 0 -menu .top.search.m
926 .top.search.m add command -label "Database" -command {database-select}
927 .top.search.m add cascade -label "Query type" -menu .top.search.m.querytype
928 menu .top.search.m.querytype
929 .top.search.m.querytype add radiobutton -label "RPN"
930 .top.search.m.querytype add radiobutton -label "CCL"
931 .top.search.m add cascade -label "Present" -menu .top.search.m.present
932 menu .top.search.m.present
933 .top.search.m.present add command -label "More" -command [list present-more 10]
934 .top.search.m.present add command -label "All" -command [list present-more {}]
935 .top.search configure -state disabled
937 menubutton .top.help -text "Help" -menu .top.help.m
940 .top.help.m add command -label "Help on help" -command {puts "Help on help"}
941 .top.help.m add command -label "About" -command {puts "About"}
943 pack .top.file .top.target .top.search -side left
944 pack .top.help -side right
946 label .mid.searchlabel -text {Search:}
947 entry .mid.searchentry -width 32 -relief sunken
948 pack .mid.searchlabel -side left
949 pack .mid.searchentry -side left -fill x -expand yes
951 focus .mid.searchentry
952 bind .mid.searchentry <Left> {left-cursor .mid.searchentry}
953 bind .mid.searchentry <Right> {right-cursor .mid.searchentry}
955 listbox .data.list -yscrollcommand {.data.scroll set}
956 scrollbar .data.scroll -orient vertical -border 1
957 pack .data.list -side left -fill both -expand yes
958 pack .data.scroll -side right -fill y
959 .data.scroll config -command {.data.list yview}
961 message .bot.target -text "None" -aspect 1000 -relief sunken -border 1
962 label .bot.status -text "Not connected" -width 12 -relief \
963 sunken -anchor w -border 1
964 label .bot.set -textvariable setNo -width 5 -relief \
965 sunken -anchor w -border 1
966 label .bot.message -text "" -width 14 -relief \
967 sunken -anchor w -border 1
968 pack .bot.target .bot.status .bot.set .bot.message -anchor nw \
969 -side left -padx 2 -pady 2
971 bind .data.list <Double-Button-1> {set indx [.data.list nearest %y]
972 show-full-marc $indx}