xvfs.tcl at tip

File lib/xvfs/xvfs.tcl from the latest check-in


#! /usr/bin/env tclsh

namespace eval ::xvfs {}
namespace eval ::xvfs::callback {}

set ::xvfs::_xvfsDir [file dirname [info script]]

# Functions
proc ::xvfs::_emitLine {line} {
	lappend ::xvfs::_emitLine $line
}

proc ::xvfs::printHelp {channel {errors ""}} {
	if {[llength $errors] != 0} {
		foreach error $errors {
			puts $channel "error: $error"
		}
		puts $channel ""
	}
	puts $channel "Usage: xvfs-create \[--help\] \[--static-init {true|false}\] \[--set-mode {flexible|standalone|client}\] \[--output <filename>\] --directory <rootDirectory> --name <fsName>"
	flush $channel
}

proc ::xvfs::sanitizeCString {string} {
	set output [join [lmap char [split $string ""] {
		if {![regexp {[A-Za-z0-9./-]} $char]} {
			binary scan $char H* char
			set char "\\[format %03o 0x$char]"
		}

		set char
	}] ""]

	return $output
}

proc ::xvfs::sanitizeCStringList {list {prefix ""} {width 80}} {
	set lines [list]
	set row [list]
	foreach item $list {
		lappend row "\"[sanitizeCString $item]\""
		
		set rowString [join $row {, }]
		set rowString "${prefix}${rowString}"
		if {[string length $rowString] > $width} {
			set row [list]
			lappend lines "${rowString},"
			unset rowString
		}
	}
	if {[info exists rowString]} {
		lappend lines $rowString
	}
	
	return [join $lines "\n"]
}

proc ::xvfs::binaryToCHex {binary {prefix ""} {width 10}} {
	set binary [binary encode hex $binary]
	set output [list]

	set width [expr {$width * 2}]
	set stopAt [expr {$width - 1}]

	set offset 0
	while 1 {
		set row [string range $binary $offset [expr {$offset + $stopAt}]]
		if {[string length $row] == 0} {
			break
		}
		incr offset [string length $row]

		set rowOutput [list]
		while {$row ne ""} {
			set value [string range $row 0 1]
			set row [string range $row 2 end]

			lappend rowOutput "\\x$value"
		}
		set rowOutput [join $rowOutput {}]
		set rowOutput "${prefix}\"${rowOutput}\""
		lappend output $rowOutput
	}

	if {[llength $output] == 0} {
		return "${prefix}\"\""
	}

	set output [join $output "\n"]
}

proc ::xvfs::processFile {fsName inputFile outputFile fileInfoDict} {
	array set fileInfo $fileInfoDict

	switch -exact -- $fileInfo(type) {
		"file" {
			set type "XVFS_FILE_TYPE_REG"
			if {[info exists fileInfo(fileContents)]} {
				set data $fileInfo(fileContents)
			} else {
				set fd [open $inputFile]
				fconfigure $fd -encoding binary -translation binary -blocking true
				set data [read $fd]
				close $fd
			}
			set size [string length $data]
			set data [string trimleft [binaryToCHex $data "\t\t\t"]]
		}
		"directory" {
			set type "XVFS_FILE_TYPE_DIR"
			set children $fileInfo(children)
			set size [llength $children]
			
			if {$size == 0} {
				set children "NULL"
			} else {
				set children [string trimleft [sanitizeCStringList $children "\t\t\t"]]
				# This initializes it using a C99 compound literal, C99 is required
				set children "(const char *\[\]) \{$children\}"
			}
		}
		default {
			return -code error "Unable to process $inputFile, unknown type: $fileInfo(type)"
		}
	}

	::xvfs::_emitLine "\t\{"
	::xvfs::_emitLine "\t\t.name = \"[sanitizeCString $outputFile]\","
	::xvfs::_emitLine "\t\t.type = $type,"
	switch -exact -- $fileInfo(type) {
		"file" {
			::xvfs::_emitLine "\t\t.data.fileContents = (const unsigned char *) $data,"
		}
		"directory" {
			::xvfs::_emitLine "\t\t.data.dirChildren  = $children,"
		}
	}
	::xvfs::_emitLine "\t\t.size = $size"
	::xvfs::_emitLine "\t\},"
}

