# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*-
# -- Tcl Module

# @@ Meta Begin
# Package diskutil 1.9
# Meta as::author      {Emmanuel Frecon}
# Meta as::build::date 2015-03-24
# Meta as::license     BSD
# Meta as::origin      http://sourceforge.net/projects/til
# Meta description     A number of disk utilities, oriented around
# Meta description     temporary files.
# Meta platform        tcl
# Meta require         {Tcl 8.2}
# Meta require         logger
# Meta require         {registry -platform windows}
# @@ Meta End


# ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS

package require Tcl 8.2
package require logger
if {
    [string equal $tcl_platform(platform) windows]
} {
    package require registry
}

# ACTIVESTATE TEAPOT-PKG END REQUIREMENTS

# ACTIVESTATE TEAPOT-PKG BEGIN DECLARE

package provide diskutil 1.9

# ACTIVESTATE TEAPOT-PKG END DECLARE
# ACTIVESTATE TEAPOT-PKG END TM
# diskutil.tcl --
#
#	A number of disk utilities, oriented around temporary files.
#
# Copyright (c) 2004-2005 by the Swedish Institute of Computer Science.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

# Version History:
#   1.0 - First version, developed for WebPR & WebPath
#   1.1 - Improved version for ACCORD
#   1.2 - Adding features for the deskpoll facility.
#   1.3 - Adding path expansion
#   1.4 - Adding file concatenation routing
#   1.5 - Name shift for the package and added name resolution routine.
#   1.6 - Adding normalisation emulation.
#   1.7 - Adding file rotation
#   1.8 - Bug fixes?
#   1.9 - Fixed temporary directory for localized windows installations.

package require Tcl 8.2
package require logger
if { $::tcl_platform(platform) == "windows" } {
    package require registry
}

namespace eval ::diskutil {
    
    # Initialise global state.
    variable DiskUtil
    if {![info exists DiskUtil]} {
	array set DiskUtil {
	    loglevel           warn
	}
	variable log [::logger::init diskutil]
	${log}::setlevel $DiskUtil(loglevel)
    }

    # Export commands
    namespace export double_backslah absolute_path append_path
    namespace export platform_tmp temporary_filename temporary_file
    namespace export temporary_directory clean_directory
    namespace export concat_files fname_resolv normalize rotate
}


# ::diskutil::loglevel -- Set/Get current log level.
#
#	Set and/or get the current log level for this library.
#
# Arguments:
#	loglvl	New loglevel
#
# Results:
#	Return the current log level
#
# Side Effects:
#	None.
proc ::diskutil::loglevel { { loglvl "" } } {
    variable DiskUtil
    variable log

    if { $loglvl != "" } {
	if { [catch "${log}::setlevel $loglvl"] == 0 } {
	    set DiskUtil(loglevel) $loglvl
	}
    }

    return $DiskUtil(loglevel)
}


# ::diskutil::normalize -- Normalize filename
#
#	This performs a job that is similar to file normalize and can
#	be used for Tcl implementations that do not support this new
#	command. (taken and adapted from wiki: http://wiki.tcl.tk/1540)
#
# Arguments:
#	fname	Input filename
#	keeprel	Do not resolve relative path, keep them relative
#
# Results:
#	Return a file name where all .. and . have been replaced.
#
# Side Effects:
#	None.
proc ::diskutil::normalize { fname { keeprel 0 } } {
    variable DiskUtil
    variable log
    
    set sp [file split $fname]
    if {[file pathtype [lindex $sp 0]] == "relative" && ! $keeprel} {
	set sp [file split [eval [list file join [pwd]] $sp]]
    }
    set np {}
    foreach ele $sp {
	if {$ele != ".."} {
	    if {$ele != "."} { lappend np $ele }
	} else {
	    if { $keeprel } {
		set np [lrange $np 0 [expr {[llength $np] - 2}]]
	    } elseif {[llength $np]> 1} {
		set np [lrange $np 0 [expr {[llength $np] - 2}]]
	    }
	}
    }
    if {[llength $np] > 0} { return [eval file join $np] }
    return ""
}


