Posted to tcl by hypnotoad at Thu Nov 14 22:18:15 GMT 2019view pretty
### # Tools to encode the /library file system as a C based VFS ### if {[llength $argv] != 4} { puts "Usage: [file tail [info script]] path cfile mountpoint cinit project" puts "path: A File system path to encode" puts "cfile: A file name to write the result to" puts "mountpoint: The root this VFS will be mounted to" puts "cinit: The name of the C function which will act as the mounting event." exit 0 } lassign $argv path cfile mountpoint cinit set path [file normalize $path] # Many functions cribbed from practcl, so we'll just leave that detail in for the moment namespace eval ::practcl {} proc ::practcl::cat fname { if {![file exists $fname]} { return } set fin [open $fname r] set data [read $fin] close $fin return $data } # Strip comments and annotations # Useful to keep file size down proc ::practcl::docstrip text { set result {} foreach line [split $text \n] { append thisline $line \n if {![info complete $thisline]} continue set outline $thisline set thisline {} if {[string trim $outline] eq {}} { continue } if {[string index [string trim $outline] 0] eq "#"} continue set cmd [string trim [lindex $outline 0] :] if {$cmd eq "namespace" && [lindex $outline 1] eq "eval"} { append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n continue } if {[string match "*::define" $cmd] && [llength $outline]==3} { append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n continue } if {$cmd eq "oo::class" && [lindex $outline 1] eq "create"} { append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n continue } append result $outline } return $result } proc ::practcl::cputs {varname args} { upvar 1 $varname buffer if {[llength $args]==1 && [string length [string trim [lindex $args 0]]] == 0} { } if {[info exist buffer]} { if {[string index $buffer end] ne "\n"} { append buffer \n } } else { set buffer \n } # Trim leading \n's append buffer [string trimleft [lindex $args 0] \n] {*}[lrange $args 1 end] } # Encode a block of (presumably) Tcl code into an ASCII text block in C proc ::practcl::tcl_to_c {body} { set result {} foreach rawline [split $body \n] { set line [string map [list \" \\\" \\ \\\\] $rawline] cputs result "\n \"$line\\n\" \\" } return [string trimright $result \\] } proc ::practcl::binary_to_c {body} { set result {} foreach rawline [split $body \n] { set line [string map [list \" \\\" \\ \\\\] $rawline] cputs result "\n \"$line\\n\" \\" } return [string trimright $result \\] } proc ::practcl::file_lexnormalize {sp} { set spx [file split $sp] # Resolution of embedded relative modifiers (., and ..). if { ([lsearch -exact $spx . ] < 0) && ([lsearch -exact $spx ..] < 0) } { # Quick path out if there are no relative modifiers return $sp } set absolute [expr {![string equal [file pathtype $sp] relative]}] # A volumerelative path counts as absolute for our purposes. set sp $spx set np {} set noskip 1 while {[llength $sp]} { set ele [lindex $sp 0] set sp [lrange $sp 1 end] set islast [expr {[llength $sp] == 0}] if {[string equal $ele ".."]} { if { ($absolute && ([llength $np] > 1)) || (!$absolute && ([llength $np] >= 1)) } { # .. : Remove the previous element added to the # new path, if there actually is enough to remove. set np [lrange $np 0 end-1] } } elseif {[string equal $ele "."]} { # Ignore .'s, they stay at the current location continue } else { # A regular element. lappend np $ele } } if {[llength $np] > 0} { return [eval [linsert $np 0 file join]] # 8.5: return [file join {*}$np] } return {} } proc ::practcl::file_relative {base dst} { # Ensure that the link to directory 'dst' is properly done relative to # the directory 'base'. if {![string equal [file pathtype $base] [file pathtype $dst]]} { return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" } set base [file_lexnormalize [file join [pwd] $base]] set dst [file_lexnormalize [file join [pwd] $dst]] set save $dst set base [file split $base] set dst [file split $dst] while {[string equal [lindex $dst 0] [lindex $base 0]]} { set dst [lrange $dst 1 end] set base [lrange $base 1 end] if {![llength $dst]} {break} } set dstlen [llength $dst] set baselen [llength $base] if {($dstlen == 0) && ($baselen == 0)} { # Cases: # (a) base == dst set dst . } else { # Cases: # (b) base is: base/sub = sub # dst is: base = {} # (c) base is: base = {} # dst is: base/sub = sub while {$baselen > 0} { set dst [linsert $dst 0 ..] incr baselen -1 } # 8.5: set dst [file join {*}$dst] set dst [eval [linsert $dst 0 file join]] } return $dst } # Can't always guarantee we are running this script with a modern Tcl # But we can be pretty sure we are running on 8.4 or better if {[::package vcompare $::tcl_version 8.6] < 0} { if {[::package vcompare $::tcl_version 8.5] < 0} { package require dict } proc ::practcl::sort_dict list { set result {} foreach key [lsort -dictionary [dict keys $list]] { dict set result $key [dict get $list $key] } return $result } proc ::practcl::binary_encode block { set result {} set buffer [binary scan $block H* buffer] foreach {hi lo} [split $buffer] { lappend result 0x$hi$lo } return $result } } else { proc ::practcl::binary_encode block { set result {} foreach {hi lo} [split [binary encode hex $block]] { lappend result 0x$hi$lo } return $result } proc ::practcl::sort_dict list { return [::lsort -stride 2 -dictionary $list] } } proc EncodeFileSystem {root {parent 0} {path {}}} { if {![file exists $path]} return puts [list EncodeFileSystem $root $parent $path] set result {} set ftail [file tail $path] set vfs_location [::practcl::file_relative $root $path] set inode [incr ::NextInode] dict set result $inode inode $inode dict set result $inode path $vfs_location dict set result $inode name $ftail dict set result $inode parent $parent dict set result $inode ctime [file ctime $path] dict set result $inode mtime [file mtime $path] dict set result $inode atime [file atime $path] if {[file isfile $path]} { set ext [file extension $path] dict set result $inode isdirectory 1 dict set result $inode ext [string trim $ext .] set content [::practcl::cat $path] dict set result $inode content $content dict set result $inode size [string length $content] } else { dict set result $inode isdirectory 1 foreach subpath [glob -nocomplain [file join $path *]] { if {[file tail $subpath] in {. ..}} continue dict for {subnode subinfo} [EncodeFileSystem $root $inode $subpath] { dict set result $subnode $subinfo } } } return $result } ### # Generate a data structure representation of the file system ### set fout [open $cfile w] fconfigure $fout -translation cr -encoding utf-8 puts $fout "/* This file is generated by [file tail [info script]] */" puts $fout {/* Attempt no edits here */ #include "tcl.h" /* * Global variables. * * The "fileHash" component is the process wide global table of all known * CVFS archive members */ static Tcl_HashTable CVFS_Filehash; static int CVFS_Initialized=0; typedef struct cvfs_file { int id; int parent; int size; long ctime; long mtime; long atime; int isdirectory; const char *name; const char *path; const char *type; } cvfs_file; } puts $fout "\#define CVFS_VOLUME \"$mountpoint\"" puts $fout "\#define CVFS_VOLUME_LEN [string length $mountpoint]" set ::NextInode -1 set DirInfo [EncodeFileSystem $path 0 $path] puts $fout "\#define CVFS_FILECOUNT [dict size $DirInfo]" puts $fout "const cvfs_file cvfs_directory\[\] = \{" dict for {id info} $DirInfo { if {$id > 0} { puts $fout , } puts $fout " \{" set structout {} lappend structout ".id = $id" dict for {f v} $info { switch $f { isdirectory - ctime - mtime - atime - parent { lappend structout ".$f = $v" } content { lappend structout ".size=[string length [dict get $info content]]" } path { lappend structout ".$f=\"$mountpoint/$v\"" } name { lappend structout ".$f=\"$v\"" } } } puts $fout " [join $structout ",\n "]" puts -nonewline $fout " \}" } puts $fout {} puts $fout "\};" puts $fout "/* Fill in content */" puts $fout "const unsigned char cvfs_data[] = \{" dict for {id info} $DirInfo { set buffer {} if {[dict exists $info content]} { binary scan [dict get $info content] H* buffer } set dat {} foreach {hi lo} [split $buffer {}] { lappend dat 0x$hi$lo } # Add a null terminator, just in case" lappend dat "0x00" if {$id > 0} { puts $fout , } puts -nonewline $fout " [list [join $dat ", "]]" } puts $fout {} puts $fout "\}\;" puts fout [string map [list %PROJECT% $project] { MODULE_SCOPE const Tcl_Filesystem cvfs_filesystem; static cvfs_file *Cvfs_FindEntry(Tcl_Obj *pathObj); static int Cvfs_FSPathInFilesystemProc(Tcl_Obj *pathPtr, ClientData *clientDataPtr); static Tcl_Obj *Cvfs_FSFilesystemPathTypeProc(Tcl_Obj *pathPtr); static Tcl_Obj *Cvfs_FSFilesystemSeparatorProc(Tcl_Obj *pathPtr); static int Cvfs_FSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); static int Cvfs_FSAccessProc(Tcl_Obj *pathPtr, int mode); static Tcl_Channel Cvfs_FSOpenFileChannelProc( Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions ); static int Cvfs_FSMatchInDirectoryProc( Tcl_Interp *cmdInterp, Tcl_Obj *returnPtr, Tcl_Obj *dirPtr, CONST char *pattern, Tcl_GlobTypeData *types ); static Tcl_Obj *Zip_FSListVolumesProc(void); static ClientData *Cvfs_FindEntry(Tcl_Obj *pathPtr) { char *path; int len; Tcl_HashEntry *hent; if (!(pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr))) return NULL; path = Tcl_GetStringFromObj(pathPtr, &len); hent = Tcl_FindHashEntry(&CVFS_Filehash, path); if(!hent) { return NULL; } return Tcl_GetHashValue(hent); } /* *------------------------------------------------------------------------- * * Cvfs_FSPathInFilesystemProc -- * * This function determines if the given path object is in the * ZIP filesystem. * * Results: * TCL_OK when the path object is in the ZIP filesystem, -1 otherwise. * * Side effects: * None. * *------------------------------------------------------------------------- */ static int Cvfs_FSPathInFilesystemProc(Tcl_Obj *pathPtr, ClientData *clientDataPtr) { cvfs_file *CurrentFile; CurrentFile=Cvfs_FindEntry(pathPtr); if(!CurrentFile) { return -1; } *clientDataPtr=CurrentFile; return TCL_OK; } static Tcl_Obj * Cvfs_FSFilesystemPathTypeProc(Tcl_Obj *pathPtr) { return Tcl_NewStringObj("cvfs", -1); } static Tcl_Obj * Cvfs_FSFilesystemSeparatorProc(Tcl_Obj *pathPtr) { return Tcl_NewStringObj("/", -1); } /* *------------------------------------------------------------------------- * * Zip_FSStatProc -- * * This function implements the ZIP filesystem specific version * of the library version of stat. * * Results: * See stat documentation. * * Side effects: * See stat documentation. * *------------------------------------------------------------------------- */ static int Cvfs_FSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf) { cvfs_file *CurrentFile; CurrentFile=(cvfs_file *)Cvfs_FindEntry(pathPtr); if(!CurrentFile) { return -1; } memset(buf, 0, sizeof (Tcl_StatBuf)); if (CurrentFile->isdirectory) { buf->st_mode = S_IFDIR | 0555; } else { buf->st_mode = S_IFREG | 0555; } buf->st_size = CurrentFile->size; buf->st_mtime = CurrentFile->mtime; buf->st_ctime = CurrentFile->ctime; buf->st_atime = CurrentFile->atime; return TCL_OK; } static int Cvfs_FSAccessProc(Tcl_Obj *pathPtr, int mode) { cvfs_file *CurrentFile; if(mode & 3) { return -1; } CurrentFile=Cvfs_FindEntry(pathPtr); if(!CurrentFile) { return -1; } return TCL_OK; } static Tcl_Obj * Cvfs_FSListVolumesProc(void) { return Tcl_NewStringObj(CVFS_VOLUME, CVFS_VOLUME_LEN); } static Tcl_Channel Cvfs_FSOpenFileChannelProc( Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions ) { int len; cvfs_file *CurrentFile; CurrentFile=Cvfs_FindEntry(pathPtr); if(!CurrentFile) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("file not found", -1)); Tcl_AppendResult(interp, " \"", filename, "\"", NULL); } return NULL; } } static int Cvfs_FSMatchInDirectoryProc( Tcl_Interp *cmdInterp, /* Interpreter to receive error msgs. */ Tcl_Obj *returnPtr, /* Object to receive results. */ Tcl_Obj *dirPtr, /* Contains path to directory to search. */ CONST char *pattern, /* Pattern to match against. */ Tcl_GlobTypeData *types) /* Object containing list of acceptable types. * May be NULL. */ { int dirOnly=0; int i; cvfs_file *DirectoryEntry; cvfs_file *FileEntry; if (types != NULL) { dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR; } DirectoryEntry=(cvfs_file *)Cvfs_FindEntry(dirPtr); if(!DirectoryEntry) { /* Could not locate directory */ return TCL_OK; } for(i=0;i<CVFS_VOLUME_LEN;i++) { FileEntry=&cvfs_directory[i]; if(FileEntry->parent != DirectoryEntry->id) continue; if (Tcl_StringCaseMatch(FileEntry->name, pattern, 0)) { Tcl_ListObjAppendElement(NULL, returnPtr, Tcl_NewStringObj(FileEntry->name,-1)); } } return TCL_OK; } const Tcl_Filesystem cvfs_filesystem = { .typeName = "cvfs_instance", .structureLength = sizeof (Tcl_Filesystem), .version = TCL_FILESYSTEM_VERSION_1, .pathInFilesystemProc = Cvfs_FSPathInFilesystemProc, .dupInternalRepProc = NULL, .freeInternalRepProc = NULL, .internalToNormalizedProc = NULL, .createInternalRepProc = NULL, .normalizePathProc = NULL, .filesystemPathTypeProc = NULL, .filesystemSeparatorProc = NULL, .statProc = Cvfs_FSStatProc, .accessProc = Cvfs_FSAccessProc, .openFileChannelProc = Cvfs_FSOpenFileChannelProc, .matchInDirectoryProc = Cvfs_FSMatchInDirectoryProc, .utimeProc = NULL; .linkProc = NULL; .listVolumesProc = NULL; .fileAttrStringsProc = NULL; .fileAttrsGetProc = NULL; .fileAttrsSetProc = NULL; .createDirectoryProc = NULL; .removeDirectoryProc = NULL; .deleteFileProc = NULL; .copyFileProc = NULL; .renameFileProc = NULL; .copyDirectoryProc = NULL; .lstatProc = NULL; .loadFileProc = NULL; .getCwdProc = NULL; .chdirProc = NULL; }; }] puts $fout "MODULE_SCOPE void $cinit(void) \{" puts $fout { int i; Tcl_DString fpBuf; if(CVFS_Initialized) { return TCL_OK; } Tcl_FSRegister(NULL, &cvfs_filesystem); Tcl_InitHashTable(&CVFS_Filehash,TCL_STRING_KEYS); Tcl_DStringInit(&fpBuf); for(i=0;i<CVFS_VOLUME_LEN;i++) { cvfs_file *ThisElement; Tcl_HashEntry *hPtr; int isNew; hPtr = Tcl_CreateHashEntry(&CVFS_Filehash, ThisElement->path, &isNew); Tcl_SetHashValue(hPtr, (ClientData)&cvfs_directory[i]); } Tcl_DStringFree(&fpBuf); CVFS_Initialized=1; return TCL_OK; } puts $fout "\}" close $fout