proc ::xvfs::processDirectory {fsName directory {subDirectory ""}} {
	set subDirectories [list]
	set outputFiles [list]
	set workingDirectory [file join $directory $subDirectory]
	set outputDirectory $subDirectory

	if {$subDirectory eq ""} {
		set isTopLevel true
	} else {
		set isTopLevel false
	}

	if {$isTopLevel} {
		::xvfs::_emitLine "static const struct xvfs_file_data xvfs_${fsName}_data\[\] = \{"
	}

	# XXX:TODO: Include hidden files ?
	set children [list]
	foreach file [glob -nocomplain -tails -directory $workingDirectory *] {
		if {$file in {. ..}} {
			continue
		}

		set inputFile [file join $workingDirectory $file]
		set outputFile [file join $outputDirectory [encoding convertto utf-8 $file]]
		set subDirectoryName [file join $outputDirectory $file]

		if {[info command ::xvfs::callback::setOutputFileName] ne ""} {
			set outputFile [::xvfs::callback::setOutputFileName $file $workingDirectory $inputFile $outputDirectory $outputFile]
			if {$outputFile eq "/"} {
				continue
			}
		}

		unset -nocomplain fileInfo
		catch {
			file lstat $inputFile fileInfo
		}
		if {![info exists fileInfo]} {
			puts stderr "warning: Unable to access $inputFile, skipping"
		}

		if {$fileInfo(type) eq "directory"} {
			lappend subDirectories $subDirectoryName
			continue
		}

		processFile $fsName $inputFile $outputFile [array get fileInfo]
		lappend outputFiles $outputFile
	}

	foreach subDirectory $subDirectories {
		lappend outputFiles {*}[processDirectory $fsName $directory $subDirectory]
	}
	
	set inputFile $directory
	set outputFile $outputDirectory
	if {[info command ::xvfs::callback::setOutputFileName] ne ""} {
		set outputFile [::xvfs::callback::setOutputFileName $directory $directory $inputFile $outputDirectory $outputFile]
	}

	if {$outputFile ne "/"} {
		unset -nocomplain fileInfo
		file stat $inputFile fileInfo
		set children [list]
		set outputFileLen [string length $outputFile]
		foreach child $outputFiles {
			if {[string range /$child 0 $outputFileLen] eq "/${outputFile}"} {
				set child [string trimleft [string range $child $outputFileLen end] /]
				if {![string match "*/*" $child]} {
					lappend children $child
				}
			}
		}
		set fileInfo(children) $children

		processFile $fsName $inputFile $outputFile [array get fileInfo]
		lappend outputFiles $outputFile
	}

	if {$isTopLevel} {
		if {[info command ::xvfs::callback::addOutputFiles] ne ""} {
			lappend outputFiles {*}[::xvfs::callback::addOutputFiles $fsName]
		}

		::xvfs::_emitLine "\};"
	}

	return $outputFiles
}

proc ::xvfs::main {argv} {
	# Main entry point
	## 1. Parse arguments
	if {[llength $argv] % 2 != 0} {
		lappend argv ""
	}

	set staticInit false
	foreach {arg val} $argv {
		switch -exact -- $arg {
			"--help" {
				printHelp stdout
				exit 0
			}
			"--directory" {
				set rootDirectory $val
			}
			"--name" {
				set fsName $val
			}
			"--static-init" {
				set staticInit $val
			}
			"--output" - "--header" - "--set-mode" {
				# Ignored, handled as part of some other process
			}
			default {
				printHelp stderr [list "Invalid option: $arg $val"]
				exit 1
			}
		}
	}

	## 2. Validate arguments
	set errors [list]
	if {![info exists rootDirectory]} {
		lappend errors "--directory must be specified"
	}
	if {![info exists fsName]} {
		lappend errors "--name must be specified"
	}

	if {[llength $errors] != 0} {
		printHelp stderr $errors
		exit 1
	}

	## 3. Initialization
	if {$staticInit} {
		::xvfs::_emitLine "#define XVFS_${fsName}_INIT_STATIC 1"
	}

	## 4. Start processing directory and producing initial output
	set ::xvfs::outputFiles [processDirectory $fsName $rootDirectory]

	set ::xvfs::fsName $fsName
	set ::xvfs::rootDirectory $rootDirectory

	# Return the output
	return [join $::xvfs::_emitLine "\n"]
}

