Tcl Library Source Code

Artifact 1ae4c9ed74959e3a520ef41cf065741bcd0f0f69319b2ec35795ec6187745c05:

Attachment "PATCH-dns.txt" to ticket [948ad9edbf] added by sbron 2020-11-24 16:44:57. (unpublished)

---

Index: modules/dns/dns.tcl
==================================================================
--- modules/dns/dns.tcl
+++ modules/dns/dns.tcl
@@ -72,11 +72,12 @@
 
     variable types
     array set types { 
         A 1  NS 2  MD 3  MF 4  CNAME 5  SOA 6  MB 7  MG 8  MR 9 
         NULL 10  WKS 11  PTR 12  HINFO 13  MINFO 14  MX 15  TXT 16
-        SPF 16 AAAA 28 SRV 33 IXFR 251 AXFR 252  MAILB 253  MAILA 254
+        SPF 16 AAAA 28 SRV 33 NAPTR 35
+        IXFR 251 AXFR 252  MAILB 253  MAILA 254
         ANY 255 * 255
     } 
 
     variable classes
     array set classes { IN 1  CS 2  CH  3  HS 4  * 255}
@@ -828,11 +829,11 @@
 	set state(status) error
     }
     catch {close $state(sock)}
     catch {after cancel $state(after)}
     if {[info exists state(-command)] && $state(-command) != {}} {
-	if {[catch {eval $state(-command) {$token}} err]} {
+	if {[catch {uplevel #0 [linsert $state(-command) end $token]} err]} {
 	    if {[string length $errormsg] == 0} {
 		set state(error) [list $err $errorInfo $errorCode]
 		set state(status) error
 	    }
 	}
@@ -1191,14 +1192,32 @@
                     lappend rdata weight [ReadUShort data $x off]
                     incr x $off
                     lappend rdata port [ReadUShort data $x off]
                     incr x $off
                     lappend rdata target [ReadName data $x off]
-                    incr x $off
                 }
+		NAPTR {
+		    set x $index
+		    set rdata [list order [ReadUShort data $x off]]
+		    incr x $off
+		    lappend rdata preference [ReadUShort data $x off]
+		    incr x $off
+		    lappend rdata flags [ReadString data $x off]
+		    incr x $off
+		    lappend rdata service [ReadString data $x off]
+		    incr x $off
+		    lappend rdata regex [ReadString data $x off]
+		    incr x $off
+		    lappend rdata replacement [ReadString data $x off]
+		}
                 TXT {
-                    set rdata [ReadString data $index $rdlength]
+		    set x $index
+		    set rdata ""
+		    while {$x < $index + $rdlength} {
+			append rdata [ReadString data $x off]
+			incr x $off
+		    }
                 }
                 SOA {
                     set x $index
                     set rdata [list MNAME [ReadName data $x off]]
                     incr x $off 
@@ -1301,27 +1320,27 @@
     }
     set used [expr {$index - $startindex}]
     return [join $r .]
 }
 
-proc ::dns::ReadString {datavar index length} {
+proc ::dns::ReadString {datavar index usedvar} {
     upvar $datavar data
+    upvar $usedvar used
     set startindex $index
 
     set r {}
-    set max [expr {$index + $length}]
 
-    while {$index < $max} {
-        binary scan [string range $data $index end] c len
-        set len [expr {$len & 0xFF}]
-        incr index
+    if {[binary scan [string range $data $index end] c len] == 1} {
+	set len [expr {$len & 0xFF}]
+	incr index
 
-        if {$len != 0} {
-            append r [string range $data $index [expr {$index + $len - 1}]]
-            incr index $len
-        }
+	if {$len != 0} {
+	    set r [string range $data $index [expr {$index + $len - 1}]]
+	    incr index $len
+	}
     }
+    set used [expr {$index - $startindex}]
     return $r
 }
 
 # -------------------------------------------------------------------------
 
@@ -1485,11 +1504,11 @@
 
 # -------------------------------------------------------------------------
 
 catch {dns::configure -nameserver [lindex [dns::nameservers] 0]}
 
-package provide dns 1.4.1
+package provide dns 1.5.0
 
 # -------------------------------------------------------------------------
 # Local Variables:
 #   indent-tabs-mode: nil
 # End:

Index: modules/dns/pkgIndex.tcl
==================================================================
--- modules/dns/pkgIndex.tcl
+++ modules/dns/pkgIndex.tcl
@@ -1,7 +1,7 @@
 # pkgIndex.tcl -
 
 if {![package vsatisfies [package provide Tcl] 8.2]} {return}
-package ifneeded dns    1.4.1 [list source [file join $dir dns.tcl]]
+package ifneeded dns    1.5.0 [list source [file join $dir dns.tcl]]
 package ifneeded resolv 1.0.3 [list source [file join $dir resolv.tcl]]
 package ifneeded ip     1.4   [list source [file join $dir ip.tcl]]
 package ifneeded spf    1.1.1 [list source [file join $dir spf.tcl]]