TclVFS

Check-in [391a075003]
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:2011-03-30 Steve Huntley <[email protected]> * globfind.tcl: Updated to latest file version (1.5.3).
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 391a075003455876f8aff07d1c27599096be50f3
User & Date: blacksqr 2011-03-30 05:14:58
Context
2011-03-30
06:44
2011-03-30 Steve Huntley <[email protected]> * vfslib.tcl, zipvfs.tcl: Added contributed patches to fix bugs 3160686 & 3224057. check-in: d888143e47 user: blacksqr tags: trunk
05:14
2011-03-30 Steve Huntley <[email protected]> * globfind.tcl: Updated to latest file version (1.5.3). check-in: 391a075003 user: blacksqr tags: trunk
2010-12-31
07:31
2010-12-31 Steve Huntley <[email protected]> * vfs.tcl: Removed requirement for 8.6 for sourcing of vfslib.tcl, since that file contains 8.5-relevant utils for chan command. Vfslib.tcl includes adequate conditional checks for version-dependent commands. check-in: a86dc1c7cc user: blacksqr tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.





1
2
3
4
5
6
7



2010-12-31  Steve Huntley  <[email protected]>

	* vfs.tcl: Removed requirement for 8.6 for sourcing of vfslib.tcl, since
	that file contains 8.5-relevant utils for chan command.  Vfslib.tcl
	includes adequate conditional checks for version-dependent commands.

2010-12-30  Steve Huntley  <[email protected]>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
2011-03-30  Steve Huntley  <[email protected]>

	* globfind.tcl: Updated to latest file version (1.5.3).

2010-12-31  Steve Huntley  <[email protected]>

	* vfs.tcl: Removed requirement for 8.6 for sourcing of vfslib.tcl, since
	that file contains 8.5-relevant utils for chan command.  Vfslib.tcl
	includes adequate conditional checks for version-dependent commands.

2010-12-30  Steve Huntley  <[email protected]>

Changes to library/template/globfind.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
..
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
...
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
...
330
331
332
333
334
335
336
337


















































































































































































338
if 0 {
########################

globfind.tcl --

Written by Stephen Huntley ([email protected])
License: Tcl license
Version 1.5

The proc globfind is a replacement for tcllib's fileutil::find

Usage: globfind ?basedir ?filtercmd? ?switches??

Options:

................................................................................

	-types   - any value acceptable to the "types" switch of the glob command.
		     ex: -types {d hidden}

Side effects:

If somewhere within the search space a directory is a link to another directory within
the search space, then the variable ::globfind::REDUNDANCY will be set to 1 (otherwise
it will be set to 0).  The name of the redundant directory will be appended to the
variable ::globfind::redundant_files.  This may be used to help track down and eliminate
infinitely looping links in the search space.

Unlike fileutil::find, the name of the basedir will be included in the results if it fits
the prefilter and filtercmd criteria (thus emulating the behavior of the standard Unix 
GNU find utility).

----

................................................................................
			set item [lindex $contents end-$i]
			incr i
			
			# kludge to fully resolve link to native name:
			set linkValue [file dirname [file normalize [file join $item __dummy__]]]

			# if item is a link, and native name is already in the search space, skip it:
			if {($linkValue != $item) && (![string first $basedir $linkValue])} {
				set [namespace current]::REDUNDANCY 1
				lappend [namespace current]::redundant_files $item
				continue
			}

			lappend checkDirs $item			
		}
................................................................................
# Eliminate emulation of [file normalize] if version 8.4 or better:
if [package vsatisfies [package present Tcl] 8.4] {
	rename ::fileutil::globfind::file {}
} else {
	package require fileutil 1.13
}

}


















































































































































































# end namespace ::fileutil::globfind






|







 







|
|
|
|







 







