Posted to tcl by hypnotoad at Thu Nov 14 22:18:15 GMT 2019view raw

  1. ###
  2. # Tools to encode the /library file system as a C based VFS
  3. ###
  4.  
  5. if {[llength $argv] != 4} {
  6. puts "Usage: [file tail [info script]] path cfile mountpoint cinit project"
  7. puts "path: A File system path to encode"
  8. puts "cfile: A file name to write the result to"
  9. puts "mountpoint: The root this VFS will be mounted to"
  10. puts "cinit: The name of the C function which will act as the mounting event."
  11. exit 0
  12. }
  13.  
  14. lassign $argv path cfile mountpoint cinit
  15.  
  16. set path [file normalize $path]
  17.  
  18. # Many functions cribbed from practcl, so we'll just leave that detail in for the moment
  19. namespace eval ::practcl {}
  20.  
  21. proc ::practcl::cat fname {
  22. if {![file exists $fname]} {
  23. return
  24. }
  25. set fin [open $fname r]
  26. set data [read $fin]
  27. close $fin
  28. return $data
  29. }
  30.  
  31. # Strip comments and annotations
  32. # Useful to keep file size down
  33. proc ::practcl::docstrip text {
  34. set result {}
  35. foreach line [split $text \n] {
  36. append thisline $line \n
  37. if {![info complete $thisline]} continue
  38. set outline $thisline
  39. set thisline {}
  40. if {[string trim $outline] eq {}} {
  41. continue
  42. }
  43. if {[string index [string trim $outline] 0] eq "#"} continue
  44. set cmd [string trim [lindex $outline 0] :]
  45. if {$cmd eq "namespace" && [lindex $outline 1] eq "eval"} {
  46. append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n
  47. continue
  48. }
  49. if {[string match "*::define" $cmd] && [llength $outline]==3} {
  50. append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n
  51. continue
  52. }
  53. if {$cmd eq "oo::class" && [lindex $outline 1] eq "create"} {
  54. append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n
  55. continue
  56. }
  57. append result $outline
  58. }
  59. return $result
  60. }
  61. proc ::practcl::cputs {varname args} {
  62. upvar 1 $varname buffer
  63. if {[llength $args]==1 && [string length [string trim [lindex $args 0]]] == 0} {
  64.  
  65. }
  66. if {[info exist buffer]} {
  67. if {[string index $buffer end] ne "\n"} {
  68. append buffer \n
  69. }
  70. } else {
  71. set buffer \n
  72. }
  73. # Trim leading \n's
  74. append buffer [string trimleft [lindex $args 0] \n] {*}[lrange $args 1 end]
  75. }
  76. # Encode a block of (presumably) Tcl code into an ASCII text block in C
  77. proc ::practcl::tcl_to_c {body} {
  78. set result {}
  79. foreach rawline [split $body \n] {
  80. set line [string map [list \" \\\" \\ \\\\] $rawline]
  81. cputs result "\n \"$line\\n\" \\"
  82. }
  83. return [string trimright $result \\]
  84. }
  85. proc ::practcl::binary_to_c {body} {
  86. set result {}
  87. foreach rawline [split $body \n] {
  88. set line [string map [list \" \\\" \\ \\\\] $rawline]
  89. cputs result "\n \"$line\\n\" \\"
  90. }
  91. return [string trimright $result \\]
  92. }
  93. proc ::practcl::file_lexnormalize {sp} {
  94. set spx [file split $sp]
  95.  
  96. # Resolution of embedded relative modifiers (., and ..).
  97.  
  98. if {
  99. ([lsearch -exact $spx . ] < 0) &&
  100. ([lsearch -exact $spx ..] < 0)
  101. } {
  102. # Quick path out if there are no relative modifiers
  103. return $sp
  104. }
  105.  
  106. set absolute [expr {![string equal [file pathtype $sp] relative]}]
  107. # A volumerelative path counts as absolute for our purposes.
  108.  
  109. set sp $spx
  110. set np {}
  111. set noskip 1
  112.  
  113. while {[llength $sp]} {
  114. set ele [lindex $sp 0]
  115. set sp [lrange $sp 1 end]
  116. set islast [expr {[llength $sp] == 0}]
  117.  
  118. if {[string equal $ele ".."]} {
  119. if {
  120. ($absolute && ([llength $np] > 1)) ||
  121. (!$absolute && ([llength $np] >= 1))
  122. } {
  123. # .. : Remove the previous element added to the
  124. # new path, if there actually is enough to remove.
  125. set np [lrange $np 0 end-1]
  126. }
  127. } elseif {[string equal $ele "."]} {
  128. # Ignore .'s, they stay at the current location
  129. continue
  130. } else {
  131. # A regular element.
  132. lappend np $ele
  133. }
  134. }
  135. if {[llength $np] > 0} {
  136. return [eval [linsert $np 0 file join]]
  137. # 8.5: return [file join {*}$np]
  138. }
  139. return {}
  140. }
  141. proc ::practcl::file_relative {base dst} {
  142. # Ensure that the link to directory 'dst' is properly done relative to
  143. # the directory 'base'.
  144.  
  145. if {![string equal [file pathtype $base] [file pathtype $dst]]} {
  146. return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)"
  147. }
  148.  
  149. set base [file_lexnormalize [file join [pwd] $base]]
  150. set dst [file_lexnormalize [file join [pwd] $dst]]
  151.  
  152. set save $dst
  153. set base [file split $base]
  154. set dst [file split $dst]
  155.  
  156. while {[string equal [lindex $dst 0] [lindex $base 0]]} {
  157. set dst [lrange $dst 1 end]
  158. set base [lrange $base 1 end]
  159. if {![llength $dst]} {break}
  160. }
  161.  
  162. set dstlen [llength $dst]
  163. set baselen [llength $base]
  164.  
  165. if {($dstlen == 0) && ($baselen == 0)} {
  166. # Cases:
  167. # (a) base == dst
  168.  
  169. set dst .
  170. } else {
  171. # Cases:
  172. # (b) base is: base/sub = sub
  173. # dst is: base = {}
  174.  
  175. # (c) base is: base = {}
  176. # dst is: base/sub = sub
  177.  
  178. while {$baselen > 0} {
  179. set dst [linsert $dst 0 ..]
  180. incr baselen -1
  181. }
  182. # 8.5: set dst [file join {*}$dst]
  183. set dst [eval [linsert $dst 0 file join]]
  184. }
  185.  
  186. return $dst
  187. }
  188. # Can't always guarantee we are running this script with a modern Tcl
  189. # But we can be pretty sure we are running on 8.4 or better
  190. if {[::package vcompare $::tcl_version 8.6] < 0} {
  191. if {[::package vcompare $::tcl_version 8.5] < 0} {
  192. package require dict
  193. }
  194. proc ::practcl::sort_dict list {
  195. set result {}
  196. foreach key [lsort -dictionary [dict keys $list]] {
  197. dict set result $key [dict get $list $key]
  198. }
  199. return $result
  200. }
  201. proc ::practcl::binary_encode block {
  202. set result {}
  203. set buffer [binary scan $block H* buffer]
  204. foreach {hi lo} [split $buffer] {
  205. lappend result 0x$hi$lo
  206. }
  207. return $result
  208. }
  209. } else {
  210. proc ::practcl::binary_encode block {
  211. set result {}
  212. foreach {hi lo} [split [binary encode hex $block]] {
  213. lappend result 0x$hi$lo
  214. }
  215. return $result
  216. }
  217.  
  218. proc ::practcl::sort_dict list {
  219. return [::lsort -stride 2 -dictionary $list]
  220. }
  221. }
  222.  
  223. proc EncodeFileSystem {root {parent 0} {path {}}} {
  224. if {![file exists $path]} return
  225. puts [list EncodeFileSystem $root $parent $path]
  226. set result {}
  227. set ftail [file tail $path]
  228. set vfs_location [::practcl::file_relative $root $path]
  229. set inode [incr ::NextInode]
  230.  
  231. dict set result $inode inode $inode
  232. dict set result $inode path $vfs_location
  233. dict set result $inode name $ftail
  234. dict set result $inode parent $parent
  235. dict set result $inode ctime [file ctime $path]
  236. dict set result $inode mtime [file mtime $path]
  237. dict set result $inode atime [file atime $path]
  238.  
  239. if {[file isfile $path]} {
  240. set ext [file extension $path]
  241. dict set result $inode isdirectory 1
  242. dict set result $inode ext [string trim $ext .]
  243. set content [::practcl::cat $path]
  244. dict set result $inode content $content
  245. dict set result $inode size [string length $content]
  246. } else {
  247. dict set result $inode isdirectory 1
  248. foreach subpath [glob -nocomplain [file join $path *]] {
  249. if {[file tail $subpath] in {. ..}} continue
  250. dict for {subnode subinfo} [EncodeFileSystem $root $inode $subpath] {
  251. dict set result $subnode $subinfo
  252. }
  253. }
  254. }
  255. return $result
  256. }
  257.  
  258. ###
  259. # Generate a data structure representation of the file system
  260. ###
  261.  
  262. set fout [open $cfile w]
  263. fconfigure $fout -translation cr -encoding utf-8
  264. puts $fout "/* This file is generated by [file tail [info script]] */"
  265. puts $fout {/* Attempt no edits here */
  266. #include "tcl.h"
  267.  
  268. /*
  269. * Global variables.
  270. *
  271. * The "fileHash" component is the process wide global table of all known
  272. * CVFS archive members
  273. */
  274. static Tcl_HashTable CVFS_Filehash;
  275. static int CVFS_Initialized=0;
  276. typedef struct cvfs_file {
  277. int id;
  278. int parent;
  279. int size;
  280. long ctime;
  281. long mtime;
  282. long atime;
  283. int isdirectory;
  284. const char *name;
  285. const char *path;
  286. const char *type;
  287. } cvfs_file;
  288.  
  289. }
  290.  
  291. puts $fout "\#define CVFS_VOLUME \"$mountpoint\""
  292. puts $fout "\#define CVFS_VOLUME_LEN [string length $mountpoint]"
  293.  
  294. set ::NextInode -1
  295. set DirInfo [EncodeFileSystem $path 0 $path]
  296. puts $fout "\#define CVFS_FILECOUNT [dict size $DirInfo]"
  297. puts $fout "const cvfs_file cvfs_directory\[\] = \{"
  298. dict for {id info} $DirInfo {
  299. if {$id > 0} {
  300. puts $fout ,
  301. }
  302. puts $fout " \{"
  303. set structout {}
  304. lappend structout ".id = $id"
  305. dict for {f v} $info {
  306. switch $f {
  307. isdirectory - ctime - mtime - atime - parent {
  308. lappend structout ".$f = $v"
  309. }
  310. content {
  311. lappend structout ".size=[string length [dict get $info content]]"
  312. }
  313. path {
  314. lappend structout ".$f=\"$mountpoint/$v\""
  315. }
  316. name {
  317. lappend structout ".$f=\"$v\""
  318. }
  319. }
  320. }
  321. puts $fout " [join $structout ",\n "]"
  322. puts -nonewline $fout " \}"
  323. }
  324. puts $fout {}
  325. puts $fout "\};"
  326.  
  327. puts $fout "/* Fill in content */"
  328. puts $fout "const unsigned char cvfs_data[] = \{"
  329. dict for {id info} $DirInfo {
  330. set buffer {}
  331. if {[dict exists $info content]} {
  332. binary scan [dict get $info content] H* buffer
  333. }
  334. set dat {}
  335. foreach {hi lo} [split $buffer {}] {
  336. lappend dat 0x$hi$lo
  337. }
  338. # Add a null terminator, just in case"
  339. lappend dat "0x00"
  340. if {$id > 0} {
  341. puts $fout ,
  342. }
  343. puts -nonewline $fout " [list [join $dat ", "]]"
  344. }
  345. puts $fout {}
  346. puts $fout "\}\;"
  347.  
  348.  
  349. puts fout [string map [list %PROJECT% $project] {
  350. MODULE_SCOPE const Tcl_Filesystem cvfs_filesystem;
  351.  
  352. static cvfs_file *Cvfs_FindEntry(Tcl_Obj *pathObj);
  353. static int Cvfs_FSPathInFilesystemProc(Tcl_Obj *pathPtr, ClientData *clientDataPtr);
  354. static Tcl_Obj *Cvfs_FSFilesystemPathTypeProc(Tcl_Obj *pathPtr);
  355. static Tcl_Obj *Cvfs_FSFilesystemSeparatorProc(Tcl_Obj *pathPtr);
  356. static int Cvfs_FSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
  357. static int Cvfs_FSAccessProc(Tcl_Obj *pathPtr, int mode);
  358. static Tcl_Channel Cvfs_FSOpenFileChannelProc(
  359. Tcl_Interp *interp, Tcl_Obj *pathPtr,
  360. int mode, int permissions
  361. );
  362. static int Cvfs_FSMatchInDirectoryProc(
  363. Tcl_Interp *cmdInterp,
  364. Tcl_Obj *returnPtr,
  365. Tcl_Obj *dirPtr,
  366. CONST char *pattern,
  367. Tcl_GlobTypeData *types
  368. );
  369. static Tcl_Obj *Zip_FSListVolumesProc(void);
  370.  
  371. static ClientData *Cvfs_FindEntry(Tcl_Obj *pathPtr) {
  372. char *path;
  373. int len;
  374. Tcl_HashEntry *hent;
  375.  
  376. if (!(pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return NULL;
  377. path = Tcl_GetStringFromObj(pathPtr, &len);
  378. hent = Tcl_FindHashEntry(&CVFS_Filehash, path);
  379. if(!hent) {
  380. return NULL;
  381. }
  382. return Tcl_GetHashValue(hent);
  383. }
  384.  
  385. /*
  386. *-------------------------------------------------------------------------
  387. *
  388. * Cvfs_FSPathInFilesystemProc --
  389. *
  390. * This function determines if the given path object is in the
  391. * ZIP filesystem.
  392. *
  393. * Results:
  394. * TCL_OK when the path object is in the ZIP filesystem, -1 otherwise.
  395. *
  396. * Side effects:
  397. * None.
  398. *
  399. *-------------------------------------------------------------------------
  400. */
  401. static int
  402. Cvfs_FSPathInFilesystemProc(Tcl_Obj *pathPtr, ClientData *clientDataPtr)
  403. {
  404. cvfs_file *CurrentFile;
  405. CurrentFile=Cvfs_FindEntry(pathPtr);
  406. if(!CurrentFile) {
  407. return -1;
  408. }
  409. *clientDataPtr=CurrentFile;
  410. return TCL_OK;
  411. }
  412.  
  413. static Tcl_Obj *
  414. Cvfs_FSFilesystemPathTypeProc(Tcl_Obj *pathPtr)
  415. {
  416. return Tcl_NewStringObj("cvfs", -1);
  417. }
  418. static Tcl_Obj *
  419. Cvfs_FSFilesystemSeparatorProc(Tcl_Obj *pathPtr)
  420. {
  421. return Tcl_NewStringObj("/", -1);
  422. }
  423. /*
  424. *-------------------------------------------------------------------------
  425. *
  426. * Zip_FSStatProc --
  427. *
  428. * This function implements the ZIP filesystem specific version
  429. * of the library version of stat.
  430. *
  431. * Results:
  432. * See stat documentation.
  433. *
  434. * Side effects:
  435. * See stat documentation.
  436. *
  437. *-------------------------------------------------------------------------
  438. */
  439.  
  440. static int
  441. Cvfs_FSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf)
  442. {
  443. cvfs_file *CurrentFile;
  444. CurrentFile=(cvfs_file *)Cvfs_FindEntry(pathPtr);
  445. if(!CurrentFile) {
  446. return -1;
  447. }
  448. memset(buf, 0, sizeof (Tcl_StatBuf));
  449. if (CurrentFile->isdirectory) {
  450. buf->st_mode = S_IFDIR | 0555;
  451. } else {
  452. buf->st_mode = S_IFREG | 0555;
  453. }
  454. buf->st_size = CurrentFile->size;
  455. buf->st_mtime = CurrentFile->mtime;
  456. buf->st_ctime = CurrentFile->ctime;
  457. buf->st_atime = CurrentFile->atime;
  458. return TCL_OK;
  459. }
  460.  
  461. static int Cvfs_FSAccessProc(Tcl_Obj *pathPtr, int mode) {
  462. cvfs_file *CurrentFile;
  463. if(mode & 3) {
  464. return -1;
  465. }
  466. CurrentFile=Cvfs_FindEntry(pathPtr);
  467. if(!CurrentFile) {
  468. return -1;
  469. }
  470. return TCL_OK;
  471. }
  472.  
  473. static Tcl_Obj *
  474. Cvfs_FSListVolumesProc(void) {
  475. return Tcl_NewStringObj(CVFS_VOLUME, CVFS_VOLUME_LEN);
  476. }
  477.  
  478. static Tcl_Channel Cvfs_FSOpenFileChannelProc(
  479. Tcl_Interp *interp, Tcl_Obj *pathPtr,
  480. int mode, int permissions
  481. ) {
  482. int len;
  483. cvfs_file *CurrentFile;
  484. CurrentFile=Cvfs_FindEntry(pathPtr);
  485. if(!CurrentFile) {
  486. if (interp != NULL) {
  487. Tcl_SetObjResult(interp, Tcl_NewStringObj("file not found", -1));
  488. Tcl_AppendResult(interp, " \"", filename, "\"", NULL);
  489. }
  490. return NULL;
  491. }
  492.  
  493. }
  494.  
  495. static int
  496. Cvfs_FSMatchInDirectoryProc(
  497. Tcl_Interp *cmdInterp, /* Interpreter to receive error msgs. */
  498. Tcl_Obj *returnPtr, /* Object to receive results. */
  499. Tcl_Obj *dirPtr, /* Contains path to directory to search. */
  500. CONST char *pattern, /* Pattern to match against. */
  501. Tcl_GlobTypeData *types) /* Object containing list of acceptable types.
  502. * May be NULL. */
  503. {
  504. int dirOnly=0;
  505. int i;
  506. cvfs_file *DirectoryEntry;
  507. cvfs_file *FileEntry;
  508. if (types != NULL) {
  509. dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR;
  510. }
  511. DirectoryEntry=(cvfs_file *)Cvfs_FindEntry(dirPtr);
  512. if(!DirectoryEntry) {
  513. /* Could not locate directory */
  514. return TCL_OK;
  515. }
  516. for(i=0;i<CVFS_VOLUME_LEN;i++) {
  517. FileEntry=&cvfs_directory[i];
  518. if(FileEntry->parent != DirectoryEntry->id) continue;
  519. if (Tcl_StringCaseMatch(FileEntry->name, pattern, 0)) {
  520. Tcl_ListObjAppendElement(NULL, returnPtr, Tcl_NewStringObj(FileEntry->name,-1));
  521. }
  522. }
  523. return TCL_OK;
  524. }
  525.  
  526.  
  527. const Tcl_Filesystem cvfs_filesystem = {
  528. .typeName = "cvfs_instance",
  529. .structureLength = sizeof (Tcl_Filesystem),
  530. .version = TCL_FILESYSTEM_VERSION_1,
  531. .pathInFilesystemProc = Cvfs_FSPathInFilesystemProc,
  532. .dupInternalRepProc = NULL,
  533. .freeInternalRepProc = NULL,
  534. .internalToNormalizedProc = NULL,
  535. .createInternalRepProc = NULL,
  536. .normalizePathProc = NULL,
  537. .filesystemPathTypeProc = NULL,
  538. .filesystemSeparatorProc = NULL,
  539. .statProc = Cvfs_FSStatProc,
  540. .accessProc = Cvfs_FSAccessProc,
  541. .openFileChannelProc = Cvfs_FSOpenFileChannelProc,
  542. .matchInDirectoryProc = Cvfs_FSMatchInDirectoryProc,
  543. .utimeProc = NULL;
  544. .linkProc = NULL;
  545. .listVolumesProc = NULL;
  546. .fileAttrStringsProc = NULL;
  547. .fileAttrsGetProc = NULL;
  548. .fileAttrsSetProc = NULL;
  549. .createDirectoryProc = NULL;
  550. .removeDirectoryProc = NULL;
  551. .deleteFileProc = NULL;
  552. .copyFileProc = NULL;
  553. .renameFileProc = NULL;
  554. .copyDirectoryProc = NULL;
  555. .lstatProc = NULL;
  556. .loadFileProc = NULL;
  557. .getCwdProc = NULL;
  558. .chdirProc = NULL;
  559. };
  560. }]
  561.  
  562. puts $fout "MODULE_SCOPE void $cinit(void) \{"
  563. puts $fout {
  564. int i;
  565. Tcl_DString fpBuf;
  566.  
  567. if(CVFS_Initialized) {
  568. return TCL_OK;
  569. }
  570. Tcl_FSRegister(NULL, &cvfs_filesystem);
  571. Tcl_InitHashTable(&CVFS_Filehash,TCL_STRING_KEYS);
  572. Tcl_DStringInit(&fpBuf);
  573. for(i=0;i<CVFS_VOLUME_LEN;i++) {
  574. cvfs_file *ThisElement;
  575. Tcl_HashEntry *hPtr;
  576. int isNew;
  577. hPtr = Tcl_CreateHashEntry(&CVFS_Filehash, ThisElement->path, &isNew);
  578. Tcl_SetHashValue(hPtr, (ClientData)&cvfs_directory[i]);
  579. }
  580. Tcl_DStringFree(&fpBuf);
  581. CVFS_Initialized=1;
  582. return TCL_OK;
  583. }
  584. puts $fout "\}"
  585. close $fout
  586.