# IR toolkit for tcl/tk
-# (c) Index Data 1995-1997
+# (c) Index Data 1995-2001
# See the file LICENSE for details.
# Sebastian Hammer, Adam Dickmeiss
#
# $Log: client.tcl,v $
-# Revision 1.101 1997-11-19 11:20:56 adam
+# Revision 1.111 2001-12-03 18:52:06 adam
+# Configure no longer searches for Tk. Removed references to SR.
+#
+# Revision 1.110 2000/10/11 12:26:47 adam
+# Using yaz.m4 for aclocal.m4.
+#
+# Revision 1.109 1999/12/12 00:25:59 adam
+# Updated list of preconfigure targets.
+#
+# Revision 1.108 1999/11/30 14:05:58 adam
+# Updated for new location of YAZ headers.
+#
+# Revision 1.107 1999/02/11 11:30:08 adam
+# Updated for WIN32.
+#
+# Revision 1.106 1998/06/10 13:22:47 adam
+# Minor changes.
+#
+# Revision 1.105 1998/06/10 13:00:45 adam
+# Added ir-version command.
+#
+# Revision 1.104 1998/02/12 13:32:41 adam
+# Updated configuration system.
+#
+# Revision 1.103 1998/01/30 13:30:50 adam
+# Name of target database is irtdb.tcl instead of clientrc.tcl.
+#
+# Revision 1.102 1997/11/19 13:19:54 adam
+# Font fix.
+#
+# Revision 1.101 1997/11/19 11:20:56 adam
# New target profile format - associative arrrays instead of LONG lists.
#
# Revision 1.100 1997/09/09 10:19:50 adam
#
#
+
# Procedure tk4 is defined - returns 0 if tk 3.6 - returns 1 otherwise
if {$tk_version == "3.6"} {
proc tk4 {} {
set queryTypes {Simple}
set queryButtons { { {I 0} {I 1} {I 2} } }
-set queryInfo { { {Title {1=4 4=1}} {Author {1=1}} \
- {Subject {1=21}} {Any {1=1016}} } }
+set queryInfo {{{Title {1=4}} {Author {1=1003}} \
+ {Subject {1=21}} {Any {1=1016}} {Abstract {1=62}}}}
wm minsize . 0 0
set setOffset 0
set setMax 0
-if {[lindex [split $tk_version .] 0] > 4} {
+if {[lindex [split $tk_version .] 0] < 5} {
set font(bb,normal) -Adobe-Helvetica-Medium-R-Normal-*-240-*
set font(bb,bold) -Adobe-Helvetica-Bold-R-Normal-*-240-*
set font(b,normal) -Adobe-Helvetica-Medium-R-Normal-*-180-*
source "${libdir}/tagsets.tcl"
}
-# Read the global configuration file.
-if {[file readable "clientrc.tcl"]} {
- source "clientrc.tcl"
-} elseif {[file readable "${libdir}/clientrc.tcl"]} {
- source "${libdir}/clientrc.tcl"
+# Read the global target configuration file.
+if {[file readable "${libdir}/irtdb.tcl"]} {
+ source "${libdir}/irtdb.tcl"
+}
+# Read the local target configuration file.
+if {[file readable "irtdb.tcl"]} {
+ source "irtdb.tcl"
}
# Read the user configuration file.
set profile($target,comstack) [lindex $profile($target) 6]
set profile($target,databases) [lindex $profile($target) 7]
set profile($target,timeDefine) $timedef
-
- incr profile(Default,windowNumber)
+ set profile($target,windowNumber) 1
}
unset profile($target)
}
}
+# Assign unique ID's to each target's window number
+set wno 1
+foreach n [array names profile *,windowNumber] {
+ set profile($n) $wno
+ incr wno
+}
+set profile(Default,windowNumber) $wno
+
# These globals describe the current query type. They are set to the
# first query type.
set queryButtonsFind [lindex $queryButtons 0]
}
+# Procedure place-force {window parent}
+# window new top level widget
+# parent parent widget used as base
+# Sets geometry of $window relative to $parent window.
+proc place-force {window parent} {
+ set g [wm geometry $parent]
+
+ set p1 [string first + $g]
+ set p2 [string last + $g]
+
+ set x [expr 40+[string range $g [expr $p1 +1] [expr $p2 -1]]]
+ set y [expr 60+[string range $g [expr $p2 +1] end]]
+ wm geometry $window +${x}+${y}
+}
+
# Procedure destroyGW {w}
# w top level widget
# Saves geometry of widget w in windowGeometry array. This
toplevel $w
if {[info exists windowGeometry($w)]} {
set g $windowGeometry($w)
- if {$g != ""} {
+ if {[string length $g]} {
wm geometry $w $g
}
}
pack $w.bot -fill both
}
+# Init: The geometry information for the main window is set - either
+# to a default value or to the value in windowGeometry(.)
+if {[catch {set g $windowGeometry(.)}]} {
+ wm geometry . 420x340+20+20
+} else {
+ wm geometry . $g
+}
+
# Procedure top-down-ok-cancel {w ok-action g}
# w top level widget with $w.bot-frame
# ok-action ok script
label $w.top.a.logo -bitmap @${libdir}/bitmaps/book1
pack $w.top.a.irtcl $w.top.a.logo -side left -expand yes
- set i unknown
- catch {set i [z39 implementationName]}
- label $w.top.p.in -text "Implementation name: $i"
- catch {set i [z39 implementationId]}
- label $w.top.p.ii -text "Implementation id: $i"
- catch {set i [z39 implementationVersion]}
- label $w.top.p.iv -text "Implementation version: $i"
- set i $tk_version
- label $w.top.p.tk -text "Tk version: $i"
+ label $w.top.p.irtcl -text "IrTcl version: [lindex [ir-version] 0]"
+ label $w.top.p.yaz -text "Yaz version: [lindex [ir-version] 1]"
- pack $w.top.p.in $w.top.p.ii $w.top.p.iv $w.top.p.tk -side top -anchor nw
+ label $w.top.p.tk -text "Tk version: $tk_version"
+
+ pack $w.top.p.irtcl $w.top.p.yaz $w.top.p.tk -side top -anchor nw
about-origin-logo 1
bottom-buttons $w [list {Close} [list destroy $w] \
configure-disable-e .top.target.m 1
configure-disable-e .top.target.m 2
if {[tk4]} {
- .top.rset.m delete 2 last
+ .top.rset.m delete 1 last
} else {
.top.rset.m delete 1 last
}
global profile settingsChanged
set profile($target,timeLastInit) [clock seconds]
+ set profile($target,timeLastExplain) {}
set settingsChanged 1
show-message {}
# Procedure search-response
# This procedure handles search-responses. If the search is successful
-# this procedure will try to retrieve a total of 20 records from the target;
+# this procedure will try to retrieve a total of 50 records from the target;
# however not more than $presentChunk records at a time. This procedure
# affects the following globals:
# $setOffset current record position offset
set l [format "%-4d %7d" $setNo $setMax]
.top.rset.m add command -label $l \
-command [list recall-set $setNo]
- if {$setMax > 20} {
- set setMax 20
+ if {$setMax > 50} {
+ set setMax 50
}
set no [z39.$setNo numberOfRecordsReturned]
dputs "Returned $no records, setOffset $setOffset"
set dataBases {}
set settingsChanged 1
+ puts "protocol-setup-action"
set timedef $profile($target,timeDefine)
if {![string length $timedef]} {
set timedef [clock seconds]
destroy $w
}
-# Procedure place-force {window parent}
-# window new top level widget
-# parent parent widget used as base
-# Sets geometry of $window relative to $parent window.
-proc place-force {window parent} {
- set g [wm geometry $parent]
-
- set p1 [string first + $g]
- set p2 [string last + $g]
-
- set x [expr 40+[string range $g [expr $p1 +1] [expr $p2 -1]]]
- set y [expr 60+[string range $g [expr $p2 +1] end]]
- wm geometry $window +${x}+${y}
-}
-
# Procedure add-database-action {target w}
# target target to be defined
# w top level widget for the target definition
puts $f "set recordSyntax $recordSyntax"
puts $f "set elementSetNames $elementSetNames"
foreach n [array names windowGeometry] {
+ dputs "set [list windowGeometry($n)] "
+ dputs [list $windowGeometry($n)]
+
puts -nonewline $f "set [list windowGeometry($n)] "
puts $f [list $windowGeometry($n)]
}
}
# Procedure save-settings
-# This procedure saves the per-host related settings clientrc.tcl which
+# This procedure saves the per-host related settings irtdb.tcl which
# is normally kept in the directory /usr/local/lib/irtcl.
# All query types and target defintion profiles are saved.
proc save-settings {} {
global queryButtons
global queryInfo
- if {[file exists clientrc.tcl]} {
- set f [open "clientrc.tcl" w]
- } elseif {![file writable "${libdir}/clientrc.tcl"]} {
- set a [alert "Cannot open ${libdir}/clientrc.tcl for writing. Do you \
- wish to save clientrc.tcl in the current directory instead?"]
- if {! $a} {
- return
- }
- set f [open "clientrc.tcl" w]
+ if {[file writable "${libdir}/irtdb.tcl"]} {
+ set f [open "${libdir}/irtdb.tcl" w]
} else {
- set f [open "${libdir}/clientrc.tcl" w]
+ set f [open "irtdb.tcl" w]
}
puts $f "# Setup file"
{Host item} 1033
{Content type} 1034
{Anywhere} 1035
+ {Author-Title-Subject} 1036
}
set w .index-setup
global useTmpValue
$w.0 configure -background red
}
-# Init: The geometry information for the main window is set - either
-# to a default value or to the value in windowGeometry(.)
-if {[catch {set g $windowGeometry(.)}]} {
- wm geometry . 420x340
-} else {
- wm geometry . $g
-}
-
# Init: Presentation formats are read.
read-formats
.top.service.m add cascade -label Database -menu .top.service.m.dblist
.top.service.m add cascade -label Present -menu .top.service.m.present
irmenu .top.service.m.present
-.top.service.m.present add command -label {10 More} \
- -command [list present-more 10]
+.top.service.m.present add command -label {50 More} \
+ -command [list present-more 50]
.top.service.m.present add command -label All \
-command [list present-more {}]
.top.service.m add command -label Search -command {search-request 0}
irmenu .top.service.m.dblist
+# Init: Definition of Set menu.
menubutton .top.rset -text Set -menu .top.rset.m
irmenu .top.rset.m
.top.rset.m add command -label Load -command {load-set}
menubutton .top.help -text "Help" -menu .top.help.m
irmenu .top.help.m
-.top.help.m add command -label "Help on help" \
- -command {tkerror "Help on help not available. Sorry"}
.top.help.m add command -label "About" -command {about-origin}
# Init: Pack menu bar items.
-state disabled
button .mid.scan -text Scan \
-command scan-request -state disabled
-button .mid.present -text {Present} -command [list present-more 10] \
+button .mid.present -text {Present} -command [list present-more 50] \
-state disabled
button .mid.clear -text Clear -command index-clear
# Init: Determine if the IrTcl extension is already there. If
# not, then dynamically load the IrTcl extension.
-if {[catch {ir z39}]} {
+set logLevel all
+if {[catch {ir-version}]} {
set e [info sharedlibextension]
- puts -nonewline "Loading irtcl$e ..."
- load ${libdir}/irtcl$e irtcl
- ir z39
- puts "ok"
+ catch {load ${libdir}/irtcl$e irtcl}
+ if {[catch {ir-version}]} {
+ load irtcl$e irtcl
+ }
+}
+
+if $debugMode {
+ ir-log-init all {} irtcl.log
+} else {
+ ir-log-init none {} {}
}
+# Create Z Assocation
+ir z39
+
if {[file exists ${libdir}/explain.tcl]} {
source ${libdir}/explain.tcl
}
source ${libdir}/setup.tcl
}
-# Init: Uncomment this line if you wan't to enable logging.
-ir-log-init all
+after 10 activateMainWindow
-# Init: If hostid is a valid target, a new connection will be established
-# immediately.
-if {[string compare $hostid Default]} {
- catch {open-target $hostid $hostbase}
+proc activateMainWindow {} {
+ global hostid hostbase
+ if {[string compare $hostid Default]} {
+ catch {open-target $hostid $hostbase}
+ }
+ show-logo 1
}
-
-# Init: Enable the logo.
-show-logo 1
-
projects / ir-tcl-moved-to-github.git / blobdiff