#----------------------------------------------------------------------
# Virtual File System for Version Control Systems
#
# Copyright (c) 2014, Peter Spjuth
#
# License for vcsvfs package: Same as for Tcl
#----------------------------------------------------------------------
package require vfs
package provide vcsvfs 0.1
namespace eval vcsvfs {
variable DataRefChan
variable mpoints {}
namespace eval fossil {}
namespace eval svn {}
namespace eval git {}
}
# Create a Virtual File System showing a revision of a fossil checkout
#
# dir: Directory in a fossil checkout
# rev: Revision to mount
#
# Returns: path to the generated VFS
proc vcsvfs::fossil::mount {dir rev} {
variable ::vcsvfs::mpoints
set dir [file normalize $dir]
# Fossil command must be run within the dir, so temporarily change pwd
set oldpwd [pwd]
cd $dir
# The mount point will always be at the fossil root, even if
# a sub directory was given.
# Locate fossil root for the given directory.
set info [exec fossil info]
regexp -line {local-root:\s*(\S.*)} $info -> root
set root [file normalize $root]
cd $root
# Getting files via ls
set allfiles [exec fossil ls --age $rev .]
foreach line [split $allfiles \n] {
# Expected format in a line:
# 2012-08-21 20:38:19 tests/rev.test
regexp {(\S+ \S+)\s+(.+)} $line -> fDate fName
dict set finfo $fName mtimestr $fDate
dict set finfo $fName type file
dict set finfo $fName isfile 1
dict set finfo $fName isdir 0
# Mark all known directory paths and build up file tree info
set parentStr ""
foreach dirPath [file split $fName] {
dict set finfo $parentStr child $dirPath 1
dict set finfo $parentStr isfile 0
dict set finfo $parentStr isdir 1
dict set finfo $parentStr type directory
set parentStr [file join $parentStr $dirPath]
}
}
# Getting files via artifact
set artifact [exec fossil artifact $rev]
foreach line [split $artifact \n] {
# Expected format in a line:
# F tests/left.txt c1572b3809a1ba6ab2de9307c96b1cfeefdcf0ba
if {[regexp {F (\S+) (\S+)} $line -> fName fSha]} {
# File names can have spaces, coded with \s
set fName [string map {\\s " "} $fName]
dict set finfo $fName sha $fSha
# TBD: Delay calling whatis until size is needed
# Expected format in a line:
# size: 629 bytes
set whatis [exec fossil whatis $fSha]
regexp {size:\s+(\d+)} $whatis -> fSize
dict set finfo $fName size $fSize
}
}
cd $oldpwd
# Generate a mount point.
set tail [string range $dir [string length $root] end]
set mountpoint "${root} ($rev)"
dict set mpoints $mountpoint "finfo" $finfo
dict set mpoints $mountpoint "origroot" $root
dict set mpoints $mountpoint "rev" $rev
dict set mpoints $mountpoint "vcstype" fossil
vfs::filesystem mount $mountpoint [list vcsvfs::Vfs]
set result $mountpoint$tail
#puts $result
#puts [dict size $finfo]
#puts [dict get $finfo [lindex $finfo 0]]
return $result
}
proc vcsvfs::fossil::unmount {dir} {
variable ::vcsvfs::mpoints
# TBD: Find the mountpoint
#dict unset mpoints $mountpoint
#vfs::filesystem unmount $mountpoint
}
# Create a Virtual File System showing a revision of an SVN checkout
#
# dir: Directory in an SVN checkout
# rev: Revision to mount
#
# Returns: path to the generated VFS
proc vcsvfs::svn::mount {dir rev} {
variable ::vcsvfs::mpoints
set dir [file normalize $dir]
# Command must be run within the dir, so temporarily change pwd
set oldpwd [pwd]
cd $dir
# The mount point will normally be at the wc root, even if
# a sub directory was given.
# Locate root for the given directory.
set info [exec svn info]
if {![regexp -line {Working Copy Root Path:\s*(\S.*)} $info -> root]} {
# Fallback to given dir
set root .
}
# TBD: Always root at given dir, for speed
set root .
set root [file normalize $root]
cd $root
# Getting files via ls
set allfiles [exec svn ls -R -r $rev]
foreach line [split $allfiles \n] {
# Each line is one file/dir name
set fName $line
if {[string index $fName end] eq "/"} {
# This is a directory, strip the /
set fName [string range $fName 0 end-1]
dict set finfo $fName isfile 0
dict set finfo $fName isdir 1
dict set finfo $fName type directory
} else {
# This is a file
dict set finfo $fName isfile 1
dict set finfo $fName isdir 0
dict set finfo $fName type file
}
# Mark all known directory paths and build up file tree info
set parentStr ""
foreach dirPath [file split $fName] {
dict set finfo $parentStr child $dirPath 1
dict set finfo $parentStr isfile 0
dict set finfo $parentStr isdir 1
dict set finfo $parentStr type directory
set parentStr [file join $parentStr $dirPath]
}
}
set xml [exec svn ls -R -r $rev --xml]
# TBD real xml parser
foreach line [split $xml \n] {
if {[regexp {<name>(.*)</name>} $line -> fName]} {
continue
}
if {[regexp {<date>(.*)</date>} $line -> fDate]} {
dict set finfo $fName mtimestr $fDate
continue
}
if {[regexp {<size>(.*)</size>} $line -> fSize]} {
dict set finfo $fName size $fSize
continue
}
}
cd $oldpwd
# Generate a mount point.
set tail [string range $dir [string length $root] end]
set mountpoint "${root} ($rev)"
dict set mpoints $mountpoint "finfo" $finfo
dict set mpoints $mountpoint "origroot" $root
dict set mpoints $mountpoint "rev" $rev
dict set mpoints $mountpoint "vcstype" svn
vfs::filesystem mount $mountpoint [list vcsvfs::Vfs]
set result $mountpoint$tail
#puts $result
#puts [dict size $finfo]
#puts [dict get $finfo [lindex $finfo 0]]
return $result
}
proc vcsvfs::svn::unmount {dir} {
variable ::vcsvfs::mpoints
# TBD: Find the mountpoint
#dict unset mpoints $mountpoint
#vfs::filesystem unmount $mountpoint
}
# Create a Virtual File System showing a revision of a GIT checkout
#
# dir: Directory in an GIT checkout
# rev: Revision to mount
#
# Returns: path to the generated VFS
proc vcsvfs::git::mount {dir rev} {
variable ::vcsvfs::mpoints
set dir [file normalize $dir]
# Command must be run within the dir, so temporarily change pwd
set oldpwd [pwd]
cd $dir
# The mount point will be at the given dir
set root $dir
# Getting files via ls
set allfiles [exec git ls-tree -r --long $rev .]
foreach line [split $allfiles \n] {
# Each line is:
# <mode> SP <type> SP <object> SP <object size> TAB <file>
regexp {(\S)+\s+(\S+)\s+(\S+)\s+(\S+)\t(.*)} $line -> \
mode type sha size fName
# TBD: check mode to see a link
if {$type eq "tree"} {
dict set finfo $fName isfile 0
dict set finfo $fName isdir 1
dict set finfo $fName "type" directory
} else {
# This is a file
dict set finfo $fName isfile 1
dict set finfo $fName isdir 0
dict set finfo $fName "type" file
dict set finfo $fName "sha" $sha
dict set finfo $fName "size" $size
set mtime [exec git log --pretty=format:%ct -n 1 $fName]
dict set finfo $fName "mtime" $mtime
}
# Mark all known directory paths and build up file tree info
set parentStr ""
foreach dirPath [file split $fName] {
dict set finfo $parentStr child $dirPath 1
dict set finfo $parentStr isfile 0
dict set finfo $parentStr isdir 1
dict set finfo $parentStr "type" directory
set parentStr [file join $parentStr $dirPath]
}
}
cd $oldpwd
# Generate a mount point.
set tail [string range $dir [string length $root] end]
set mountpoint "${root} ($rev)"
dict set mpoints $mountpoint "finfo" $finfo
dict set mpoints $mountpoint "origroot" $root
dict set mpoints $mountpoint "rev" $rev
dict set mpoints $mountpoint "vcstype" git
vfs::filesystem mount $mountpoint [list vcsvfs::Vfs]
set result $mountpoint$tail
#puts $result
#puts [dict size $finfo]
#puts [dict get $finfo [lindex $finfo 0]]
return $result
}
proc vcsvfs::git::unmount {dir} {
variable ::vcsvfs::mpoints
# TBD: Find the mountpoint
#dict unset mpoints $mountpoint
#vfs::filesystem unmount $mountpoint
}
# Handler for Reflected Channel
proc vcsvfs::DataRefChan {id cmd chId args} {
variable DataRefChan
switch $cmd {
initialize {
set mode [lindex $args 0]
return "initialize finalize watch read"
}
finalize {
unset DataRefChan($id,data)
return
}
watch {
#set eventSpec [lindex $args 0]
return
}
read {
set count [lindex $args 0]
set si $DataRefChan($id,ptr)
set newPtr [expr {$si + $count}]
set ei [expr {$newPtr - 1}]
set data [string range $DataRefChan($id,data) $si $ei]
set DataRefChan($id,ptr) $newPtr
return $data
}
}
}
# Set up a Reflected Channel which reads the provided data
proc vcsvfs::CreateDataRefChan {data} {
variable DataRefChan
set t 0
while {[info exists DataRefChan($t,data)]} {
incr t
}
set DataRefChan($t,data) $data
set DataRefChan($t,ptr) 0
set chId [chan create r [list vcsvfs::DataRefChan $t]]
return $chId
}
# This is used before closing a pipe from a command.
# It should read all data to avoid errors from the command.
proc vcsvfs::ReadAllBeforeClose {chId} {
read $chId
}
# Helper for glob matching in directory
proc vcsvfs::MatchInDirectory {finfo relative actual args} {
set pattern [lindex $args 0]
set types [lindex $args 1]
set allowFile 0
set allowDir 0
if {[vfs::matchDirectories $types]} {set allowDir 1}
if {[vfs::matchFiles $types]} {set allowFile 1}
set result {}
if {[dict exists $finfo $relative child]} {
set childD [dict get $finfo $relative child]
} else {
# Empty dir
return {}
}
foreach child [dict keys $childD] {
if {![string match $pattern $child]} continue
set local [file join $relative $child]
if {[dict get $finfo $local isfile] && !$allowFile} continue
if {[dict get $finfo $local isdir] && !$allowDir} continue
lappend result [file join $actual $child]
}
return $result
}
# Extract file data from Fossil revision
proc vcsvfs::fossil::openFile {rootD relative} {
set oldpwd [pwd]
cd [dict get $rootD "origroot"]
set rev [dict get $rootD rev]
# Which way of extracting file data is best?
# fossil finfo -p -r $rev $relative
# set sha [dict get $finfor sha]
# fossil artifact $sha
# fossil cat $relative -r $rev
# Read through a pipe to get a binary channel
set chId [open [list |fossil cat $relative -r $rev] rb]
#set data [read $chId]
#close $chId
cd $oldpwd
#set chId [vcsvfs::CreateDataRefChan $data]
return [list $chId [list vcsvfs::ReadAllBeforeClose $chId]]
}
# Extract file data from Subversion revision
proc vcsvfs::svn::openFile {rootD relative} {
set oldpwd [pwd]
cd [dict get $rootD "origroot"]
set rev [dict get $rootD rev]
# Read through a pipe to get a binary channel
set chId [open [list |svn cat -r $rev $relative] rb]
#set data [read $chId]
#close $chId
cd $oldpwd
#set chId [vcsvfs::CreateDataRefChan $data]
return [list $chId [list vcsvfs::ReadAllBeforeClose $chId]]
}
# Some notes about git commands that can be good to have
proc vcsvfs::git::openFile {rootD relative} {
set oldpwd [pwd]
cd [dict get $rootD "origroot"]
set rev [dict get $rootD rev]
set sha [dict get $rootD finfo $relative sha]
#git cat-file
#git show <rev>^{tree}
# example: git show HEAD^^^:apa
# Read through a pipe to get a binary channel
set chId [open [list |git cat-file blob $sha] rb]
#set data [read $chId]
#close $chId
cd $oldpwd
#set chId [vcsvfs::CreateDataRefChan $data]
return [list $chId [list vcsvfs::ReadAllBeforeClose $chId]]
}
# Parse a time string from Fossil
proc vcsvfs::fossil::mTime {mtimestr} {
# TBD parse to mtime correct?
set mtime [clock scan $mtimestr -gmt 1]
return $mtime
}
# Parse a time string from Subversion
proc vcsvfs::svn::mTime {mtimestr} {
# TBD parse to mtime correct?
# Remove any decimals from time string
regsub {\.\d+Z} $mtimestr "" mtimestr
set mtime [clock scan $mtimestr -gmt 1]
return $mtime
}
# The handler for the mounted VFS
proc vcsvfs::Vfs {subcmd root relative actual args} {
variable mpoints
#puts "\nVfs called:"
#puts " Su $subcmd"
#puts " Ro $root"
#puts " Re $relative"
#puts " Ac $actual"
#puts " Ar $args"
set rootD [dict get $mpoints $root]
set origroot [dict get $rootD origroot]
set finfo [dict get $rootD finfo]
set vcstype [dict get $rootD vcstype]
if {![dict exists $finfo $relative]} {
# Unknown path
vfs::filesystem posixerror $::vfs::posix(EACCES)
return -code error $::vfs::posix(EACCES)
}
set finfor [dict get $finfo $relative]
#puts " $finfor"
switch $subcmd {
access {
set mode [vfs::accessMode [lindex $args 0]]
# Only read supported
if {$mode ne "R"} {
vfs::filesystem posixerror $::vfs::posix(EACCES)
return -code error $::vfs::posix(EACCES)
}
return
}
fileattributes {
#set index [lindex $args 0]
#set value [lindex $args 1]
return
}
matchindirectory {
return [vcsvfs::MatchInDirectory $finfo $relative $actual {*}$args]
}
open {
set mode [lindex $args 0]
if {$mode == {}} {set mode r}
#set permissions [lindex $args 1]
if {$mode ne "r"} {
# Read only
vfs::filesystem posixerror $::vfs::posix(EACCES)
return -code error $::vfs::posix(EACCES)
}
return [vcsvfs::${vcstype}::openFile $rootD $relative]
}
stat {
set res [dict create dev 0 ino 0 "mode" 0 nlink 0 uid 0 gid 0 \
size 0 atime 0 mtime 0 ctime 0 type file]
dict set res type [dict get $finfor type]
if {[dict get $finfor isfile]} {
if {![dict exists $finfor mtime]} {
set mtime [vcsvfs::${vcstype}::mTime \
[dict get $finfor mtimestr]]
dict set finfor "mtime" $mtime
# Cache in main dictionary too
dict set mpoints $root "finfo" $relative "mtime" $mtime
}
dict set res "mtime" [dict get $finfor "mtime"]
dict set res size [dict get $finfor size]
}
return $res
}
createdirectory - deletefile - removedirectory - utime {
# Read-only, always error
}
}
vfs::filesystem posixerror $::vfs::posix(EACCES)
return -code error $::vfs::posix(EACCES)
}
##################################################################
# Test structure
##################################################################
if 0 {
# File traversing stuff from wiki...
proc ftw_1 {{dirs .}} {
while {[llength $dirs]} {
set dirs [lassign $dirs name]
lappend dirs {*}[glob -nocomplain -directory $name -type d *]
puts $name
}
}
proc ls-l { dir } {
# Get the current year, because the date format depends on it.
set thisYear [clock format [clock seconds] -format %Y]
# Walk the files in the given directory, accumulating lines
# in $retval
set retval {}
set sep {}
# In Tcl older than 8.3 use 'glob [file join $dir *]'
foreach fileName [lsort [glob -dir $dir *]] {
append retval $sep
set sep \n
# Get status of the file
#file stat $fileName stat
# use 'file lstat' instead: if the file is a symbolic link we don't want info about its target
file lstat $fileName stat
# Put in one character for file type. Use - for a plain file.
set type -
if { [info exists stat(type)]
&& [string compare file $stat(type)] } {
set type [string index $stat(type) 0]
}
append retval $type
# Decode $stat(mode) into permissions the way that ls does it.
foreach { mask pairs } {
00400 { 00400 r }
00200 { 00200 w }
04100 { 04100 s 04000 S 00100 x }
00040 { 00040 r }
00020 { 00020 w }
02010 { 02010 s 02000 S 00010 x }
00004 { 00004 r }
00002 { 00002 w }
01001 { 01001 t 01000 T 00001 x }
} {
set value [expr $stat(mode) & $mask]
set bit -
foreach { x b } $pairs {
if { $value == $x } {
set bit $b
}
}
append retval $bit
}
# Put in link count, user ID, and size. Note that the UID
# will be numeric. If you know how to back-translate this
# from Tcl, please feel free to edit it in!
# LV writes - use file userid and file groupid to convert the numbers back to names.
# I don't know what version of Tcl added those commands...
append retval [format %4d $stat(nlink)] { }
array set attribs [file attributes $fileName]
if {[info exists attribs(-owner)]} {
append retval [format %-8s $attribs(-owner)]
append retval [format %-8s $attribs(-group)]
} else {
append retval [format %8d $stat(uid)]
append retval [format %8d $stat(gid)]
}
append retval [format %9d $stat(size)]
# Put in the date. The current year is formatted differently
# from prior years.
set year [clock format $stat(mtime) -format "%Y"]
if { $year == $thisYear } {
set modified [clock format $stat(mtime) -format "%h %e %H:%M"]
} else {
set modified [clock format $stat(mtime) -format "%h %e %Y"]
}
# glennj: see note below
append retval { } $modified { }
# Finally, put in the file name, stripping off the directory.
append retval [file tail $fileName]
if {[string compare $stat(type) link] == 0} {
append retval " -> [file readlink $fileName]"
}
if {$type eq "-"} {
set ch [open $fileName]
set x [read $ch]
set x [string range $x 0 4]
close $ch
append retval " = '$x'"
}
unset stat attribs
}
return $retval
}
set d [vcsvfs::fossil::mount ~/src/eskil f96b0fd915]
puts "------------- GLOB:"
puts [join [glob -dir $d *] \n]
puts "------------- FTW:"
ftw_1 [list $d]
puts "------------- LS:"
puts [ls-l $d]
}