Tcl Library Source Code

Changes On Branch ak-fix-traverse-symlinks
Login

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

Changes In Branch ak-fix-traverse-symlinks Excluding Merge-Ins

This is equivalent to a diff from d9d86cd9ff to 4599fe667f

2014-11-27
01:09
fileutil 1.14.9 - Fixed issue with symlink handling of the "find" command. While the original code broke cycles it also broke (i.e. skipped) non-cycle symlinks. The new code breaks only cycles. fileutil::traverse 0.4.4 - Ditto. Updated tests, docs. No ticket associated with this. check-in: e4cc97ecc8 user: aku tags: trunk
00:54
Updated version information in the package index as well, and updated the documentation. This is now ready for merging. Closed-Leaf check-in: 4599fe667f user: andreask tags: ak-fix-traverse-symlinks
00:10
Confirmed same issue for fileutil(::find). Test added, fixed buglet in expected output. check-in: 935565ca7e user: andreask tags: ak-fix-traverse-symlinks
00:04
Extended testsuite of fileutil::traverse demonstrating a problem with its symlink handling. While it properly breaks cycles, it can also break non-cycle links if the referenced path is handled before the link. And vice versa, if the link is handled the non-link path is not traversed. The fileutil package's find command is likely affected in the same manner. Opened branch to fix this. check-in: e3bc24a81e user: andreask tags: ak-fix-traverse-symlinks
2014-11-25
14:50
Create branch for working on modules for JSON Web Token (JWT) support. Leaf check-in: 783e8f3bf8 user: neilmadden tags: nmadden-json-web-token
2014-11-19
04:49
Get lastest from trunk check-in: 24cd9d7b26 user: aku tags: nettool
04:29
Merged pooryorick's original work and branch check-in: d9d86cd9ff user: aku tags: trunk
01:09
Ticket [ba3b0d913c] - Extended configure(.in) to enable specification of the path to the tclsh to use. Thanks to pooryorick for the patch. check-in: 262292fc92 user: andreask tags: trunk
2014-11-14
23:34
add --with-tclsh to configure, see issue ba3b0d91 Closed-Leaf check-in: e08de35f0a user: pooryorick tags: pyk-withtclsh-ba3b0d91

Changes to modules/fileutil/fileutil.man.
1

2
3
4
5
6
7
8

1
2
3
4
5
6
7
8
-
+







[vset PACKAGE_VERSION 1.14.8]
[vset PACKAGE_VERSION 1.14.9]
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin fileutil n [vset PACKAGE_VERSION]]
[keywords cat]
[keywords {file utilities}]
[keywords grep]
[keywords {temp file}]
[keywords test]
Changes to modules/fileutil/fileutil.tcl.
9
10
11
12
13
14
15
16

17
18
19
20
21
22
23
9
10
11
12
13
14
15

16
17
18
19
20
21
22
23







-
+







# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: fileutil.tcl,v 1.78 2010/06/17 04:46:19 andreas_kupries Exp $

package require Tcl 8.2
package require cmdline
package provide fileutil 1.14.8
package provide fileutil 1.14.9

namespace eval ::fileutil {
    namespace export \
	    grep find findByPattern cat touch foreachLine \
	    jail stripPwd stripN stripPath tempdir tempfile \
	    install fileType writeFile appendToFile \
	    insertIntoFile removeFromFile replaceInFile \
109
110
111
112
113
114
115
116



117
118
119
120
121
122
123
109
110
111
112
113
114
115

116
117
118
119
120
121
122
123
124
125







-
+
+
+







	# handled by _fully_ normalizing directory paths and checking
	# if we encountered the normalized form before. The array
	# 'known' is our cache where we record the known normalized
	# paths.

	set pending [list $basedir]
	set at      0
	array set   known {}
	array set   parent {}
	array set   norm   {}
	Enter {} $basedir

	while {$at < [llength $pending]} {
	    # Get next directory not yet processed.
	    set current [lindex $pending $at]
	    incr at

	    # Is the directory accessible? Continue if not.
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
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
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184







-
-
+
+
-










+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








		# Detection of symlink loops via a portable path
		# normalization computing a canonical form of the path
		# followed by a check if that canonical form was
		# encountered before. If ok, record directory for
		# expansion in future iterations.

		set norm [fileutil::fullnormalize $f]
		if {[info exists known($norm)]} continue
		Enter $current $f
		if {[Cycle $f]} continue
		set known($norm) .

		lappend pending $f
	    }
	}
    } else {
	return -code error "$basedir does not exist"
    }

    return $result
}

proc  ::fileutil::Enter {parent path} {
    upvar 1 parent _parent norm _norm
    set _parent($path) $parent
    set _norm($path)   [fileutil::fullnormalize $path]
}

