X-Git-Url: http://git.indexdata.com/?a=blobdiff_plain;f=client.tcl;h=e0a2d1d10d06f8c7a5cd3966440dcbff62dc2aa5;hb=a710ad4e294c229cd66ee162c4ee972a2240aecd;hp=6473a39e4d61c92763e0f784ddd13fd54a87e409;hpb=477f6feccaf785916170e8f1f94873e798eb77ed;p=ir-tcl-moved-to-github.git

diff --git a/client.tcl b/client.tcl
index 6473a39..e0a2d1d 100644
--- a/client.tcl
+++ b/client.tcl
@@ -1,10 +1,28 @@
 # IR toolkit for tcl/tk
-# (c) Index Data 1995-1997
+# (c) Index Data 1995-1998
 # 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.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
@@ -347,6 +365,7 @@
 #
 #
 
+
 # Procedure tk4 is defined - returns 0 if tk 3.6 - returns 1 otherwise
 if {$tk_version == "3.6"} {
     proc tk4 {} {
@@ -494,7 +513,7 @@ 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-*
@@ -544,11 +563,13 @@ if {[file readable "${libdir}/tagsets.tcl"]} {
     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.
@@ -575,13 +596,20 @@ foreach target [array names profile] {
 	    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]
@@ -725,6 +753,21 @@ proc post-menu {wbutton wmenu} {
 
 }
 
+# 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
@@ -765,6 +808,25 @@ proc top-down-window {w} {
     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
+}
+
+# Init: The geometry information for the main window is set - either
+# to a default value or to the value in windowGeometry(.)
+toplevelG .init
+place-force .init .
+message .init.top -aspect 500 -text "IrTcl" -relief raised -border 1 -font $font(bb,normal)
+text .init.msg -width 40 -height 4
+pack .init.top -side top -fill x -expand yes
+pack .init.msg -side bottom -fill both -expand yes
+wm iconify .
+update
+
 # Procedure top-down-ok-cancel {w ok-action g}
 #  w          top level widget with $w.bot-frame
 #  ok-action  ok script
@@ -1069,17 +1131,12 @@ proc about-origin {} {
     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]"
+
+    label $w.top.p.tk -text "Tk version: $tk_version"
 
-    pack $w.top.p.in $w.top.p.ii $w.top.p.iv $w.top.p.tk -side top -anchor nw
+    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] \
@@ -1410,7 +1467,7 @@ proc close-target {} {
     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
     }
@@ -2323,21 +2380,6 @@ proc protocol-setup-action {target w} {
     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
@@ -2898,7 +2940,7 @@ proc save-geometry {} {
 }
 
 # 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 {} {
@@ -2909,17 +2951,10 @@ 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"
 
@@ -3897,14 +3932,6 @@ proc search-fields {w buttondefs} {
     $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
 
@@ -3962,6 +3989,7 @@ irmenu .top.service.m.present
 
 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}
@@ -4131,14 +4159,23 @@ pack .bot.a.status .bot.a.set .bot.a.message \
 
 # 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"
+    .init.msg insert end "Loading irtcl$e.\n"
+    catch {load ${libdir}/irtcl$e irtcl}
+    if {[catch {ir-version}]} {
+	catch {load irtcl$e irtcl}
+    }
 }
 
+.init.msg insert end "IrTcl version [lindex [ir-version] 0]\n"
+.init.msg insert end "YAZ version [lindex [ir-version] 1]\n"
+ir-log-init all irtcl.log
+
+# Create Z Assocation
+ir z39
+
 if {[file exists ${libdir}/explain.tcl]} {
     source ${libdir}/explain.tcl
 }
@@ -4147,15 +4184,14 @@ if {[file exists ${libdir}/setup.tcl]} {
     source ${libdir}/setup.tcl
 }
 
-# Init: Uncomment this line if you wan't to enable logging.
-ir-log-init all
+after 900 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
+    destroy .init
+    wm deiconify .
+    if {[string compare $hostid Default]} {
+	catch {open-target $hostid $hostbase}
+    }
+    show-logo 1
 }
-
-# Init: Enable the logo.
-show-logo 1
-