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