Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'

7 files changed, 1226 insertions, 0 deletions

diff --git a/tcllib/modules/tar/ChangeLog b/tcllib/modules/tar/ChangeLog
new file mode 100644
index 0000000..89a34bb
--- /dev/null
+++ b/tcllib/modules/tar/ChangeLog
@@ -0,0 +1,186 @@
+2013-11-22  Andreas Kupries <andreask@activestate.com>
+
+	* tar.man: Reviewed the work on the pyk-tar branch. Brought
+	* tar.tcl: new testsuite up to spec. Reviewed the skip fix,
+	* tar.test: modified it to reinstate the skip limit per round
+	* test-support.tcl: without getting the bug back. Bumped version
+	  to 0.9. Thanks to PoorYorick for the initial work on the bug,
+	  fix, and testsuite. This also fixes ticket [6b7aa0aecc].
+
+2013-08-12  Andreas Kupries  <andreask@activestate.com>
+
+	* tar.man (tar::untar, contents, stat, get): Extended the
+	* tar.tcl: procedures to detect and properly handle @LongName
+	* pkgIndex.tcl: header entries as generated by GNU tar. These
+	  entries contain the file name for the next header entry as file
+	  data, for files whose name is longer than the 100-char field of
+	  the regular header. Version bumped to 0.8. This is a new
+	  feature.
+
+2013-02-01  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.15 ========================
+	* 
+
+2012-09-11  Andreas Kupries  <andreask@activestate.com>
+
+	* tar.tcl (seekorskip): Fixed seekorskip which prevented its use
+	* pkgIndex.tcl: from a non-seekable channel, like stdin. The issue
+	  was that the original attempt to seek before skipping not just
+	  failed, but apparently still moved the read pointer in some way
+	  which skipped over irreplacable input, breaking the next call of
+	  readHeader. Using [tell] to check seekability does not break in
+	  this manner. Bumped version to 0.7.1.
+
+2011-12-13  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.14 ========================
+	* 
+
+2011-01-24  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.13 ========================
+	* 
+
+2011-01-20  Andreas Kupries  <andreask@activestate.com>
+
+	* tar.tcl: [Bug 3162548]: Applied patch by Alexandre Ferrieux,
+	* tar.man: extending various tar commands to be able to use
+	* pkgIndex.tcl: the -chan option, and channels instead of files.
+	  Version bumped to 0.7
+
+2009-12-07  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.12 ========================
+	* 
+
+2009-12-03  Andreas Kupries  <andreask@activestate.com>
+
+	* tar.man: [Patch 2840147]. Applied. New options -prefix and
+	* tar.tcl: -quick for tar::add. -prefix allows specifying a
+	* tar.pcx: prefix for filenames in the archive, and -quick 1
+	* pkgIndex.tcl: changes back to the seek-from-end algorithm for
+	  finding the place where to add the new files. The new default
+	  scans from start (robust). Bumped version to 0.6.
+
+2009-05-12  Aaron Faupell  <afaupell@users.sourceforge.net>
+
+	* tar.tcl: add support for reading pre-posix archives.
+	  if a file isnt writable when extracting, try deleting
+	  before giving up.
+
+2008-12-12  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.11.1 ========================
+	* 
+
+2008-11-26  Aaron Faupell  <afaupell@users.sourceforge.net>
+
+	* tar.man: add and clarify documentation
+
+2008-10-16  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.11 ========================
+	* 
+
+2008-06-14  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	* tar.pcx: New file. Syntax definitions for the public commands of
+	  the tar package.
+
+2007-09-12  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.10 ========================
+	* 
+
+2007-03-21  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	* tar.man: Fixed all warnings due to use of now deprecated
+	  commands. Added a section about how to give feedback.
+
+2007-02-08  Aaron Faupell  <afaupell@users.sourceforge.net>
+
+	* tar.tcl: bug fix in recursion algorithm that missed
+	some files in deep subdirs. incremented version
+
+2007-01-08  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	* tar.tcl: Bumped version to 0.3, for the bugfix described
+	* tar.man: by the last entry.
+	* pkgIndex.tcl:
+
+2006-12-20  Aaron Faupell  <afaupell@users.sourceforge.net>
+
+	* tar.tcl: fix in parseOpts which affected -file and -glob
+	  arguments to tar::untar
+	* tar.man: clarifications to add, create, and untar
+
+2006-10-03  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.9 ========================
+	* 
+
+2006-29-06  Aaron Faupell  <afaupell@users.sourceforge.net>
+
+	* tar.tcl: fixed bug in parseOpts
+
+2005-11-08  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	* pkgIndex.tcl: Corrected buggy commit, synchronized version
+	* tar.man:      numbers across all relevant files.
+
+2005-11-08  Aaron Faupell  <afaupell@users.sourceforge.net>
+
+	* tar.tcl: bumped version to 0.2 because of new feature
+	* tar.man: tar::remove
+
+2005-11-07  Andreas Kupries <andreask@activestate.com>
+
+	* tar.man: Fixed error, incorrect placement of [call] markup
+	  outside of list.
+
+2005-11-04  Aaron Faupell  <afaupell@users.sourceforge.net>
+
+	* tar.man: added tar::remove command and documentation for it
+	* tar.tcl:
+
+2005-10-06  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.8 ========================
+	* 
+
+2005-09-30  Andreas Kupries <andreask@activestate.com>
+
+	* tar.tcl: qualified all [open] calls with :: to ensure usag of
+	  the builtin. Apparently mitigates conflict between this package
+	  and the vfs::tar module.
+
+2004-10-05  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	*
+	* Released and tagged Tcllib 1.7 ========================
+	* 
+
+2004-10-02  Andreas Kupries  <andreas_kupries@users.sourceforge.net>
+
+	* tar.man: Added keywords and title/module description to the
+	  documentation.
+
+2004-09-10  Aaron Faupell  <afaupell@users.sourceforge.net>
+
+	* tar.tcl: Fixed typo bug in ::tar::add
+	* tar.man: Added info for ::tar::stat
+
+2004-08-23  Andreas Kupries  <andreask@activestate.com>
+
+	* tar.man: Fixed problems in the documentation.
+
diff --git a/tcllib/modules/tar/pkgIndex.tcl b/tcllib/modules/tar/pkgIndex.tcl
new file mode 100644
index 0000000..c2a8d70
--- /dev/null
+++ b/tcllib/modules/tar/pkgIndex.tcl
@@ -0,0 +1,5 @@
+if {![package vsatisfies [package provide Tcl] 8.4]} {
+    # PRAGMA: returnok
+    return
+}
+package ifneeded tar 0.10 [list source [file join $dir tar.tcl]]
diff --git a/tcllib/modules/tar/tar.man b/tcllib/modules/tar/tar.man
new file mode 100644
index 0000000..c55159f
--- /dev/null
+++ b/tcllib/modules/tar/tar.man
@@ -0,0 +1,167 @@
+[vset PACKAGE_VERSION 0.10]
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin tar n [vset PACKAGE_VERSION]]
+[keywords archive]
+[keywords {tape archive}]
+[keywords tar]
+[moddesc   {Tar file handling}]
+[titledesc {Tar file creation, extraction & manipulation}]
+[category  {File formats}]
+[require Tcl 8.4]
+[require tar [opt [vset PACKAGE_VERSION]]]
+[description]
+
+[para] Note: Starting with version 0.8 the tar reader commands
+(contents, stats, get, untar) support the GNU LongName extension
+(header type 'L') for large paths.
+
+[para]
+
+[list_begin definitions]
+
+[call [cmd ::tar::contents] [arg tarball] [opt [option -chan]]]
+
+Returns a list of the files contained in [arg tarball]. The order is not sorted and depends on the order
+files were stored in the archive.
+[para]
+
+If the option [option -chan] is present [arg tarball] is interpreted as an open channel.
+It is assumed that the channel was opened for reading, and configured for binary input.
+The command will [emph not] close the channel.
+
+[call [cmd ::tar::stat] [arg tarball] [opt file] [opt [option -chan]]]
+
+Returns a nested dict containing information on the named [opt file] in [arg tarball],
+or all files if none is specified. The top level are pairs of filename and info. The info is a dict with the keys
+"[const mode] [const uid] [const gid] [const size] [const mtime] [const type] [const linkname] [const uname] [const gname]
+ [const devmajor] [const devminor]"
+
+[example {
+% ::tar::stat tarball.tar
+foo.jpg {mode 0644 uid 1000 gid 0 size 7580 mtime 811903867 type file linkname {} uname user gname wheel devmajor 0 devminor 0}
+}]
+
+[para]
+If the option [option -chan] is present [arg tarball] is interpreted as an open channel.
+It is assumed that the channel was opened for reading, and configured for binary input.
+The command will [emph not] close the channel.
+
+[call [cmd ::tar::untar] [arg tarball] [arg args]]
+
+Extracts [arg tarball]. [arg -file] and [arg -glob] limit the extraction
+to files which exactly match or pattern match the given argument. No error is
+thrown if no files match. Returns a list of filenames extracted and the file
+size. The size will be null for non regular files. Leading path seperators are
+stripped so paths will always be relative.
+
+[list_begin options]
+[opt_def -dir dirName]
+Directory to extract to. Uses [cmd pwd] if none is specified
+[opt_def -file fileName]
+Only extract the file with this name. The name is matched against the complete path
+stored in the archive including directories.
+[opt_def -glob pattern]
+Only extract files patching this glob style pattern. The pattern is matched against the complete path
+stored in the archive.
+[opt_def -nooverwrite]
+Dont overwrite files that already exist
+[opt_def -nomtime]
+Leave the file modification time as the current time instead of setting it to the value in the archive.
+[opt_def -noperms]
+In Unix, leave the file permissions as the current umask instead of setting them to the values in the archive.
+
+[opt_def -chan]
+If this option is present [arg tarball] is interpreted as an open channel.
+It is assumed that the channel was opened for reading, and configured for binary input.
+The command will [emph not] close the channel.
+
+[list_end]
+[para]
+
+[example {
+% foreach {file size} [::tar::untar tarball.tar -glob *.jpg] {
+puts "Extracted $file ($size bytes)"
+}
+}]
+
+[call [cmd ::tar::get] [arg tarball] [arg fileName] [opt [option -chan]]]
+
+Returns the contents of [arg fileName] from the [arg tarball]
+[para]
+
+[example {
+% set readme [::tar::get tarball.tar doc/README] {
+% puts $readme
+}
+}]
+
+[para]
+If the option [option -chan] is present [arg tarball] is interpreted as an open channel.
+It is assumed that the channel was opened for reading, and configured for binary input.
+The command will [emph not] close the channel.
+
+[call [cmd ::tar::create] [arg tarball] [arg files] [arg args]]
+
+Creates a new tar file containing the [arg files]. [arg files] must be specified
+as a single argument which is a proper list of filenames.
+
+[list_begin options]
+[opt_def -dereference]
+Normally [cmd create] will store links as an actual link pointing at a file that may
+or may not exist in the archive. Specifying this option will cause the actual file point to
+ by the link to be stored instead.
+
+[opt_def -chan]
+If this option is present [arg tarball] is interpreted as an open channel.
+It is assumed that the channel was opened for writing, and configured for binary output.
+The command will [emph not] close the channel.
+
+[list_end]
+[para]
+
+[example {
+% ::tar::create new.tar [glob -nocomplain file*]
+% ::tar::contents new.tar
+file1 file2 file3
+}]
+
+[call [cmd ::tar::add] [arg tarball] [arg files] [arg args]]
+
+Appends [arg files] to the end of the existing [arg tarball]. [arg files] must be specified
+as a single argument which is a proper list of filenames.
+
+[list_begin options]
+[opt_def -dereference]
+Normally [cmd add] will store links as an actual link pointing at a file that may
+or may not exist in the archive. Specifying this option will cause the actual file point to
+ by the link to be stored instead.
+[opt_def -prefix string]
+Normally [cmd add] will store files under exactly the name specified as
+argument. Specifying a [opt -prefix] causes the [arg string] to be
+prepended to every name.
+[opt_def -quick]
+The only sure way to find the position in the [arg tarball] where new
+files can be added is to read it from start, but if [arg tarball] was
+written with a "blocksize" of 1 (as this package does) then one can
+alternatively find this position by seeking from the end. The
+[opt -quick] option tells [cmd add] to do the latter.
+[list_end]
+[para]
+
+[call [cmd ::tar::remove] [arg tarball] [arg files]]
+
+Removes [arg files] from the [arg tarball]. No error will result if the file does not exist in the
+tarball. Directory write permission and free disk space equivalent to at least the size of the tarball
+will be needed.
+
+[example {
+% ::tar::remove new.tar {file2 file3}
+% ::tar::contents new.tar
+file3
+}]
+
+[list_end]
+
+[vset CATEGORY tar]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/tar/tar.pcx b/tcllib/modules/tar/tar.pcx
new file mode 100644
index 0000000..59e008a
--- /dev/null
+++ b/tcllib/modules/tar/tar.pcx
@@ -0,0 +1,83 @@
+# -*- tcl -*- tar.pcx
+# Syntax of the commands provided by package tar.
+#
+# For use by TclDevKit's static syntax checker (v4.1+).
+# See http://www.activestate.com/solutions/tcl/
+# See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api
+# for the specification of the format of the code in this file.
+#
+
+package require pcx
+pcx::register tar
+pcx::tcldep   0.4 needs tcl 8.2
+pcx::tcldep   0.5 needs tcl 8.2
+pcx::tcldep   0.6 needs tcl 8.2
+
+namespace eval ::tar {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 0.4 std ::tar::add \
+    {checkSimpleArgs 2 -1 {
+	checkFileName
+	{checkListValues 1 -1 checkFileName}
+	{checkSwitches 1 {
+	    {-dereference checkBoolean}
+	} {}}
+    }}
+pcx::check 0.6 std ::tar::add \
+    {checkSimpleArgs 2 -1 {
+	checkFileName
+	{checkListValues 1 -1 checkFileName}
+	{checkSwitches 1 {
+	    {-dereference checkBoolean}
+	    {-quick checkBoolean}
+	    {-prefix checkWord}
+	} {}}
+    }}
+pcx::check 0.4 std ::tar::contents \
+    {checkSimpleArgs 1 1 {
+	checkFileName
+    }}
+pcx::check 0.4 std ::tar::create \
+    {checkSimpleArgs 2 -1 {
+	checkFileName
+	{checkListValues 1 -1 checkFileName}
+	{checkSwitches 1 {
+	    {-chan        checkChannelID}
+	    {-dereference checkBoolean}
+	} {}}
+    }}
+pcx::check 0.4 std ::tar::get \
+    {checkSimpleArgs 2 2 {
+	checkFileName
+	checkFileName
+    }}
+pcx::check 0.4 std ::tar::remove \
+    {checkSimpleArgs 2 2 {
+	checkFileName
+	{checkListValues 1 -1 checkFileName}
+    }}
+pcx::check 0.4 std ::tar::stat \
+    {checkSimpleArgs 1 2 {
+	checkFileName
+	checkFileName
+    }}
+pcx::check 0.4 std ::tar::untar \
+    {checkSimpleArgs 1 -1 {
+	checkFileName
+	{checkSwitches 1 {
+	    {-chan        checkChannelID}
+	    {-dir         checkFileName}
+	    {-file        checkFileName}
+	    {-glob        checkPattern}
+	    {-nomtime     checkBoolean}
+	    {-nooverwrite checkBoolean}
+	    {-noperms     checkBoolean}
+	} {}}
+    }}
+
+# Initialization via pcx::init.
+# Use a ::tar::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/tar/tar.tcl b/tcllib/modules/tar/tar.tcl
new file mode 100644
index 0000000..2892896
--- /dev/null
+++ b/tcllib/modules/tar/tar.tcl
@@ -0,0 +1,540 @@
+# tar.tcl --
+#
+#       Creating, extracting, and listing posix tar archives
+#
+# Copyright (c) 2004    Aaron Faupell <afaupell@users.sourceforge.net>
+# Copyright (c) 2013    Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#                       (GNU tar @LongLink support).
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# 
+# RCS: @(#) $Id: tar.tcl,v 1.17 2012/09/11 17:22:24 andreas_kupries Exp $
+
+package require Tcl 8.4
+package provide tar 0.10
+
+namespace eval ::tar {}
+
+proc ::tar::parseOpts {acc opts} {
+    array set flags $acc
+    foreach {x y} $acc {upvar $x $x}
+    
+    set len [llength $opts]
+    set i 0
+    while {$i < $len} {
+        set name [string trimleft [lindex $opts $i] -]
+        if {![info exists flags($name)]} {return -code error "unknown option \"$name\""}
+        if {$flags($name) == 1} {
+            set $name [lindex $opts [expr {$i + 1}]]
+            incr i $flags($name)
+        } elseif {$flags($name) > 1} {
+            set $name [lrange $opts [expr {$i + 1}] [expr {$i + $flags($name)}]]
+            incr i $flags($name)
+        } else {
+            set $name 1
+        }
+        incr i
+    }
+}
+
+proc ::tar::pad {size} {
+    set pad [expr {512 - ($size % 512)}]
+    if {$pad == 512} {return 0}
+    return $pad
+}
+
+proc ::tar::seekorskip {ch off wh} {
+    if {[tell $ch] < 0} {
+	if {$wh!="current"} {
+	    error "WHENCE=$wh not supported on non-seekable channel $ch"
+	}
+	skip $ch $off
+	return
+    }
+    seek $ch $off $wh
+    return
+}
+
+proc ::tar::skip {ch skipover} {
+    while {$skipover > 0} {
+	set requested $skipover
+
+	# Limit individual skips to 64K, as a compromise between speed
+	# of skipping (Number of read requests), and memory usage
+	# (Note how skipped block is read into memory!). While the
+	# read data is immediately discarded it still generates memory
+	# allocation traffic, gets copied, etc. Trying to skip the
+	# block in one go without the limit may cause us to run out of
+	# (virtual) memory, or just induce swapping, for nothing.
+
+	if {$requested > 65536} {
+	    set requested 65536
+	}
+
+	set skipped [string length [read $ch $requested]]
+
+	# Stop in short read into the end of the file.
+	if {!$skipped && [eof $ch]} break
+
+	# Keep track of how much is (not) skipped yet.
+	incr skipover -$skipped
+    }
+    return
+}
+
+proc ::tar::readHeader {data} {
+    binary scan $data a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155 \
+                      name mode uid gid size mtime cksum type \
+                      linkname magic version uname gname devmajor devminor prefix
+
+    foreach x {name type linkname} {
+        set $x [string trim [set $x] "\x00"]
+    }
+    foreach x {uid gid size mtime cksum} {
+        set $x [format %d 0[string trim [set $x] " \x00"]]
+    }
+    set mode [string trim $mode " \x00"]
+
+    if {$magic == "ustar "} {
+        # gnu tar
+        # not fully supported
+        foreach x {uname gname prefix} {
+            set $x [string trim [set $x] "\x00"]
+        }
+        foreach x {devmajor devminor} {
+            set $x [format %d 0[string trim [set $x] " \x00"]]
+        }
+    } elseif {$magic == "ustar\x00"} {
+        # posix tar
+        foreach x {uname gname prefix} {
+            set $x [string trim [set $x] "\x00"]
+        }
+        foreach x {devmajor devminor} {
+            set $x [format %d 0[string trim [set $x] " \x00"]]
+        }
+    } else {
+        # old style tar
+        foreach x {uname gname devmajor devminor prefix} { set $x {} }
+        if {$type == ""} {
+            if {[string match */ $name]} {
+                set type 5
+            } else {
+                set type 0
+            }
+        }
+    }
+
+    return [list name $name mode $mode uid $uid gid $gid size $size mtime $mtime \
+                 cksum $cksum type $type linkname $linkname magic $magic \
+                 version $version uname $uname gname $gname devmajor $devmajor \
+                 devminor $devminor prefix $prefix]
+}
+
+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]]
+	HandleLongLink $fh header
+        if {$header(name) == ""} break
+	if {$header(prefix) != ""} {append header(prefix) /}
+        lappend ret $header(prefix)$header(name)
+        seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current
+    }
+    if {!$chan} {
+	close $fh
+    }
+    return $ret
+}
+
+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]]
+	HandleLongLink $fh header
+        if {$header(name) == ""} break
+	if {$header(prefix) != ""} {append header(prefix) /}
+        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]
+        lappend ret $header(prefix)$header(name) [list mode $header(mode) uid $header(uid) gid $header(gid) \
+                    size $header(size) mtime $header(mtime) type $header(type) linkname $header(linkname) \
+                    uname $header(uname) gname $header(gname) devmajor $header(devmajor) devminor $header(devminor)]
+    }
+    if {!$chan} {
+	close $fh
+    }
+    return $ret
+}
+
+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]} {
+	set data [read $fh 512]
+        array set header [readHeader $data]
+	HandleLongLink $fh header
+        if {$header(name) == ""} break
+	if {$header(prefix) != ""} {append header(prefix) /}
+        set name [string trimleft $header(prefix)$header(name) /]
+        if {$name == $file} {
+            set file [read $fh $header(size)]
+            if {!$chan} {
+		close $fh
+	    }
+            return $file
+        }
+        seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current
+    }
+    if {!$chan} {
+	close $fh
+    }
+    return {}
+}
+
+proc ::tar::untar {tar args} {
+    set nooverwrite 0
+    set data 0
+    set nomtime 0
+    set noperms 0
+    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]} {
+        set pattern [string map {* \\* ? \\? \\ \\\\ \[ \\\[ \] \\\]} $file]
+    } elseif {[info exists glob]} {
+        set pattern $glob
+    }
+
+    set ret {}
+    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]]
+	HandleLongLink $fh header
+        if {$header(name) == ""} break
+	if {$header(prefix) != ""} {append header(prefix) /}
+        set name [string trimleft $header(prefix)$header(name) /]
+        if {![string match $pattern $name] || ($nooverwrite && [file exists $name])} {
+            seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current
+            continue
+        }
+
+        set name [file join $dir $name]
+        if {![file isdirectory [file dirname $name]]} {
+            file mkdir [file dirname $name]
+            lappend ret [file dirname $name] {}
+        }
+        if {[string match {[0346]} $header(type)]} {
+            if {[catch {::open $name w+} new]} {
+                # sometimes if we dont have write permission we can still delete
+                catch {file delete -force $name}
+                set new [::open $name w+]
+            }
+            fconfigure $new -encoding binary -translation lf -eofchar {}
+            fcopy $fh $new -size $header(size)
+            close $new
+            lappend ret $name $header(size)
+        } elseif {$header(type) == 5} {
+            file mkdir $name
+            lappend ret $name {}
+        } elseif {[string match {[12]} $header(type)] && $::tcl_platform(platform) == "unix"} {
+            catch {file delete $name}
+            if {![catch {file link [string map {1 -hard 2 -symbolic} $header(type)] $name $header(linkname)}]} {
+                lappend ret $name {}
+            }
+        }
+        seekorskip $fh [pad $header(size)] current
+        if {![file exists $name]} continue
+
+        if {$::tcl_platform(platform) == "unix"} {
+            if {!$noperms} {
+                catch {file attributes $name -permissions 0[string range $header(mode) 2 end]}
+            }
+            catch {file attributes $name -owner $header(uid) -group $header(gid)}
+            catch {file attributes $name -owner $header(uname) -group $header(gname)}
+        }
+        if {!$nomtime} {
+            file mtime $name $header(mtime)
+        }
+    }
+    if {!$chan} {
+	close $fh
+    }
+    return $ret
+}
+
+## 
+ # ::tar::statFile
+ # 
+ # Returns stat info about a filesystem object, in the form of an info 
+ # dictionary like that returned by ::tar::readHeader.
+ # 
+ # The mode, uid, gid, mtime, and type entries are always present. 
+ # The size and linkname entries are present if relevant for this type 
+ # of object. The uname and gname entries are present if the OS supports 
+ # them. No devmajor or devminor entry is present.
+ ##
+
+proc ::tar::statFile {name followlinks} {
+    if {$followlinks} {
+        file stat $name stat
+    } else {
+        file lstat $name stat
+    }
+    
+    set ret {}
+    
+    if {$::tcl_platform(platform) == "unix"} {
+        lappend ret mode 1[file attributes $name -permissions]
+        lappend ret uname [file attributes $name -owner]
+        lappend ret gname [file attributes $name -group]
+        if {$stat(type) == "link"} {
+            lappend ret linkname [file link $name]
+        }
+    } else {
+        lappend ret mode [lindex {100644 100755} [expr {$stat(type) == "directory"}]]
+    }
+    
+    lappend ret  uid $stat(uid)  gid $stat(gid)  mtime $stat(mtime) \
+      type $stat(type)
+    
+    if {$stat(type) == "file"} {lappend ret size $stat(size)}
+    
+    return $ret
+}
+
+## 
+ # ::tar::formatHeader
+ # 
+ # Opposite operation to ::tar::readHeader; takes a file name and info 
+ # dictionary as arguments, returns a corresponding (POSIX-tar) header.
+ # 
+ # The following dictionary entries must be present:
+ #   mode
+ #   type
+ # 
+ # The following dictionary entries are used if present, otherwise 
+ # the indicated default is used:
+ #   uid       0
+ #   gid       0
+ #   size      0
+ #   mtime     [clock seconds]
+ #   linkname  {}
+ #   uname     {}
+ #   gname     {}
+ #   
+ # All other dictionary entries, including devmajor and devminor, are 
+ # presently ignored.
+ ##
+
+proc ::tar::formatHeader {name info} {
+    array set A {
+        linkname ""
+        uname ""
+        gname ""
+        size 0
+        gid  0
+        uid  0
+    }
+    set A(mtime) [clock seconds]
+    array set A $info
+    array set A {devmajor "" devminor ""}
+
+    set type [string map {file 0 directory 5 characterSpecial 3 \
+      blockSpecial 4 fifo 6 link 2 socket A} $A(type)]
+    
+    set osize  [format %o $A(size)]
+    set ogid   [format %o $A(gid)]
+    set ouid   [format %o $A(uid)]
+    set omtime [format %o $A(mtime)]
+    
+    set name [string trimleft $name /]
+    if {[string length $name] > 255} {
+        return -code error "path name over 255 chars"
+    } elseif {[string length $name] > 100} {
+	set common [string range $name end-99 154]
+	if {[set splitpoint [string first / $common]] == -1} {
+	    return -code error "path name cannot be split into prefix and name"
+	}
+	set prefix [string range $name 0 end-100][string range $common 0 $splitpoint-1]
+	set name   [string range $common $splitpoint+1 end][string range $name 155 end]
+    } else {
+        set prefix ""
+    }
+
+    set header [binary format a100A8A8A8A12A12A8a1a100A6a2a32a32a8a8a155a12 \
+                              $name $A(mode)\x00 $ouid\x00 $ogid\x00\
+                              $osize\x00 $omtime\x00 {} $type \
+                              $A(linkname) ustar\x00 00 $A(uname) $A(gname)\
+                              $A(devmajor) $A(devminor) $prefix {}]
+
+    binary scan $header c* tmp
+    set cksum 0
+    foreach x $tmp {incr cksum $x}
+
+    return [string replace $header 148 155 [binary format A8 [format %o $cksum]\x00]]
+}
+
+
+proc ::tar::recurseDirs {files followlinks} {
+    foreach x $files {
+        if {[file isdirectory $x] && ([file type $x] != "link" || $followlinks)} {
+            if {[set more [glob -dir $x -nocomplain *]] != ""} {
+                eval lappend files [recurseDirs $more $followlinks]
+            } else {
+                lappend files $x
+            }
+        }
+    }
+    return $files
+}
+
+proc ::tar::writefile {in out followlinks name} {
+     puts -nonewline $out [formatHeader $name [statFile $in $followlinks]]
+     set size 0
+     if {[file type $in] == "file" || ($followlinks && [file type $in] == "link")} {
+         set in [::open $in]
+         fconfigure $in -encoding binary -translation lf -eofchar {}
+         set size [fcopy $in $out]
+         close $in
+     }
+     puts -nonewline $out [string repeat \x00 [pad $size]]
+}
+
+proc ::tar::create {tar files args} {
+    set dereference 0
+    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]
+
+    if {!$chan} {
+	close $fh
+    }
+    return $tar
+}
+
+proc ::tar::add {tar files args} {
+    set dereference 0
+    set prefix ""
+    set quick 0
+    parseOpts {dereference 0 prefix 1 quick 0} $args
+    
+    set fh [::open $tar r+]
+    fconfigure $fh -encoding binary -translation lf -eofchar {}
+    
+    if {$quick} then {
+        seek $fh -1024 end
+    } else {
+        set data [read $fh 512]
+        while {[regexp {[^\0]} $data]} {
+            array set header [readHeader $data]
+            seek $fh [expr {$header(size) + [pad $header(size)]}] current
+            set data [read $fh 512]
+        }
+        seek $fh -512 current
+    }
+
+    foreach x [recurseDirs $files $dereference] {
+        writefile $x $fh $dereference $prefix$x
+    }
+    puts -nonewline $fh [string repeat \x00 1024]
+
+    close $fh
+    return $tar
+}
+
+proc ::tar::remove {tar files} {
+    set n 0
+    while {[file exists $tar$n.tmp]} {incr n}
+    set tfh [::open $tar$n.tmp w]
+    set fh [::open $tar r]
+
+    fconfigure $fh  -encoding binary -translation lf -eofchar {}
+    fconfigure $tfh -encoding binary -translation lf -eofchar {}
+
+    while {![eof $fh]} {
+        array set header [readHeader [read $fh 512]]
+        if {$header(name) == ""} {
+            puts -nonewline $tfh [string repeat \x00 1024]
+            break
+        }
+	if {$header(prefix) != ""} {append header(prefix) /}
+        set name $header(prefix)$header(name)
+        set len [expr {$header(size) + [pad $header(size)]}]
+        if {[lsearch $files $name] > -1} {
+            seek $fh $len current
+        } else {
+            seek $fh -512 current
+            fcopy $fh $tfh -size [expr {$len + 512}]
+        }
+    }
+
+    close $fh
+    close $tfh
+
+    file rename -force $tar$n.tmp $tar
+}
+
+proc ::tar::HandleLongLink {fh hv} {
+    upvar 1 $hv header thelongname thelongname
+
+    # @LongName Part I.
+    if {$header(type) == "L"} {
+	# Size == Length of name. Read it, and pad to full 512
+	# size.  After that is a regular header for the actual
+	# file, where we have to insert the name. This is handled
+	# by the next iteration and the part II below.
+	set thelongname [string trimright [read $fh $header(size)] \000]
+	seekorskip $fh [pad $header(size)] current
+	return -code continue
+    }
+    # Not supported yet: type 'K' for LongLink (long symbolic links).
+
+    # @LongName, part II, get data from previous entry, if defined.
+    if {[info exists thelongname]} {
+	set header(name) $thelongname
+	# Prevent leakage to further entries.
+	unset thelongname
+    }
+
+    return
+}
diff --git a/tcllib/modules/tar/tar.test b/tcllib/modules/tar/tar.test
new file mode 100644
index 0000000..7fa3c7d
--- /dev/null
+++ b/tcllib/modules/tar/tar.test
@@ -0,0 +1,119 @@
+# -*- tcl -*-
+# These tests are in the public domain
+# -------------------------------------------------------------------------
+
+source [file join \
+	[file dirname [file dirname [file normalize [info script]]]] \
+	devtools testutilities.tcl]
+
+testsNeedTcl     8.5 ; # Virt channel support!
+testsNeedTcltest 1.0
+
+# Check if we have TclOO available.
+tcltest::testConstraint tcloo [expr {![catch {package require TclOO}]}]
+
+support {
+    if {[tcltest::testConstraint tcloo]} {
+	use virtchannel_base/memchan.tcl tcl::chan::memchan
+    }
+    useLocalFile tests/support.tcl
+}
+testing {
+    useLocal tar.tcl tar
+}
+
+# -------------------------------------------------------------------------
+
+test tar-stream {stream} -constraints tcloo -setup {
+    setup1
+} -body {
+    string length [read $chan1]
+} -cleanup {
+    cleanup1
+} -result 128000
+
+test tar-pad {pad} -body {
+    tar::pad 230 
+} -result {282}
+
+test tar-skip {skip} -constraints tcloo -setup {
+    setup1
+} -body {
+    tar::skip $chan1 10
+    lappend res [read $chan1 10]
+    tar::skip $chan1 72313
+    lappend res [read $chan1 10]
+} -cleanup {
+    cleanup1
+} -result {{6 7 8 9 10} {07 13908 1}}
+
+test tar-seekorskip-backwards {seekorskip} -constraints tcl8.6plus -setup setup1 -body {
+    # The zlib push stuff is Tcl 8.6+. Properly restrict the test.
+    zlib push gzip $chan1
+    catch {tar::seekorskip $chan1 -10 start} cres
+    lappend res $cres
+    catch {tar::seekorskip $chan1 10 start} cres
+    lappend res $cres
+    catch {tar::seekorskip $chan1 -10 end} cres
+    lappend res $cres
+    catch {tar::seekorskip $chan1 10 end} cres
+    lappend res $cres
+    lappend res [read $chan1 10]
+} -cleanup cleanup1 -match glob \
+    -result [list \
+		 {WHENCE=start not supported*} \
+		 {WHENCE=start not supported*} \
+		 {WHENCE=end not supported*} \
+		 {WHENCE=end not supported*} \
+		 {1 2 3 4 5 } \
+		]
+
+test tar-header {header} -body {
+    set file1 [dict get $filesys Dir1 File1]
+    dict set file1 path /Dir1/File1
+    set header [header_posix $file1]
+    set parsed [string trim [tar::readHeader $header]]
+    set golden "name /Dir1/File1 mode 755 uid 13103 gid 18103 size 100 mtime 5706756101 cksum 3676 type 0 linkname {} magic ustar\0 version 00 uname {} gname {} devmajor 0 devminor 0 prefix {}"
+    set len [string length $parsed]
+    foreach {key value} $golden {
+	if {[set value1 [dict get $parsed $key]] ne $value } {
+	    lappend res [list $key $value $value1]
+	}
+    }
+} -result {}
+
+test tar-add {add} -constraints tcloo -setup {
+    setup1
+} -body {
+    tar::create $chan1 [list $tmpdir/one/a $tmpdir/one/two/a $tmpdir/one/three/a] -chan
+    seek $chan1 0
+    lappend res {*}[tar::contents $chan1 -chan]
+    seek $chan1 0
+    lappend res [string trim [tar::get $chan1 $tmpdir/one/two/a -chan]]
+} -cleanup {
+    cleanup1
+} -result {tartest/one/a tartest/one/two/a tartest/one/three/a hello2}
+
+
+test tar-bug-2840180 {} -setup {
+    setup2
+} -body {
+    tar::create $chan1 [list $tmpdir/[large-path]/a] -chan
+    seek $chan1 0
+
+    # What the package sees.
+    lappend res {*}[tar::contents $chan1 -chan]
+    close $chan1
+
+    # What a regular tar package sees.
+    lappend res [exec 2> $tmpfile.err tar tvf $tmpfile]
+    join $res \n
+} -cleanup {
+    cleanup2
+} -match glob -result [join [list \
+				 tartest/[large-path]/a \
+				 "* tartest/[large-path]/a" \
+				] \n]
+
+# -------------------------------------------------------------------------
+testsuiteCleanup
diff --git a/tcllib/modules/tar/tests/support.tcl b/tcllib/modules/tar/tests/support.tcl
new file mode 100644
index 0000000..09db4dd
--- /dev/null
+++ b/tcllib/modules/tar/tests/support.tcl
@@ -0,0 +1,126 @@
+
+proc stream {{size 128000}} {
+    set chan [tcl::chan::memchan]
+    set line {}
+    while 1 {
+	incr i
+	set istring $i
+	set ilen [string length $istring]
+	if {$line ne {}} {
+	    append line { }
+	    incr size -1 
+	}
+	append line $istring
+	incr size -$ilen
+	if {$size < 1} {
+	    set line [string range $line 0 end-[expr {abs(1-$size)}]]
+	    puts $chan $line
+	    break
+	}
+
+	if {$i % 10 == 0} {
+	    puts $chan $line 
+	    incr size -1 ;# for the [puts] newline
+	    set line {}
+	}
+    }
+
+    seek $chan 0
+    return $chan
+}
+
+proc header_posix {tarball} {
+    dict with tarball {} 
+    tar::formatHeader $path \
+	[dict create \
+	     mode $mode \
+	     type $type \
+	     uid  $uid \
+	     gid  $gid \
+	     size $size \
+	     mtime $mtime]
+}
+
+proc setup1 {} {
+    variable chan1
+    variable res {}
+    variable tmpdir tartest
+
+    tcltest::makeDirectory $tmpdir
+
+    foreach directory {
+	one
+	one/two
+	one/three
+    } {
+	tcltest::makeDirectory $tmpdir/$directory
+	set    chan [open $tmpdir/$directory/a w]
+	puts  $chan hello[incr i]
+	close $chan
+    }
+    set chan1 [stream]
+}
+
+proc large-path {} {
+    return aaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbtcllib/modules/tar
+}
+
+proc setup2 {} {
+    variable chan1
+    variable res {}
+    variable tmpdir tartest
+    variable tmpfile tarX
+
+    tcltest::makeDirectory $tmpdir
+    tcltest::makeFile {} $tmpfile
+
+    foreach directory [list [large-path]] {
+	tcltest::makeDirectory $tmpdir/$directory
+	set    chan [open $tmpdir/$directory/a w]
+	puts  $chan hello[incr i]
+	close $chan
+    }
+    set chan1 [open $tmpfile w+]
+}
+
+proc cleanup1 {} {
+    variable chan1
+    close $chan1
+    tcltest::removeDirectory tartest
+    return
+}
+
+proc cleanup2 {} {
+    variable chan1
+    variable tmpdir
+    variable tmpfile
+    catch { close $chan1 }
+    tcltest::removeDirectory $tmpdir
+    tcltest::removeFile      $tmpfile
+    tcltest::removeFile      $tmpfile.err
+    return
+}
+
+variable filesys {
+    Dir1 {
+	File1 {
+	    type 0
+	    mode 755
+	    uid 13103
+	    gid 18103
+	    size 100
+	    mtime 5706756101
+	}
+    }
+
+    Dir2 {
+	File1 {
+	    type 0
+	    mode 644
+	    uid 15103
+	    gid 19103
+	    size 100
+	    mtime 5706776103
+	}
+    }
+}