# ::diskutil::double_backslash --
#
#	Double every backslash in a native filename
#
# Arguments:
#	fname_in	Input filename
#
# Results:
#	Return a file name where all backslashes have been doubled and
#	all remaining characters are unchanged.
#
# Side Effects:
#	None.
proc ::diskutil::double_backslash { fname_in } {
    set len [string length $fname_in]
    set fname_out ""
    for { set i 0 } { $i<$len } { incr i } {
	set char [string index $fname_in $i]
	if { $char == "\\" } {
	    append fname_out "\\\\"
	} else {
	    append fname_out $char
	}
    }

    return $fname_out
}



# ::diskutil::absolute_path --
#
#	Resolve a path name so that it is absolute from the root of
#	the file system.
#
# Arguments:
#	relpath	Relative file or dir path
#
# Results:
#	Returns the absolute path for a file, i.e. no . or .. in path.
#	Return "" in case of impossible resolution.
#
# Side Effects:
#	This implementation actually changes to the directory of the
#	specified path and back to the initial directory.  If
#	something goes wrong while changing directory and the command
#	abruptbly returns, the current directory might be different
#	than before calling the command.
proc ::diskutil::absolute_path { relpath } {
    variable log

    set abspath ""
    set olddir [pwd]

    if { [file isdirectory $relpath] } {
	if { [catch "cd $relpath"] != 0 } {
	    ${log}::error "Cannot change to directory $relpath"
	    return ""
	}
	set abspath [pwd]
    } else {
	set dirname [file dirname $relpath]
	set filename [file tail $relpath]
	if { [catch {cd "$dirname"} err] } {
	    ${log}::error "Cannot change to directory $dirname: $err"
	    return ""
	}
	set abspath [file join [pwd] $filename]
    }
    cd $olddir

    ${log}::debug "$relpath resolved to $abspath"
    return $abspath
}


# ::diskutil::append_path --
#
#	This command arranges to append directories to a PATH like
#	variable.  It aims at offering a platform-independent
#	interface to this kind of environment variable.
#
# Arguments:
#	path_p	"pointer" to path variable.
#	dirs	List of directories to append
#	native	Should directories be translated to native file path format?
#
# Results:
#	None.
#
# Side Effects:
#	None.
proc ::diskutil::append_path { path_p dirs { native 0 } } {
    global tcl_platform

    upvar $path_p path

    # Make sure the path variable exists and initialise it if it does not.
    if { [catch "set path"] != 0 } {
	set path ""
    }
    
    foreach dir $dirs {
	if { $dir != "" } {
	    # Convert to native file path format if requested
	    if { $native } {
		set d [file nativename $dir]
	    } else {
		set d $dir
	    }
	    
	    # Add the directory to the path variable.
	    if { $path == "" } {
		set path $d
	    } else {
		if { $tcl_platform(platform) == "windows" } {
		    append path ";$d"
		} else {
		    append path ":$d"
		}
	    }
	}
    }

    return ""
}


# ::diskutil::expand_filename --
#
#	Search a path like variable for a directory containing a given
#	file and return its path. This command is platform aware and
#	handles path separators as ";" on Windows and as ":" on UNIX.
#	Return an empty string if nothing was found.
#
# Arguments:
#	path	; or : separated path
#	fname	Name of file to look for
#
# Results:
#	Returns the full access path to the first file matching the
#	name and pointed at by the path specification.  An empty
#	string is returned if the file was not found.
#
# Side Effects:
#	None.
proc ::diskutil::expand_filename { path fname } {
    global tcl_platform

    if { $tcl_platform(platform) == "windows" } {
	set alldirs [split $path ";"]
    } else {
	set alldirs [split $path ":"]
    }
    
    foreach d $alldirs {
	set fullpath [file join $d $fname]
	if { [file exists $fullpath] } {
	    return $fullpath
	}
    }

    return ""
}


