<commit_before># 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

package require Tcl 8.2
package require logger

package provide diskutil 1.9

namespace eval ::diskutil {
    
    # Initialise global state.
    variable DiskUtil
    if {![info exists DiskUtil]} {
	array set DiskUtil {
	    tmpdir             ""
	    gtmpdir            ""
	    winemu_dir         "~/.CommonStore"
	    loglevel           warn
	    comments           "\#"
	    empty              {\"\" \{\} -}
	    dft_prgpath        ""
	    resolvers          {::tcl_platform "" 0 * ::env "" 1 *}
	    idgene             0
	}
	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
    namespace export fname_resolve resolver
}


# ::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 ""
}


proc ::diskutil::__first_dir_of { dirlist } {
}


# ::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.  The procedure
#	caches its result for future access.
#
# Arguments:
#	None.
#
# Results:
#	A valid temporary directory for file storage, an empty string
#	on errors.
#
# Side Effects:
#	None.
proc ::diskutil::platform_tmp { } {
    global tcl_platform env
    variable DiskUtil
    variable log

    if { $DiskUtil(tmpdir) == "" } {
	set dirlist [list]
	if { [array names env "TEMP"] == "TEMP" } {
	    lappend dirlist $env(TEMP)
	}
	if { [array names env "TMP"] == "TMP" } {
	    lappend dirlist $env(TMP)
	}
	if { [array names env "TMPDIR"] == "TMPDIR" } {
	    lappend dirlist $env(TMPDIR)
	}
	if { $tcl_platform(platform) == "windows" } {
	    # Windows Vista introduced a new way to organise things
	    # up.  Start with LOCALAPPDATA, it is completely safe
	    # since on older OSes the variable doesn't even
	    # exist. Usually, the TEMP variable should be the same as
	    # the test below, but in some extreme cases TEMP is not
	    # set (for example, when starting from within cygwin).
	    if { [array names env "LOCALAPPDATA"] == "LOCALAPPDATA" } {
		lappend dirlist [file join $env(LOCALAPPDATA) "Temp"]
	    }
	    # This is on NT, 98, etc. Problem is that "Local Settings"
	    # actually sometimes is in the local language of the OS,
	    # e.g. "Lokala Instllningar" in Swedish.
	    if { [array names env "USERPROFILE"] == "USERPROFILE" } {
		lappend dirlist \
		    [file join $env(USERPROFILE) "Local Settings" "Temp"]
	    }
	    # There used to be such a dir, I wonder it still exists at
	    # all and is accessible. Adding it for "in case".
	    if { [array names env "WINDIR"] == "WINDIR" } {
		lappend dirlist [file join $env(WINDIR) "Temp"]
	    }
	    if { [array names env "SYSTEMROOT"] == "SYSTEMROOT" } {
		lappend dirlist [file join $env(SYSTEMROOT) "Temp"]
	    }
	} else {
	    lappend dirlist "/usr/tmp/"
	    lappend dirlist "/tmp"
	}

	# Parse the list of possible temporary directories and try to
	# see if they really are directories that we can access.
	# Maybe we should also do a file writable, but on windows this
	# always returns 1 on directories (it seems to be at least).
	foreach d $dirlist {
	    if { [file isdirectory $d] } {
		# The glob will catch if the directory does not
		# properly exist or cannot be access.
		if { ! [catch {glob -nocomplain -directory $d -- *} err] } {
		    set DiskUtil(tmpdir) $d
		    break
		}
	    }
	}
	if { $DiskUtil(tmpdir) == "" } {
	    ${log}::error "Could not find a temporary directory!"
	} else {
	    ${log}::notice "Will use $DiskUtil(tmpdir) as temporary directory"
	}
    }
    return [::diskutil::double_backslash $DiskUtil(tmpdir)]
}



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


proc ::diskutil::global_platform_tmp {} {
    global tcl_platform env
    variable DiskUtil
    variable log

    if { $DiskUtil(gtmpdir) == "" } {
	set dirlist {}
	if { $tcl_platform(platform) == "windows" } {
	    if { [info exists env(ALLUSERSPROFILE)] } {
		# Cope with XP, where we had an Application Data, but
		# also with later versions av windows, where we don't.
		if { [info exists env(APPDATA)] } {
		    lappend dirlist \
			[file join $env(ALLUSERSPROFILE) \
			     [file tail $env(APPDATA)]]
		}
		lappend dirlist \
		    [file join $env(ALLUSERSPROFILE) "Application Data"]
		lappend dirlist \
		    [file join $env(ALLUSERSPROFILE)]
	    }
	    # There used to be such a dir, I wonder it still exists at
	    # all and is accessible. Adding it for "in case".
	    if { [info exists env(WINDIR)] } {
		lappend dirlist [file join $env(WINDIR) "Temp"]
	    }
	    if { [info exists env(SYSTEMROOT)] } {
		lappend dirlist [file join $env(SYSTEMROOT) "Temp"]
	    }
	} else {
	    set dirlist [list "/usr/tmp" "/var/tmp"]
	    if { [info exists env(TMPDIR)] } {
		lappend dirlist [file join $env(TMPDIR)]
	    }
	}

	# Parse the list of possible temporary directories and try to
	# see if they really are directories that we can access.
	# Maybe we should also do a file writable, but on windows this
	# always returns 1 on directories (it seems to be at least).
	foreach d $dirlist {
	    if { [file isdirectory $d] } {
		# The glob will catch if the directory does not
		# properly exist or cannot be access.
		if { ! [catch {glob -nocomplain -directory $d -- *} err] } {
		    set DiskUtil(gtmpdir) $d
		    break
		}
	    }
	}
	if { $DiskUtil(gtmpdir) == "" } {
	    ${log}::error "Could not find a temporary directory!"
	} else {
	    ${log}::notice "Will use $DiskUtil(gtmpdir) as global \
                            temporary directory"
	}
    }
    return [::diskutil::double_backslash $DiskUtil(gtmpdir)]
}


proc ::diskutil::global_app_directory { { prgpath "" } { prgname "" } } {
    variable DiskUtil
    variable log

    if { $prgpath == "" } {
	# Make sure to actually store the program path in a local
	# variable in case the path contained a "." and was therefore
	# related to the current directory at start. This because,
	# obviously, the current directory can change at any time!
	if { $DiskUtil(dft_prgpath) == "" } {
	    if { [info exists ::starkit::topdir] } {
		set DiskUtil(dft_prgpath) [normalize $::starkit::topdir]
	    } else {
		set DiskUtil(dft_prgpath) [normalize $::argv0]
	    }
	    ${log}::info "Default program path is at $DiskUtil(dft_prgpath)"
	}
	set prgpath $DiskUtil(dft_prgpath)
    }

    if { $prgname eq "" } {
	set prgname [file rootname [file tail $prgpath]]
    }
    set dir [file join [global_platform_tmp] $prgname]
    if { [catch {file mkdir $dir} err] } {
	${log}::error "Cannot create global storage for app at $dir: $err"
	set dir ""
    }
    return $dir
}


# ::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"]<commit_msg>Arrange to be able to prefer prior location for global program directory between sessions.<commit_after># 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

package require Tcl 8.2
package require logger

package provide diskutil 1.9

namespace eval ::diskutil {
    
