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