# ::diskutil::expand_execname --
#
#	Search a path like variable for a directory containing a given
#	file and return its path. This command is platform aware and
#	handles path separators as ";" on Windows and as ":" on UNIX.
#	On Windows, the command is intelligent enough to look for BAT
#	files and exe files also (appended to the raw file name).
#
# Arguments:
#	path	; or : separated path
#	fname	Name of file to look for
#
# Results:
#	Returns the full access path to the executable file matching
#	the name and pointed at by the path specification.  An empty
#	string is returned if the file was not found.
#
# Side Effects:
#	None.
proc ::diskutil::expand_execname { path fname } {
    global tcl_platform

    if { $tcl_platform(platform) == "windows" } {
	set alldirs [split $path ";"]
	set postfix [list "" ".bat" ".exe"]
    } else {
	set alldirs [split $path ":"]
	set postfix [list ""]
    }
    
    foreach d $alldirs {
	foreach p $postfix {
	    set fullpath [file join $d ${fname}${p}]
	    if { [file executable $fullpath] } {
		return $fullpath
	    }
	}
    }

    return ""
}


# ::diskutil::platform_tmp --
#
#	Returns the location of a valid machine-wide
#	platform-dependent temporary directory where files can be
#	stored.  The implementation is aware of the current
#	environment and of the current platform.  First it looks at
#	some well-known environement variables that might point to
#	valid directories.  Second it looks for a temporary directory
#	in well-known locations and depending on the platform.  On
#	Windows, this implementation attempts to prioritise the file
#	space that is associated to the current user.
#
# Arguments:
#	None.
#
# Results:
#	A valid temporary directory for file storage.
#
# Side Effects:
#	None.
proc ::diskutil::platform_tmp { } {
    global tcl_platform env

    # First try among some well-known environment variables for a
    # temporary directory
    set dir ""
    if { $dir eq "" && [array names env "TEMP"] == "TEMP" } {
	set dir $env(TEMP)
	if { ![file writable $dir] } {
	    set dir ""
	}
    }
    if { $dir eq "" && [array names env "TMP"] == "TMP" } {
	set dir $env(TMP)
	if { ![file writable $dir] } {
	    set dir ""
	}
    }
    if { $dir eq "" && [array names env "TMPDIR"] == "TMPDIR" } {
	set dir $env(TMPDIR)
	if { ![file writable $dir] } {
	    set dir ""
	}
    }

    # Try some more, in a platform dependent manner
    if { $dir == "" } {
	if { $tcl_platform(platform) == "windows" } {
	    # Try where it really should be, via the registry information
	    set dir [registry get {HKEY_CURRENT_USER\Environment} {TEMP}]
	    if { $dir ne "" } {
		# Replace environment variables by their values
		foreach e [array names env] {
		    regsub "%${e}%" $dir $env($e) dir
		}
		if { ![file writable $dir]} {
		    set dir ""
		}
	    }
	    if { $dir eq "" \
		     && [array names env "USERPROFILE"] == "USERPROFILE" } {
		set dir [file join $env(USERPROFILE) "Local Settings" "Temp"]
		if { ![file writable $dir]} {
		    set dir ""
		}
	    }
	    if { $dir eq "" && [array names env "WINDIR"] == "WINDIR" } {
		set dir [file join $env(WINDIR) "Temp"]
		if { ![file writable $dir]} {
		    set dir ""
		}
	    }
	    if { $dir eq "" \
		     && [array names env "SYSTEMROOT"] == "SYSTEMROOT" } {
		set dir [file join $env(SYSTEMROOT) "Temp"]
		if { ![file writable $dir]} {
		    set dir ""
		}
	    }
	    if { $dir eq "" } {
		set dir $env(SYSTEMROOT)
	    }
	} else {
	    if { [file isdirectory "/usr/tmp"] && [file writable "/usr/tmp"]} {
		set dir "/usr/tmp"
	    } elseif { [file isdirectory "/tmp"] && [file writable "/tmp"]} {
		set dir "/tmp"
	    }
	}
    }

    return [::diskutil::double_backslash $dir]
}



# ::diskutil::temporary_filename --
#
#	This command returns an adequate name to be used for a
#	temporary file.  It supports both a prefix and an extension so
#	as to ease future recognition of orphane temporary files.
#
# Arguments:
#	pfx	Optional prefix to the name of the file
#	ext	ptional extension of the file (might or not start with
#               a dot, a dot will always separate the name from the
#               extension anyhow)
#
# Results:
#	Returns a file name ready for use.
#
# Side Effects:
#	None.
proc ::diskutil::temporary_filename { { pfx "" } { ext "" } } {
    set time [clock clicks]
    if { $time < 0 } {
	set time [ expr - $time]
    }

    set name $pfx
    if { $pfx != "" } {
	append name "_"
    }

    append name [format "%d_%d" $time [expr int(1000*rand())]]
    if { $ext != "" } {
	if { [string index $ext 0] == "." } {
	    append name "$ext"
	} else {
	    append name ".$ext"
	}
    }

    return $name
}