proc ::xvfs::run {args} {
	uplevel #0 { package require minirivet }

	set ::xvfs::argv $args
	::minirivet::parse [file join $::xvfs::_xvfsDir xvfs.c.rvt]
}

proc ::xvfs::setOutputChannel {channel} {
	uplevel #0 { package require minirivet }
	tailcall ::minirivet::setOutputChannel $channel
}

proc ::xvfs::setOutputVariable {variable} {
	uplevel #0 { package require minirivet }
	tailcall ::minirivet::setOutputVariable $variable
}

proc ::xvfs::staticIncludeHeaderData {headerData} {
	set ::xvfs::xvfsCoreH $headerData
}

proc ::xvfs::staticIncludeHeader {pathToHeaderFile} {
	set fd [open $pathToHeaderFile]
	::xvfs::staticIncludeHeaderData [read $fd]
	close $fd
}

proc ::xvfs::setSpecificMode {mode} {
	::minirivet::_emitOutput "#undef XVFS_MODE_SERVER\n"
	::minirivet::_emitOutput "#undef XVFS_MODE_CLIENT\n"
	::minirivet::_emitOutput "#undef XVFS_MODE_FLEXIBLE\n"
	::minirivet::_emitOutput "#undef XVFS_MODE_STANDALONE\n"
	::minirivet::_emitOutput "#define XVFS_MODE_[string toupper $mode] 1\n"
}

proc ::xvfs::_tryFit {list} {
	set idx -1
	set lastItem -100000
	foreach item $list {
		incr idx

		if {$item <= $lastItem} {
			return ""
		}

		set difference [expr {$item - $idx}]
		if {$idx != 0} {
			set divisor [expr {$item / $idx}]
		} else {
			set divisor 1
		}
		lappend differences $difference
		lappend divisors $divisor

		set lastItem $item
	}

	foreach divisor [lrange $divisors 1 end] {
		incr divisorCount
		incr divisorValue $divisor
	}
	set divisor [expr {$divisorValue / $divisorCount}]

	for {set i 0} {$i < [llength $list]} {incr i} {
		lappend outList $i
	}

	set mapFunc " - ${difference}"

	set newList [lmap v $list { expr "\$v${mapFunc}" }]
	if {$newList eq $outList} {
		return $mapFunc
	}

	if {$divisor != 1} {
		set mapFunc " / ${divisor}"
		set newList [lmap v $list { expr "\$v${mapFunc}" }]
		if {$newList eq $outList} {
			return $mapFunc
		}

		set subMapFunc [_tryFit $newList]
		if {$subMapFunc != ""} {
			return " / ${divisor}${subMapFunc}"
		}
	}

	return ""
}