    # Initialise global state.
    variable DiskUtil
    if {![info exists DiskUtil]} {
	array set DiskUtil {
	    tmpdir             ""
	    gtmpdir            ""
	    winemu_dir         "~/.CommonStore"
	    loglevel           warn
	    comments           "\#"
	    empty              {\"\" \{\} -}
	    dft_prgpath        ""
	    resolvers          {::tcl_platform "" 0 * ::env "" 1 *}
	    idgene             0
	}
	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
    namespace export fname_resolve resolver
}


# ::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 ""
}


proc ::diskutil::__first_dir_of { dirlist } {
}


# ::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.  The procedure
#	caches its result for future access.
#
# Arguments:
#	None.
#
# Results:
#	A valid temporary directory for file storage, an empty string
#	on errors.
#
# Side Effects:
#	None.
proc ::diskutil::platform_tmp { } {
    global tcl_platform env
    variable DiskUtil
    variable log

    if { $DiskUtil(tmpdir) == "" } {
	set dirlist [list]
	if { [array names env "TEMP"] == "TEMP" } {
	    lappend dirlist $env(TEMP)
	}
	if { [array names env "TMP"] == "TMP" } {
	    lappend dirlist $env(TMP)
	}
	if { [array names env "TMPDIR"] == "TMPDIR" } {
	    lappend dirlist $env(TMPDIR)
	}
	if { $tcl_platform(platform) == "windows" } {
	    # Windows Vista introduced a new way to organise things
	    # up.  Start with LOCALAPPDATA, it is completely safe
	    # since on older OSes the variable doesn't even
	    # exist. Usually, the TEMP variable should be the same as
	    # the test below, but in some extreme cases TEMP is not
	    # set (for example, when starting from within cygwin).
	    if { [array names env "LOCALAPPDATA"] == "LOCALAPPDATA" } {
		lappend dirlist [file join $env(LOCALAPPDATA) "Temp"]
	    }
	    # This is on NT, 98, etc. Problem is that "Local Settings"
	    # actually sometimes is in the local language of the OS,
	    # e.g. "Lokala Instllningar" in Swedish.
	    if { [array names env "USERPROFILE"] == "USERPROFILE" } {
		lappend dirlist \
		    [file join $env(USERPROFILE) "Local Settings" "Temp"]
	    }
	    # There used to be such a dir, I wonder it still exists at
	    # all and is accessible. Adding it for "in case".
	    if { [array names env "WINDIR"] == "WINDIR" } {
		lappend dirlist [file join $env(WINDIR) "Temp"]
	    }
	    if { [array names env "SYSTEMROOT"] == "SYSTEMROOT" } {
		lappend dirlist [file join $env(SYSTEMROOT) "Temp"]
	    }
	} else {
	    lappend dirlist "/usr/tmp/"
	    lappend dirlist "/tmp"
	}

	# Parse the list of possible temporary directories and try to
	# see if they really are directories that we can access.
	# Maybe we should also do a file writable, but on windows this
	# always returns 1 on directories (it seems to be at least).
	foreach d $dirlist {
	    if { [file isdirectory $d] } {
		# The glob will catch if the directory does not
		# properly exist or cannot be access.
		if { ! [catch {glob -nocomplain -directory $d -- *} err] } {
		    set DiskUtil(tmpdir) $d
		    break
		}
	    }
	}
	if { $DiskUtil(tmpdir) == "" } {
	    ${log}::error "Could not find a temporary directory!"
	} else {
	    ${log}::notice "Will use $DiskUtil(tmpdir) as temporary directory"
	}
    }
    return [::diskutil::double_backslash $DiskUtil(tmpdir)]
}



# ::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::global_platform_tmp -- Computer-wide storage location
#
#       This will return the location of a directory where to store files and
#       directory on a computer-wide basis, i.e. files and directory that would
#       be program dependent by might be accessed (and modified) by all users of
#       the program. Directory lookup is cached for the life of the program in a
#       global variable to this module.
#
# Arguments:
#       witness A glob-style pattern to prefer a directory that would already
#               contain something that matches. When not found, first existing
#               working directory will be returned.
#
# Results:
#       The full-path to the directory
#
# Side Effects:
#       Uses the pattern to look for presence of files and check their access.
proc ::diskutil::global_platform_tmp { {witness "*"} } {
    global tcl_platform env
    variable DiskUtil
    variable log

    if { $DiskUtil(gtmpdir) == "" } {
	set dirlist {}
	if { $tcl_platform(platform) == "windows" } {
	    if { [info exists env(ALLUSERSPROFILE)] } {
		# Cope with XP, where we had an Application Data, but
		# also with later versions av windows, where we don't.
		if { [info exists env(APPDATA)] } {
		    lappend dirlist \
			[file join $env(ALLUSERSPROFILE) \
			     [file tail $env(APPDATA)]]
		}
		lappend dirlist \
		    [file join $env(ALLUSERSPROFILE) "Application Data"]
		lappend dirlist \
		    [file join $env(ALLUSERSPROFILE)]
	    }
	    # There used to be such a dir, I wonder it still exists at
	    # all and is accessible. Adding it for "in case".
	    if { [info exists env(WINDIR)] } {
		lappend dirlist [file join $env(WINDIR) "Temp"]
	    }
	    if { [info exists env(SYSTEMROOT)] } {
		lappend dirlist [file join $env(SYSTEMROOT) "Temp"]
	    }
	} else {
	    set dirlist [list "/usr/tmp" "/var/tmp"]
	    if { [info exists env(TMPDIR)] } {
		lappend dirlist [file join $env(TMPDIR)]
	    }
	}

	# Parse the list of possible temporary directories and try to
	# see if they really are directories that we can access and where we can
	# find the witness pattern. Maybe we should also do a file writable, but
	# on windows this always returns 1 on directories (it seems to be at
	# least).
	foreach d $dirlist {
	    if { [file isdirectory $d] } {
		# The glob will catch if the directory does not properly exist
		# or cannot be access.
		if { [catch {glob -nocomplain -directory $d -- $witness} content] == 0 } {
		    # We capture the first directory that contains the
		    # "witness". In case the witness was the special case that
		    # matches anything, we accept any directory that would just
		    # not be empty.
		    if { $witness eq "*" || [llength $content] > 0 } {
			set DiskUtil(gtmpdir) $d
			break
		    }
		}
	    }
	}
	if { $DiskUtil(gtmpdir) == "" } {
	    if { $witness eq "*" } {
		${log}::error "Could not find a temporary directory!"
	    } else {
		# Recurse once and only once more to look for first matching
		# directory.
		return [global_platform_tmp *]
	    }
	} else {
	    ${log}::notice "Will use $DiskUtil(gtmpdir) as global \
                            temporary directory"
	}
    }
    return [::diskutil::double_backslash $DiskUtil(gtmpdir)]
}


proc ::diskutil::global_app_directory { { prgpath "" } { prgname "" } } {
    variable DiskUtil
    variable log

    if { $prgpath == "" } {
	# Make sure to actually store the program path in a local
	# variable in case the path contained a "." and was therefore
	# related to the current directory at start. This because,
	# obviously, the current directory can change at any time!
	if { $DiskUtil(dft_prgpath) == "" } {
	    if { [info exists ::starkit::topdir] } {
		set DiskUtil(dft_prgpath) [normalize $::starkit::topdir]
	    } else {
		set DiskUtil(dft_prgpath) [normalize $::argv0]
	    }
	    ${log}::info "Default program path is at $DiskUtil(dft_prgpath)"
	}
	set prgpath $DiskUtil(dft_prgpath)
    }

    if { $prgname eq "" } {
	set prgname [file rootname [file tail $prgpath]]
    }
    set dir [file join [global_platform_tmp $prgname] $prgname]
    if { [catch {file mkdir $dir} err] } {
	${log}::error "Cannot create global storage for app at $dir: $err"
	set dir ""
    }
    return $dir
}


# ::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"]
{'fraction_non_alphanumeric': 0.10988899845760955, 'fraction_numerical': 0.004146754658777719, 'mean_word_length': 2.8431639296472646, 'pattern_counts': {'":': 10, '<': 13, '<?xml version=': 0, '>': 12, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2446402', 'n_tokens_mistral': 13389, 'n_tokens_neox': 12683, 'n_words': 4811}