#----------------------------------------------------------------------
# Virtual File System for Version Control Systems
#
# Copyright (c) 2014-2015, Peter Spjuth
#
# License for vcsvfs package: Same as for Tcl
#----------------------------------------------------------------------
package require vfs
package provide vcsvfs 0.2
namespace eval vcsvfs {
variable DataRefChan
variable mpoints {}
namespace eval fossil {}
namespace eval svn {}
namespace eval git {}
namespace eval hg {}
}
# Create a command which when eval'd recreates known file systems
proc vcsvfs::serialize {} {
variable ::vcsvfs::mpoints
return [list vcsvfs::deserialize $mpoints]
}
# Pick up the command created by serialize
proc vcsvfs::deserialize {data} {
variable ::vcsvfs::mpoints
dict for {key value} $data {
dict set mpoints $key $value
# Handle if this is done again, do not mount it twice
if {[string match *vcsvfs* [file system $key]]} {
continue
}
vfs::filesystem mount $key [list vcsvfs::Vfs]
}
}
# 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 manifest artifact
# This is a quick and robust way to get the file tree and each file's sha
# Other info is trickier and is handled below
if {[catch {exec fossil artifact $rev} artifact]} {
return -code error "No such fossil revision: $rev"
}
set commitTime 0
set cTime now
set finfo {}
set todo [split $artifact \n]
while {[llength $todo] > 0} {
set line [lindex $todo 0]
set todo [lrange $todo 1 end]
# Expected format in a line:
# B baseline
# F tests/left.txt c1572b3809a1ba6ab2de9307c96b1cfeefdcf0ba
# D 2015-02-23T23:30:07.509
if {[regexp {^B (.*)} $line -> bUuid]} {
# Pick up a baseline manifest and parse it first
set artifact [exec fossil "artifact" $bUuid]
set todo [concat [split $artifact \n] $todo]
continue
}
if {[regexp {^D (.*)} $line -> cTime]} {
# Remove decimals and middle T
regsub {\.\d+} $cTime "" cTime
regsub {T} $cTime " " cTime
set commitTime [clock scan $cTime -gmt 1]
}
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
dict set finfo $fName mtimestr $cTime ;# Anything
dict set finfo $fName type file
dict set finfo $fName isfile 1
dict set finfo $fName isdir 0
# Setting size is delayed until needed since the needed
# calls are relatively expensive.
# 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]
}
}
}
# Try to use "fossil ls -r, available in newer versions"
set doneCollecting 0
if { ! [catch {exec fossil ls -r $rev -v} lsdata]} {
set lsdata [string trim $lsdata \n]
foreach line [split $lsdata \n] {
# Expected format in a line:
# 2012-08-21 20:38:19 4563 tests/rev.test
regexp {(\S+ \S+)\s+(\d+)\s+(.+)} $line -> fDate fSize fName
dict set finfo $fName mtimestr $fDate
dict set finfo $fName size $fSize
}
set doneCollecting 1
}
# Getting files via http fileage to aquire file times
# Since dates are parsed from the age string they are rather imprecise
# Use a while around it to be able to break free easily (faking goto)
while { ! $doneCollecting} {
set html [exec fossil http << "GET /fileage?name=$rev"]
if { ! [regexp {Files in.*} $html html]} {
# Not the expected format of response, skip
break
}
if { ! [regexp {\d{4}-\d{2}-\d{2} \d{2}:\d{2}:\d{2}} $html cTime2]} {
# Not the expected format of response, skip
break
}
# This is currently unused since we do not trust the formatted time in
# the web page. The time stamp from the artifact is used later.
set commitTime2 [clock scan $cTime2 -gmt 1]
#puts "CT $commitTime CT2 $commitTime2"
# Rows in the HTML table
foreach row [regexp -all -inline {<tr>.*?</tr>} $html] {
# Columns in the HTML table
set cols [regexp -all -inline {<td>(.*?)</td>} $row]
set col1 [string trim [lindex $cols 1]]
set col2 [string trim [lindex $cols 3]]
# First column is age, in readable format
# e.g. "current" "36.4 minutes" "97.0 days" "1.06 years"
if {$col1 eq ""} continue
if {$col1 eq "current"} {
set fTime $commitTime
set err 0
} else {
set value [lindex $col1 0]
set unit [lindex $col1 1]
set err 0
switch -glob $unit {
second* {
set value [expr {int($value)}]
set unit second
set err 0
}
minute* {
# In general, try to underestimate the value. The web
# page rounds to one decimal.
set value [expr {int(($value-0.05)*60)}]
set unit second
set err 6
}
hour* {
set value [expr {int(($value-0.05)*60*60)}]
set unit second
set err 360
}
day* {
set value [expr {int(($value-0.05)*60*60*24)}]
set unit second
set err 8640
}
year* {
# Year has two decimals
set value [expr {int(($value-0.005)*60*60*24*365)}]
set unit second
set err [expr {6*60*24*365}]
}
default {
puts "Unhandled unit: $unit in '$col1'"
set value [expr {int($value)}]
}
}
set fTime [expr {$commitTime - $value}]
}
#puts "AGE $col1 -> $fTime"
# Second column is file names, separated by <br>
# Remove links
regsub -all {<a .*?>} $col2 "" col2
regsub -all {</a>} $col2 "" col2
regsub -all {\n} $col2 "" col2
regsub -all {<br>} $col2 "\n" col2
set col2 [string trim $col2]
foreach fName [split $col2 \n] {
# Check that it matches something filled in from the artifact
if {[dict exists $finfo $fName]} {
dict set finfo $fName mtime $fTime
# Store error estimate for debug help
dict set finfo $fName errX $err
}
}
}
# Kill surrounding while loop
break
}
# As another step, get current file stamps from fossil ls.
# Since ls show current checkout they might not be valid for the rev
# being looked at. However if they are still present and older than the
# ones from fileage they are likely correct.
# Also, fileage and ls uses different criteria for which commit defines
# the age (across merges), so things basically will be a best effort guess.
if { ! $doneCollecting} {
set allfiles [exec fossil ls --age .]
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
set mTime [clock scan $fDate -gmt 1]
if {[dict exists $finfo $fName mtime]} {
set x [dict get $finfo $fName mtime]
set e [dict get $finfo $fName errX]
if {$mTime < $x} {
dict set finfo $fName mtime $mTime
} elseif {abs($mTime - $x) < 3600} {
#puts "$fName age $x ls $mTime diff [expr {$mTime - $x}] err $e"
}
}
}
}
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 HG checkout
#
# dir: Directory in an HG checkout
# rev: Revision to mount
#
# Returns: path to the generated VFS
proc vcsvfs::hg::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 root [exec hg root]
# TBD: Always root at given dir, for speed
#set root .
#set root [file normalize $root]
#cd $root
# Getting files via manifest
set allfiles [exec hg manifest --debug -r $rev]
# Expected line format:
# sha1sum perms *? name
foreach line [split $allfiles \n] {
# Each line is one file name
regexp {^(\S+)\s+\S+\s+\*?\s*(\S.*)$} $line -> sha fName
dict set finfo $fName isfile 1
dict set finfo $fName isdir 0
dict set finfo $fName "sha" $sha
dict set finfo $fName type file
# Fake mtime and size from sha, to make same look same
dict set finfo $fName mtime [scan [string range $sha 0 6] %x]
dict set finfo $fName size [scan [string range $sha 7 9] %x]
# 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]
}
}
# TBD: Any way to get file sizes and mtimes from HG?
# Try using the hglist extension
set cmd [list hg ls --template "{size} {date} {name}\n" -a \
--recursive -r $rev]
if { ! [catch {exec {*}$cmd} allfiles]} {
# Expected line format:
# size date name
foreach line [split $allfiles \n] {
if {[regexp {^(\d+)\s+(\d+)\S*\s+(\S.*)$} $line -> size mtime fName]} {
# Check that it matches something filled in from the manifest
if {[dict exists $finfo $fName]} {
dict set finfo $fName "mtime" $mtime
dict set finfo $fName "size" $size
}
}
}
}
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" hg
vfs::filesystem mount $mountpoint [list vcsvfs::Vfs]
set result $mountpoint$tail
return $result
}
proc vcsvfs::hg::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
# TBD: Delay this call until mtime is needed?
set mtime [exec git log --pretty=format:%ct -n 1 $rev -- $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 mode} {
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 requested mode
set chId [open [list |fossil cat $relative -r $rev] $mode]
cd $oldpwd
return [list $chId [list vcsvfs::ReadAllBeforeClose $chId]]
}
# Extract file data from Subversion revision
proc vcsvfs::svn::openFile {rootD relative mode} {
set oldpwd [pwd]
cd [dict get $rootD "origroot"]
set rev [dict get $rootD rev]
# Read through a pipe to get requested mode
set chId [open [list |svn cat -r $rev $relative] $mode]
cd $oldpwd
return [list $chId [list vcsvfs::ReadAllBeforeClose $chId]]
}
# Extract file data from HG revision
proc vcsvfs::hg::openFile {rootD relative mode} {
set oldpwd [pwd]
cd [dict get $rootD "origroot"]
set rev [dict get $rootD rev]
# Read through a pipe to get requested mode
set chId [open [list |hg cat -r $rev $relative] $mode]
cd $oldpwd
return [list $chId [list vcsvfs::ReadAllBeforeClose $chId]]
}
# Some notes about git commands that can be good to have
proc vcsvfs::git::openFile {rootD relative mode} {
set oldpwd [pwd]
cd [dict get $rootD "origroot"]
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 requested mode
set chId [open [list |git cat-file blob $sha] $mode]
cd $oldpwd
return [list $chId [list vcsvfs::ReadAllBeforeClose $chId]]
}
# Fossil may delay filling in size, this takes car of that
proc vcsvfs::fossil::size {finfo} {
# Use "fossil whatis" on its sha
# Expected format in a line:
# size: 629 bytes
set whatis [exec fossil whatis [dict get $finfo sha]]
regexp {size:\s+(\d+)} $whatis -> fSize
return $fSize
}
# Parse a time string from Fossil
proc vcsvfs::fossil::mTime {finfo} {
set mtimestr [dict get $finfo 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 {finfo} {
set mtimestr [dict get $finfo 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" && $mode ne "rb"} {
# Read only
vfs::filesystem posixerror $::vfs::posix(EACCES)
return -code error $::vfs::posix(EACCES)
}
return [vcsvfs::${vcstype}::openFile $rootD $relative $mode]
}
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]} {
# Fill in any postponed info
if { ! [dict exists $finfor mtime]} {
set mtime [vcsvfs::${vcstype}::mTime $finfor]
dict set finfor "mtime" $mtime
# Cache in main dictionary too
dict set mpoints $root "finfo" $relative "mtime" $mtime
}
if { ! [dict exists $finfor size]} {
set size [vcsvfs::${vcstype}::size $finfor]
dict set finfor "size" $size
# Cache in main dictionary too
dict set mpoints $root "finfo" $relative "size" $size
}
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]
}