proc ::xvfs::generatePerfectHashFunctionCall {cVarName cVarLength invalidValue nameList args} {
	# Manage config
	## Default config
	array set config {
		useCacheFirst  false
		cacheValue     true
		enableCache    false
	}
	set config(cacheFile) [file join [file normalize ~/.cache] xvfs phf-cache.db]

	## User config
	foreach {configKey configVal} $args {
		if {![info exists config($configKey)]} {
			error "Invalid option: $configKey"
		}
	}
	array set config $args

	if {$config(enableCache)} {
		package require sqlite3
	}

	# Adjustment for computing the expense of a function call by its length
	# Calls that take longer should be made longer, so make CRC32 longer
	# than Adler32
	set lengthAdjustment [list Tcl_ZlibCRC32 Tcl_CRCxxx32]

	# Check for a cached entry
	if {$config(enableCache) && $config(useCacheFirst)} {
		catch {
			set hashKey $nameList

			sqlite3 ::xvfs::phfCache $config(cacheFile)
			::xvfs::phfCache eval {CREATE TABLE IF NOT EXISTS cache(hashKey PRIMARY KEY, function BLOB);}
			::xvfs::phfCache eval {SELECT function FROM cache WHERE hashKey = $hashKey LIMIT 1;} cacheRow {}
		}
		catch {
			::xvfs::phfCache close
		}

		if {[info exists cacheRow(function)]} {
			set phfCall $cacheRow(function)
			set phfCall [string map [list @@CVARNAME@@ $cVarName @@CVARLENGTH@@ $cVarLength @@INVALIDVALUE@@ $invalidValue] $phfCall]

			return $phfCall
		}
	}

	set minVal 0
	set maxVal [llength $nameList]
	set testExpr_(0) {[zlib adler32 $nameItem $alpha] % $gamma}
	set testExpr(1) {[zlib crc32 $nameItem $alpha] % $gamma}
	set testExpr_(2) {[zlib adler32 $nameItem [zlib crc32 $nameItem $alpha]] % $gamma}
	set testExpr_(3) {[zlib crc32 $nameItem [zlib adler32 $nameItem $alpha]] % $gamma}
	set testExprC(0) {((Tcl_ZlibAdler32(${alpha}LU, (unsigned char *) @@CVARNAME@@, @@CVARLENGTH@@) % ${gamma}LU)${fitMod})}
	set testExprC(1) {((Tcl_ZlibCRC32(${alpha}LU, (unsigned char *) @@CVARNAME@@, @@CVARLENGTH@@) % ${gamma}LU)${fitMod})}
	set testExprC(2) {((Tcl_ZlibAdler32(Tcl_ZlibCRC32(${alpha}LU, (unsigned char *) @@CVARNAME@@, @@CVARLENGTH@@), (unsigned char *) @@CVARNAME@@, @@CVARLENGTH@@) % ${gamma}LU)${fitMod})}
	set testExprC(3) {((Tcl_ZlibCRC32(Tcl_ZlibAdler32(${alpha}LU, (unsigned char *) @@CVARNAME@@, @@CVARLENGTH@@), (unsigned char *) @@CVARNAME@@, @@CVARLENGTH@@) % ${gamma}LU)${fitMod})}

	# Short-circuit for known cases
	if {$maxVal == 1} {
		return 0
	}

	set round -1

	while true {
		incr round

		set gamma [expr {$maxVal + ($round % ($maxVal * 128))}]
		set alpha [expr {$round / 6}]

		foreach {testExprID testExprContents} [array get testExpr] {
			set unFitList [list]
			foreach nameItem $nameList {
				set testExprVal [expr $testExprContents]
				lappend unFitList $testExprVal
			}

			set failed false
			set fitMod [_tryFit $unFitList]
			if {$fitMod eq ""} {
				set failed true
			}

			if {!$failed} {
				break
			}
		}

		if {!$failed} {
			break
		}

	}

	set phfCall [string map [list { - 0LU} ""] [subst $testExprC($testExprID)]]

	# Check cache for a better answer
	if {$config(enableCache)} {
		catch {
			set hashKey $nameList
			set cacheDir [file dirname $config(cacheFile)]
			file mkdir $cacheDir

			unset -nocomplain cacheRow

			sqlite3 ::xvfs::phfCache $config(cacheFile)
			::xvfs::phfCache eval {CREATE TABLE IF NOT EXISTS cache(hashKey PRIMARY KEY, function BLOB);}
			::xvfs::phfCache eval {SELECT function FROM cache WHERE hashKey = $hashKey LIMIT 1;} cacheRow {}

			set updateCache false
			if {[info exists cacheRow(function)]} {
				if {[string length [string map $lengthAdjustment $cacheRow(function)]] <= [string length [string map $lengthAdjustment $phfCall]]} {
					# Use the cached value since it is better
					set phfCall $cacheRow(function)
				} else {
					set updateCache true
				}
			} else {
				set updateCache true
			}

			if {$updateCache && $config(cacheValue)} {
				# Save to cache
				::xvfs::phfCache eval {INSERT OR REPLACE INTO cache (hashKey, function) VALUES ($hashKey, $phfCall);}
			}
		}

		catch {
			::xvfs::phfCache close
		}
	}

	set phfCall [string map [list @@CVARNAME@@ $cVarName @@CVARLENGTH@@ $cVarLength @@INVALIDVALUE@@ $invalidValue] $phfCall]

	return $phfCall
}