# ::diskutil::temporary_file --
#
#	This command returns the absolute path to a temporary file.
#	It is up to the caller to create the file and check whether
#	creation was successful or not.  This command is a utility
#	wrapper around platform_tmp and temporary_filename.
#
# Arguments:
#	pfx	Optional prefix to the name of the file
#	ext	ptional extension of the file (might or not start with
#               a dot, a dot will always separate the name from the
#               extension anyhow)
#
# Results:
#	An absolute path to a temporary filename.
#
# Side Effects:
#	None.
proc ::diskutil::temporary_file { { pfx "" } { ext "" } } {
    # Return the path
    return [file join [platform_tmp] [temporary_filename $pfx $ext]]
}


# ::diskutil::temporary_file --
#
#	This command creates and returns the absolute path to a
#	temporary directory.  This command will create directories in
#	the directory returned by platform_tmp.
#
# Arguments:
#	pfx	Optional prefix to push in from of dir name
#
# Results:
#	An absolute path to a temporary directory.
#
# Side Effects:
#	None.
proc ::diskutil::temporary_directory { { prefix "" } } {
    set dir [platform_tmp]

    set done 0
    while { ! $done } {
	set time [clock clicks]
	if { $time < 0 } {
	    set time [ expr - $time]
	}
	set rawname [format "%d~%d" [expr $time % 100] [expr int(100*rand())]]
	if { $prefix == "" } {
	    set name $rawname
	} else {
	    set name "${prefix}_${rawname}"
	}
	set dirname [file join $dir $name]

	set res [catch "file mkdir $dirname"]
	if { $res == 0 && [file exists $dirname] } {
	    set done 1
	}
    }

    return $dirname
}


# ::diskutil::clean_directory --
#
#	This command cleans up all files and directories that match a
#	given pattern in a directory.  It allows to specify specific
#	files or directory that should be kept.  If <rm_ptn> is empty,
#	all files and sub directories of the directory are suppressed.
#	The command return the number of items removed, a negative
#	number on error.
#
# Arguments:
#	d	Directory to clean.
#	rm_ptn	Patterns (string match like) of file and directory names
#               to remove
#	keep_ptn	Patterns (string match like) of file and directory
#                       namesto keep (allows to keep some of the files and
#                       directories that would be removed by <rm_ptn>
#
# Results:
#	The number of file removed, a negative number in case of error.
#
# Side Effects:
#	Effectively remove the files!
proc ::diskutil::clean_directory { d { rm_ptn {} } { keep_ptn {} } } {
    variable log

    set current_d [pwd]
    
    ${log}::notice "Cleanup directory $d"

    if { [catch "cd \"$d\""] != 0 } {
	${log}::error "Could not change directory to \"$d\"!"
	return -1
    }
    
    set nb_removed 0
    if { [llength $rm_ptn] == 0 } {
	if { [catch "glob *" files] == 0 } {
	    foreach f $files {
		${log}::info "Removing: $f" 4
		if { [catch "file delete -force -- $f"] == 0 } {
		    incr nb_removed
		}
	    }
	}
    } else {
	foreach ptn $rm_ptn {
	    if { [catch "glob \"$ptn\"" files] == 0 } {
		foreach f $files {
		    set match 0
		    foreach ptn $keep_ptn {
			if { [string match "$ptn" "$f"] } {
			    set match 1
			    break
			}
		    }
		    
		    if { ! $match } {
			${log}::info "Removing: $f"
			if { [catch "file delete -force -- $f"] == 0 } {
			    incr nb_removed
			}
		    }
		}
	    }
	}
    }

    cd $current_d
    return $nb_removed
}