proc  ::fileutil::Cycle {path} {
    upvar 1 parent parent _norm _norm
    set nform $_norm($path)
    set paren $_parent($path)
    while {$paren ne {}} {
	if {$_norm($paren) eq $nform} { return yes }
	set paren $_parent($paren)
    }
    return no
}

# Helper command for fileutil::find. Performs the filtering of the
# result per a filter command for the candidates found by the
# traversal core, see above. This is portable.

proc ::fileutil::FADD {filename} {
    upvar 1 result result filt filt filtercmd filtercmd
Changes to modules/fileutil/find.setup.
211
212
213
214
215
216
217

































































































218
219
220
221
222
223
224
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








proc f_setupdot {} {
    makeDirectory          dotfiles
    makeFile "" [file join dotfiles foo]
    makeFile "" [file join dotfiles .foo]
    return
}



# Complex directory tree with DAG-links and circular links. We want to
# break the latter, but not the former. I.e. DAG-links allow us to
# find a file by multiple paths, and we wish to see these all.
#
#  Paths    Links              Seen		Broken		Why
#  dir/a                     | a
#  dir/b                     | a/c
#  dir/a/c                   |			a/c/g		== a
#  dir/a/d                   | a/c/h
#  dir/a/c/g --> ..          |                  a/c/h/e         == c
#  dir/a/c/h --> ../../b     | a/c/h/f					
#  dir/a/c/i                 | a/c/i					
#  dir/b/e   --> ../a/c	     | a/d					
#  dir/b/f                   | b					
#                            | b/e					
#                            | b/e/g					
#                            | b/e/g/c					
#                            | 			b/e/g/c/g	== b/e/g
#                            |			b/e/g/c/h	== b
#                            | b/e/g/d
#                            |			b/e/h		== b
#                            | b/e/i
#                            | b/f

proc pathmap {args} {
    set res {}
    foreach p $args {
	lappend res [tempPath $p]
    }
    return $res
}

proc f_setupcircle3 {} {

    makeDirectory z/a
    makeDirectory z/a/c
    makeDirectory z/b
    makeFile ""   z/a/d
    makeFile ""   z/a/c/i
    makeFile ""   z/b/f

    f_link        z/a/c/g ../../a
    f_link        z/a/c/h ../../b
    f_link        z/b/e   ../a/c
    return
}

proc f_cleanup3 {} {
    # Remove sym links first. Not doing this causes the file delete for
    # the directory to fail (on Windows, Unix would have been fine).
    catch { removeFile z/a/c/g }
    catch { removeFile z/a/c/h }
    catch { removeFile z/b/e }
    removeDirectory z
    return
}

proc f_link {src target} {
    # Added use of 'file link' for Tcl 8.4+, on windows, to have a
    # modicum of x-platform testing regarding the handling of symbolic
    # links.

    if {
	[string equal $::tcl_platform(platform) windows] &&
	[package vsatisfies [package require Tcl] 8.4]
    } {
	if {[string equal $::tcl_platform(platform) windows]} {
	    # Windows doesn't like the .. in the target, it needs an
	    # absolute path.

	    # NOTE/BUG Even so the 'fullnormalize' in the traverser
	    # returns bogus results for the link, whereas use of file
	    # normalize and fullnormalize in a simple tclsh,
	    # i.e. outside of the testing is ok.

	    # It seems if the 'file join' in fullnormalize is replaced
	    # by a plain / then the results are ok again => The
	    # handling of paths on Windows by the Tcl core is bogus in
	    # some way which breaks the core 'normalize'.

	    set here [pwd]
	    cd [file dirname [tempPath $src]]
	    file link [file tail $src] [file normalize $target]
	    cd $here
	} else {
	    file link [tempPath $src] $target
	}
	return
    }

    exec ln -s $target [tempPath $src]
    return
}


proc f_cleanupdot {} {
    removeDirectory dotfiles
    return
}

proc f_setupnostat {} {
265
266
267
268
269
270
271

272
273

274


275
276
277
278
279
280
281
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382







+


+

+
+







	exec chmod +r [tempPath find3/find4]
    }
    removeDirectory find3
    return
}

proc f_cleanall {} {
    rename f_link           {}
    rename f_setup          {}
    rename f_cleanup        {}
    rename f_cleanup3       {}
    rename f_setupcircle    {}
    rename f_setupcircle2   {}
    rename f_setupcircle3   {}
    rename f_setupdot       {}
    rename f_cleanupdot     {}
    rename f_setupnostat    {}
    rename f_cleanupnostat  {}
    rename f_setupnoread    {}
    rename f_cleanupnoread  {}
    rename f_cleanall       {}
Changes to modules/fileutil/find.test.
136
137
138
139
140
141
142























143
144
145
146
147
148
149
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
168
169
170
171
172







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







    set res [lsort [fileutil::find [tempPath {find 1}]]]
    f_cleanup
    set res
} [list [tempPath {find 1/file [1]}] \
	[tempPath {find 1/find 2}] \
	[tempPath {find 1/find 2/file 3}]]


