# Sebastian Hammer, Adam Dickmeiss
#
# $Log: client.tcl,v $
-# Revision 1.72 1995-10-16 17:00:52 adam
+# Revision 1.86 1996-01-22 09:29:01 adam
+# Wrote comments.
+#
+# Revision 1.85 1996/01/19 16:22:36 adam
+# New method: apduDump - returns information about last incoming APDU.
+#
+# Revision 1.84 1996/01/11 13:12:10 adam
+# Bug fix.
+#
+# Revision 1.83 1995/11/28 17:26:36 adam
+# Removed Carriage return from ir-tcl.c!
+# Removed misc. debug logs.
+#
+# Revision 1.82 1995/11/02 08:47:56 adam
+# Text widgets are flat now.
+#
+# Revision 1.81 1995/10/19 10:34:43 adam
+# More configurable client.
+#
+# Revision 1.80 1995/10/18 17:20:32 adam
+# Work on target setup in client.tcl.
+#
+# Revision 1.79 1995/10/18 16:42:37 adam
+# New settings: smallSetElementSetNames and mediumSetElementSetNames.
+#
+# Revision 1.78 1995/10/18 15:45:36 quinn
+# *** empty log message ***
+#
+# Revision 1.77 1995/10/18 15:37:46 adam
+# Piggy-back present.
+#
+# Revision 1.76 1995/10/18 15:15:20 adam
+# Fixed bug.
+#
+# Revision 1.75 1995/10/17 14:18:05 adam
+# Minor changes in presentation formats.
+#
+# Revision 1.74 1995/10/17 12:18:57 adam
+# Bug fix: when target connection closed, the connection was not
+# properly reestablished.
+#
+# Revision 1.73 1995/10/17 10:58:06 adam
+# More work on presentation formats.
+#
+# Revision 1.72 1995/10/16 17:00:52 adam
# New setting: elementSetNames.
# Various client improvements. Medium presentation format looks better.
#
#
#
+# Procedure tk4 is defined - returns 0 if tk 3.6 - returns 1 otherwise
if {$tk_version == "3.6"} {
proc tk4 {} {
return 0
}
}
+# The following two procedures deals with menu entries. The interface
+# changed from Tk 3.6 to 4.X
+
+# Procedure configure-enable-e {w n}
+# w is a menu
+# n menu entry number (0 is first entry)
+# Enables menu entry
+
+# Procedure configure-disable-e {w n}
+# w is a menu
+# n menu entry number (0 is first entry)
+# Disables menu entry
+
if {[tk4]} {
proc configure-enable-e {w n} {
incr n
set noFocus {}
}
+# Set monoFlag to 1 if screen is known not to support colors; otherwise
+# set monoFlag to 0
if {![tk4]} {
if {[tk colormodel .] == "color"} {
set monoFlag 0
set monoFlag 0
}
+# Define libdir to the IrTcl configuration directory.
+# In the line below LIBDIR will be modified during 'make install'.
set libdir LIBDIR
+
+# If the bitmaps sub directory is present with a bitmap we assume
+# the client is run from the source directory in which case we
+# set libdir the current directory.
if {[file readable bitmaps/book2]} {
set libdir .
}
+
+# Make a final check to see if libdir was set ok.
if {! [file readable ${libdir}/bitmaps/book2]} {
puts "Cannot locate system files in ${libdir}. You must either run this"
puts "program from the source directory root of ir-tcl or you must assure"
exit 1
}
+# Initialize a lot of globals.
set hotTargets {}
set hotInfo {}
set busy 0
-set profile(Default) {{} {} {210} {} 16384 8192 tcpip {} 1 {} {} Z39 1}
+set profile(Default) {{} {} {210} {} 50000 30000 tcpip {} 1 {} {} Z39 1 2 0 0 4}
set hostid Default
set settingsChanged 0
set setNo 0
set recordSyntax None
set elementSetNames None
set delayRequest {}
+set debugMode 0
set queryTypes {Simple}
set queryButtons { { {I 0} {I 1} {I 2} } }
set setOffset 0
set setMax 0
+# Procedure tkerror {err}
+# err error message
+# Override the Tk error handler function.
proc tkerror err {
set w .tkerrorw
bottom-buttons $w [list {Close} [list destroy $w]] 1
}
+# Read the global configuration file.
+if {[file readable "clientrc.tcl"]} {
+ source "clientrc.tcl"
+} else {
+ if {[file readable "${libdir}/clientrc.tcl"]} {
+ source "${libdir}/clientrc.tcl"
+ }
+}
+
+# Read the user configuration file.
+if {[file readable "~/.clientrc.tcl"]} {
+ source "~/.clientrc.tcl"
+}
+
+# These globals describe the current query type. They are set to the
+# first query type.
+set queryButtonsFind [lindex $queryButtons 0]
+set queryInfoFind [lindex $queryInfo 0]
+
+# Procedure read-formats
+# Read all Tcl source files in the subdirectory 'formats'.
+# The name of each source will correspond to a display format.
proc read-formats {} {
global displayFormats
global libdir
- if {[catch {set formats [glob -nocomplain ${libdir}/formats/*.tcl]}]} {
- set formats ./formats/raw.tcl
- }
+
+ set oldDir [pwd]
+ cd ${libdir}/formats
+ set formats [glob {*.[tT][cC][lL]}]
foreach f $formats {
if {[file readable $f]} {
source $f
set l [string length $f]
- set f [string range $f [string length "${libdir}/formats/"] \
- [expr $l - 5]]
+ set f [string tolower [string range $f 0 [expr $l - 5]]]
lappend displayFormats $f
}
}
+ cd $oldDir
}
+# Procedure set-wrap {m}
+# m boolean wrap mode
+# Handler to enable/disable text wrap in the main record window
proc set-wrap {m} {
global textWrap
.data.record configure -wrap $m
}
+# Procedure dputs {m}
+# m string to be printed
+# puts utility for debugging.
proc dputs {m} {
+ global debugMode
+ if {$debugMode} {
+ puts $m
+ }
+}
+
+# Procedure apduDump {}
+# Logs BER dump of last APDU in window if debugMode is true.
+proc apduDump {} {
+ global debugMode
+
+ set w .apdu
+
+ if {$debugMode == 0} return
+ set x [z39 apduInfo]
+
+ set offset [lindex $x 1]
+ set length [lindex $x 0]
+
+ if {![winfo exists $w]} {
+ catch {destroy $w}
+ toplevelG $w
+
+ wm title $w "APDU information"
+
+ wm minsize $w 0 0
+
+ top-down-window $w
+
+ text $w.top.t -width 60 -height 12 -wrap word -relief flat \
+ -borderwidth 0 \
+ -yscrollcommand [list $w.top.s set]
+ scrollbar $w.top.s -command [list $w.top.t yview]
+
+ pack $w.top.s -side right -fill y
+ pack $w.top.t -expand yes -fill both
+
+ bottom-buttons $w [list {Close} [list destroy $w]] 0
+ }
+ $w.top.t insert end "Length: ${length}\n"
+ if {$offset != -1} {
+ $w.top.t insert end "Offset: ${offset}\n"
+ }
+ $w.top.t insert end [lindex $x 2]
+ $w.top.t insert end "---------------------------------\n"
+
}
+# Procedure set-display-format {f}
+# f display format
+# Reformats main record window to use display format given by f
proc set-display-format {f} {
global displayFormat
global setNo
add-title-lines -1 10000 1
}
+# Procedure initBindings
+# Disables various default bindings for Text and Listbox widgets.
proc initBindings {} {
set w Text
bind $w <1> {}
set w Entry
}
+# Procedure post-menu {wbutton wmenu}
+# wbutton button widget
+# wmenu menu widget
+# Post menu near button. Note: not used.
proc post-menu {wbutton wmenu} {
$wmenu activate none
focus $wmenu
}
+# Procedure destroyGW {w}
+# w top level widget
+# Saves geometry of widget w in windowGeometry array. This
+# Procedure is used to save current geometry of a window before
+# it is destroyed.
+# See also topLevelG.
proc destroyGW {w} {
global windowGeometry
set windowGeometry($w) [wm geometry $w]
}
+
+# Procedure topLevelG
+# w top level widget
+# Makes a new top level widget named w; sets geometry of window if it
+# exists in windowGeometry array. The destroyGW procedure is set
+# to be called when the Destroy event occurs.
proc toplevelG {w} {
global windowGeometry
bind $w <Destroy> [list destroyGW $w]
}
-if {[file readable "clientrc.tcl"]} {
- source "clientrc.tcl"
-} else {
- if {[file readable "${libdir}/clientrc.tcl"]} {
- source "${libdir}/clientrc.tcl"
- }
-}
-
-if {[file readable "~/.clientrc.tcl"]} {
- source "~/.clientrc.tcl"
-}
-
-set queryButtonsFind [lindex $queryButtons 0]
-set queryInfoFind [lindex $queryInfo 0]
-
+# Procedure top-down-window {w}
+# w window (possibly top level)
+# Makes two frames inside w called top and bot.
proc top-down-window {w} {
frame $w.top -relief raised -border 1
frame $w.bot -relief raised -border 1
pack $w.bot -fill both
}
+# Procedure top-down-ok-cancel {w ok-action g}
+# w top level widget with $w.bot-frame
+# ok-action ok script
+# g grab flag
+# Makes two buttons in the bot frame called Ok and Cancel. The
+# ok-action is executed if Ok is pressed. If Cancel is activated
+# The window is destroyed. If g is true a grab is performed on the
+# window and the procedure waits until the window is destroyed.
proc top-down-ok-cancel {w ok-action g} {
frame $w.bot.left -relief sunken -border 1
pack $w.bot.left -side left -expand yes -ipadx 2 -ipady 2 -padx 1 -pady 1
}
}
+# Procedure bottom-buttons {w buttonList g}
+# w top level widget with $w.bot-frame
+# buttonList button specifications
+# g grab flag
+# Makes a list of buttons in the $w.bot frame. The buttonList is a list
+# of button specifications. Each button specification consists of two
+# items; the first item is button label name; the second item is a script
+# of be executed when that button is executed. A grab is performed if g
+# is true and it waits for the window to be destroyed.
proc bottom-buttons {w buttonList g} {
set i 0
set l [llength $buttonList]
}
}
+# Procedure cancel-operation
+# This handler is invoked when the user wishes to cancel an operation.
+# If the system is currently busy a "Cancel" will be displayed in the
+# status area and the cancelFlag is set to true indicating that future
+# responses from the target should be ignored. The system is no longer
+# when this procedure exists.
proc cancel-operation {} {
global cancelFlag
global busy
}
}
+# Procedure show-target {target base}
+# target name of target
+# base name of database
+# Displays target name and database name in the target status area.
proc show-target {target base} {
global profile
}
}
+# Procedure show-logo {v1}
+# v1 integer level
+# This procedure maintains the book logo in the bottom of the screen.
+# It is invoked only once during initialization of windows, etc., and
+# by itself. The global 'busy' variable determines whether the logo is
+# moving or not.
proc show-logo {v1} {
global busy
global libdir
}
}
}
-
+
+# Procedure show-status {status b sb}
+# status status message string
+# b busy indicator
+# sb search busy indicator
+# Display status information according to 'status' and sets the global
+# busy flag 'busy' to b if b is non-empty. If sb is non-empty it indicates
+# whether service buttons should be enabled or disabled.
proc show-status {status b sb} {
global busy
global scanEnable
}
}
+# Procedure show-message {msg}
+# msg message string
+# Sets message the bottom of the screen to msg.
proc show-message {msg} {
.bot.a.message configure -text "$msg"
}
+# Procedure insertWithTags {w text args}
+# w text widget
+# text string to be inserted
+# args list of tags
+# Inserts text at the insertion point in widget w. The text is tagged
+# with the tags in args.
proc insertWithTags {w text args} {
set start [$w index insert]
$w insert insert $text
}
}
+# Procedure popup-license
+# Displays LICENSE information.
proc popup-license {} {
global libdir
set w .popup-licence
top-down-window $w
- text $w.top.t -width 80 -height 10 -wrap word \
+ text $w.top.t -width 80 -height 10 -wrap word -relief flat -borderwidth 0 \
-yscrollcommand [list $w.top.s set]
scrollbar $w.top.s -command [list $w.top.t yview]
bottom-buttons $w [list {Close} [list destroy $w]] 1
}
+# Procedure about-target
+# Displays various information about the current target, such
+# as implementation-name, implementation-id, etc.
proc about-target {} {
set w .about-target-w
global hostid
bottom-buttons $w [list {Close} [list destroy $w]] 1
}
+# Procedure about-origin-logo {n}
+# n integer level
+# Displays book logo in the .about-origin-w widget
proc about-origin-logo {n} {
global libdir
set w .about-origin-w
after 140 [list about-origin-logo $n]
}
+# Procedure about-origin
+# Display various information about origin (this client).
proc about-origin {} {
set w .about-origin-w
global libdir
{License} [list popup-license]] 0
}
+# Procedure popup-marc {sno no b df}
+# sno result set number
+# no record position number
+# b popup window number
+# df display format
+# Displays record in set $sno at position $no in window .full-marc$b.
+# The global variable $popupMarcdf holds the current format method.
proc popup-marc {sno no b df} {
global displayFormats
global popupMarcdf
pack $w.top -side top -fill both -expand yes
pack $w.bot -fill both
- text $w.top.record -width 60 -height 5 -wrap word \
+ text $w.top.record -width 60 -height 5 -wrap word -relief flat -borderwidth 0 \
-yscrollcommand [list $w.top.s set]
scrollbar $w.top.s -command [list $w.top.record yview]
$ffunc $sno $no $w.top.record 0
}
+# Procedure update-target-hotlist {target base}
+# target current target name
+# base current database name
+# Updates the global $hotTargets so that $target and $base are
+# moved to the front, i.e. they become the number 1 target/base.
+# The target menu is updated by a call to set-target-hotlist.
proc update-target-hotlist {target base} {
global hotTargets
set-target-hotlist $olen
}
+# Procedure delete-target-hotlist {target}
+# target target to be deleted
+# Updates the global $hotTargets so that $target is removed.
+# The target menu is updated by a call to set-target-hotlist.
proc delete-target-hotlist {target} {
global hotTargets
set-target-hotlist $olen
}
+# Procedure set-target-hotlist {olen}
+# olen number of hot target entries to be deleted from menu
+# Updates the target menu with the targets with the first 8 entries
+# in the $hotTargets global.
proc set-target-hotlist {olen} {
global hotTargets
}
}
+# Procedure reopen-target {target base}
+# target target to be opened
+# base base to be used
+# Closes connection with current target and opens a new connection
+# with $target and database $base.
proc reopen-target {target base} {
close-target
open-target $target $base
update-target-hotlist $target $base
}
+# Procedure define-target-action
+# Prepares the setup of a new target. The name of the target
+# is read from the dialog .target-define dialog and the target
+# definition window is displayed by a call to protocol-setup.
proc define-target-action {} {
global profile
}
foreach n [array names profile] {
if {$n == $target} {
+ destroy .target-define
protocol-setup $n
return
}
}
set seq [lindex $profile(Default) 12]
dputs "seq=${seq}"
+ dputs $profile(Default)
set profile($target) $profile(Default)
set profile(Default) [lreplace $profile(Default) 12 12 [incr seq]]
-
+
protocol-setup $target
destroy .target-define
}
+# Procedure fail-response {target}
+# target current target
+# Error handler (IrTcl failback) that takes care of serious protocol
+# errors, connection lost, etc.
proc fail-response {target} {
+ global debugMode
+
set c [lindex [z39 failInfo] 0]
set m [lindex [z39 failInfo] 1]
+ if {$c == 4 || $c == 5} {
+ set debugMode 1
+ apduDump
+ }
close-target
tkerror "$m ($c)"
}
+# Procedure connect-response {target base}
+# target current target
+# base current database
+# IrTcl connect response handler.
proc connect-response {target base} {
dputs "connect-response"
show-target $target $base
init-request
}
+# Procedure open-target {target base}
+# target target to be opened
+# base database to be used
+# Opens a new connection with $target/$base.
proc open-target {target base} {
global profile
global hostid
+ global presentChunk
z39 disconnect
z39 comstack [lindex $profile($target) 6]
} else {
z39 databaseNames $base
}
+ set x [lindex $profile($target) 13]
+ if {$x == ""} {
+ set x 2
+ }
+ z39 largeSetLowerBound $x
+
+ set x [lindex $profile($target) 14]
+ if {$x == ""} {
+ set x 0
+ }
+ z39 smallSetUpperBound $x
+
+ set x [lindex $profile($target) 15]
+ if {$x == ""} {
+ set x 0
+ }
+ z39 mediumSetPresentNumber $x
+
+ set presentChunk [lindex $profile($target) 16]
+ if {$presentChunk == ""} {
+ set presentChunk 4
+ }
+
z39 failback [list fail-response $target]
z39 callback [list connect-response $target $base]
update idletasks
configure-enable-e .top.target.m 2
}
+# Procedure close-target
+# Shuts down the connection with current target.
proc close-target {} {
global hostid
global cancelFlag
global cancelFlag
global scanEnable
+ dputs {init-reponse}
+ apduDump
if {$cancelFlag} {
close-target
return
set target $hostid
+ if {[z39 connect] == ""} {
+ return
+ }
dputs "search-request"
show-message {}
if {!$bflag && $busy} {
}
if {$elementSetNames == "None" } {
z39.$setNo elementSetNames {}
+ z39.$setNo smallSetElementSetNames {}
+ z39.$setNo mediumSetElementSetNames {}
} else {
z39.$setNo elementSetNames $elementSetNames
+ z39.$setNo smallSetElementSetNames $elementSetNames
+ z39.$setNo mediumSetElementSetNames $elementSetNames
}
z39 callback {search-response}
z39.$setNo search $query
set w .scan-window
dputs "In scan-response"
+ apduDump
set m [z39.scan numberOfEntriesReturned]
dputs $m
dputs attr=$attr
global cancelFlag
global busy
global delayRequest
+ global presentChunk
+ apduDump
dputs "In search-response"
if {$cancelFlag} {
dputs "Handling cancel"
if {$setMax > 20} {
set setMax 20
}
- z39 callback {present-response}
- z39.$setNo present $setOffset 1
- show-status Retrieving 1 0
+ set no [z39.$setNo numberOfRecordsReturned]
+ dputs "Returned $no records, setOffset $setOffset"
+ add-title-lines $setNo $no $setOffset
+ set setOffset [expr $setOffset + $no]
+
+ set toGet [expr $setMax - $setOffset + 1]
+ if {$toGet > 0} {
+ if {$setOffset == 1} {
+ set toGet 1
+ } elseif {$toGet > $presentChunk} {
+ set toGet $presentChunk
+ }
+ z39 callback {present-response}
+ z39.$setNo present $setOffset $toGet
+ show-status Retrieving 1 0
+ }
}
proc present-more {number} {
global busy
global cancelFlag
global delayRequest
+ global presentChunk
dputs "present-more"
if {$cancelFlag} {
if {$toGet <= 0} {
return
}
- if {$toGet > 3} {
- set toGet 3
+ if {$toGet > $presentChunk} {
+ set toGet $presentChunk
}
z39.$setNo present $setOffset $toGet
show-status Retrieving 1 0
global setNo
global busy
+ dputs "add-title-lines offset=${offset} no=${no}"
if {$setno != -1} {
set setNo $setno
} else {
set setno $setNo
}
if {$offset == 1} {
+
.bot.a.set configure -text $setno
.data.record delete 0.0 end
}
set o [expr $i + $offset]
set type [z39.$setno type $o]
if {$type == ""} {
+ dputs "no more at $o"
break
}
.data.record tag bind r$o <Any-Enter> {}
global setMax
global cancelFlag
global delayRequest
+ global presentChunk
dputs "In present-response"
+ apduDump
set no [z39.$setNo numberOfRecordsReturned]
dputs "Returned $no records, setOffset $setOffset"
add-title-lines $setNo $no $setOffset
if {$no > 0 && $setOffset <= $setMax} {
dputs "present-request from ${setOffset}"
set toGet [expr $setMax - $setOffset + 1]
- if {$toGet > 3} {
- set toGet 3
+ if {$toGet > $presentChunk} {
+ set toGet $presentChunk
}
z39.$setNo present $setOffset $toGet
} else {
top-down-ok-cancel $w {define-target-action} 1
}
-proc protocol-setup-delete {target} {
+proc protocol-setup-delete {target w} {
global profile
global settingsChanged
set a [alert "Are you sure you want to delete the target \
definition $target ?"]
if {$a} {
- set wno [lindex $profile($target) 12]
- set w .setup-${wno}
destroy $w
unset profile($target)
set settingsChanged 1
}
}
-proc protocol-setup-action {target} {
+proc protocol-setup-action {target w} {
global profile
- global csRadioType
- global protocolRadioType
global settingsChanged
- global RPNCheck
- global CCLCheck
- global ResultSetCheck
+ global targetS
- set wno [lindex $profile($target) 12]
- set w .setup-${wno}
-
- set b {}
+ set dataBases {}
set settingsChanged 1
set len [$w.top.databases.list size]
for {set i 0} {$i < $len} {incr i} {
- lappend b [$w.top.databases.list get $i]
+ lappend dataBases [$w.top.databases.list get $i]
}
+ set wno [lindex $profile($target) 12]
+
set profile($target) [list [$w.top.description.entry get] \
[$w.top.host.entry get] \
[$w.top.port.entry get] \
[$w.top.idAuthentication.entry get] \
- [$w.top.maximumRecordSize.entry get] \
- [$w.top.preferredMessageSize.entry get] \
- $csRadioType \
- $b \
- $RPNCheck \
- $CCLCheck \
- $ResultSetCheck \
- $protocolRadioType \
- $wno]
+ $targetS($target,MRS) \
+ $targetS($target,PMS) \
+ $targetS($target,csType) \
+ $dataBases \
+ $targetS($target,RPN) \
+ $targetS($target,CCL) \
+ $targetS($target,ResultSets) \
+ $targetS($target,protocolType) \
+ $wno \
+ $targetS($target,LSLB) \
+ $targetS($target,SSUB) \
+ $targetS($target,MSPN) \
+ $targetS($target,presentChunk) ]
cascade-target-list
delete-target-hotlist $target
wm geometry $window +${x}+${y}
}
-proc add-database-action {target} {
+proc add-database-action {target w} {
global profile
- set wno [lindex $profile($target) 12]
- set w .setup-${wno}
-
$w.top.databases.list insert end \
[.database-select.top.database.entry get]
destroy .database-select
}
-proc add-database {target} {
+proc add-database {target wp} {
global profile
set w .database-select
toplevel $w
set oldFocus [focus]
- set wno [lindex $profile($target) 12]
- place-force $w .setup-${wno}
+ place-force $w $wp
top-down-window $w
entry-fields $w.top {database} \
{{Database to add:}} \
- [list add-database-action $target] {destroy .database-select}
+ [list add-database-action $target $wp] {destroy .database-select}
- top-down-ok-cancel $w [list add-database-action $target] 1
+ top-down-ok-cancel $w [list add-database-action $target $wp] 1
focus $oldFocus
}
-proc delete-database {target} {
+proc delete-database {target w} {
global profile
- set wno [lindex $profile($target) 12]
- set w .setup-${wno}
set l {}
foreach i [$w.top.databases.list curselection] {
set b [$w.top.databases.list get $i]
proc protocol-setup {target} {
global profile
- global csRadioType
- global protocolRadioType
- global RPNCheck
- global CCLCheck
- global ResultSetCheck
-
- set wno [lindex $profile($target) 12]
- set w .setup-${wno}
+ global targetS
+
+ set bno 0
+ while {[winfo exists .setup-$bno]} {
+ incr bno
+ }
+ set w .setup-$bno
toplevelG $w
frame $w.top.host
frame $w.top.port
frame $w.top.idAuthentication
- frame $w.top.maximumRecordSize
- frame $w.top.preferredMessageSize
frame $w.top.cs-type -relief ridge -border 2
frame $w.top.protocol -relief ridge -border 2
frame $w.top.query -relief ridge -border 2
# Maximum/preferred/idAuth ...
pack $w.top.description $w.top.host $w.top.port \
- $w.top.idAuthentication $w.top.maximumRecordSize \
- $w.top.preferredMessageSize -side top -anchor e -pady 2
+ $w.top.idAuthentication -side top -anchor e -pady 2
- entry-fields $w.top {description host port idAuthentication \
- maximumRecordSize preferredMessageSize} \
- {{Description:} {Host:} {Port:} {Id Authentication:} \
- {Maximum Record Size:} {Preferred Message Size:}} \
- [list protocol-setup-action $target] [list destroy $w]
+ entry-fields $w.top {description host port idAuthentication } \
+ {{Description:} {Host:} {Port:} {Id Authentication:}} \
+ [list protocol-setup-action $target $w] [list destroy $w]
- foreach sub {description host port idAuthentication \
- maximumRecordSize preferredMessageSize} {
+ foreach sub {description host port idAuthentication} {
dputs $sub
- bind $w.top.$sub.entry <Control-a> [list add-database $target]
- bind $w.top.$sub.entry <Control-d> [list delete-database $target]
+ bind $w.top.$sub.entry <Control-a> [list add-database $target $w]
+ bind $w.top.$sub.entry <Control-d> [list delete-database $target $w]
}
$w.top.description.entry insert 0 [lindex $profile($target) 0]
$w.top.host.entry insert 0 [lindex $profile($target) 1]
$w.top.port.entry insert 0 [lindex $profile($target) 2]
$w.top.idAuthentication.entry insert 0 [lindex $profile($target) 3]
- $w.top.maximumRecordSize.entry insert 0 [lindex $profile($target) 4]
- $w.top.preferredMessageSize.entry insert 0 [lindex $profile($target) 5]
- set csRadioType [lindex $profile($target) 6]
- set RPNCheck [lindex $profile($target) 8]
- set CCLCheck [lindex $profile($target) 9]
- set ResultSetCheck [lindex $profile($target) 10]
- set protocolRadioType [lindex $profile($target) 11]
- if {$protocolRadioType == ""} {
- set protocolRadioType Z39
- }
-
+ set targetS($target,csType) [lindex $profile($target) 6]
+ set targetS($target,RPN) [lindex $profile($target) 8]
+ set targetS($target,CCL) [lindex $profile($target) 9]
+ set targetS($target,ResultSets) [lindex $profile($target) 10]
+ set targetS($target,protocolType) [lindex $profile($target) 11]
+ if {$targetS($target,protocolType) == ""} {
+ set targetS($target,protocolType) Z39
+ }
+ set targetS($target,LSLB) [lindex $profile($target) 13]
+ set targetS($target,SSUB) [lindex $profile($target) 14]
+ set targetS($target,MSPN) [lindex $profile($target) 15]
+ set targetS($target,presentChunk) [lindex $profile($target) 16]
+ set targetS($target,MRS) [lindex $profile($target) 4]
+ set targetS($target,PMS) [lindex $profile($target) 5]
# Databases ....
pack $w.top.databases -side left -pady 2 -padx 2 -expand yes -fill both
label $w.top.databases.label -text "Databases"
- button $w.top.databases.add -text "Add" \
- -command [list add-database $target]
- button $w.top.databases.delete -text "Delete" \
- -command [list delete-database $target]
+ button $w.top.databases.add -text Add \
+ -command [list add-database $target $w]
+ button $w.top.databases.delete -text Delete \
+ -command [list delete-database $target $w]
if {! [tk4]} {
listbox $w.top.databases.list -geometry 14x6 \
-yscrollcommand "$w.top.databases.scroll set"
label $w.top.cs-type.label -text "Transport"
radiobutton $w.top.cs-type.tcpip -text "TCP/IP" -anchor w \
- -variable csRadioType -value tcpip
+ -variable targetS($target,csType) -value tcpip
radiobutton $w.top.cs-type.mosi -text "MOSI" -anchor w\
- -variable csRadioType -value mosi
+ -variable targetS($target,csType) -value mosi
pack $w.top.cs-type.label $w.top.cs-type.tcpip $w.top.cs-type.mosi \
-padx 2 -side top -fill x
label $w.top.protocol.label -text "Protocol"
radiobutton $w.top.protocol.z39v2 -text "Z39.50" -anchor w \
- -variable protocolRadioType -value Z39
+ -variable targetS($target,protocolType) -value Z39
radiobutton $w.top.protocol.sr -text "SR" -anchor w \
- -variable protocolRadioType -value SR
+ -variable targetS($target,protocolType) -value SR
pack $w.top.protocol.label $w.top.protocol.z39v2 $w.top.protocol.sr \
-padx 2 -side top -fill x
pack $w.top.query -pady 2 -padx 2 -side top -fill x
label $w.top.query.label -text "Query support"
- checkbutton $w.top.query.c1 -text "RPN query" -anchor w -variable RPNCheck
- checkbutton $w.top.query.c2 -text "CCL query" -anchor w -variable CCLCheck
- checkbutton $w.top.query.c3 -text "Result sets" -anchor w -variable ResultSetCheck
+ checkbutton $w.top.query.c1 -text "RPN query" -anchor w \
+ -variable targetS($target,RPN)
+ checkbutton $w.top.query.c2 -text "CCL query" -anchor w \
+ -variable targetS($target,CCL)
+ checkbutton $w.top.query.c3 -text "Result sets" -anchor w \
+ -variable targetS($target,ResultSets)
pack $w.top.query.label -side top
pack $w.top.query.c1 $w.top.query.c2 $w.top.query.c3 \
-padx 2 -side top -fill x
# Ok-cancel
- bottom-buttons $w [list {Ok} [list protocol-setup-action $target] \
- {Delete} [list protocol-setup-delete $target] \
+ bottom-buttons $w [list {Ok} [list protocol-setup-action $target $w] \
+ {Delete} [list protocol-setup-delete $target $w] \
+ {Advanced} [list advanced-setup $target $bno] \
{Cancel} [list destroy $w]] 0
}
+
+proc advanced-setup {target b} {
+ global profile
+ global targetS
+
+ set w .advanced-setup-$b
+
+ toplevelG $w
+
+ wm title $w "Advanced setup $target"
+
+ top-down-window $w
+
+ if {$target == ""} {
+ set target Default
+ }
+ dputs target
+
+ frame $w.top.largeSetLowerBound
+ frame $w.top.smallSetUpperBound
+ frame $w.top.mediumSetPresentNumber
+ frame $w.top.presentChunk
+ frame $w.top.maximumRecordSize
+ frame $w.top.preferredMessageSize
+
+ pack $w.top.largeSetLowerBound $w.top.smallSetUpperBound \
+ $w.top.mediumSetPresentNumber $w.top.presentChunk \
+ $w.top.maximumRecordSize $w.top.preferredMessageSize \
+ -side top -anchor e -pady 2
+
+ entry-fields $w.top {largeSetLowerBound smallSetUpperBound \
+ mediumSetPresentNumber presentChunk maximumRecordSize \
+ preferredMessageSize} \
+ {{Large Set Lower Bound:} {Small Set Upper Bound:} \
+ {Medium Set Present Number:} {Present Chunk:} \
+ {Maximum Record Size:} {Preferred Message Size:}} \
+ [list advanced-setup-action $target $b] [list destroy $w]
+
+ $w.top.largeSetLowerBound.entry insert 0 $targetS($target,LSLB)
+ $w.top.smallSetUpperBound.entry insert 0 $targetS($target,SSUB)
+ $w.top.mediumSetPresentNumber.entry insert 0 $targetS($target,MSPN)
+ $w.top.presentChunk.entry insert 0 $targetS($target,presentChunk)
+ $w.top.maximumRecordSize.entry insert 0 $targetS($target,MRS)
+ $w.top.preferredMessageSize.entry insert 0 $targetS($target,PMS)
+
+ bottom-buttons $w [list {Ok} [list advanced-setup-action $target $b] \
+ {Cancel} [list destroy $w]] 0
+}
+
+proc advanced-setup-action {target b} {
+ set w .advanced-setup-$b
+ global targetS
+
+ set targetS($target,LSLB) [$w.top.largeSetLowerBound.entry get]
+ set targetS($target,SSUB) [$w.top.smallSetUpperBound.entry get]
+ set targetS($target,MSPN) [$w.top.mediumSetPresentNumber.entry get]
+ set targetS($target,presentChunk) [$w.top.presentChunk.entry get]
+ set targetS($target,MRS) [$w.top.maximumRecordSize.entry get]
+ set targetS($target,PMS) [$w.top.preferredMessageSize.entry get]
+
+ dputs "advanced-setup-action"
+ destroy $w
+}
+
proc database-select-action {} {
set w .database-select.top
set b {}
}
.top.target.m.slist delete 0 last
foreach n [lsort [array names profile]] {
- if {$n != "Default"} {
- .top.target.m.slist add command -label $n \
- -command [list protocol-setup $n]
- }
+ .top.target.m.slist add command -label $n \
+ -command [list protocol-setup $n]
}
}
global popupMarcdf
global recordSyntax
global elementSetNames
+ global hostid
set windowGeometry(.) [wm geometry .]
if {[catch {set f [open ~/.clientrc.tcl w]}]} {
return
}
+ if {$hostid != "Default"} {
+ puts $f "set hostid \{$hostid\}"
+ set b [z39 databaseNames]
+ puts $f "set hostbase $b"
+ }
puts $f "set hotTargets \{ $hotTargets \}"
puts $f "set textWrap $textWrap"
puts $f "set displayFormat $displayFormat"
.top.options.m add cascade -label "Wrap" -menu .top.options.m.wrap
.top.options.m add cascade -label "Syntax" -menu .top.options.m.syntax
.top.options.m add cascade -label "Elements" -menu .top.options.m.elements
+.top.options.m add radiobutton -label "Debug" -variable debugMode -value 1
menu .top.options.m.query
.top.options.m.query add cascade -label "Select" \
pack .mid.search .mid.scan .mid.present .mid.clear -side left \
-fill y -pady 1
-text .data.record -height 2 -width 20 -wrap none \
+text .data.record -height 2 -width 20 -wrap none -borderwidth 0 -relief flat \
-yscrollcommand [list .data.scroll set] -wrap $textWrap
scrollbar .data.scroll -command [list .data.record yview]
if {[tk4]} {
}
.data.record tag configure marc-data -foreground black
.data.record tag configure marc-head \
- -font -Adobe-Times-Medium-R-Normal-*-140-* \
- -foreground white -background black
+ -font -Adobe-Times-Bold-R-Normal-*-140-* \
+ -foreground brown -relief raised -borderwidth 1
+.data.record tag configure marc-small-head -foreground brown
.data.record tag configure marc-pref \
-font -Adobe-Times-Medium-R-Normal-*-140-* \
-foreground blue
puts "ok"
}
#z39 logLevel all
+
+if {$hostid != "Default"} {
+ catch {open-target $hostid $hostbase}
+}
+
show-logo 1
projects / ir-tcl-moved-to-github.git / blobdiff