47dcf5fc27 2019-05-01 1: #! /usr/bin/env tclsh
47dcf5fc27 2019-05-01 2:
47dcf5fc27 2019-05-01 3: namespace eval ::xvfs {}
0e8537c65f 2019-09-20 4: namespace eval ::xvfs::callback {}
2b7fa3a8fa 2019-09-20 5:
2b7fa3a8fa 2019-09-20 6: set ::xvfs::_xvfsDir [file dirname [info script]]
47dcf5fc27 2019-05-01 7:
47dcf5fc27 2019-05-01 8: # Functions
0bdbe4333e 2019-09-20 9: proc ::xvfs::_emitLine {line} {
eebfe1f40f 2020-03-25 10: lappend ::xvfs::_emitLine $line
0bdbe4333e 2019-09-20 11: }
0bdbe4333e 2019-09-20 12:
47dcf5fc27 2019-05-01 13: proc ::xvfs::printHelp {channel {errors ""}} {
47dcf5fc27 2019-05-01 14: if {[llength $errors] != 0} {
47dcf5fc27 2019-05-01 15: foreach error $errors {
702c74c153 2019-09-20 16: puts $channel "error: $error"
47dcf5fc27 2019-05-01 17: }
702c74c153 2019-09-20 18: puts $channel ""
47dcf5fc27 2019-05-01 19: }
717062426a 2020-04-13 20: puts $channel "Usage: xvfs-create \[--help\] \[--static-init {true|false}\] \[--set-mode {flexible|standalone|client}\] \[--output <filename>\] --directory <rootDirectory> --name <fsName>"
47dcf5fc27 2019-05-01 21: flush $channel
47dcf5fc27 2019-05-01 22: }
47dcf5fc27 2019-05-01 23:
47dcf5fc27 2019-05-01 24: proc ::xvfs::sanitizeCString {string} {
47dcf5fc27 2019-05-01 25: set output [join [lmap char [split $string ""] {
47dcf5fc27 2019-05-01 26: if {![regexp {[A-Za-z0-9./-]} $char]} {
47dcf5fc27 2019-05-01 27: binary scan $char H* char
47dcf5fc27 2019-05-01 28: set char "\\[format %03o 0x$char]"
47dcf5fc27 2019-05-01 29: }
47dcf5fc27 2019-05-01 30:
47dcf5fc27 2019-05-01 31: set char
47dcf5fc27 2019-05-01 32: }] ""]
47dcf5fc27 2019-05-01 33:
47dcf5fc27 2019-05-01 34: return $output
47dcf5fc27 2019-05-01 35: }
47dcf5fc27 2019-05-01 36:
32b55a907b 2019-05-02 37: proc ::xvfs::sanitizeCStringList {list {prefix ""} {width 80}} {
32b55a907b 2019-05-02 38: set lines [list]
32b55a907b 2019-05-02 39: set row [list]
32b55a907b 2019-05-02 40: foreach item $list {
32b55a907b 2019-05-02 41: lappend row "\"[sanitizeCString $item]\""
32b55a907b 2019-05-02 42:
32b55a907b 2019-05-02 43: set rowString [join $row {, }]
32b55a907b 2019-05-02 44: set rowString "${prefix}${rowString}"
32b55a907b 2019-05-02 45: if {[string length $rowString] > $width} {
32b55a907b 2019-05-02 46: set row [list]
d961175fd9 2019-09-20 47: lappend lines "${rowString},"
32b55a907b 2019-05-02 48: unset rowString
32b55a907b 2019-05-02 49: }
32b55a907b 2019-05-02 50: }
32b55a907b 2019-05-02 51: if {[info exists rowString]} {
32b55a907b 2019-05-02 52: lappend lines $rowString
32b55a907b 2019-05-02 53: }
32b55a907b 2019-05-02 54:
32b55a907b 2019-05-02 55: return [join $lines "\n"]
32b55a907b 2019-05-02 56: }
32b55a907b 2019-05-02 57:
47dcf5fc27 2019-05-01 58: proc ::xvfs::binaryToCHex {binary {prefix ""} {width 10}} {
2176e9cacf 2019-09-18 59: set binary [binary encode hex $binary]
47dcf5fc27 2019-05-01 60: set output [list]
47dcf5fc27 2019-05-01 61:
47dcf5fc27 2019-05-01 62: set width [expr {$width * 2}]
47dcf5fc27 2019-05-01 63: set stopAt [expr {$width - 1}]
47dcf5fc27 2019-05-01 64:
2176e9cacf 2019-09-18 65: set offset 0
2176e9cacf 2019-09-18 66: while 1 {
2176e9cacf 2019-09-18 67: set row [string range $binary $offset [expr {$offset + $stopAt}]]
2176e9cacf 2019-09-18 68: if {[string length $row] == 0} {
2176e9cacf 2019-09-18 69: break
2176e9cacf 2019-09-18 70: }
2176e9cacf 2019-09-18 71: incr offset [string length $row]
47dcf5fc27 2019-05-01 72:
47dcf5fc27 2019-05-01 73: set rowOutput [list]
47dcf5fc27 2019-05-01 74: while {$row ne ""} {
47dcf5fc27 2019-05-01 75: set value [string range $row 0 1]
47dcf5fc27 2019-05-01 76: set row [string range $row 2 end]
47dcf5fc27 2019-05-01 77:
47dcf5fc27 2019-05-01 78: lappend rowOutput "\\x$value"
47dcf5fc27 2019-05-01 79: }
47dcf5fc27 2019-05-01 80: set rowOutput [join $rowOutput {}]
47dcf5fc27 2019-05-01 81: set rowOutput "${prefix}\"${rowOutput}\""
47dcf5fc27 2019-05-01 82: lappend output $rowOutput
47dcf5fc27 2019-05-01 83: }
47dcf5fc27 2019-05-01 84:
47dcf5fc27 2019-05-01 85: if {[llength $output] == 0} {
47dcf5fc27 2019-05-01 86: return "${prefix}\"\""
47dcf5fc27 2019-05-01 87: }
47dcf5fc27 2019-05-01 88:
47dcf5fc27 2019-05-01 89: set output [join $output "\n"]
47dcf5fc27 2019-05-01 90: }
47dcf5fc27 2019-05-01 91:
47dcf5fc27 2019-05-01 92: proc ::xvfs::processFile {fsName inputFile outputFile fileInfoDict} {
47dcf5fc27 2019-05-01 93: array set fileInfo $fileInfoDict
47dcf5fc27 2019-05-01 94:
47dcf5fc27 2019-05-01 95: switch -exact -- $fileInfo(type) {
47dcf5fc27 2019-05-01 96: "file" {
47dcf5fc27 2019-05-01 97: set type "XVFS_FILE_TYPE_REG"
d8e00cd4a3 2019-09-20 98: if {[info exists fileInfo(fileContents)]} {
d8e00cd4a3 2019-09-20 99: set data $fileInfo(fileContents)
d8e00cd4a3 2019-09-20 100: } else {
d8e00cd4a3 2019-09-20 101: set fd [open $inputFile]
d8e00cd4a3 2019-09-20 102: fconfigure $fd -encoding binary -translation binary -blocking true
d8e00cd4a3 2019-09-20 103: set data [read $fd]
d8e00cd4a3 2019-09-20 104: close $fd
d8e00cd4a3 2019-09-20 105: }
47dcf5fc27 2019-05-01 106: set size [string length $data]
47dcf5fc27 2019-05-01 107: set data [string trimleft [binaryToCHex $data "\t\t\t"]]
47dcf5fc27 2019-05-01 108: }
47dcf5fc27 2019-05-01 109: "directory" {
47dcf5fc27 2019-05-01 110: set type "XVFS_FILE_TYPE_DIR"
32b55a907b 2019-05-02 111: set children $fileInfo(children)
32b55a907b 2019-05-02 112: set size [llength $children]
32b55a907b 2019-05-02 113:
32b55a907b 2019-05-02 114: if {$size == 0} {
32b55a907b 2019-05-02 115: set children "NULL"
32b55a907b 2019-05-02 116: } else {
32b55a907b 2019-05-02 117: set children [string trimleft [sanitizeCStringList $children "\t\t\t"]]
32b55a907b 2019-05-02 118: # This initializes it using a C99 compound literal, C99 is required
32b55a907b 2019-05-02 119: set children "(const char *\[\]) \{$children\}"
32b55a907b 2019-05-02 120: }
47dcf5fc27 2019-05-01 121: }
47dcf5fc27 2019-05-01 122: default {
47dcf5fc27 2019-05-01 123: return -code error "Unable to process $inputFile, unknown type: $fileInfo(type)"
47dcf5fc27 2019-05-01 124: }
47dcf5fc27 2019-05-01 125: }
47dcf5fc27 2019-05-01 126:
0bdbe4333e 2019-09-20 127: ::xvfs::_emitLine "\t\{"
0bdbe4333e 2019-09-20 128: ::xvfs::_emitLine "\t\t.name = \"[sanitizeCString $outputFile]\","
0bdbe4333e 2019-09-20 129: ::xvfs::_emitLine "\t\t.type = $type,"
32b55a907b 2019-05-02 130: switch -exact -- $fileInfo(type) {
32b55a907b 2019-05-02 131: "file" {
eebfe1f40f 2020-03-25 132: ::xvfs::_emitLine "\t\t.data.fileContents = (const unsigned char *) $data,"
32b55a907b 2019-05-02 133: }
32b55a907b 2019-05-02 134: "directory" {
eebfe1f40f 2020-03-25 135: ::xvfs::_emitLine "\t\t.data.dirChildren = $children,"
32b55a907b 2019-05-02 136: }
32b55a907b 2019-05-02 137: }
eebfe1f40f 2020-03-25 138: ::xvfs::_emitLine "\t\t.size = $size"
0bdbe4333e 2019-09-20 139: ::xvfs::_emitLine "\t\},"
47dcf5fc27 2019-05-01 140: }
47dcf5fc27 2019-05-01 141:
47dcf5fc27 2019-05-01 142: proc ::xvfs::processDirectory {fsName directory {subDirectory ""}} {
47dcf5fc27 2019-05-01 143: set subDirectories [list]
47dcf5fc27 2019-05-01 144: set outputFiles [list]
47dcf5fc27 2019-05-01 145: set workingDirectory [file join $directory $subDirectory]
47dcf5fc27 2019-05-01 146: set outputDirectory $subDirectory
47dcf5fc27 2019-05-01 147:
47dcf5fc27 2019-05-01 148: if {$subDirectory eq ""} {
47dcf5fc27 2019-05-01 149: set isTopLevel true
47dcf5fc27 2019-05-01 150: } else {
47dcf5fc27 2019-05-01 151: set isTopLevel false
47dcf5fc27 2019-05-01 152: }
47dcf5fc27 2019-05-01 153:
47dcf5fc27 2019-05-01 154: if {$isTopLevel} {
0bdbe4333e 2019-09-20 155: ::xvfs::_emitLine "static const struct xvfs_file_data xvfs_${fsName}_data\[\] = \{"
47dcf5fc27 2019-05-01 156: }
47dcf5fc27 2019-05-01 157:
47dcf5fc27 2019-05-01 158: # XXX:TODO: Include hidden files ?
32b55a907b 2019-05-02 159: set children [list]
47dcf5fc27 2019-05-01 160: foreach file [glob -nocomplain -tails -directory $workingDirectory *] {
47dcf5fc27 2019-05-01 161: if {$file in {. ..}} {
47dcf5fc27 2019-05-01 162: continue
47dcf5fc27 2019-05-01 163: }
47dcf5fc27 2019-05-01 164:
47dcf5fc27 2019-05-01 165: set inputFile [file join $workingDirectory $file]
d99958bdd3 2019-05-03 166: set outputFile [file join $outputDirectory [encoding convertto utf-8 $file]]
30c469fcf7 2019-09-20 167: set subDirectoryName [file join $outputDirectory $file]
0e8537c65f 2019-09-20 168:
0e8537c65f 2019-09-20 169: if {[info command ::xvfs::callback::setOutputFileName] ne ""} {
ed3da129b8 2019-09-20 170: set outputFile [::xvfs::callback::setOutputFileName $file $workingDirectory $inputFile $outputDirectory $outputFile]
e592c85e70 2019-09-20 171: if {$outputFile eq "/"} {
0e8537c65f 2019-09-20 172: continue
0e8537c65f 2019-09-20 173: }
0e8537c65f 2019-09-20 174: }
47dcf5fc27 2019-05-01 175:
47dcf5fc27 2019-05-01 176: unset -nocomplain fileInfo
47dcf5fc27 2019-05-01 177: catch {
47dcf5fc27 2019-05-01 178: file lstat $inputFile fileInfo
47dcf5fc27 2019-05-01 179: }
47dcf5fc27 2019-05-01 180: if {![info exists fileInfo]} {
30ffb49c05 2019-09-20 181: puts stderr "warning: Unable to access $inputFile, skipping"
47dcf5fc27 2019-05-01 182: }
47dcf5fc27 2019-05-01 183:
47dcf5fc27 2019-05-01 184: if {$fileInfo(type) eq "directory"} {
30c469fcf7 2019-09-20 185: lappend subDirectories $subDirectoryName
32b55a907b 2019-05-02 186: continue
47dcf5fc27 2019-05-01 187: }
47dcf5fc27 2019-05-01 188:
47dcf5fc27 2019-05-01 189: processFile $fsName $inputFile $outputFile [array get fileInfo]
47dcf5fc27 2019-05-01 190: lappend outputFiles $outputFile
47dcf5fc27 2019-05-01 191: }
47dcf5fc27 2019-05-01 192:
47dcf5fc27 2019-05-01 193: foreach subDirectory $subDirectories {
47dcf5fc27 2019-05-01 194: lappend outputFiles {*}[processDirectory $fsName $directory $subDirectory]
47dcf5fc27 2019-05-01 195: }
32b55a907b 2019-05-02 196:
32b55a907b 2019-05-02 197: set inputFile $directory
32b55a907b 2019-05-02 198: set outputFile $outputDirectory
e592c85e70 2019-09-20 199: if {[info command ::xvfs::callback::setOutputFileName] ne ""} {
e592c85e70 2019-09-20 200: set outputFile [::xvfs::callback::setOutputFileName $directory $directory $inputFile $outputDirectory $outputFile]
e592c85e70 2019-09-20 201: }
32b55a907b 2019-05-02 202:
e592c85e70 2019-09-20 203: if {$outputFile ne "/"} {
e592c85e70 2019-09-20 204: unset -nocomplain fileInfo
e592c85e70 2019-09-20 205: file stat $inputFile fileInfo
30c469fcf7 2019-09-20 206: set children [list]
30c469fcf7 2019-09-20 207: set outputFileLen [string length $outputFile]
30c469fcf7 2019-09-20 208: foreach child $outputFiles {
30c469fcf7 2019-09-20 209: if {[string range /$child 0 $outputFileLen] eq "/${outputFile}"} {
30c469fcf7 2019-09-20 210: set child [string trimleft [string range $child $outputFileLen end] /]
30c469fcf7 2019-09-20 211: if {![string match "*/*" $child]} {
30c469fcf7 2019-09-20 212: lappend children $child
30c469fcf7 2019-09-20 213: }
30c469fcf7 2019-09-20 214: }
30c469fcf7 2019-09-20 215: }
e592c85e70 2019-09-20 216: set fileInfo(children) $children
e592c85e70 2019-09-20 217:
e592c85e70 2019-09-20 218: processFile $fsName $inputFile $outputFile [array get fileInfo]
e592c85e70 2019-09-20 219: lappend outputFiles $outputFile
e592c85e70 2019-09-20 220: }
47dcf5fc27 2019-05-01 221:
47dcf5fc27 2019-05-01 222: if {$isTopLevel} {
d8e00cd4a3 2019-09-20 223: if {[info command ::xvfs::callback::addOutputFiles] ne ""} {
e592c85e70 2019-09-20 224: lappend outputFiles {*}[::xvfs::callback::addOutputFiles $fsName]
d8e00cd4a3 2019-09-20 225: }
d8e00cd4a3 2019-09-20 226:
0bdbe4333e 2019-09-20 227: ::xvfs::_emitLine "\};"
47dcf5fc27 2019-05-01 228: }
47dcf5fc27 2019-05-01 229:
47dcf5fc27 2019-05-01 230: return $outputFiles
47dcf5fc27 2019-05-01 231: }
47dcf5fc27 2019-05-01 232:
47dcf5fc27 2019-05-01 233: proc ::xvfs::main {argv} {
47dcf5fc27 2019-05-01 234: # Main entry point
47dcf5fc27 2019-05-01 235: ## 1. Parse arguments
47dcf5fc27 2019-05-01 236: if {[llength $argv] % 2 != 0} {
47dcf5fc27 2019-05-01 237: lappend argv ""
47dcf5fc27 2019-05-01 238: }
47dcf5fc27 2019-05-01 239:
717062426a 2020-04-13 240: set staticInit false
47dcf5fc27 2019-05-01 241: foreach {arg val} $argv {
47dcf5fc27 2019-05-01 242: switch -exact -- $arg {
47dcf5fc27 2019-05-01 243: "--help" {
47dcf5fc27 2019-05-01 244: printHelp stdout
47dcf5fc27 2019-05-01 245: exit 0
47dcf5fc27 2019-05-01 246: }
47dcf5fc27 2019-05-01 247: "--directory" {
47dcf5fc27 2019-05-01 248: set rootDirectory $val
47dcf5fc27 2019-05-01 249: }
47dcf5fc27 2019-05-01 250: "--name" {
47dcf5fc27 2019-05-01 251: set fsName $val
717062426a 2020-04-13 252: }
717062426a 2020-04-13 253: "--static-init" {
717062426a 2020-04-13 254: set staticInit $val
807cab65f7 2020-03-25 255: }
807cab65f7 2020-03-25 256: "--output" - "--header" - "--set-mode" {
0bdbe4333e 2019-09-20 257: # Ignored, handled as part of some other process
47dcf5fc27 2019-05-01 258: }
47dcf5fc27 2019-05-01 259: default {
47dcf5fc27 2019-05-01 260: printHelp stderr [list "Invalid option: $arg $val"]
47dcf5fc27 2019-05-01 261: exit 1
47dcf5fc27 2019-05-01 262: }
47dcf5fc27 2019-05-01 263: }
47dcf5fc27 2019-05-01 264: }
47dcf5fc27 2019-05-01 265:
47dcf5fc27 2019-05-01 266: ## 2. Validate arguments
47dcf5fc27 2019-05-01 267: set errors [list]
47dcf5fc27 2019-05-01 268: if {![info exists rootDirectory]} {
47dcf5fc27 2019-05-01 269: lappend errors "--directory must be specified"
47dcf5fc27 2019-05-01 270: }
47dcf5fc27 2019-05-01 271: if {![info exists fsName]} {
47dcf5fc27 2019-05-01 272: lappend errors "--name must be specified"
47dcf5fc27 2019-05-01 273: }
47dcf5fc27 2019-05-01 274:
47dcf5fc27 2019-05-01 275: if {[llength $errors] != 0} {
47dcf5fc27 2019-05-01 276: printHelp stderr $errors
47dcf5fc27 2019-05-01 277: exit 1
47dcf5fc27 2019-05-01 278: }
47dcf5fc27 2019-05-01 279:
717062426a 2020-04-13 280: ## 3. Initialization
717062426a 2020-04-13 281: if {$staticInit} {
717062426a 2020-04-13 282: ::xvfs::_emitLine "#define XVFS_${fsName}_INIT_STATIC 1"
717062426a 2020-04-13 283: }
717062426a 2020-04-13 284:
717062426a 2020-04-13 285: ## 4. Start processing directory and producing initial output
32b55a907b 2019-05-02 286: set ::xvfs::outputFiles [processDirectory $fsName $rootDirectory]
47dcf5fc27 2019-05-01 287:
47dcf5fc27 2019-05-01 288: set ::xvfs::fsName $fsName
47dcf5fc27 2019-05-01 289: set ::xvfs::rootDirectory $rootDirectory
eebfe1f40f 2020-03-25 290:
eebfe1f40f 2020-03-25 291: # Return the output
eebfe1f40f 2020-03-25 292: return [join $::xvfs::_emitLine "\n"]
2b7fa3a8fa 2019-09-20 293: }
2b7fa3a8fa 2019-09-20 294:
e592c85e70 2019-09-20 295: proc ::xvfs::run {args} {
d36db7c01b 2019-09-20 296: uplevel #0 { package require minirivet }
3cb72a0d20 2019-09-20 297:
e592c85e70 2019-09-20 298: set ::xvfs::argv $args
2b7fa3a8fa 2019-09-20 299: ::minirivet::parse [file join $::xvfs::_xvfsDir xvfs.c.rvt]
2b7fa3a8fa 2019-09-20 300: }
2b7fa3a8fa 2019-09-20 301:
d36db7c01b 2019-09-20 302: proc ::xvfs::setOutputChannel {channel} {
d36db7c01b 2019-09-20 303: uplevel #0 { package require minirivet }
d36db7c01b 2019-09-20 304: tailcall ::minirivet::setOutputChannel $channel
d36db7c01b 2019-09-20 305: }
d36db7c01b 2019-09-20 306:
d36db7c01b 2019-09-20 307: proc ::xvfs::setOutputVariable {variable} {
d36db7c01b 2019-09-20 308: uplevel #0 { package require minirivet }
d36db7c01b 2019-09-20 309: tailcall ::minirivet::setOutputVariable $variable
09e53d3c38 2019-09-20 310: }
09e53d3c38 2019-09-20 311:
09e53d3c38 2019-09-20 312: proc ::xvfs::staticIncludeHeaderData {headerData} {
09e53d3c38 2019-09-20 313: set ::xvfs::xvfsCoreH $headerData
09e53d3c38 2019-09-20 314: }
09e53d3c38 2019-09-20 315:
09e53d3c38 2019-09-20 316: proc ::xvfs::staticIncludeHeader {pathToHeaderFile} {
09e53d3c38 2019-09-20 317: set fd [open $pathToHeaderFile]
09e53d3c38 2019-09-20 318: ::xvfs::staticIncludeHeaderData [read $fd]
09e53d3c38 2019-09-20 319: close $fd
807cab65f7 2020-03-25 320: }
807cab65f7 2020-03-25 321:
807cab65f7 2020-03-25 322: proc ::xvfs::setSpecificMode {mode} {
807cab65f7 2020-03-25 323: ::minirivet::_emitOutput "#undef XVFS_MODE_SERVER\n"
807cab65f7 2020-03-25 324: ::minirivet::_emitOutput "#undef XVFS_MODE_CLIENT\n"
807cab65f7 2020-03-25 325: ::minirivet::_emitOutput "#undef XVFS_MODE_FLEXIBLE\n"
807cab65f7 2020-03-25 326: ::minirivet::_emitOutput "#undef XVFS_MODE_STANDALONE\n"
807cab65f7 2020-03-25 327: ::minirivet::_emitOutput "#define XVFS_MODE_[string toupper $mode] 1\n"
37d00c3cfb 2019-11-04 328: }
37d00c3cfb 2019-11-04 329:
37d00c3cfb 2019-11-04 330: proc ::xvfs::_tryFit {list} {
37d00c3cfb 2019-11-04 331: set idx -1
37d00c3cfb 2019-11-04 332: set lastItem -100000
37d00c3cfb 2019-11-04 333: foreach item $list {
37d00c3cfb 2019-11-04 334: incr idx
37d00c3cfb 2019-11-04 335:
37d00c3cfb 2019-11-04 336: if {$item <= $lastItem} {
37d00c3cfb 2019-11-04 337: return ""
37d00c3cfb 2019-11-04 338: }
37d00c3cfb 2019-11-04 339:
37d00c3cfb 2019-11-04 340: set difference [expr {$item - $idx}]
37d00c3cfb 2019-11-04 341: if {$idx != 0} {
37d00c3cfb 2019-11-04 342: set divisor [expr {$item / $idx}]
37d00c3cfb 2019-11-04 343: } else {
37d00c3cfb 2019-11-04 344: set divisor 1
37d00c3cfb 2019-11-04 345: }
37d00c3cfb 2019-11-04 346: lappend differences $difference
37d00c3cfb 2019-11-04 347: lappend divisors $divisor
37d00c3cfb 2019-11-04 348:
37d00c3cfb 2019-11-04 349: set lastItem $item
37d00c3cfb 2019-11-04 350: }
37d00c3cfb 2019-11-04 351:
37d00c3cfb 2019-11-04 352: foreach divisor [lrange $divisors 1 end] {
37d00c3cfb 2019-11-04 353: incr divisorCount
37d00c3cfb 2019-11-04 354: incr divisorValue $divisor
37d00c3cfb 2019-11-04 355: }
37d00c3cfb 2019-11-04 356: set divisor [expr {$divisorValue / $divisorCount}]
37d00c3cfb 2019-11-04 357:
37d00c3cfb 2019-11-04 358: for {set i 0} {$i < [llength $list]} {incr i} {
37d00c3cfb 2019-11-04 359: lappend outList $i
37d00c3cfb 2019-11-04 360: }
37d00c3cfb 2019-11-04 361:
37d00c3cfb 2019-11-04 362: set mapFunc " - ${difference}"
37d00c3cfb 2019-11-04 363:
37d00c3cfb 2019-11-04 364: set newList [lmap v $list { expr "\$v${mapFunc}" }]
37d00c3cfb 2019-11-04 365: if {$newList eq $outList} {
37d00c3cfb 2019-11-04 366: return $mapFunc
37d00c3cfb 2019-11-04 367: }
37d00c3cfb 2019-11-04 368:
37d00c3cfb 2019-11-04 369: if {$divisor != 1} {
37d00c3cfb 2019-11-04 370: set mapFunc " / ${divisor}"
37d00c3cfb 2019-11-04 371: set newList [lmap v $list { expr "\$v${mapFunc}" }]
37d00c3cfb 2019-11-04 372: if {$newList eq $outList} {
37d00c3cfb 2019-11-04 373: return $mapFunc
37d00c3cfb 2019-11-04 374: }
37d00c3cfb 2019-11-04 375:
37d00c3cfb 2019-11-04 376: set subMapFunc [_tryFit $newList]
37d00c3cfb 2019-11-04 377: if {$subMapFunc != ""} {
37d00c3cfb 2019-11-04 378: return " / ${divisor}${subMapFunc}"
37d00c3cfb 2019-11-04 379: }
37d00c3cfb 2019-11-04 380: }
37d00c3cfb 2019-11-04 381:
37d00c3cfb 2019-11-04 382: return ""
37d00c3cfb 2019-11-04 383: }
37d00c3cfb 2019-11-04 384:
f615eecc64 2019-10-10 385: proc ::xvfs::generatePerfectHashFunctionCall {cVarName cVarLength invalidValue nameList args} {
37d00c3cfb 2019-11-04 386: # Manage config
37d00c3cfb 2019-11-04 387: ## Default config
f615eecc64 2019-10-10 388: array set config {
37d00c3cfb 2019-11-04 389: useCacheFirst false
37d00c3cfb 2019-11-04 390: cacheValue true
37d00c3cfb 2019-11-04 391: enableCache false
f615eecc64 2019-10-10 392: }
37d00c3cfb 2019-11-04 393: set config(cacheFile) [file join [file normalize ~/.cache] xvfs phf-cache.db]
f615eecc64 2019-10-10 394:
37d00c3cfb 2019-11-04 395: ## User config
f615eecc64 2019-10-10 396: foreach {configKey configVal} $args {
f615eecc64 2019-10-10 397: if {![info exists config($configKey)]} {
f615eecc64 2019-10-10 398: error "Invalid option: $configKey"
f615eecc64 2019-10-10 399: }
f615eecc64 2019-10-10 400: }
f615eecc64 2019-10-10 401: array set config $args
f615eecc64 2019-10-10 402:
37d00c3cfb 2019-11-04 403: if {$config(enableCache)} {
37d00c3cfb 2019-11-04 404: package require sqlite3
37d00c3cfb 2019-11-04 405: }
37d00c3cfb 2019-11-04 406:
37d00c3cfb 2019-11-04 407: # Adjustment for computing the expense of a function call by its length
37d00c3cfb 2019-11-04 408: # Calls that take longer should be made longer, so make CRC32 longer
37d00c3cfb 2019-11-04 409: # than Adler32
37d00c3cfb 2019-11-04 410: set lengthAdjustment [list Tcl_ZlibCRC32 Tcl_CRCxxx32]
37d00c3cfb 2019-11-04 411:
37d00c3cfb 2019-11-04 412: # Check for a cached entry
37d00c3cfb 2019-11-04 413: if {$config(enableCache) && $config(useCacheFirst)} {
37d00c3cfb 2019-11-04 414: catch {
37d00c3cfb 2019-11-04 415: set hashKey $nameList
37d00c3cfb 2019-11-04 416:
37d00c3cfb 2019-11-04 417: sqlite3 ::xvfs::phfCache $config(cacheFile)
37d00c3cfb 2019-11-04 418: ::xvfs::phfCache eval {CREATE TABLE IF NOT EXISTS cache(hashKey PRIMARY KEY, function BLOB);}
37d00c3cfb 2019-11-04 419: ::xvfs::phfCache eval {SELECT function FROM cache WHERE hashKey = $hashKey LIMIT 1;} cacheRow {}
37d00c3cfb 2019-11-04 420: }
37d00c3cfb 2019-11-04 421: catch {
37d00c3cfb 2019-11-04 422: ::xvfs::phfCache close
37d00c3cfb 2019-11-04 423: }
37d00c3cfb 2019-11-04 424:
37d00c3cfb 2019-11-04 425: if {[info exists cacheRow(function)]} {
37d00c3cfb 2019-11-04 426: set phfCall $cacheRow(function)
37d00c3cfb 2019-11-04 427: set phfCall [string map [list @@CVARNAME@@ $cVarName @@CVARLENGTH@@ $cVarLength @@INVALIDVALUE@@ $invalidValue] $phfCall]
37d00c3cfb 2019-11-04 428:
37d00c3cfb 2019-11-04 429: return $phfCall
37d00c3cfb 2019-11-04 430: }
37d00c3cfb 2019-11-04 431: }
37d00c3cfb 2019-11-04 432:
37d00c3cfb 2019-11-04 433: set minVal 0
37d00c3cfb 2019-11-04 434: set maxVal [llength $nameList]
37d00c3cfb 2019-11-04 435: set testExpr_(0) {[zlib adler32 $nameItem $alpha] % $gamma}
37d00c3cfb 2019-11-04 436: set testExpr(1) {[zlib crc32 $nameItem $alpha] % $gamma}
37d00c3cfb 2019-11-04 437: set testExpr_(2) {[zlib adler32 $nameItem [zlib crc32 $nameItem $alpha]] % $gamma}
37d00c3cfb 2019-11-04 438: set testExpr_(3) {[zlib crc32 $nameItem [zlib adler32 $nameItem $alpha]] % $gamma}
37d00c3cfb 2019-11-04 439: set testExprC(0) {((Tcl_ZlibAdler32(${alpha}LU, (unsigned char *) @@CVARNAME@@, @@CVARLENGTH@@) % ${gamma}LU)${fitMod})}
37d00c3cfb 2019-11-04 440: set testExprC(1) {((Tcl_ZlibCRC32(${alpha}LU, (unsigned char *) @@CVARNAME@@, @@CVARLENGTH@@) % ${gamma}LU)${fitMod})}
37d00c3cfb 2019-11-04 441: set testExprC(2) {((Tcl_ZlibAdler32(Tcl_ZlibCRC32(${alpha}LU, (unsigned char *) @@CVARNAME@@, @@CVARLENGTH@@), (unsigned char *) @@CVARNAME@@, @@CVARLENGTH@@) % ${gamma}LU)${fitMod})}
37d00c3cfb 2019-11-04 442: set testExprC(3) {((Tcl_ZlibCRC32(Tcl_ZlibAdler32(${alpha}LU, (unsigned char *) @@CVARNAME@@, @@CVARLENGTH@@), (unsigned char *) @@CVARNAME@@, @@CVARLENGTH@@) % ${gamma}LU)${fitMod})}
37d00c3cfb 2019-11-04 443:
37d00c3cfb 2019-11-04 444: # Short-circuit for known cases
37d00c3cfb 2019-11-04 445: if {$maxVal == 1} {
37d00c3cfb 2019-11-04 446: return 0
37d00c3cfb 2019-11-04 447: }
37d00c3cfb 2019-11-04 448:
37d00c3cfb 2019-11-04 449: set round -1
37d00c3cfb 2019-11-04 450:
37d00c3cfb 2019-11-04 451: while true {
37d00c3cfb 2019-11-04 452: incr round
37d00c3cfb 2019-11-04 453:
37d00c3cfb 2019-11-04 454: set gamma [expr {$maxVal + ($round % ($maxVal * 128))}]
37d00c3cfb 2019-11-04 455: set alpha [expr {$round / 6}]
37d00c3cfb 2019-11-04 456:
37d00c3cfb 2019-11-04 457: foreach {testExprID testExprContents} [array get testExpr] {
37d00c3cfb 2019-11-04 458: set unFitList [list]
37d00c3cfb 2019-11-04 459: foreach nameItem $nameList {
37d00c3cfb 2019-11-04 460: set testExprVal [expr $testExprContents]
37d00c3cfb 2019-11-04 461: lappend unFitList $testExprVal
37d00c3cfb 2019-11-04 462: }
37d00c3cfb 2019-11-04 463:
37d00c3cfb 2019-11-04 464: set failed false
37d00c3cfb 2019-11-04 465: set fitMod [_tryFit $unFitList]
37d00c3cfb 2019-11-04 466: if {$fitMod eq ""} {
37d00c3cfb 2019-11-04 467: set failed true
f615eecc64 2019-10-10 468: }
f615eecc64 2019-10-10 469:
f615eecc64 2019-10-10 470: if {!$failed} {
f615eecc64 2019-10-10 471: break
f615eecc64 2019-10-10 472: }
a719156faf 2019-10-09 473: }
a719156faf 2019-10-09 474:
a719156faf 2019-10-09 475: if {!$failed} {
a719156faf 2019-10-09 476: break
a719156faf 2019-10-09 477: }
37d00c3cfb 2019-11-04 478:
37d00c3cfb 2019-11-04 479: }
37d00c3cfb 2019-11-04 480:
37d00c3cfb 2019-11-04 481: set phfCall [string map [list { - 0LU} ""] [subst $testExprC($testExprID)]]
37d00c3cfb 2019-11-04 482:
37d00c3cfb 2019-11-04 483: # Check cache for a better answer
37d00c3cfb 2019-11-04 484: if {$config(enableCache)} {
37d00c3cfb 2019-11-04 485: catch {
37d00c3cfb 2019-11-04 486: set hashKey $nameList
37d00c3cfb 2019-11-04 487: set cacheDir [file dirname $config(cacheFile)]
37d00c3cfb 2019-11-04 488: file mkdir $cacheDir
37d00c3cfb 2019-11-04 489:
37d00c3cfb 2019-11-04 490: unset -nocomplain cacheRow
37d00c3cfb 2019-11-04 491:
37d00c3cfb 2019-11-04 492: sqlite3 ::xvfs::phfCache $config(cacheFile)
37d00c3cfb 2019-11-04 493: ::xvfs::phfCache eval {CREATE TABLE IF NOT EXISTS cache(hashKey PRIMARY KEY, function BLOB);}
37d00c3cfb 2019-11-04 494: ::xvfs::phfCache eval {SELECT function FROM cache WHERE hashKey = $hashKey LIMIT 1;} cacheRow {}
37d00c3cfb 2019-11-04 495:
37d00c3cfb 2019-11-04 496: set updateCache false
37d00c3cfb 2019-11-04 497: if {[info exists cacheRow(function)]} {
37d00c3cfb 2019-11-04 498: if {[string length [string map $lengthAdjustment $cacheRow(function)]] <= [string length [string map $lengthAdjustment $phfCall]]} {
37d00c3cfb 2019-11-04 499: # Use the cached value since it is better
37d00c3cfb 2019-11-04 500: set phfCall $cacheRow(function)
37d00c3cfb 2019-11-04 501: } else {
37d00c3cfb 2019-11-04 502: set updateCache true
37d00c3cfb 2019-11-04 503: }
37d00c3cfb 2019-11-04 504: } else {
37d00c3cfb 2019-11-04 505: set updateCache true
37d00c3cfb 2019-11-04 506: }
37d00c3cfb 2019-11-04 507:
37d00c3cfb 2019-11-04 508: if {$updateCache && $config(cacheValue)} {
37d00c3cfb 2019-11-04 509: # Save to cache
37d00c3cfb 2019-11-04 510: ::xvfs::phfCache eval {INSERT OR REPLACE INTO cache (hashKey, function) VALUES ($hashKey, $phfCall);}
37d00c3cfb 2019-11-04 511: }
37d00c3cfb 2019-11-04 512: }
37d00c3cfb 2019-11-04 513:
37d00c3cfb 2019-11-04 514: catch {
37d00c3cfb 2019-11-04 515: ::xvfs::phfCache close
37d00c3cfb 2019-11-04 516: }
37d00c3cfb 2019-11-04 517: }
37d00c3cfb 2019-11-04 518:
37d00c3cfb 2019-11-04 519: set phfCall [string map [list @@CVARNAME@@ $cVarName @@CVARLENGTH@@ $cVarLength @@INVALIDVALUE@@ $invalidValue] $phfCall]
a719156faf 2019-10-09 520:
a719156faf 2019-10-09 521: return $phfCall
37d00c3cfb 2019-11-04 522: }
37d00c3cfb 2019-11-04 523:
37d00c3cfb 2019-11-04 524: proc ::xvfs::generateHashTable {outCVarName cVarName cVarLength invalidValue nameList args} {
37d00c3cfb 2019-11-04 525: # Manage config
37d00c3cfb 2019-11-04 526: ## Default config
37d00c3cfb 2019-11-04 527: array set config {
37d00c3cfb 2019-11-04 528: prefix ""
37d00c3cfb 2019-11-04 529: hashTableSize 10
37d00c3cfb 2019-11-04 530: validate 0
37d00c3cfb 2019-11-04 531: onValidated "break;"
37d00c3cfb 2019-11-04 532: }
37d00c3cfb 2019-11-04 533:
37d00c3cfb 2019-11-04 534: ## User config
37d00c3cfb 2019-11-04 535: foreach {configKey configVal} $args {
37d00c3cfb 2019-11-04 536: if {![info exists config($configKey)]} {
37d00c3cfb 2019-11-04 537: error "Invalid option: $configKey"
37d00c3cfb 2019-11-04 538: }
37d00c3cfb 2019-11-04 539: }
37d00c3cfb 2019-11-04 540: array set config $args
37d00c3cfb 2019-11-04 541:
37d00c3cfb 2019-11-04 542: if {[llength $nameList] < $config(hashTableSize)} {
37d00c3cfb 2019-11-04 543: set config(hashTableSize) [llength $nameList]
37d00c3cfb 2019-11-04 544: }
37d00c3cfb 2019-11-04 545:
37d00c3cfb 2019-11-04 546: set maxLength 0
37d00c3cfb 2019-11-04 547: set index -1
37d00c3cfb 2019-11-04 548: foreach name $nameList {
37d00c3cfb 2019-11-04 549: incr index
37d00c3cfb 2019-11-04 550: set length [string length $name]
37d00c3cfb 2019-11-04 551: set hash [expr {[zlib adler32 $name 0] % $config(hashTableSize)}]
37d00c3cfb 2019-11-04 552:
37d00c3cfb 2019-11-04 553: lappend indexesAtLength($length) $index
37d00c3cfb 2019-11-04 554: lappend indexesAtHash($hash) $index
37d00c3cfb 2019-11-04 555:
37d00c3cfb 2019-11-04 556: if {$length > $maxLength} {
37d00c3cfb 2019-11-04 557: set maxLength $length
37d00c3cfb 2019-11-04 558: }
37d00c3cfb 2019-11-04 559: }
37d00c3cfb 2019-11-04 560:
37d00c3cfb 2019-11-04 561: set maxIndexes 0
37d00c3cfb 2019-11-04 562: foreach {hash indexes} [array get indexesAtHash] {
37d00c3cfb 2019-11-04 563: set indexesCount [llength $indexes]
37d00c3cfb 2019-11-04 564:
37d00c3cfb 2019-11-04 565: if {$indexesCount > $maxIndexes} {
37d00c3cfb 2019-11-04 566: set maxIndexes $indexesCount
37d00c3cfb 2019-11-04 567: }
37d00c3cfb 2019-11-04 568: }
37d00c3cfb 2019-11-04 569:
37d00c3cfb 2019-11-04 570: lappend outputHeader "${config(prefix)}long ${outCVarName}_idx;"
37d00c3cfb 2019-11-04 571: lappend outputHeader "${config(prefix)}int ${outCVarName}_hash;"
37d00c3cfb 2019-11-04 572:
37d00c3cfb 2019-11-04 573: for {set hash 0} {$hash < $config(hashTableSize)} {incr hash} {
37d00c3cfb 2019-11-04 574: if {[info exists indexesAtHash($hash)]} {
37d00c3cfb 2019-11-04 575: set indexes $indexesAtHash($hash)
37d00c3cfb 2019-11-04 576: } else {
37d00c3cfb 2019-11-04 577: set indexes [list]
37d00c3cfb 2019-11-04 578: }
37d00c3cfb 2019-11-04 579:
3c8c52a9f8 2019-11-04 580: if {[llength $indexes] != $maxIndexes} {
3c8c52a9f8 2019-11-04 581: lappend indexes $invalidValue
3c8c52a9f8 2019-11-04 582: }
37d00c3cfb 2019-11-04 583: lappend outputHeader "${config(prefix)}static const long ${outCVarName}_hashTable_${hash}\[\] = \{"
37d00c3cfb 2019-11-04 584: lappend outputHeader "${config(prefix)}\t[join $indexes {, }]"
37d00c3cfb 2019-11-04 585: lappend outputHeader "${config(prefix)}\};"
37d00c3cfb 2019-11-04 586: }
37d00c3cfb 2019-11-04 587:
37d00c3cfb 2019-11-04 588: lappend outputHeader "${config(prefix)}static const long * const ${outCVarName}_hashTable\[${config(hashTableSize)}\] = \{"
37d00c3cfb 2019-11-04 589:
37d00c3cfb 2019-11-04 590: for {set hash 0} {$hash < $config(hashTableSize)} {incr hash} {
37d00c3cfb 2019-11-04 591: lappend outputHeader "${config(prefix)}\t${outCVarName}_hashTable_${hash},"
37d00c3cfb 2019-11-04 592: }
37d00c3cfb 2019-11-04 593:
37d00c3cfb 2019-11-04 594: lappend outputHeader "${config(prefix)}\};"
37d00c3cfb 2019-11-04 595: lappend outputBody "${config(prefix)}${outCVarName}_hash = Tcl_ZlibAdler32(0, (unsigned char *) ${cVarName}, ${cVarLength}) % ${config(hashTableSize)};"
3c8c52a9f8 2019-11-04 596: lappend outputBody "${config(prefix)}for (${outCVarName}_idx = 0; ${outCVarName}_idx < ${maxIndexes}; ${outCVarName}_idx++) \{"
37d00c3cfb 2019-11-04 597: lappend outputBody "${config(prefix)}\t${outCVarName} = ${outCVarName}_hashTable\[${outCVarName}_hash\]\[${outCVarName}_idx\];"
37d00c3cfb 2019-11-04 598: lappend outputBody "${config(prefix)}\tif (${outCVarName} == $invalidValue) \{"
37d00c3cfb 2019-11-04 599: lappend outputBody "${config(prefix)}\t\tbreak;"
37d00c3cfb 2019-11-04 600: lappend outputBody "${config(prefix)}\t\}"
37d00c3cfb 2019-11-04 601: lappend outputBody ""
37d00c3cfb 2019-11-04 602: lappend outputBody "${config(prefix)}\tif (${config(validate)}) \{"
37d00c3cfb 2019-11-04 603: lappend outputBody "${config(prefix)}\t\t${config(onValidated)}"
37d00c3cfb 2019-11-04 604: lappend outputBody "${config(prefix)}\t\}"
37d00c3cfb 2019-11-04 605: lappend outputBody "${config(prefix)}\}"
37d00c3cfb 2019-11-04 606:
37d00c3cfb 2019-11-04 607: return [dict create header [join $outputHeader "\n"] body [join $outputBody "\n"]]
d36db7c01b 2019-09-20 608: }
47dcf5fc27 2019-05-01 609:
47dcf5fc27 2019-05-01 610: package provide xvfs 1