|







 







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
..
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
...
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
...
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
if 0 {
########################

globfind.tcl --

Written by Stephen Huntley ([email protected])
License: Tcl license
Version 1.5.3

The proc globfind is a replacement for tcllib's fileutil::find

Usage: globfind ?basedir ?filtercmd? ?switches??

Options:

................................................................................

	-types   - any value acceptable to the "types" switch of the glob command.
		     ex: -types {d hidden}

Side effects:

If somewhere within the search space a directory is a link to another directory within
the search space, then the variable ::fileutil::globfind::REDUNDANCY will be set to 1 
(otherwise it will be set to 0).  The name of the redundant directory will be appended to the
variable ::fileutil::globfind::redundant_files.  This information may be used to help track down 
and eliminate infinitely looping links in the search space.

Unlike fileutil::find, the name of the basedir will be included in the results if it fits
the prefilter and filtercmd criteria (thus emulating the behavior of the standard Unix 
GNU find utility).

----

................................................................................
			set item [lindex $contents end-$i]
			incr i
			
			# kludge to fully resolve link to native name:
			set linkValue [file dirname [file normalize [file join $item __dummy__]]]

			# if item is a link, and native name is already in the search space, skip it:
			if {($linkValue != $item) && (![string first $basedir/ $linkValue/])} {
				set [namespace current]::REDUNDANCY 1
				lappend [namespace current]::redundant_files $item
				continue
			}

			lappend checkDirs $item			
		}
................................................................................
# Eliminate emulation of [file normalize] if version 8.4 or better:
if [package vsatisfies [package present Tcl] 8.4] {
	rename ::fileutil::globfind::file {}
} else {
	package require fileutil 1.13
}


# -----------------
# Following are sample filter commands that can be used with globfind:

# scfind: a command suitable for use as a filtercmd with globfind, arguments
# duplicate a subset of GNU find args.

proc scfind {args} {
	set filename [file join [pwd] [lindex $args end]]
	set switches [lrange $args 0 end-1]

	array set types {
		f	file
		d	directory
		c	characterSpecial
		b	blockSpecial
		p	fifo
		l	link
		s	socket
	}

	array set signs {
		- <
		+ >
	}

	array set multiplier {
		time 86400
		min   3600
	}
	file stat $filename fs
	set pass 1
	set switchLength [llength $switches]
	for {set i 0} {$i < $switchLength} {incr i} {
		set sw [lindex $switches $i]
		switch -- $sw {
			-type {
				set value [lindex $switches [incr i]]
				if ![string equal $fs(type) $types($value)] {return 0}
			}
			-regex {
				set value [lindex $switches [incr i]]
				if ![regexp $value $filename] {return 0}
			}
			-size {
				set value [lindex $switches [incr i]]
				set sign "=="
				if [info exists signs([string index $value 0])] {
					set sign $signs([string index $value 0])
					set value [string range $value 1 end]
				}
				set sizetype [string index $value end]
				set value [string range $value 0 end-1]
				if [string equal $sizetype b] {set value [expr $value * 512]}
				if [string equal $sizetype k] {set value [expr $value * 1024]}
				if [string equal $sizetype w] {set value [expr $value * 2]}

				if ![expr $fs(size) $sign $value] {return 0}
			}
			-atime -
			-mtime -
			-ctime -
			-amin -
			-mmin -
			-cmin {
				set value [lindex $switches [incr i]]

				set sw [string range $sw 1 end]
				set time "[string index $sw 0]time"
				set interval [string range $sw 1 end]
				set sign "=="
				if [info exists signs([string index $value 0])] {
					set sign $signs([string index $value 0])
					set value [string range $value 1 end]
				}
				set value [expr [clock seconds] - ($value * $multiplier($interval))]
				if ![expr $value $sign $fs($time)] {return 0}
			}
 		}
	}
	return 1
}

# find: example use of globfind and scfind to duplicate a subset of the
# command line interface of GNU find.
# ex: 
#	find $env(HOME) -type l -atime +1

proc find {args} {
	globfind [lindex $args 0] [list [subst "scfind $args"]]
}

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

