Tcl Library Source Code

Check-in [165e7adf41]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:add a test suite for tar module fix for bug 6b7aa0aecca6fdce12589884c3c9ea2b50c92ad4, tar::skip silently truncates at 65536
Timelines: family | ancestors | descendants | both | pyk-tar
Files: files | file ages | folders
SHA1: 165e7adf41eba43c5771708a2f79330b70f25d80
User & Date: pooryorick 2013-11-16 07:19:36
Context
2013-11-17
15:45
fix setup1 script for tar.test so that tests don't pollute each other check-in: cecf9adb75 user: pooryorick tags: pyk-tar
2013-11-16
07:19
add a test suite for tar module fix for bug 6b7aa0aecca6fdce12589884c3c9ea2b50c92ad4, tar::skip silently truncates at 65536 check-in: 165e7adf41 user: pooryorick tags: pyk-tar
2013-11-01
23:37
general cleanup. use expr operators like eq instead of string commands check-in: 913f7d92c5 user: pooryorick tags: pyk-mime-cleanup
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to modules/tar/tar.tcl.

54
55
56
57
58
59
60
61
62
63
64

65
66
67
68
69
70
71
72
...
172
173
174
175
176
177
178

179
180
181
182
183
184
185
186
    }
    seek $ch $off $wh
    return
}

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
    }
    return
}

proc ::tar::readHeader {data} {
    binary scan $data a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155 \
                      name mode uid gid size mtime cksum type \
................................................................................
    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
        set name [string trimleft $header(prefix)$header(name) /]
        if {$name == $file} {
            set file [read $fh $header(size)]
            if {!$chan} {
		close $fh






|
|
|
<
>
|







 







>
|







54
55
56
57
58
59
60
61
62
63

64
65
66
67
68
69
70
71
72
...
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
    }
    seek $ch $off $wh
    return
}

proc ::tar::skip {ch len} {
    while {$len>0} {
	set readsize [string length [read $ch $len]]
	if {$readsize == 0 && [eof $ch]} {
	    return

	}
	incr len -$readsize
    }
    return
}

proc ::tar::readHeader {data} {
    binary scan $data a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155 \
                      name mode uid gid size mtime cksum type \
................................................................................
    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
        set name [string trimleft $header(prefix)$header(name) /]
        if {$name == $file} {
            set file [read $fh $header(size)]
            if {!$chan} {
		close $fh

Added modules/tar/tar.test.














































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
# These tests are in the public domain

package require tcltest
package require tcl::chan::memchan

source [file join \
	[file dirname [file dirname [file normalize [info script]]]] \
	devtools testutilities.tcl]

testing {
    useLocal tar.tcl tar
}


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
}

set TMP_MAX 1000
variable tmpdir
while 1 {
    if {![file exists tartest[incr i]]} {
	set tmpdir tartest$i
	makeDirectory $tmpdir
	break
    }
    if {$ > $TMP_MAX} {
	error "could not create temporary directory"
    }
}


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
	}
    }
}


proc header_posix {tarball} {
    dict with tarball {} 
    tar::formatHeader $path [
	dict create mode $mode type $type uid $uid gid $gid size $size mtime $mtime]
}


variable setup1 {
    set res {}
    set directories {one one/two one/three}
    foreach directory $directories {
	makeDirectory $directory $tmpdir 
	set chan [open $tmpdir/$directory/a w]
	puts $chan hello[incr i]
	close $chan
    }
    set chan1 [stream]
}

variable cleanup1 {
    close $chan1
}

test test-stream {} -setup $setup1 -body {
    string length [read $chan1]
} -cleanup $cleanup1 -result 128000


test tar-pad {} -body {
    tar::pad 230 
} -result {282}

test tar-skip {} -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 {} -setup $setup1 -body {
    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 {} -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 {} -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 {tartest1/one/a tartest1/one/two/a tartest1/one/three/a hello3}

testsuiteCleanup