# ::diskutil::concat_files --
#
#	Concatenate one or serveral files one after the other to
#	produce another file.  
#
# Arguments:
#	dst_file	Name of destination file
#	in_files	List of paths to the files to be concatenated.
#
# Results:
#	Return the number of concatenated files.
#
# Side Effects:
#	Create a file.  If it existed, its old content will be lost.
proc ::diskutil::concat_files { dst_file in_files } {
    set nb_f 0
    set f [open $dst_file "w"]
    foreach in_file $in_files {
	if { [file exists $in_file] && [file readable $in_file] } {
	    set in [open $in_file]
	    puts $f [read $in]
	    close $in
	    incr nb_f
	}
    }
    close $f

    return $nb_f
}


# ::diskutil::fname_resolv --
#
#	Replace %key% strings in a series of filenames and return the
#	resulting file name.  The recognised keys are the
#	following. Every index of the tcl_platform global variable
#	will be recognised as a key, this includes useful keys such as
#	%os%, %platform% or %user%. A number of handcrafted keys are
#	also recognised.  These are %progdir% - the directory path to
#	the "executable" being run, i.e. the main Tcl script - and
#	%progname% - the raw name of the executable being run, without
#	extension, nor directory name.  An argument allows to use
#	another alternative path for %progname% and %progdir%, but
#	these keys will default to using the global argv0 variable.
#
# Arguments:
#	fnames	(list of) file names.
#	prgpath	Full path to program being used for %progdir% and %progname%
#
# Results:
#	A modified (list of) file names
#
# Side Effects:
#	None.
proc ::diskutil::fname_resolv { fnames { prgpath "" } } {
    global tcl_platform

    # Replace the content of any index in the tcl_platform array
    foreach name [array names tcl_platform] {
	regsub "%${name}%" $fnames $tcl_platform($name) fnames
    }

    # Provides support for "%hostname%"
    if { [info commands "::dnsresolv::hostname"] != "" } {
	regsub "%hostname%" $fnames [::dnsresolv::hostname] fnames
    } else {
	regsub "%hostname%" $fnames [info hostname] fnames
    }

    # Provides support for "%progdir%"
    if { $prgpath == "" } {
	if { [info exists ::starkit::topdir] } {
	    set prgpath $::starkit::topdir
	} else {
	    set prgpath $::argv0
	}
    }
    regsub "%progdir%" $fnames [file dirname $prgpath] fnames
    regsub "%progname%" $fnames [file rootname [file tail $prgpath]] fnames
    
    return $fnames
}


# ::diskutil::__rotate_fname -- Generate rotation name
#
#	Generates the name of a rotation file.  If the input file name
#	contains a zero (0) or one (1), it will be replaced by the
#	number passed as an argument. Otherwise, the number will be
#	appended to the file name.
#
# Arguments:
#	rot_fname	Name template of file to rotate
#	num     	Sequencer
#
# Results:
#	Return the rotation file name
#
# Side Effects:
#	None.
proc ::diskutil::__rotate_fname { rot_fname num } {
    # Find first figure from the list in the main template
    foreach figure [list 0 1] {
	set idx [string last $figure $rot_fname]
	if { $idx >= 0 } {
	    break
	}
    }

    if { $idx >= 0 } {
	set out_fname [string range $rot_fname 0 [expr {$idx - 1}]]
	append out_fname $num
	append out_fname [string range $rot_fname [expr {$idx + 1}] end]
    } else {
	set out_fname "${rot_fname}.${num}"
    }
    return $out_fname
}