# globsync: sync two locations so that the target looks just like the source:

# If "destructive" is set to 1, files in the target will be deleted if files in equivalent
# locations in source don't exist.   If 0, files that exist only in target will be left
# alone, leaving target not an exact duplicate of source.

# if "log" is set to 1, progress messages will be written to stdout.  If 0, not.

# "source" is location to be duplicated.
# "target" is location to be synced to look like source.
# file is parameter fed to globsync by globfind.

# ex: globfind ~user_a {globsync 1 1 ~user_a ~user_b}

proc globsync {destructive log source target file} {
	set source [file normalize $source]
	set target [file normalize $target]
	set sourceLength [llength [file split $source]]
	set targetLength [llength [file split $target]]
	set targetFile [file normalize [file join $target [join [lrange [file split $file] $sourceLength end] /]]]
	array set sourceAttr [file attributes $file]
	file stat $file fs
	array set sourceAttr "mtime $fs(mtime)"
	if ![file isdirectory $file] {

		if [file isdirectory $targetFile] {file delete -force -- $targetFile}
		set err [catch {file copy -force -- $file $targetFile} result]
		if $err {set err [catch {file mkdir [file dirname $targetFile] ; file copy -force -- $file $targetFile} result]}
		if $err {errHandle $result}
		if $log {puts "copied $file to $targetFile"}

		array set targetAttr [file attributes $targetFile]
		foreach attr [array names sourceAttr] {
			if {[array get sourceAttr $attr] != [array get targetAttr $attr]} {catch {file attributes $targetFile $attr $sourceAttr($attr)}}
		}
		return 0
	}
	set err [catch {file mkdir $targetFile} result]
	if $err {set err [catch {file delete -force -- $targetFile ; file mkdir $targetFile} result]}
	if $err {errHandle $result}
	array set targetAttr [file attributes $targetFile]
	file stat $targetFile fs
	array set targetAttr "mtime $fs(mtime)"
	foreach attr [array names sourceAttr] {
		if {[array get sourceAttr $attr] != [array get targetAttr $attr]} {
			catch {file attributes $targetFile $attr $sourceAttr($attr)}
		}
	}
	set sourceDirs [glob -dir $file -nocomplain -type d *]
	if {[lindex [file system $file] 0] != "tclvfs"} {append sourceDirs " [glob -dir $file -nocomplain -type {d hidden} *]"}
	set targetDirs [glob -dir $targetFile -nocomplain -type d *]
	if {[lindex [file system $targetFile] 0] != "tclvfs"} {append sourceDirs " [glob -dir $targetFile -nocomplain -type {d hidden} *]"}

	if !$destructive {set targetDirs {}}
	foreach td $targetDirs {
		set sd [file join $source [join [lrange [file split $td] $targetLength end] /]]
		if {[lsearch $sourceDirs $sd] < 0} {	
			file delete -force -- $td
			if $log {puts "deleted directory $td"}

		}
	}
	set sourceFiles [glob -dir $file -nocomplain -types {b c f l p s} *]
	if {[lindex [file system $file] 0] != "tclvfs"} {append sourceFiles " [glob -dir $file -nocomplain -types {b c f l p s hidden} *]"}
		
	set targetFiles {}
	if $destructive {
		set targetFiles [glob -dir $targetFile -nocomplain -types {b c f l p s} *]
		if {[lindex [file system $targetFile] 0] != "tclvfs"} {append targetFiles " [glob -dir $targetFile -nocomplain -types {b c f l p s hidden} *]"}
	}
	foreach tf $targetFiles {
		set sf [file join $source [join [lrange [file split $tf] $targetLength end] /]]
		if {[lsearch $sourceFiles $sf] < 0} {
			file delete -force -- $tf
			if $log {puts "deleted file $tf"}
		}	
	}
	return 0
}

proc errHandle {result} {
	error $result
}

}
# end namespace ::fileutil::globfind