test find-1.11.0 {find result, circular links, unix} -setup {
    f_setupcircle3
} -constraints unix -body {
    join [lsort [fileutil::find [tempPath z]]] \n
} -cleanup {
    f_cleanup3
} -result [join [pathmap \
		     z z/a z/a/c z/a/c/g z/a/c/h z/a/c/h/e z/a/c/h/f \
		     z/a/c/i z/a/d z/b z/b/e z/b/e/g z/b/e/g/c z/b/e/g/d \
		     z/b/e/h z/b/e/i z/b/f] \n]

test find-1.11.1 {find result, circular links, windows, 8.4+} -setup {
    f_setupcircle3
} -constraints {win tcl8.4plus} -body {
    join [lsort [fileutil::find [tempPath z]]] \n
} -cleanup {
    f_cleanup3
} -result [join [pathmap \
		     z z/a z/a/c z/a/c/g z/a/c/h z/a/c/h/e z/a/c/h/f \
		     z/a/c/i z/a/d z/b z/b/e z/b/e/g z/b/e/g/c z/b/e/g/d \
		     z/b/e/h z/b/e/i z/b/f] \n]

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

test find-2.0 {find by pattern} {
    list [catch {
        ::fileutil::findByPattern [tempPath {}] -glob {fil*} foo
    } err] $err
} {1 {wrong#args for "::fileutil::findByPattern", should be "::fileutil::findByPattern basedir ?-regexp|-glob? ?--? patterns"}}
Changes to modules/fileutil/pkgIndex.tcl.
1
2

3
4
5

6
7
8
9
10
1

2
3
4

5
6
7
8
9
10

-
+


-
+





if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded fileutil 1.14.8 [list source [file join $dir fileutil.tcl]]
package ifneeded fileutil 1.14.9 [list source [file join $dir fileutil.tcl]]

if {![package vsatisfies [package provide Tcl] 8.3]} {return}
package ifneeded fileutil::traverse 0.4.3 [list source [file join $dir traverse.tcl]]
package ifneeded fileutil::traverse 0.4.4 [list source [file join $dir traverse.tcl]]

if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded fileutil::multi     0.1   [list source [file join $dir multi.tcl]]
package ifneeded fileutil::multi::op 0.5.3 [list source [file join $dir multiop.tcl]]
package ifneeded fileutil::decode    0.2   [list source [file join $dir decode.tcl]]
Changes to modules/fileutil/traverse.man.
1
2

3
4
5
6
7
8
9
1

2
3
4
5
6
7
8
9

-
+







[comment {-*- text -*- doctools manpage}]
[manpage_begin fileutil_traverse n 0.4.3]
[manpage_begin fileutil_traverse n 0.4.4]
[keywords {directory traversal}]
[keywords traversal]
[moddesc   {file utilities}]
[titledesc {Iterative directory traversal}]
[category  {Programming tools}]
[require Tcl 8.3]
[require fileutil::traverse [opt 0.4.3]]
76
77
78
79
80
81
82
83
84
85
86










87
88
89
90
91
92
93
76
77
78
79
80
81
82




83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99







-
-
-
-
+
+
+
+
+
+
+
+
+
+







This is the lowest possible interface to the traverser, the core all
higher methods are built on. When invoked it returns a boolean value
indicating whether it found a path matching the current configuration
([const True]), or not ([const False]). If a path was found it is
stored into the variable named by [arg filevar], in the context of the
caller.

The [method foreach] method simply calls this method in a loop until
it returned [const False]. This method is exposed so that we are also
able to incrementally traverse a directory hierarchy in an event-based
manner.
[para] The [method foreach] method simply calls this method in a loop
until it returned [const False]. This method is exposed so that we are
also able to incrementally traverse a directory hierarchy in an
event-based manner.

[para] Note that the traverser does follow symbolic links, except when
doing so would cause it to enter a link-cycle. In other words, the
command takes care to [emph not] lose itself in infinite loops upon
encountering circular link structures. Note that even links which are
not followed will still appear in the result.

[list_end]

[section OPTIONS]

[list_begin options]
[opt_def -prefilter command_prefix]
Changes to modules/fileutil/traverse.tcl.
202
203
204
205
206
207
208
209
210


211
212
213
214
215
216
217
218
219
220
202
203
204
205
206
207
208


209
210
211
212

213
214
215
216
217
218
219







-
-
+
+


-







		    [string equal [file tail $f] ".."]
		} continue

		if {[Valid $f]} {
		    lappend _results $f
		}

		set norm [fileutil::fullnormalize $f]
		if {[info exists _known($norm)]} continue
		Enter $top $f
		if {[Cycle $f]} continue

		if {[Recurse $f]} {
		    set _known($norm) .
		    lappend _pending $f
		}
	    }

	    # Stop expanding if we have paths to return.

	    if {[llength $_results]} {
243
244
245
246
247
248
249
250










251



252
253
254

















255
256


257
258
259
260
261
262
263
264
265

266
267
268
269
270
271
272
273
242
243
244
245
246
247
248

249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283

284
285
286
287
288
289
290
291
292
293

294

295
296
297
298
299
300
301







-
+
+
+
+
+
+
+
+
+
+

+
+
+



+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

-
+
+








-
+
-







    # * Set of directories already visited (normalized paths), for
    #   detection of circular symbolic links.

    variable _init         0  ; # Initialization flag.
    variable _base         {} ; # Base directory.
    variable _pending      {} ; # Processing stack.
    variable _results      {} ; # Result stack.
    variable _known -array {} ; # Seen paths.

    # sym link handling (to break cycles, while allowing the following of non-cycle links).
    # Notes
    # - path parent   tracking is lexical.
    # - path identity tracking is based on the normalized path, i.e. the path with all
    #   symlinks resolved.
    # Maps
    # - path -> parent     (easier to follow the list than doing dirname's)
    # - path -> normalized (cache to avoid redundant calls of fullnormalize)
    # cycle <=> A parent's normalized form (NF) is identical to the current path's NF

    variable _parent -array {}
    variable _norm   -array {}

    # ### ### ### ######### ######### #########
    ## Internal helpers.

    proc Enter {parent path} {
	upvar 1 _parent _parent _norm _norm
	set _parent($path) $parent
	set _norm($path)   [fileutil::fullnormalize $path]
    }

    proc Cycle {path} {
	upvar 1 _parent _parent _norm _norm
	set nform $_norm($path)
	set paren $_parent($path)
	while {$paren ne {}} {
	    if {$_norm($paren) eq $nform} { return yes }
	    set paren $_parent($paren)
	}
	return no
    }

    method Init {} {
	array unset _known *
	array unset _parent *
	array unset _norm   *

	# Path ok as result?
	if {[Valid $_base]} {
	    lappend _results $_base
	}

	# Expansion allowed by prefilter?
	if {[file isdirectory $_base] && [Recurse $_base]} {
	    set norm [fileutil::fullnormalize $_base]
	    Enter {} $_base
	    set _known($norm) .
	    lappend _pending $_base
	}

	# System is set up now.
	set _init 1
	return
    }
413
414
415
416
417
418
419
420

441
442
443
444
445
446
447

448







-
+
	return $l
    }
}

