Tk Library Source Code

Artifact 038d54a651c4cf9182da169e5fcdd88bbf68c60b:

Attachment "tarchan.patch" to ticket [3162548fff] added by ferrieux 2011-01-20 18:04:07.

---

--- tar.tcl	2011-01-20 11:52:25.379585352 +0100
+++ tarchan/tar.tcl	2011-01-20 11:52:02.698778019 +0100
@@ -41,6 +41,29 @@ proc ::tar::pad {size} {
     return $pad
 }
 
+proc ::tar::seekorskip {ch off wh} {
+	if {![catch {seek $ch $off $wh} res]} {
+		return
+	}
+	if {![regexp {invalid.argument$} $res]} {
+		error $res
+	}
+	if {$wh!="current"} {
+		error "WHENCE=$wh not supported on non-seekable channel $ch"
+	}
+	skip $ch $off
+}
+
+proc ::tar::skip {ch len} {
+	while {$len>0} {
+		set buf $len
+		if {$buf>65536} {set buf 65536}
+		set n [read $ch $buf]
+		if {$n<$buf} break
+		incr len -$buf
+	}
+}
+
 proc ::tar::readHeader {data} {
     binary scan $data a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155 \
                       name mode uid gid size mtime cksum type \
@@ -89,26 +112,42 @@ proc ::tar::readHeader {data} {
                  devminor $devminor prefix $prefix]
 }
 
-proc ::tar::contents {file} {
-    set fh [::open $file]
+proc ::tar::contents {file args} {
+	set chan 0
+	parseOpts {chan 0} $args
+	if {$chan} {
+		set fh $file
+	} else {
+		set fh [::open $file]
+		fconfigure $fh -encoding binary -translation lf -eofchar {}
+	}
     set ret {}
     while {![eof $fh]} {
         array set header [readHeader [read $fh 512]]
         if {$header(name) == ""} break
         lappend ret $header(prefix)$header(name)
-        seek $fh [expr {$header(size) + [pad $header(size)]}] current
+        seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current
     }
-    close $fh
+	if {!$chan} {
+		close $fh
+	}
     return $ret
 }
 
-proc ::tar::stat {tar {file {}}} {
-    set fh [::open $tar]
+proc ::tar::stat {tar {file {}} args} {
+	set chan 0
+	parseOpts {chan 0} $args
+	if {$chan} {
+		set fh $tar
+	} else {
+		set fh [::open $tar]
+		fconfigure $fh -encoding binary -translation lf -eofchar {}
+	}
     set ret {}
     while {![eof $fh]} {
         array set header [readHeader [read $fh 512]]
         if {$header(name) == ""} break
-        seek $fh [expr {$header(size) + [pad $header(size)]}] current
+        seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current
         if {$file != "" && "$header(prefix)$header(name)" != $file} {continue}
         set header(type) [string map {0 file 5 directory 3 characterSpecial 4 blockSpecial 6 fifo 2 link} $header(type)]
         set header(mode) [string range $header(mode) 2 end]
@@ -116,25 +155,37 @@ proc ::tar::stat {tar {file {}}} {
                     size $header(size) mtime $header(mtime) type $header(type) linkname $header(linkname) \
                     uname $header(uname) gname $header(gname) devmajor $header(devmajor) devminor $header(devminor)]
     }
-    close $fh
+	if {!$chan} {
+		close $fh
+	}
     return $ret
 }
 
-proc ::tar::get {tar file} {
-    set fh [::open $tar]
-    fconfigure $fh -encoding binary -translation lf -eofchar {}
+proc ::tar::get {tar file args} {
+	set chan 0
+	parseOpts {chan 0} $args
+	if {$chan} {
+		set fh $tar
+	} else {
+		set fh [::open $tar]
+		fconfigure $fh -encoding binary -translation lf -eofchar {}
+	}
     while {![eof $fh]} {
         array set header [readHeader [read $fh 512]]
         if {$header(name) == ""} break
         set name [string trimleft $header(prefix)$header(name) /]
         if {$name == $file} {
             set file [read $fh $header(size)]
-            close $fh
+            if {!$chan} {
+				close $fh
+			}
             return $file
         }
-        seek $fh [expr {$header(size) + [pad $header(size)]}] current
+        seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current
     }
-    close $fh
+	if {!$chan} {
+		close $fh
+	}
     return {}
 }
 
@@ -143,7 +194,8 @@ proc ::tar::untar {tar args} {
     set data 0
     set nomtime 0
     set noperms 0
-    parseOpts {dir 1 file 1 glob 1 nooverwrite 0 nomtime 0 noperms 0} $args
+	set chan 0
+    parseOpts {dir 1 file 1 glob 1 nooverwrite 0 nomtime 0 noperms 0 chan 0} $args
     if {![info exists dir]} {set dir [pwd]}
     set pattern *
     if {[info exists file]} {
@@ -153,14 +205,18 @@ proc ::tar::untar {tar args} {
     }
 
     set ret {}
-    set fh [::open $tar]
-    fconfigure $fh -encoding binary -translation lf -eofchar {}
+	if {$chan} {
+		set fh $tar
+	} else {
+		set fh [::open $tar]
+		fconfigure $fh -encoding binary -translation lf -eofchar {}
+	}
     while {![eof $fh]} {
         array set header [readHeader [read $fh 512]]
         if {$header(name) == ""} break
         set name [string trimleft $header(prefix)$header(name) /]
         if {![string match $pattern $name] || ($nooverwrite && [file exists $name])} {
-            seek $fh [expr {$header(size) + [pad $header(size)]}] current
+            seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current
             continue
         }
 
@@ -188,7 +244,7 @@ proc ::tar::untar {tar args} {
                 lappend ret $name {}
             }
         }
-        seek $fh [pad $header(size)] current
+        seekorskip $fh [pad $header(size)] current
         if {![file exists $name]} continue
 
         if {$::tcl_platform(platform) == "unix"} {
@@ -202,7 +258,9 @@ proc ::tar::untar {tar args} {
             file mtime $name $header(mtime)
         }
     }
-    close $fh
+	if {!$chan} {
+		close $fh
+	}
     return $ret
 }
 
@@ -342,16 +400,23 @@ proc ::tar::writefile {in out followlink
 
 proc ::tar::create {tar files args} {
     set dereference 0
-    parseOpts {dereference 0} $args
-    
-    set fh [::open $tar w+]
-    fconfigure $fh -encoding binary -translation lf -eofchar {}
+	set chan 0
+    parseOpts {dereference 0 chan 0} $args
+
+	if {$chan} {
+		set fh $tar
+	} else {
+		set fh [::open $tar w+]
+		fconfigure $fh -encoding binary -translation lf -eofchar {}
+	}
     foreach x [recurseDirs $files $dereference] {
         writefile $x $fh $dereference $x
     }
     puts -nonewline $fh [string repeat \x00 1024]
 
-    close $fh
+	if {!$chan} {
+		close $fh
+	}
     return $tar
 }