Lines of
lib/xvfs/xvfs.tcl
from check-in 36d0805e0e
that are changed by the sequence of edits moving toward
check-in 807cab65f7:
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: }
eebfe1f40f 2020-03-25 20: puts $channel "Usage: dir2c \[--help\] \[--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" {
36d0805e0e 2019-12-03 132: ::xvfs::_emitLine "\t\t.data.fileContents = (const unsigned char *) $data,"
133: }
134: "directory" {
36d0805e0e 2019-12-03 135: ::xvfs::_emitLine "\t\t.data.dirChildren = $children,"
136: }
137: }
36d0805e0e 2019-12-03 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: }
eebfe1f40f 2020-03-25 252: "--output" - "--header" {
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:
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::_tryFit {list} {
314: set idx -1
315: set lastItem -100000
316: foreach item $list {
317: incr idx
318:
319: if {$item <= $lastItem} {
320: return ""
321: }
322:
323: set difference [expr {$item - $idx}]
324: if {$idx != 0} {
325: set divisor [expr {$item / $idx}]
326: } else {
327: set divisor 1
328: }
329: lappend differences $difference
330: lappend divisors $divisor
331:
332: set lastItem $item
333: }
334:
335: foreach divisor [lrange $divisors 1 end] {
336: incr divisorCount
337: incr divisorValue $divisor
338: }
339: set divisor [expr {$divisorValue / $divisorCount}]
340:
341: for {set i 0} {$i < [llength $list]} {incr i} {
342: lappend outList $i
343: }
344:
345: set mapFunc " - ${difference}"
346:
347: set newList [lmap v $list { expr "\$v${mapFunc}" }]
348: if {$newList eq $outList} {
349: return $mapFunc
350: }
351:
352: if {$divisor != 1} {
353: set mapFunc " / ${divisor}"
354: set newList [lmap v $list { expr "\$v${mapFunc}" }]
355: if {$newList eq $outList} {
356: return $mapFunc
357: }
358:
359: set subMapFunc [_tryFit $newList]
360: if {$subMapFunc != ""} {
361: return " / ${divisor}${subMapFunc}"
362: }
363: }
364:
365: return ""
366: }
367:
368: proc ::xvfs::generatePerfectHashFunctionCall {cVarName cVarLength invalidValue nameList args} {
369: # Manage config
370: ## Default config
371: array set config {
372: useCacheFirst false
373: cacheValue true
374: enableCache false
375: }
376: set config(cacheFile) [file join [file normalize ~/.cache] xvfs phf-cache.db]
377:
378: ## User config
379: foreach {configKey configVal} $args {
380: if {![info exists config($configKey)]} {
381: error "Invalid option: $configKey"
382: }
383: }
384: array set config $args
385:
386: if {$config(enableCache)} {
387: package require sqlite3
388: }
389:
390: # Adjustment for computing the expense of a function call by its length
391: # Calls that take longer should be made longer, so make CRC32 longer
392: # than Adler32
393: set lengthAdjustment [list Tcl_ZlibCRC32 Tcl_CRCxxx32]
394:
395: # Check for a cached entry
396: if {$config(enableCache) && $config(useCacheFirst)} {
397: catch {
398: set hashKey $nameList
399:
400: sqlite3 ::xvfs::phfCache $config(cacheFile)
401: ::xvfs::phfCache eval {CREATE TABLE IF NOT EXISTS cache(hashKey PRIMARY KEY, function BLOB);}
402: ::xvfs::phfCache eval {SELECT function FROM cache WHERE hashKey = $hashKey LIMIT 1;} cacheRow {}
403: }
404: catch {
405: ::xvfs::phfCache close
406: }
407:
408: if {[info exists cacheRow(function)]} {
409: set phfCall $cacheRow(function)
410: set phfCall [string map [list @@CVARNAME@@ $cVarName @@CVARLENGTH@@ $cVarLength @@INVALIDVALUE@@ $invalidValue] $phfCall]
411:
412: return $phfCall
413: }
414: }
415:
416: set minVal 0
417: set maxVal [llength $nameList]
418: set testExpr_(0) {[zlib adler32 $nameItem $alpha] % $gamma}
419: set testExpr(1) {[zlib crc32 $nameItem $alpha] % $gamma}
420: set testExpr_(2) {[zlib adler32 $nameItem [zlib crc32 $nameItem $alpha]] % $gamma}
421: set testExpr_(3) {[zlib crc32 $nameItem [zlib adler32 $nameItem $alpha]] % $gamma}
422: set testExprC(0) {((Tcl_ZlibAdler32(${alpha}LU, (unsigned char *) @@CVARNAME@@, @@CVARLENGTH@@) % ${gamma}LU)${fitMod})}
423: set testExprC(1) {((Tcl_ZlibCRC32(${alpha}LU, (unsigned char *) @@CVARNAME@@, @@CVARLENGTH@@) % ${gamma}LU)${fitMod})}
424: set testExprC(2) {((Tcl_ZlibAdler32(Tcl_ZlibCRC32(${alpha}LU, (unsigned char *) @@CVARNAME@@, @@CVARLENGTH@@), (unsigned char *) @@CVARNAME@@, @@CVARLENGTH@@) % ${gamma}LU)${fitMod})}
425: set testExprC(3) {((Tcl_ZlibCRC32(Tcl_ZlibAdler32(${alpha}LU, (unsigned char *) @@CVARNAME@@, @@CVARLENGTH@@), (unsigned char *) @@CVARNAME@@, @@CVARLENGTH@@) % ${gamma}LU)${fitMod})}
426:
427: # Short-circuit for known cases
428: if {$maxVal == 1} {
429: return 0
430: }
431:
432: set round -1
433:
434: while true {
435: incr round
436:
437: set gamma [expr {$maxVal + ($round % ($maxVal * 128))}]
438: set alpha [expr {$round / 6}]
439:
440: foreach {testExprID testExprContents} [array get testExpr] {
441: set unFitList [list]
442: foreach nameItem $nameList {
443: set testExprVal [expr $testExprContents]
444: lappend unFitList $testExprVal
445: }
446:
447: set failed false
448: set fitMod [_tryFit $unFitList]
449: if {$fitMod eq ""} {
450: set failed true
451: }
452:
453: if {!$failed} {
454: break
455: }
456: }
457:
458: if {!$failed} {
459: break
460: }
461:
462: }
463:
464: set phfCall [string map [list { - 0LU} ""] [subst $testExprC($testExprID)]]
465:
466: # Check cache for a better answer
467: if {$config(enableCache)} {
468: catch {
469: set hashKey $nameList
470: set cacheDir [file dirname $config(cacheFile)]
471: file mkdir $cacheDir
472:
473: unset -nocomplain cacheRow
474:
475: sqlite3 ::xvfs::phfCache $config(cacheFile)
476: ::xvfs::phfCache eval {CREATE TABLE IF NOT EXISTS cache(hashKey PRIMARY KEY, function BLOB);}
477: ::xvfs::phfCache eval {SELECT function FROM cache WHERE hashKey = $hashKey LIMIT 1;} cacheRow {}
478:
479: set updateCache false
480: if {[info exists cacheRow(function)]} {
481: if {[string length [string map $lengthAdjustment $cacheRow(function)]] <= [string length [string map $lengthAdjustment $phfCall]]} {
482: # Use the cached value since it is better
483: set phfCall $cacheRow(function)
484: } else {
485: set updateCache true
486: }
487: } else {
488: set updateCache true
489: }
490:
491: if {$updateCache && $config(cacheValue)} {
492: # Save to cache
493: ::xvfs::phfCache eval {INSERT OR REPLACE INTO cache (hashKey, function) VALUES ($hashKey, $phfCall);}
494: }
495: }
496:
497: catch {
498: ::xvfs::phfCache close
499: }
500: }
501:
502: set phfCall [string map [list @@CVARNAME@@ $cVarName @@CVARLENGTH@@ $cVarLength @@INVALIDVALUE@@ $invalidValue] $phfCall]
503:
504: return $phfCall
505: }
506:
507: proc ::xvfs::generateHashTable {outCVarName cVarName cVarLength invalidValue nameList args} {
508: # Manage config
509: ## Default config
510: array set config {
511: prefix ""
512: hashTableSize 10
513: validate 0
514: onValidated "break;"
515: }
516:
517: ## User config
518: foreach {configKey configVal} $args {
519: if {![info exists config($configKey)]} {
520: error "Invalid option: $configKey"
521: }
522: }
523: array set config $args
524:
525: if {[llength $nameList] < $config(hashTableSize)} {
526: set config(hashTableSize) [llength $nameList]
527: }
528:
529: set maxLength 0
530: set index -1
531: foreach name $nameList {
532: incr index
533: set length [string length $name]
534: set hash [expr {[zlib adler32 $name 0] % $config(hashTableSize)}]
535:
536: lappend indexesAtLength($length) $index
537: lappend indexesAtHash($hash) $index
538:
539: if {$length > $maxLength} {
540: set maxLength $length
541: }
542: }
543:
544: set maxIndexes 0
545: foreach {hash indexes} [array get indexesAtHash] {
546: set indexesCount [llength $indexes]
547:
548: if {$indexesCount > $maxIndexes} {
549: set maxIndexes $indexesCount
550: }
551: }
552:
553: lappend outputHeader "${config(prefix)}long ${outCVarName}_idx;"
554: lappend outputHeader "${config(prefix)}int ${outCVarName}_hash;"
555:
556: for {set hash 0} {$hash < $config(hashTableSize)} {incr hash} {
557: if {[info exists indexesAtHash($hash)]} {
558: set indexes $indexesAtHash($hash)
559: } else {
560: set indexes [list]
561: }
562:
563: if {[llength $indexes] != $maxIndexes} {
564: lappend indexes $invalidValue
565: }
566: lappend outputHeader "${config(prefix)}static const long ${outCVarName}_hashTable_${hash}\[\] = \{"
567: lappend outputHeader "${config(prefix)}\t[join $indexes {, }]"
568: lappend outputHeader "${config(prefix)}\};"
569: }
570:
571: lappend outputHeader "${config(prefix)}static const long * const ${outCVarName}_hashTable\[${config(hashTableSize)}\] = \{"
572:
573: for {set hash 0} {$hash < $config(hashTableSize)} {incr hash} {
574: lappend outputHeader "${config(prefix)}\t${outCVarName}_hashTable_${hash},"
575: }
576:
577: lappend outputHeader "${config(prefix)}\};"
578: lappend outputBody "${config(prefix)}${outCVarName}_hash = Tcl_ZlibAdler32(0, (unsigned char *) ${cVarName}, ${cVarLength}) % ${config(hashTableSize)};"
579: lappend outputBody "${config(prefix)}for (${outCVarName}_idx = 0; ${outCVarName}_idx < ${maxIndexes}; ${outCVarName}_idx++) \{"
580: lappend outputBody "${config(prefix)}\t${outCVarName} = ${outCVarName}_hashTable\[${outCVarName}_hash\]\[${outCVarName}_idx\];"
581: lappend outputBody "${config(prefix)}\tif (${outCVarName} == $invalidValue) \{"
582: lappend outputBody "${config(prefix)}\t\tbreak;"
583: lappend outputBody "${config(prefix)}\t\}"
584: lappend outputBody ""
585: lappend outputBody "${config(prefix)}\tif (${config(validate)}) \{"
586: lappend outputBody "${config(prefix)}\t\t${config(onValidated)}"
587: lappend outputBody "${config(prefix)}\t\}"
588: lappend outputBody "${config(prefix)}\}"
589:
590: return [dict create header [join $outputHeader "\n"] body [join $outputBody "\n"]]
591: }
592:
593: package provide xvfs 1