# ### ### ### ######### ######### #########
## Ready

package provide fileutil::traverse 0.4.3
package provide fileutil::traverse 0.4.4
Changes to modules/fileutil/traverse.test.
298
299
300
301
302
303
304




























305
306
307
308
309
310
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+






    $t destroy
    unset rec
    f_cleanupnostat
} -result [list [list [tempPath find3/find4] {Inacessible directory}]]

# traverse 1.3.x - error callback, all platforms - Not possible. We have
# no win32 setup code for non-readable/non-accessible directories.

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

test traverse-1.4.0 {Traverse result, circular links, unix} -setup {
    f_setupcircle3
    set t [fileutil::traverse %AUTO% [tempPath z]]
} -constraints unix -body {
    join [lsort [$t files]] \n
} -cleanup {
    $t destroy
    f_cleanup3
} -result [join [pathmap \
		     z z/a z/a/c z/a/c/g z/a/c/h z/a/c/h/e z/a/c/h/f \
		     z/a/c/i z/a/d z/b z/b/e z/b/e/g z/b/e/g/c z/b/e/g/d \
		     z/b/e/h z/b/e/i z/b/f] \n]

test traverse-1.4.1 {Traverse result, circular links, windows, 8.4+} -setup {
    f_setupcircle3
    set t [fileutil::traverse %AUTO% [tempPath z]]
} -constraints {win tcl8.4plus} -body {
    join [lsort [$t files]] \n
} -cleanup {
    $t destroy
    f_cleanup3
} -result [join [pathmap \
		     z z/a z/a/c z/a/c/g z/a/c/h z/a/c/h/e z/a/c/h/f \
		     z/a/c/i z/a/d z/b z/b/e z/b/e/g z/b/e/g/c z/b/e/g/d \
		     z/b/e/h z/b/e/i z/b/f] \n]

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

f_cleanall
testsuiteCleanup
return