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