Tcl Library Source Code

if {![package vsatisfies [package provide Tcl] 8.4]} {
    # PRAGMA: returnok
    return
}
package ifneeded tar 0.11 [list source [file join $dir tar.tcl]]

[vset PACKAGE_VERSION 0.11]
[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}]

% 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.

[para] An error is thrown when [arg fileName] is not found in the tar
archive.

[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]

#
# 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.11

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 -errorcode {TAR INVALID OPTION} \
		-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 {

    if {$pad == 512} {return 0}
    return $pad
}

proc ::tar::seekorskip {ch off wh} {
    if {[tell $ch] < 0} {
	if {$wh!="current"} {
	    return -code error -errorcode [LIST TAR INVALID WHENCE $wh] \
		"WHENCE=$wh not supported on non-seekable channel $ch"
	}
	skip $ch $off
	return
    }
    seek $ch $off $wh
    return
}

	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) eq ""} break
	if {$header(prefix) ne ""} {append header(prefix) /}
        set name [string trimleft $header(prefix)$header(name) /]
        if {$name eq $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 -code error -errorcode {TAR MISSING FILE} \
	"Tar \"$tar\": File \"$file\" not found"
}

proc ::tar::untar {tar args} {
    set nooverwrite 0
    set data 0
    set nomtime 0
    set noperms 0

    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 -errorcode {TAR BAD PATH LENGTH} \
	    "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 -errorcode {TAR BAD PATH UNSPLITTABLE} \
		"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 ""
    }

    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 {Ticket 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]

# -------------------------------------------------------------------------

test tar-tkt-9f4c0e3e95-1.0 {Ticket 9f4c0e3e95, A} -setup {
    set tarfile [setup-tkt-9f4c0e3e95]
} -body {
    string trim [tar::get $tarfile 02]
} -cleanup {
    cleanup-tkt-9f4c0e3e95
    unset tarfile
} -result {zero-two}

test tar-tkt-9f4c0e3e95-1.1 {Ticket 9f4c0e3e95, B, } -setup {
    set tarfile [setup-tkt-9f4c0e3e95]
} -body {
    tar::get $tarfile 0b10
} -cleanup {
    cleanup-tkt-9f4c0e3e95
    unset tarfile
} -returnCodes error -result {Tar "tartest/t.tar": File "0b10" not found}

# -------------------------------------------------------------------------
testsuiteCleanup

	    uid 15103
	    gid 19103
	    size 100
	    mtime 5706776103
	}
    }
}

proc setup-tkt-9f4c0e3e95 {} {
    variable tmpdir tartest

    tcltest::makeDirectory $tmpdir
    tcltest::makeFile {zero-two}   $tmpdir/02
    tcltest::makeFile {number two} $tmpdir/2

    set here [pwd]
    cd $tmpdir
    tar::create t.tar {2 02}
    cd $here

    return $tmpdir/t.tar
}

proc cleanup-tkt-9f4c0e3e95 {} {
    variable tmpdir
    tcltest::removeFile      $tmpdir/2
    tcltest::removeFile      $tmpdir/02
    tcltest::removeDirectory $tmpdir
    return
}