3 # Revision 1.28 1995-06-02 14:52:13 adam
4 # Minor changes really.
6 # Revision 1.27 1995/06/02 14:29:42 adam
7 # Work on scan interface - up/down buttons.
9 # Revision 1.26 1995/06/01 16:36:46 adam
10 # About buttons. Minor bug fixes.
12 # Revision 1.25 1995/05/31 13:09:57 adam
13 # Client searches/presents may be interrupted.
14 # New moving book-logo.
16 # Revision 1.24 1995/05/31 08:36:24 adam
17 # Bug fix in client.tcl: didn't save options on clientrc.tcl.
18 # New method: referenceId. More work on scan.
20 # Revision 1.23 1995/05/29 10:33:41 adam
21 # README and rename of startup script.
23 # Revision 1.22 1995/05/26 11:44:09 adam
24 # Bugs fixed. More work on MARC utilities and queries. Test
25 # client is up-to-date again.
27 # Revision 1.21 1995/05/11 15:34:46 adam
28 # Scan request changed a bit. This version works with RLG.
30 # Revision 1.20 1995/04/21 16:31:57 adam
31 # New radiobutton: protocol (z39v2/SR).
33 # Revision 1.19 1995/04/18 16:11:50 adam
34 # First version of graphical Scan. Some work on query-by-form.
36 # Revision 1.18 1995/04/10 10:50:22 adam
37 # Result-set name defaults to suffix of ir-set name.
38 # Started working on scan. Not finished at this point.
40 # Revision 1.17 1995/03/31 09:34:57 adam
41 # Search-button disabled when there is no connection.
43 # Revision 1.16 1995/03/31 08:56:36 adam
44 # New button "Search".
46 # Revision 1.15 1995/03/28 12:45:22 adam
47 # New ir method failback: called on disconnect/protocol error.
48 # New ir set/get method: protocol: SR / Z3950.
49 # Simple popup and disconnect when failback is invoked.
51 # Revision 1.14 1995/03/22 16:07:55 adam
54 # Revision 1.13 1995/03/21 17:27:26 adam
55 # Short-hand keys in setup.
57 # Revision 1.12 1995/03/21 13:41:03 adam
58 # Comstack cs_create not used too often. Non-blocking connect.
60 # Revision 1.11 1995/03/21 10:39:06 adam
61 # Diagnostic error message displayed with tkerror.
63 # Revision 1.10 1995/03/20 15:24:06 adam
64 # Diagnostic records saved on searchResponse.
66 # Revision 1.9 1995/03/17 18:26:16 adam
67 # Non-blocking i/o used now. Database names popup as cascade items.
69 # Revision 1.8 1995/03/17 15:45:00 adam
70 # Improved target/database setup.
72 # Revision 1.7 1995/03/16 17:54:03 adam
73 # Minor changes really.
75 # Revision 1.6 1995/03/15 19:10:20 adam
76 # Database setup in protocol-setup (rather target setup).
78 # Revision 1.5 1995/03/15 13:59:23 adam
81 # Revision 1.4 1995/03/14 17:32:29 adam
82 # Presentation of full Marc record in popup window.
84 # Revision 1.3 1995/03/12 19:31:52 adam
85 # Pattern matching implemented when retrieving MARC records. More
86 # diagnostic functions.
88 # Revision 1.2 1995/03/10 18:00:15 adam
89 # Actual presentation in line-by-line format. RPN query support.
91 # Revision 1.1 1995/03/09 16:15:07 adam
92 # First presentRequest attempts. Hot-target list.
99 set profile(Default) {{} {} {210} {} 16384 8192 tcpip {} 1 {} {} z39v2}
101 set settingsChanged 0
107 set queryTypes {Simple}
108 set queryButtons { { {I 0} {I 1} {I 2} } }
109 set queryInfo { { {Title {1=4}} {Author {1=1}} \
110 {Subject {1=21}} {Any {1=1016}} } }
114 if {[file readable "clientrc.tcl"]} {
115 source "clientrc.tcl"
118 set queryButtonsFind [lindex $queryButtons 0]
119 set queryInfoFind [lindex $queryInfo 0]
121 proc top-down-window {w} {
122 frame $w.top -relief raised -border 1
123 frame $w.bot -relief raised -border 1
125 pack $w.top -side top -fill both -expand yes
126 pack $w.bot -fill both
129 proc top-down-ok-cancel {w ok-action g} {
130 frame $w.bot.left -relief sunken -border 1
131 pack $w.bot.left -side left -expand yes -ipadx 2 -ipady 2 -padx 5 -pady 5
132 button $w.bot.left.ok -width 6 -text {Ok} \
133 -command ${ok-action}
134 pack $w.bot.left.ok -expand yes -ipadx 2 -ipady 2 -padx 3 -pady 3
135 button $w.bot.cancel -width 6 -text {Cancel} \
136 -command "destroy $w"
137 pack $w.bot.cancel -side left -expand yes
145 proc bottom-buttons {w buttonList g} {
147 set l [llength $buttonList]
149 frame $w.bot.$i -relief sunken -border 1
150 pack $w.bot.$i -side left -expand yes -padx 5 -pady 5
151 button $w.bot.$i.ok -text [lindex $buttonList $i] \
152 -command [lindex $buttonList [expr $i+1]]
153 pack $w.bot.$i.ok -expand yes -ipadx 2 -ipady 2 -padx 3 -pady 3 -side left
157 button $w.bot.$i -text [lindex $buttonList $i] \
158 -command [lindex $buttonList [expr $i+1]]
159 pack $w.bot.$i -expand yes -ipadx 2 -ipady 2 -padx 3 -pady 3 -side left
169 proc cancel-operation {} {
175 show-status Cancelled 0 {}
179 proc show-target {target} {
180 .bot.a.target configure -text "$target"
183 proc show-logo {v1} {
190 .bot.logo configure -bitmap @book${v1}
191 after 140 [list show-logo $v1]
195 .bot.logo configure -bitmap @book1
204 proc show-status {status b sb} {
208 .bot.a.status configure -text "$status"
210 if {$busy == 0} {set busy 1}
218 .top.search configure -state normal
219 .mid.search configure -state normal
220 .mid.scan configure -state normal
221 .mid.present configure -state normal
222 if {[winfo exists .scan-window]} {
223 .scan-window.bot.2 configure -state normal
224 .scan-window.bot.4 configure -state normal
228 .top.search configure -state disabled
229 .mid.search configure -state disabled
230 .mid.scan configure -state disabled
231 .mid.present configure -state disabled
233 if {[winfo exists .scan-window]} {
234 .scan-window.bot.2 configure -state disabled
235 .scan-window.bot.4 configure -state disabled
241 proc show-message {msg} {
242 .bot.a.message configure -text "$msg"
245 proc insertWithTags {w text args} {
246 set start [$w index insert]
247 $w insert insert $text
248 foreach tag [$w tag names $start] {
249 $w tag remove $tag $start insert
252 $w tag add $i $start insert
256 proc about-target {} {
257 set w .about-target-w
261 wm title $w "About target"
265 set i [z39 targetImplementationName]
266 label $w.top.in -text "Implementation name: $i"
267 set i [z39 targetImplementationId]
268 label $w.top.ii -text "Implementation id: $i"
269 set i [z39 targetImplementationVersion]
270 label $w.top.iv -text "Implementation version: $i"
272 label $w.top.op -text "Protocol options: $i"
274 pack $w.top.in $w.top.ii $w.top.iv $w.top.op -side top -anchor nw
276 bottom-buttons $w [list {Close} [list destroy $w]] 1
279 proc about-origin {} {
280 set w .about-origin-w
284 wm title $w "About IrTcl"
288 set i [z39 implementationName]
289 label $w.top.in -text "Implementation name: $i"
290 set i [z39 implementationId]
291 label $w.top.ii -text "Implementation id: $i"
293 pack $w.top.in $w.top.ii -side top -anchor nw
295 bottom-buttons $w [list {Close} [list destroy $w]] 1
298 proc show-full-marc {no b} {
302 if {[z39.$setNo type $no] != "DB"} {
306 set w .full-marc-$fullMarcSeq
311 if {[winfo exists $w]} {
312 $w.top.record delete 0.0 end
320 frame $w.top -relief raised -border 1
321 frame $w.bot -relief raised -border 1
323 pack $w.top -side top -fill both -expand yes
324 pack $w.bot -fill both
326 text $w.top.record -width 60 -height 12 -wrap word \
327 -yscrollcommand [list $w.top.s set]
328 scrollbar $w.top.s -command [list $w.top.record yview]
332 set r [z39.$setNo getMarc $no list * * *]
334 $w.top.record tag configure marc-tag -foreground blue
335 $w.top.record tag configure marc-data -foreground black
336 $w.top.record tag configure marc-id -foreground red
339 set tag [lindex $line 0]
340 set indicator [lindex $line 1]
341 set fields [lindex $line 2]
343 if {$indicator != ""} {
344 insertWithTags $w.top.record "$tag $indicator" marc-tag
346 insertWithTags $w.top.record "$tag " marc-tag
348 foreach field $fields {
349 set id [lindex $field 0]
350 set data [lindex $field 1]
352 insertWithTags $w.top.record " $id " marc-id
354 set start [$w.top.record index insert]
355 insertWithTags $w.top.record $data {}
357 $w.top.record insert end "\n"
360 bind $w <Return> {destroy .full-marc}
362 pack $w.top.s -side right -fill y
363 pack $w.top.record -expand yes -fill both
365 bottom-buttons $w [list \
366 {Close} [list destroy $w] \
367 {Duplicate} [list show-full-marc $no 1]] 0
371 proc update-target-hotlist {target} {
374 set len [llength $hotTargets]
376 .top.target.m delete 6 [expr 6+[llength $hotTargets]]
378 set indx [lsearch $hotTargets $target]
380 set hotTargets [lreplace $hotTargets $indx $indx]
382 set hotTargets [linsert $hotTargets 0 $target]
386 proc set-target-hotlist {} {
390 foreach target $hotTargets {
391 .top.target.m add command -label "$i $target" -command \
392 "reopen-target $target {}"
400 proc reopen-target {target base} {
402 open-target $target $base
403 update-target-hotlist $target
406 proc define-target-action {} {
409 set target [.target-define.top.target.entry get]
413 update-target-hotlist $target
414 foreach n [array names profile] {
420 set profile($target) $profile(Default)
421 protocol-setup $target
422 destroy .target-define
425 proc fail-response {target} {
427 tkerror "Target connection closed or protocol error"
430 proc connect-response {target} {
431 puts "connect-response"
436 proc open-target {target base} {
441 z39 comstack [lindex $profile($target) 6]
442 z39 idAuthentication [lindex $profile($target) 3]
443 z39 maximumRecordSize [lindex $profile($target) 4]
444 z39 preferredMessageSize [lindex $profile($target) 5]
445 puts -nonewline "maximumRecordSize="
446 puts [z39 maximumRecordSize]
447 puts -nonewline "preferredMessageSize="
448 puts [z39 preferredMessageSize]
449 show-status {Connecting} 0 0
451 z39 databaseNames [lindex [lindex $profile($target) 7] 0]
453 z39 databaseNames $base
455 z39 failback [list fail-response $target]
456 z39 callback [list connect-response $target]
457 z39 connect [lindex $profile($target) 1]:[lindex $profile($target) 2]
458 z39 options search present scan namedResultSets triggerResourceCtrl
459 show-status {Connecting} 1 {}
461 .top.target.m disable 0
462 .top.target.m enable 1
463 .top.target.m enable 2
466 proc close-target {} {
474 show-status {Not connected} 0 0
476 .top.target.m disable 1
477 .top.target.m disable 2
478 .top.target.m enable 0
481 proc load-set-action {} {
485 ir-set z39.$setNo z39
487 set fname [.load-set.top.filename.entry get]
492 show-status {Loading} 1 {}
493 z39.$setNo loadFile $fname
495 set no [z39.$setNo numberOfRecordsReturned]
496 add-title-lines $setNo $no 1
498 show-status {Ready} 0 {}
511 frame $w.top.filename
513 pack $w.top.filename -side top -anchor e -pady 2
515 entry-fields $w.top {filename} \
517 {load-set-action} {destroy .load-set}
519 top-down-ok-cancel $w {load-set-action} 1
523 proc init-request {} {
531 z39 callback {init-response}
532 show-status {Initializing} 1 {}
536 proc init-response {} {
543 show-status {Ready} 0 1
544 if {![z39 initResult]} {
545 set u [z39 userInformationField]
547 tkerror "Connection rejected by target: $u"
551 proc search-request {} {
561 if {$searchEnable == 0} {
564 set query [index-query]
569 ir-set z39.$setNo z39
571 if {[lindex $profile($target) 10] == 1} {
572 z39.$setNo setName $setNo
573 puts "setName=${setNo}"
575 z39.$setNo setName Default
576 puts "setName=Default"
578 if {[lindex $profile($target) 8] == 1} {
579 z39.$setNo queryType rpn
581 if {[lindex $profile($target) 9] == 1} {
582 z39.$setNo queryType ccl
584 z39 callback {search-response}
585 z39.$setNo search $query
586 show-status {Search} 1 0
589 proc scan-request {attr} {
601 z39 callback [list scan-response $attr 0 25]
602 if {![winfo exists $w]} {
612 listbox $w.top.list -yscrollcommand [list $w.top.scroll set] \
613 -font fixed -geometry 50x14
614 scrollbar $w.top.scroll -orient vertical -border 1
615 pack $w.top.list -side left -fill both -expand yes
616 pack $w.top.scroll -side right -fill y
617 $w.top.scroll config -command [list $w.top.list yview]
619 listbox $w.top.list -font fixed -geometry 60x14
620 pack $w.top.list -side left -fill both -expand yes
623 bottom-buttons $w [list {Close} [list destroy $w] \
624 {Up} [list scan-up $attr] \
625 {Down} [list scan-down $attr]] 0
626 bind $w.top.list <Up> [list scan-up $attr]
627 bind $w.top.list <Down> [list scan-down $attr]
630 z39.scan numberOfTermsRequested 5
631 z39.scan preferredPositionInResponse 1
632 z39.scan scan "${attr} b"
634 show-status {Scan} 1 0
638 proc scan-response {attr start toget} {
642 puts "In scan-response"
643 set m [z39.scan numberOfEntriesReturned]
649 if {![winfo exists .scan-window]} {
650 show-status {Ready} 0 1
655 for {set i 0} {$i < $m} {incr i} {
656 set term [lindex [z39.scan scanLine $i] 1]
657 set nostr [format " %-6d" [lindex [z39.scan scanLine $i] 2]]
658 $w.top.list insert $i "$nostr $term"
661 $w.top.list delete $start end
662 for {set i 0} {$i < $m} {incr i} {
663 set term [lindex [z39.scan scanLine $i] 1]
664 set nostr [format " %-6d" [lindex [z39.scan scanLine $i] 2]]
665 $w.top.list insert end "$nostr $term"
669 show-status {Ready} 0 1
673 if {$toget > 0 && $m > 1 && $m < $toget} {
674 set ntoget [expr $toget - $m + 1]
676 z39 callback [list scan-response $attr [expr $start + $m - 1] $ntoget]
678 puts "down continue: $q"
680 z39.scan numberOfTermsRequested 10
682 z39.scan numberOfTermsRequested $ntoget
684 z39.scan preferredPositionInResponse 1
685 z39.scan scan "${attr} \{$q\}"
688 if {$toget < 0 && $m > 1 && $m < [expr - $toget]} {
689 set ntoget [expr - $toget - $m]
691 z39 callback [list scan-response $attr 0 -$ntoget]
692 set q [string range [$w.top.list get 0] 7 end]
693 puts "up continue: $q"
695 z39.scan numberOfTermsRequested 10
696 z39.scan preferredPositionInResponse 11
698 z39.scan numberOfTermsRequested $ntoget
699 z39.scan preferredPositionInResponse [incr ntoget]
701 z39.scan scan "${attr} \{$q\}"
704 show-status {Ready} 0 1
707 proc scan-down {attr} {
711 set scanView [expr $scanView + 5]
712 set s [$w.top.list size]
713 if {$scanView > $s} {
714 z39 callback [list scan-response $attr [expr $s - 1] 30]
715 set q [string range [$w.top.list get [expr $s - 1]] 7 end]
717 z39.scan numberOfTermsRequested 10
718 z39.scan preferredPositionInResponse 1
719 show-status {Scan} 1 0
720 z39.scan scan "${attr} \{$q\}"
723 $w.top.list yview $scanView
726 proc scan-up {attr} {
731 z39 callback [list scan-response $attr 0 -30]
732 set q [string range [$w.top.list get 0] 7 end]
734 z39.scan numberOfTermsRequested 10
735 z39.scan preferredPositionInResponse 11
736 show-status {Scan} 1 0
737 z39.scan scan "${attr} \{$q\}"
740 set scanView [expr $scanView - 5]
741 $w.top.list yview $scanView
744 proc search-response {} {
751 puts "In search-response"
753 show-status {Ready} 0 1
754 show-message "[z39.$setNo resultCount] hits"
755 set setMax [z39.$setNo resultCount]
757 set status [z39.$setNo responseStatus]
758 if {[lindex $status 0] == "NSD"} {
759 set code [lindex $status 1]
760 set msg [lindex $status 2]
761 set addinfo [lindex $status 3]
762 tkerror "NSD$code: $msg: $addinfo"
774 z39 callback {present-response}
775 z39.$setNo present $setOffset 1
776 show-status {Retrieve} 1 0
779 proc present-more {number} {
788 set max [z39.$setNo resultCount]
789 if {$max <= $setMax} {
797 z39 callback {present-response}
799 set toGet [expr $setMax - $setOffset + 1]
803 z39.$setNo present $setOffset $toGet
804 show-status {Retrieve} 1 0
807 proc init-title-lines {} {
808 .data.list delete 0 end
811 proc add-title-lines {setno no offset} {
812 for {set i 0} {$i < $no} {incr i} {
813 set o [expr $i + $offset]
814 set type [z39.$setno type $o]
816 set title [lindex [z39.$setno getMarc $o field 245 * a] 0]
817 set year [lindex [z39.$setno getMarc $o field 260 * c] 0]
818 set nostr [format "%5d" $o]
819 .data.list insert end "$nostr $title - $year"
820 } elseif {$type == "SD"} {
821 set err [lindex [z39.$setno diag $o] 1]
822 set add [lindex [z39.$setno diag $o] 2]
826 .data.list insert end "Error ${err}${add}"
827 } elseif {$type == ""} {
828 .data.list insert end "empty"
833 proc present-response {} {
839 puts "In present-response"
840 set no [z39.$setNo numberOfRecordsReturned]
841 puts "Returned $no records, setOffset $setOffset"
842 add-title-lines $setNo $no $setOffset
843 set setOffset [expr $setOffset + $no]
844 set status [z39.$setNo responseStatus]
845 if {[lindex $status 0] == "NSD"} {
846 show-status {Ready} 0 1
847 set code [lindex $status 1]
848 set msg [lindex $status 2]
849 set addinfo [lindex $status 3]
850 tkerror "NSD$code: $msg: $addinfo"
854 show-status {Ready} 0 1
858 if {$no > 0 && $setOffset <= $setMax} {
859 puts "present from ${setOffset}"
860 set toGet [expr $setMax - $setOffset + 1]
864 z39.$setNo present $setOffset $toGet
866 show-status {Finished} 0 1
870 proc left-cursor {w} {
871 set i [$w index insert]
878 proc right-cursor {w} {
879 set i [$w index insert]
884 proc bind-fields {list returnAction escapeAction} {
885 set max [expr [llength $list]-1]
886 for {set i 0} {$i < $max} {incr i} {
887 bind [lindex $list $i] <Return> $returnAction
888 bind [lindex $list $i] <Escape> $escapeAction
889 bind [lindex $list $i] <Tab> [list focus [lindex $list [expr $i+1]]]
890 bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
891 bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
893 bind [lindex $list $i] <Return> $returnAction
894 bind [lindex $list $i] <Escape> $escapeAction
895 bind [lindex $list $i] <Tab> [list focus [lindex $list 0]]
896 bind [lindex $list $i] <Left> [list left-cursor [lindex $list $i]]
897 bind [lindex $list $i] <Right> [list right-cursor [lindex $list $i]]
898 focus [lindex $list 0]
901 proc entry-fields {parent list tlist returnAction escapeAction} {
904 foreach field $list {
905 set label ${parent}.${field}.label
906 set entry ${parent}.${field}.entry
907 label $label -text [lindex $tlist $i] -anchor e
908 entry $entry -width 32 -relief sunken
909 pack $label -side left
910 pack $entry -side right
914 bind-fields $alist $returnAction $escapeAction
917 proc define-target-dialog {} {
925 -side top -anchor e -pady 2
926 entry-fields $w.top {target} \
928 {define-target-action} {destroy .target-define}
929 top-down-ok-cancel $w {define-target-action} 1
932 proc protocol-setup-action {target} {
935 global protocolRadioType
936 global settingsChanged
939 global ResultSetCheck
941 set w .setup-${target}.top
943 #set w .protocol-setup.top
946 set settingsChanged 1
947 set len [$w.databases.list size]
948 for {set i 0} {$i < $len} {incr i} {
949 lappend b [$w.databases.list get $i]
951 set profile($target) [list [$w.description.entry get] \
952 [$w.host.entry get] \
953 [$w.port.entry get] \
954 [$w.idAuthentication.entry get] \
955 [$w.maximumRecordSize.entry get] \
956 [$w.preferredMessageSize.entry get] \
965 puts $profile($target)
966 destroy .setup-${target}
969 proc place-force {window parent} {
970 set g [wm geometry $parent]
972 set p1 [string first + $g]
973 set p2 [string last + $g]
975 set x [expr 40+[string range $g [expr $p1 +1] [expr $p2 -1]]]
976 set y [expr 60+[string range $g [expr $p2 +1] end]]
977 wm geometry $window +${x}+${y}
980 proc add-database-action {target} {
981 set w .setup-${target}
983 ${w}.top.databases.list insert end \
984 [.database-select.top.database.entry get]
985 destroy .database-select
988 proc add-database {target} {
989 set w .database-select
994 place-force $w .setup-${target}
998 frame $w.top.database
1000 pack $w.top.database -side top -anchor e -pady 2
1002 entry-fields $w.top {database} \
1003 {{Database to add:}} \
1004 [list add-database-action $target] {destroy .database-select}
1006 top-down-ok-cancel $w [list add-database-action $target] 1
1010 proc delete-database {target} {
1011 set w .setup-${target}
1013 foreach i [lsort -decreasing \
1014 [$w.top.databases.list curselection]] {
1015 $w.top.databases.list delete $i
1019 proc protocol-setup {target} {
1020 set w .setup-$target
1024 global protocolRadioType
1027 global ResultSetCheck
1031 wm title $w "Setup $target"
1036 if {$target == ""} {
1040 puts $profile($target)
1044 frame $w.top.description
1045 frame $w.top.idAuthentication
1046 frame $w.top.maximumRecordSize
1047 frame $w.top.preferredMessageSize
1048 frame $w.top.cs-type -relief ridge -border 2
1049 frame $w.top.protocol -relief ridge -border 2
1050 frame $w.top.query -relief ridge -border 2
1051 frame $w.top.databases -relief ridge -border 2
1053 # Maximum/preferred/idAuth ...
1054 pack $w.top.description $w.top.host $w.top.port \
1055 $w.top.idAuthentication $w.top.maximumRecordSize \
1056 $w.top.preferredMessageSize -side top -anchor e -pady 2
1058 entry-fields $w.top {description host port idAuthentication \
1059 maximumRecordSize preferredMessageSize} \
1060 {{Description:} {Host:} {Port:} {Id Authentication:} \
1061 {Maximum Record Size:} {Preferred Message Size:}} \
1062 [list protocol-setup-action $target] [list destroy $w]
1064 foreach sub {description host port idAuthentication \
1065 maximumRecordSize preferredMessageSize} {
1067 bind $w.top.$sub.entry <Control-a> "add-database $target"
1068 bind $w.top.$sub.entry <Control-d> "delete-database $target"
1070 $w.top.description.entry insert 0 [lindex $profile($target) 0]
1071 $w.top.host.entry insert 0 [lindex $profile($target) 1]
1072 $w.top.port.entry insert 0 [lindex $profile($target) 2]
1073 $w.top.idAuthentication.entry insert 0 [lindex $profile($target) 3]
1074 $w.top.maximumRecordSize.entry insert 0 [lindex $profile($target) 4]
1075 $w.top.preferredMessageSize.entry insert 0 [lindex $profile($target) 5]
1076 set csRadioType [lindex $profile($target) 6]
1077 set RPNCheck [lindex $profile($target) 8]
1078 set CCLCheck [lindex $profile($target) 9]
1079 set ResultSetCheck [lindex $profile($target) 10]
1080 set protocolRadioType [lindex $profile($target) 11]
1081 if {$protocolRadioType == ""} {
1082 set protocolRadioType z39v2
1086 pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill both
1088 label $w.top.databases.label -text "Databases"
1089 button $w.top.databases.add -text "Add" \
1090 -command "add-database $target"
1091 button $w.top.databases.delete -text "Delete" \
1092 -command "delete-database $target"
1093 listbox $w.top.databases.list -geometry 20x6 \
1094 -yscrollcommand "$w.top.databases.scroll set"
1095 scrollbar $w.top.databases.scroll -orient vertical -border 1
1096 pack $w.top.databases.label -side top -fill x \
1098 pack $w.top.databases.add $w.top.databases.delete -side top -fill x \
1100 pack $w.top.databases.list -side left -fill both -expand yes \
1102 pack $w.top.databases.scroll -side right -fill y \
1104 $w.top.databases.scroll config -command "$w.top.databases.list yview"
1106 foreach b [lindex $profile($target) 7] {
1107 $w.top.databases.list insert end $b
1111 pack $w.top.cs-type -pady 6 -padx 6 -side top -fill x
1113 label $w.top.cs-type.label -text "Transport"
1114 radiobutton $w.top.cs-type.tcpip -text "TCP/IP" -anchor w \
1115 -command {puts tcp/ip} -variable csRadioType -value tcpip
1116 radiobutton $w.top.cs-type.mosi -text "MOSI" -anchor w\
1117 -command {puts mosi} -variable csRadioType -value mosi
1119 pack $w.top.cs-type.label $w.top.cs-type.tcpip $w.top.cs-type.mosi \
1120 -padx 4 -side top -fill x
1123 pack $w.top.protocol -pady 6 -padx 6 -side top -fill x
1125 label $w.top.protocol.label -text "Protocol"
1126 radiobutton $w.top.protocol.z39v2 -text "Z39.50" -anchor w \
1127 -command {puts z39v2} -variable protocolRadioType -value z39v2
1128 radiobutton $w.top.protocol.sr -text "SR" -anchor w \
1129 -command {puts sr} -variable protocolRadioType -value sr
1131 pack $w.top.protocol.label $w.top.protocol.z39v2 $w.top.protocol.sr \
1132 -padx 4 -side top -fill x
1135 pack $w.top.query -pady 6 -padx 6 -side top -fill x
1137 label $w.top.query.label -text "Query support"
1138 checkbutton $w.top.query.c1 -text "RPN query" -anchor w -variable RPNCheck
1139 checkbutton $w.top.query.c2 -text "CCL query" -anchor w -variable CCLCheck
1140 checkbutton $w.top.query.c3 -text "Result sets" -anchor w -variable ResultSetCheck
1142 pack $w.top.query.label -side top
1143 pack $w.top.query.c1 $w.top.query.c2 $w.top.query.c3 \
1144 -padx 4 -side top -fill x
1147 top-down-ok-cancel $w [list protocol-setup-action $target] 0
1150 proc database-select-action {} {
1151 set w .database-select.top
1153 foreach indx [$w.databases.list curselection] {
1154 lappend b [$w.databases.list get $indx]
1157 z39 databaseNames $b
1159 destroy .database-select
1162 proc database-select {} {
1163 set w .database-select
1173 frame $w.top.databases -relief ridge -border 2
1175 pack $w.top.databases -side left -pady 6 -padx 6 -expand yes -fill x
1177 label $w.top.databases.label -text "List"
1178 listbox $w.top.databases.list -geometry 20x6 \
1179 -yscrollcommand "$w.top.databases.scroll set"
1180 scrollbar $w.top.databases.scroll -orient vertical -border 1
1181 pack $w.top.databases.label -side top -fill x \
1183 pack $w.top.databases.list -side left -fill both -expand yes \
1185 pack $w.top.databases.scroll -side right -fill y \
1187 $w.top.databases.scroll config -command "$w.top.databases.list yview"
1189 foreach b [lindex $profile($hostid) 7] {
1190 $w.top.databases.list insert end $b
1192 top-down-ok-cancel $w {database-select-action} 1
1195 proc cascade-target-list {} {
1198 foreach sub [winfo children .top.target.m.clist] {
1199 puts "deleting $sub"
1202 .top.target.m.clist delete 0 last
1203 foreach n [array names profile] {
1204 if {$n != "Default"} {
1205 set nl [string tolower $n]
1206 if {[llength [lindex $profile($n) 7]] > 1} {
1207 .top.target.m.clist add cascade -label $n \
1208 -menu .top.target.m.clist.$nl
1209 menu .top.target.m.clist.$nl
1210 foreach b [lindex $profile($n) 7] {
1211 .top.target.m.clist.$nl add command -label $b \
1212 -command "reopen-target $n $b"
1215 .top.target.m.clist add command -label $n \
1216 -command "reopen-target $n {}"
1220 .top.target.m.slist delete 0 last
1221 foreach n [array names profile] {
1222 if {$n != "Default"} {
1223 .top.target.m.slist add command -label $n \
1224 -command "protocol-setup $n"
1229 proc cascade-query-list {} {
1233 .top.query.m.slist delete 0 last
1234 foreach n $queryTypes {
1235 .top.query.m.slist add command -label $n \
1236 -command [list query-setup $i]
1241 .top.query.m.clist delete 0 last
1242 foreach n $queryTypes {
1243 .top.query.m.clist add command -label $n \
1244 -command [list query-select $i]
1249 proc save-settings {} {
1252 global settingsChanged
1257 set f [open "clientrc.tcl" w]
1258 puts $f "# Setup file"
1259 puts $f "set hotTargets \{ $hotTargets \}"
1261 foreach n [array names profile] {
1262 puts -nonewline $f "set profile($n) \{"
1263 puts -nonewline $f $profile($n)
1266 puts -nonewline $f "set queryTypes \{"
1267 puts -nonewline $f $queryTypes
1270 puts -nonewline $f "set queryButtons \{"
1271 puts -nonewline $f $queryButtons
1274 puts -nonewline $f "set queryInfo \{"
1275 puts -nonewline $f $queryInfo
1279 set settingsChanged 0
1291 message $w.top.message -text $ask
1293 pack $w.top.message -side left -pady 6 -padx 20 -expand yes -fill x
1296 top-down-ok-cancel $w {alert-action} 1
1300 proc alert-action {} {
1306 proc exit-action {} {
1307 global settingsChanged
1309 if {$settingsChanged} {
1310 set a [alert "you havent saved your settings. Do you wish to save?"]
1318 proc listbuttonaction {w name h user i} {
1319 $w configure -text [lindex $name 0]
1320 $h [lindex $name 1] $user $i
1323 proc listbuttonx {button no names handle user} {
1324 if {[winfo exists $button]} {
1325 $button configure -text [lindex [lindex $names $no] 0]
1326 ${button}.m delete 0 last
1328 menubutton $button -text [lindex [lindex $names $no] 0] \
1329 -width 10 -menu ${button}.m -relief raised -border 1
1333 foreach name $names {
1334 ${button}.m add command -label [lindex $name 0] \
1335 -command [list listbuttonaction ${button} $name \
1341 proc listbutton {button no names} {
1342 menubutton $button -text [lindex $names $no] -width 10 -menu ${button}.m \
1343 -relief raised -border 1
1345 foreach name $names {
1346 ${button}.m add command -label $name \
1347 -command [list ${button} configure -text $name]
1351 proc query-add-index-action {queryNo} {
1352 set w .setup-query-$queryNo
1355 global queryButtonsTmp
1357 lappend queryInfoTmp [list [.query-add-index.top.index.entry get] {}]
1359 destroy .query-add-index
1360 #destroy $w.top.lines
1361 #frame $w.top.lines -relief ridge -border 2
1362 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1363 #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1366 proc query-add-line {queryNo} {
1367 set w .setup-query-$queryNo
1370 global queryButtonsTmp
1372 lappend queryButtonsTmp {I 0}
1374 #destroy $w.top.lines
1375 #frame $w.top.lines -relief ridge -border 2
1376 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1377 #pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1380 proc query-del-line {queryNo} {
1381 set w .setup-query-$queryNo
1384 global queryButtonsTmp
1386 set l [llength $queryButtonsTmp]
1391 set queryButtonsTmp [lreplace $queryButtonsTmp $l $l]
1392 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1395 proc query-add-index {queryNo} {
1396 set w .query-add-index
1399 place-force $w .setup-query-$queryNo
1403 -side top -anchor e -pady 2
1404 entry-fields $w.top {index} \
1406 [list query-add-index-action $queryNo] {destroy .query-add-index}
1407 top-down-ok-cancel $w [list query-add-index-action $queryNo] 1
1410 proc query-setup-action {queryNo} {
1413 global queryButtonsTmp
1415 global queryButtonsFind
1416 global queryInfoFind
1418 set queryInfo [lreplace $queryInfo $queryNo $queryNo \
1420 set queryButtons [lreplace $queryButtons $queryNo $queryNo \
1422 set queryInfoFind $queryInfoTmp
1423 set queryButtonsFind $queryButtonsTmp
1427 destroy .setup-query-$queryNo
1429 index-lines .lines 1 $queryButtonsFind $queryInfoFind activate-index
1432 proc activate-e-index {value no i} {
1433 global queryButtonsTmp
1435 puts $queryButtonsTmp
1436 set queryButtonsTmp [lreplace $queryButtonsTmp $no $no [list I $i]]
1437 puts $queryButtonsTmp
1443 proc activate-index {value no i} {
1444 global queryButtonsFind
1446 set queryButtonsFind [lreplace $queryButtonsFind $no $no [list I $i]]
1448 puts "queryButtonsFind $queryButtonsFind"
1454 proc query-setup {queryNo} {
1455 set w .setup-query-$queryNo
1457 set queryTypes {Simple}
1460 global queryButtonsTmp
1463 set queryName [lindex $queryTypes $queryNo]
1464 set queryInfoTmp [lindex $queryInfo $queryNo]
1465 set queryButtonsTmp [lindex $queryButtons $queryNo]
1467 #set queryButtons { {I 0 I 1 I 2} }
1468 #set queryInfo { { {Title ti} {Author au} {Subject sh} } }
1472 wm title $w "Query setup $queryName"
1477 frame $w.top.lines -relief ridge -border 2
1478 frame $w.top.use -relief ridge -border 2
1479 frame $w.top.relation -relief ridge -border 2
1480 frame $w.top.position -relief ridge -border 2
1481 frame $w.top.structure -relief ridge -border 2
1482 frame $w.top.truncation -relief ridge -border 2
1483 frame $w.top.completeness -relief ridge -border 2
1487 index-lines $w.top.lines 0 $queryButtonsTmp $queryInfoTmp activate-e-index
1489 pack $w.top.lines -side left -pady 6 -padx 6 -fill y
1492 pack $w.top.use -side left -pady 6 -padx 6 -fill y
1494 label $w.top.use.label -text "Use"
1495 listbox $w.top.use.list -geometry 20x10 \
1496 -yscrollcommand "$w.top.use.scroll set"
1497 scrollbar $w.top.use.scroll -orient vertical -border 1
1498 pack $w.top.use.label -side top -fill x \
1500 pack $w.top.use.list -side left -fill both -expand yes \
1502 pack $w.top.use.scroll -side right -fill y \
1504 $w.top.use.scroll config -command "$w.top.use.list yview"
1506 foreach u {{Personal name} {Corporate name}} {
1507 $w.top.use.list insert end $u
1509 # Relation Attributes
1510 pack $w.top.relation -pady 6 -padx 6 -side top
1512 label $w.top.relation.label -text "Relation" -width 18
1514 listbutton $w.top.relation.b 0\
1515 {{None} {Less than} {Greater than or equal} \
1516 {Equal} {Greater than or equal} {Greater than} {Not equal} \
1518 {Stem} {Relevance} {AlwaysMatches}}
1520 pack $w.top.relation.label $w.top.relation.b -fill x
1522 # Position Attributes
1523 pack $w.top.position -pady 6 -padx 6 -side top
1525 label $w.top.position.label -text "Position" -width 18
1527 listbutton $w.top.position.b 0 {{None} {First in field} {First in subfield}
1528 {Any position in field}}
1530 pack $w.top.position.label $w.top.position.b -fill x
1532 # Structure Attributes
1534 pack $w.top.structure -pady 6 -padx 6 -side top
1536 label $w.top.structure.label -text "Structure" -width 18
1538 listbutton $w.top.structure.b 0 {{None} {Phrase} {Word} {Key} {Year}
1539 {Date (norm)} {Word list} {Date (un-norm)} {Name (norm)} {Date (un-norm)}
1540 {Structure} {urx} {free-form} {doc-text} {local-number} {string}
1543 pack $w.top.structure.label $w.top.structure.b -fill x
1545 # Truncation Attributes
1547 pack $w.top.truncation -pady 6 -padx 6 -side top
1549 label $w.top.truncation.label -text "Truncation" -width 18
1551 listbutton $w.top.truncation.b 0 {{Auto} {Right} {Left} {Left and right} \
1552 {No truncation} {Process #} {Re-1} {Re-2}}
1553 pack $w.top.truncation.label $w.top.truncation.b -fill x
1555 # Completeness Attributes
1557 pack $w.top.completeness -pady 6 -padx 6 -side top
1559 label $w.top.completeness.label -text "Truncation" -width 18
1561 listbutton $w.top.completeness.b 0 {{None} {Incomplete subfield} \
1562 {Complete subfield} {Complete field}}
1563 pack $w.top.completeness.label $w.top.completeness.b -fill x
1566 bottom-buttons $w [list \
1567 {Ok} [list query-setup-action $queryNo] \
1568 {Add index} [list query-add-index $queryNo] \
1569 {Add line} [list query-add-line $queryNo] \
1570 {Delete line} [list query-del-line $queryNo] \
1571 {Cancel} [list destroy $w]] 0
1574 proc index-clear {} {
1575 global queryButtonsFind
1578 foreach b $queryButtonsFind {
1579 .lines.$i.e delete 0 end
1584 proc index-query {} {
1585 global queryButtonsFind
1586 global queryInfoFind
1591 foreach b $queryButtonsFind {
1592 set term [string trim [.lines.$i.e get]]
1594 set attr [lindex [lindex $queryInfoFind [lindex $b 1]] 1]
1596 set term "\{${term}\}"
1598 set term "@attr $a ${term}"
1601 set qs "@and ${qs} ${term}"
1612 proc index-lines {w realOp buttonInfo queryInfo handle} {
1614 foreach b $buttonInfo {
1615 if {! [winfo exists $w.$i]} {
1616 frame $w.$i -background white -border 1
1618 listbuttonx $w.$i.l [lindex $b 1] $queryInfo $handle $i
1621 if {! [winfo exists $w.$i.e]} {
1622 entry $w.$i.e -width 32 -relief sunken -border 1
1623 bind $w.$i.e <FocusIn> [list $w.$i configure \
1625 bind $w.$i.e <FocusOut> [list $w.$i configure \
1627 pack $w.$i.l -side left
1628 pack $w.$i.e -side left -fill x -expand yes
1629 pack $w.$i -side top -fill x -padx 2 -pady 2
1630 bind $w.$i.e <Left> [list left-cursor $w.$i.e]
1631 bind $w.$i.e <Right> [list right-cursor $w.$i.e]
1632 bind $w.$i.e <Return> search-request
1635 pack $w.$i.l -side left
1636 pack $w.$i -side top -fill x -padx 2 -pady 2
1641 while {[winfo exists $w.$j]} {
1652 bind $w.$j.e <Tab> "focus $w.$k.e"
1656 bind $w.$i.e <Tab> "focus $w.0.e"
1661 proc search-fields {w buttondefs} {
1663 foreach buttondef $buttondefs {
1664 frame $w.$i -background white
1666 listbutton $w.$i.l 0 $buttondef
1667 entry $w.$i.e -width 32 -relief sunken
1669 pack $w.$i.l -side left
1670 pack $w.$i.e -side left -fill x -expand yes
1672 pack $w.$i -side top -fill x -padx 2 -pady 2
1674 bind $w.$i.e <Left> [list left-cursor $w.$i.e]
1675 bind $w.$i.e <Right> [list right-cursor $w.$i.e]
1683 bind $w.$j.e <Tab> "focus $w.$k.e \n
1684 $w.$k configure -background red \n
1685 $w.$j configure -background white"
1688 bind $w.$i.e <Tab> "focus $w.0.e \n
1689 $w.0 configure -background red \n
1690 $w.$i configure -background white"
1692 $w.0 configure -background red
1695 frame .top -border 1 -relief raised
1696 frame .lines -border 1 -relief raised
1697 frame .mid -border 1 -relief raised
1698 frame .data -border 1 -relief raised
1699 frame .bot -border 1 -relief raised
1700 pack .top .lines .mid -side top -fill x
1701 pack .data -side top -fill both -expand yes
1704 menubutton .top.file -text "File" -underline 0 -menu .top.file.m
1706 .top.file.m add command -label "Save settings" -command {save-settings}
1707 .top.file.m add command -label "Load Set" -command {load-set}
1708 .top.file.m add separator
1709 .top.file.m add command -label "Exit" -command {exit-action}
1710 .top.file.m add separator
1711 .top.file.m add command -label "About" -command {about-origin}
1713 menubutton .top.target -text "Target" -underline 0 -menu .top.target.m
1715 .top.target.m add cascade -label "Connect" -menu .top.target.m.clist
1716 .top.target.m add command -label "Disconnect" -command {close-target}
1717 .top.target.m add command -label "About" -command {about-target}
1718 .top.target.m add cascade -label "Setup" -menu .top.target.m.slist
1719 .top.target.m add command -label "Setup new" -command {define-target-dialog}
1720 .top.target.m add separator
1723 .top.target.m disable 1
1724 .top.target.m disable 2
1726 menu .top.target.m.clist
1727 menu .top.target.m.slist
1730 menubutton .top.search -text "Search" -underline 0 -menu .top.search.m
1732 .top.search.m add command -label "Database" -command {database-select}
1733 .top.search.m add cascade -label "Query type" -menu .top.search.m.querytype
1734 menu .top.search.m.querytype
1735 .top.search.m.querytype add radiobutton -label "RPN"
1736 .top.search.m.querytype add radiobutton -label "CCL"
1737 .top.search.m add cascade -label "Present" -menu .top.search.m.present
1738 menu .top.search.m.present
1739 .top.search.m.present add command -label "More" -command [list present-more 10]
1740 .top.search.m.present add command -label "All" -command [list present-more {}]
1741 .top.search configure -state disabled
1743 menubutton .top.query -text "Query" -underline 0 -menu .top.query.m
1745 .top.query.m add cascade -label "Choose" -menu .top.query.m.clist
1746 .top.query.m add command -label "Define" -command {new-query-dialog}
1747 .top.query.m add cascade -label "Edit" -menu .top.query.m.slist
1748 menu .top.query.m.clist
1749 menu .top.query.m.slist
1752 menubutton .top.help -text "Help" -menu .top.help.m
1755 .top.help.m add command -label "Help on help" \
1756 -command {tkerror "Help on help not available. Sorry"}
1757 .top.help.m add command -label "About" \
1758 -command {tkerror "About not available. Sorry"}
1760 pack .top.file .top.target .top.query .top.search -side left
1761 pack .top.help -side right
1763 index-lines .lines 1 $queryButtonsFind [lindex $queryInfo 0] activate-index
1765 button .mid.search -width 7 -text {Search} -command search-request \
1767 button .mid.scan -width 7 -text {Scan} \
1768 -command [list scan-request "@attr 1=4"] -state disabled
1769 button .mid.present -width 7 -text {Present} -command [list present-more 10] \
1772 button .mid.clear -width 7 -text {Clear} -command index-clear
1773 pack .mid.search .mid.scan .mid.present .mid.clear -side left \
1774 -fill y -padx 5 -pady 3
1776 listbox .data.list -yscrollcommand {.data.scroll set} -font fixed
1777 scrollbar .data.scroll -orient vertical -border 1
1778 pack .data.list -side left -fill both -expand yes
1779 pack .data.scroll -side right -fill y
1780 .data.scroll config -command {.data.list yview}
1782 button .bot.logo -bitmap @book1 -command cancel-operation
1784 pack .bot.a -side left -fill x
1785 pack .bot.logo -side right -padx 2 -pady 2
1787 message .bot.a.target -text "" -aspect 1000 -border 1
1789 label .bot.a.status -text "Not connected" -width 15 -relief \
1790 sunken -anchor w -border 1
1791 label .bot.a.set -textvariable setNo -width 5 -relief \
1792 sunken -anchor w -border 1
1793 label .bot.a.message -text "" -width 15 -relief \
1794 sunken -anchor w -border 1
1796 pack .bot.a.target -side top -anchor nw -padx 2 -pady 2
1797 pack .bot.a.status .bot.a.set .bot.a.message \
1798 -side left -padx 2 -pady 2
1800 bind .data.list <Double-Button-1> {set indx [.data.list nearest %y]
1801 show-full-marc [incr indx] 0}
1804 z39 options search present scan namedResultSets triggerResourceCtrl