# ::diskutil::rotate -- Rotate files in directory
#
#	Rotate files (such as log files) in a directory.  An input
#	file (generally the file that is dynamically changed) will be
#	moved in the archive and a number of existing files in the
#	archive will be kept.
#
# Arguments:
#	in_fname	Full path to the input file, the routine handles
#                       archive increments correctly even if it contains a
#                       zero.
#	keep     	Number of archive files to keep (zero is valid!)
#	rot_fname     	Path to the rotation archive.  Any 0 or 1 in the name
#                       will be replaced by the archive increments (otherwise
#                       these will be appended).  Relative paths will be
#                       appended to the directory of the input file.  An
#                       empty string takes the input file name as a template.
#
# Results:
#	None.
#
# Side Effects:
#	Will rename, move and even remove files on disk appropriately
proc ::diskutil::rotate { in_fname { keep 4 } { rot_fname "" } } {
    variable DiskUtil
    variable log

    # Decide upon the name template for the rotation files.  An empty
    # string will be understood as the same as the "pumped" file,
    # i.e. the incoming file for the rotation.  Otherwise, the
    # rotation files are joined with the directory of the input file,
    # which allows to cover both the case of relative and absolute
    # path names for the destination.
    if { $rot_fname eq "" } {
	set rot_fname $in_fname
    } else {
	set rot_fname [file join [file dirname $in_fname] $rot_fname]
    }

    # If the input (pump) file name contains a zero then rotation will
    # start at index 1 only.
    if { [string last "0" [file tail $in_fname]] } {
	set start 1
    } else {
	set start 0
    }

    # Rotate already existing files.
    for { set i [expr {$keep - 1}]} { $i >= $start } { incr i -1 } {
	if { [file exists [__rotate_fname $rot_fname $i]] } {
	    ${log}::debug "Moving \"[__rotate_fname $rot_fname $i]\"\
		           to \"[__rotate_fname $rot_fname [expr {$i + 1}]]\""
	    if { [catch {file rename -force -- \
			     [__rotate_fname $rot_fname $i] \
			     [__rotate_fname $rot_fname [expr {$i + 1}]]} \
		      err] } {
		${log}::warn \
		    "Could not rename \"[__rotate_fname $rot_fname $i]\"\
		     to \"[__rotate_fname $rot_fname [expr {$i + 1}]]\": $err"
	    }
	}
    }

    # And perform the last rotation, which means installing the input
    # pump file as first in the rotation list.
    if { $keep >= 1 } {
	${log}::debug \
	    "Moving \"$in_fname\" to \"[__rotate_fname $rot_fname $start]\""
	if { [catch {file rename -force -- \
			 $in_fname [__rotate_fname $rot_fname $start]} err] } {
	    ${log}::warn "Could not rename \"$in_fname\"\
                          to \"[__rotate_fname $rot_fname $start]\": $err"
	}
    } else {
	${log}::debug "Removing \"$in_fname\""
	if { [catch {file delete -force -- $in_fname} err] } {
	    ${log}::warn "Could not remove \"in_fname\": $err"
	}
    }
}


# ::diskutil::__computesignature -- Compute a file signature
#
#	This command computes an integer signature for the file which
#	name is passed as an argument.  The signature can be based on
#	the root name of the file, its size and its modification,
#	which should guarantee that the integer will change as soon as
#	the file changes.
#
# Arguments:
#	fname	Path to file
#	what	What to compute
#	max	max value
#
# Results:
#	An integer identifying the file
#
# Side Effects:
#	None.
proc ::diskutil::__computesignature { fname {what "size mtime name"}
				      {max 2147483647}} {
    variable DiskUtil
    variable log

    set sig 0
    if { [lsearch $what "name"] >= 0 } {
	set rname [file tail $fname]
	for { set i 0 } { $i < [string length $rname] } { incr i } {
	    set sig [expr ($sig + [scan [string index $rname $i] %c]) % $max]
	}
    }
    if { [lsearch $what "size"] >= 0 } {
	set size [file size $fname]
	set sig [expr ($sig + [file size $fname]) % $max]
    }
    if { [lsearch $what "mtime"] >= 0 } {
	set mtime [file mtime $fname]
	set sig [expr ($sig + [file mtime $fname]) % $max]
    }
    ${log}::debug "Signature of $fname is $sig"

    return $sig
}


# ::diskutil::match -- Match a file name
#
#	Match a file name against a list of allowed / denied filters
#	and return whether the file should be treated or not.
#
# Arguments:
#	fname	name of file
#	consider	List of regular expressions for file names to consider
#	ignore	List of regular expressions for file names to ignore
#
# Results:
#	Return a boolean telling whether the file should be handled or not.
#
# Side Effects:
#	None.
proc ::diskutil::match { fname {consider {".*"}} {ignore {}} } {
    variable DiskUtil
    variable log

    set do 0
    foreach rxp $consider {
	if { [catch {regexp $rxp $fname} res] == 0 } {
	    if { $res } {
		set do 1
		break
	    }
	} else {
	    ${log}::warn "Failed matching $rxp against $fname: $res"
	}
    }
    
    set dont 0
    foreach rxp $ignore {
	if { [catch {regexp $rxp $fname} res] == 0 } {
	    if { $res } {
		set dont 1
		break
	    }
	} else {
	    ${log}::warn "Failed matching $rxp against $fname: $res"
	}
    }

    return [expr {$do && !$dont}]
}