proc ::xvfs::generateHashTable {outCVarName cVarName cVarLength invalidValue nameList args} {
	# Manage config
	## Default config
	array set config {
		prefix        ""
		hashTableSize 10
		validate      0
		onValidated   "break;"
	}

	## User config
	foreach {configKey configVal} $args {
		if {![info exists config($configKey)]} {
			error "Invalid option: $configKey"
		}
	}
	array set config $args

	if {[llength $nameList] < $config(hashTableSize)} {
		set config(hashTableSize) [llength $nameList]
	}

	set maxLength 0
	set index -1
	foreach name $nameList {
		incr index
		set length [string length $name]
		set hash [expr {[zlib adler32 $name 0] % $config(hashTableSize)}]

		lappend indexesAtLength($length) $index
		lappend indexesAtHash($hash) $index

		if {$length > $maxLength} {
			set maxLength $length
		}
	}

	set maxIndexes 0
	foreach {hash indexes} [array get indexesAtHash] {
		set indexesCount [llength $indexes]

		if {$indexesCount > $maxIndexes} {
			set maxIndexes $indexesCount
		}
	}

	lappend outputHeader "${config(prefix)}long ${outCVarName}_idx;"
	lappend outputHeader "${config(prefix)}int ${outCVarName}_hash;"

	for {set hash 0} {$hash < $config(hashTableSize)} {incr hash} {
		if {[info exists indexesAtHash($hash)]} {
			set indexes $indexesAtHash($hash)
		} else {
			set indexes [list]
		}

		if {[llength $indexes] != $maxIndexes} {
			lappend indexes $invalidValue
		}
		lappend outputHeader "${config(prefix)}static const long ${outCVarName}_hashTable_${hash}\[\] = \{"
		lappend outputHeader "${config(prefix)}\t[join $indexes {, }]"
		lappend outputHeader "${config(prefix)}\};"
	}

	lappend outputHeader "${config(prefix)}static const long * const ${outCVarName}_hashTable\[${config(hashTableSize)}\] = \{"

	for {set hash 0} {$hash < $config(hashTableSize)} {incr hash} {
		lappend outputHeader "${config(prefix)}\t${outCVarName}_hashTable_${hash},"
	}

	lappend outputHeader "${config(prefix)}\};"
	lappend outputBody "${config(prefix)}${outCVarName}_hash = Tcl_ZlibAdler32(0, (unsigned char *) ${cVarName}, ${cVarLength}) % ${config(hashTableSize)};"
	lappend outputBody "${config(prefix)}for (${outCVarName}_idx = 0; ${outCVarName}_idx < ${maxIndexes}; ${outCVarName}_idx++) \{"
	lappend outputBody "${config(prefix)}\t${outCVarName} = ${outCVarName}_hashTable\[${outCVarName}_hash\]\[${outCVarName}_idx\];"
	lappend outputBody "${config(prefix)}\tif (${outCVarName} == $invalidValue) \{"
	lappend outputBody "${config(prefix)}\t\tbreak;"
	lappend outputBody "${config(prefix)}\t\}"
	lappend outputBody ""
	lappend outputBody "${config(prefix)}\tif (${config(validate)}) \{"
	lappend outputBody "${config(prefix)}\t\t${config(onValidated)}"
	lappend outputBody "${config(prefix)}\t\}"
	lappend outputBody "${config(prefix)}\}"

	return [dict create header [join $outputHeader "\n"] body [join $outputBody "\n"]]
}

package provide xvfs 1