Tk Library Source Code

Artifact 442ef871c3f79cd402915390d89af3f5dc2f725e:

Attachment "comm.diff" to ticket [1006282fff] added by cleverly 2004-08-10 06:26:38.

---

--- /usr/local/lib/tcllib1.6/comm/comm.tcl	2004-02-15 16:15:51.000000000 -0700
+++ my-comm.tcl	2004-08-09 17:00:35.000000000 -0600
@@ -46,6 +46,7 @@
 	    acceptVers		{3 2}
 	    defVers		2
 	    defaultEncoding	"utf-8"
+	    defaultSilent   0
 	}
 	set comm(lastport) [expr {[pid] % 32768 + 9999}]
 	# fast check for acceptable versions
@@ -64,6 +65,8 @@
     # comm()
     #	$ch,port		listening port (our id)
     #	$ch,socket		listening socket
+    #   $ch,silent      boolean to indicate whether to throw error on
+    #                   protocol negotiation failure
     #	$ch,local		boolean to indicate if port is local
     #	$ch,serial		next serial number for commands
     #
@@ -247,6 +250,7 @@
     comm_cmd_abort $chan
     catch {unset comm($chan,port)}
     catch {unset comm($chan,local)}
+    catch {unset comm($chan,silent)}
     catch {unset comm($chan,socket)}
     unset comm($chan,serial)
     set pos [lsearch -exact $comm(chans) $chan]
@@ -331,6 +335,7 @@
     set comm($chan,listen) 0
     set comm($chan,socket) ""
     set comm($chan,local)  1
+    set comm($chan,silent) $comm(defaultSilent)
     set comm($chan,encoding) $comm(defaultEncoding)
 
     if {[llength $args] > 0} {
@@ -488,6 +493,7 @@
 ::comm::commConfVars chan ro
 ::comm::commConfVars serial ro
 ::comm::commConfVars encoding enc
+::comm::commConfVars silent b
 
 # ::comm::commConfigure --
 #
@@ -585,6 +591,14 @@
 	}
     }
 
+    foreach var {silent} {
+	# FRINK: nocheck
+	if {[info exists $var] && [set $var] != $comm($chan,$var)} {
+	    # FRINK: nocheck
+	    set comm($chan,$var) [set $var]
+	}
+    }
+
     if {[info exists encoding] &&
 	![string equal $encoding $comm($chan,encoding)]} {
 	# This should not be entered yet
@@ -746,6 +760,8 @@
     }
     if {![info exists vers]} {
 	close $fid
+	if {[info exists comm($chan,silent)] && 
+	    [string is true -strict $comm($chan,silent)]} then return
 	error "Unknown offered protocols \"$protoline\" from $addr/$remport"
     }