# ::diskutil::__signature -- Recursive signature computation
#
#	This command performs signature computation of directory trees
#	according to the directives contained in the context pointed
#	at by the identifier.  This command is the core of the
#	signature computation and performs the work as described in
#	::diskutil::signature.
#
# Arguments:
#	id	Identifier of signature context
#	fname	Name of file to test during recursion.
#
# Results:
#	None
#
# Side Effects:
#	Will store signature computation in the context.
proc ::diskutil::__signature { id fname } {
    variable DiskUtil
    variable log

    set varname ::diskutil::sig_$id
    upvar \#0 $varname Signature
    
    set fsig 0
    if { [match $fname $Signature(-consider) $Signature(-ignore)] } {
	if { [file isdirectory $fname] } {
	    if { ! ([string is true $Signature(-ignoretop)] \
			&& $fname == $Signature(fname)) } {
		set fsig [__computesignature $fname $Signature(-compute) \
			      $Signature(-max)]
	    }
	    set allfiles [glob -nocomplain ${fname}/*]
	    foreach f $allfiles {
		__signature $id $f
	    }
	} else {
	    set fsig [__computesignature $fname $Signature(-compute) \
			  $Signature(-max)]
	}
    }
    
    set Signature(signature) \
	[expr ($Signature(signature) + $fsig) % $Signature(-max)]
}


# ::diskutil::signature -- Compute a file/directory signature
#
#	This command computes an integer signature for the
#	file/directory which name is passed as an argument.  The
#	signature is based on the root name of the file, its size and
#	its modification, which should guarantee that the integer will
#	change as soon as the file changes.  Directories are recursed
#	across all their files to take inner changes into account.
#	This command takes options, all starting with a leading dash
#	(-) and followed by a value.  These are: -compute tells which
#	elements should be used for computing every single signature,
#	it is a list of the following strings: size (size of the
#	file), name (name (tail) of file), mtime (modification time)
#	and defaults to {size name mtime}; -ignoretop tells if the top
#	(directory) should be set aside when computing the signature
#	(which allows to compare directory hierarchies in different
#	places); -ignore allows to set aside special files or
#	directories (it is a list of regular expressions and defaults
#	to .*~$ .*bak$); -consider tells which files and directories
#	should be considered during traversal (same as above, defaults
#	to .*); -max is the maximum integer when doing signature
#	calculations, all elements will be added modulo that value.
#
# Arguments:
#	fname	Path to file
#
# Results:
#	An integer identifying the file
#
# Side Effects:
#	None.
proc ::diskutil::signature { fname args } {
    variable DiskUtil
    variable log

    # Create context with default values
    if { [array names DiskUtil idgene] == "" } { set DiskUtil(idgene) 0 }
    set id [incr DiskUtil(idgene)]
    set varname ::diskutil::sig_$id
    upvar \#0 $varname Signature
    array set Signature {
	-compute      "size name mtime"
	-ignoretop    off
	-consider     ".*"
	-ignore       ".*~$ .*bak$"
	-max          2147483647
    }
    set Signature(id) $id
    set Signature(fname) $fname
    set Signature(signature) 0
    
    # Parse options and store requested options.
    set o [lsort [array names Signature "-*"]]
    foreach {opt value} $args {
	if { [lsearch $o $opt] == -1 } {
	    return -code error "Unkown option $opt, must be: [join $o ", " ]"
	}
	set Signature($opt) $value
    }

    # Recurse through tree and do the work.
    __signature $id $fname
    
    # And return result.
    ${log}::info "Signature of $fname is $Signature(signature)"
    set sig $Signature(signature)
    unset Signature

    return $sig
}

package provide diskutil 1.9