1 2package provide vfs::ns 0.5.1 3 4package require vfs 1.0 5 6# Thanks to jcw for the idea here. This is a 'file system' which 7# is actually a representation of the Tcl command namespace hierarchy. 8# Namespaces are directories, and procedures are files. Tcl allows 9# procedures with the same name as a namespace, which are hidden in 10# a filesystem representation. 11 12namespace eval vfs::ns {} 13 14proc vfs::ns::Mount {ns local} { 15 if {![namespace exists ::$ns]} { 16 error "No such namespace" 17 } 18 ::vfs::log "ns $ns mounted at $local" 19 vfs::filesystem mount $local [list vfs::ns::handler $ns] 20 vfs::RegisterMount $local [list vfs::ns::Unmount] 21 return $local 22} 23 24proc vfs::ns::Unmount {local} { 25 vfs::filesystem unmount $local 26} 27 28proc vfs::ns::handler {ns cmd root relative actualpath args} { 29 regsub -all / $relative :: relative 30 if {$cmd == "matchindirectory"} { 31 eval [list $cmd $ns $relative $actualpath] $args 32 } else { 33 eval [list $cmd $ns $relative] $args 34 } 35} 36 37# If we implement the commands below, we will have a perfect 38# virtual file system for namespaces. 39 40proc vfs::ns::stat {ns name} { 41 ::vfs::log "stat $name" 42 if {[namespace exists ::${ns}::${name}]} { 43 return [list type directory size 0 mode 0777 \ 44 ino -1 depth 0 name $name atime 0 ctime 0 mtime 0 dev -1 \ 45 uid -1 gid -1 nlink 1] 46 } elseif {[llength [info procs ::${ns}::${name}]]} { 47 return [list type file] 48 } else { 49 return -code error "could not read \"$name\": no such file or directory" 50 } 51} 52 53proc vfs::ns::access {ns name mode} { 54 ::vfs::log "access $name $mode" 55 if {[namespace exists ::${ns}::${name}]} { 56 return 1 57 } elseif {[llength [info procs ::${ns}::${name}]]} { 58 if {$mode & 2} { 59 error "read-only" 60 } 61 return 1 62 } else { 63 error "No such file" 64 } 65} 66 67proc vfs::ns::exists {ns name} { 68 if {[namespace exists ::${ns}::${name}]} { 69 return 1 70 } elseif {[llength [info procs ::${ns}::${name}]]} { 71 return 1 72 } else { 73 return 0 74 } 75} 76 77proc vfs::ns::open {ns name mode permissions} { 78 ::vfs::log "open $name $mode $permissions" 79 # return a list of two elements: 80 # 1. first element is the Tcl channel name which has been opened 81 # 2. second element (optional) is a command to evaluate when 82 # the channel is closed. 83 switch -- $mode { 84 "" - 85 "r" { 86 set nfd [vfs::memchan] 87 fconfigure $nfd -translation binary 88 puts -nonewline $nfd [_generate ::${ns}::${name}] 89 fconfigure $nfd -translation auto 90 seek $nfd 0 91 return [list $nfd] 92 } 93 default { 94 return -code error "illegal access mode \"$mode\"" 95 } 96 } 97} 98 99proc vfs::ns::_generate {p} { 100 lappend a proc $p 101 set argslist [list] 102 foreach arg [info args $p] { 103 if {[info default $p $arg v]} { 104 lappend argslist [list $arg $v] 105 } else { 106 lappend argslist $arg 107 } 108 } 109 lappend a $argslist [info body $p] 110} 111 112proc vfs::ns::matchindirectory {ns path actualpath pattern type} { 113 ::vfs::log "matchindirectory $path $actualpath $pattern $type" 114 set res [list] 115 116 set ns ::[string trim $ns :] 117 set nspath ${ns}::${path} 118 if {![namespace exists $nspath]} {return {}} 119 set slash 1 120 if {[::vfs::matchDirectories $type]} { 121 # add matching directories to $res 122 if {[string length $pattern]} { 123 eval [linsert [namespace children $nspath $pattern] 0 lappend res] 124 } elseif {[namespace exists $nspath]} { 125 lappend res $nspath 126 } 127 } 128 129 if {[::vfs::matchFiles $type]} { 130 # add matching files to $res 131 if {[string length $pattern]} { 132 eval [linsert [info procs ${nspath}::$pattern] 0 lappend res] 133 } elseif {[llength [info procs $nspath]]} { 134 lappend res $nspath 135 set slash 0 136 } 137 } 138 139 # There is a disconnect between 8.4 and 8.5 with the / handling 140 # Make sure actualpath gets just one trailing / 141 if {$slash && ![string match */ $actualpath]} { append actualpath / } 142 143 set realres [list] 144 foreach r $res { 145 regsub "^(::)?${ns}(::)?${path}(::)?" $r $actualpath rr 146 lappend realres $rr 147 } 148 #::vfs::log $realres 149 150 return $realres 151} 152 153proc vfs::ns::createdirectory {ns name} { 154 ::vfs::log "createdirectory $name" 155 namespace eval ::${ns}::${name} {} 156} 157 158proc vfs::ns::removedirectory {ns name recursive} { 159 ::vfs::log "removedirectory $name" 160 namespace delete ::${ns}::${name} 161} 162 163proc vfs::ns::deletefile {ns name} { 164 ::vfs::log "deletefile $name" 165 rename ::${ns}::${name} {} 166} 167 168proc vfs::ns::fileattributes {ns name args} { 169 ::vfs::log "fileattributes $args" 170 switch -- [llength $args] { 171 0 { 172 # list strings 173 return [list -args -body] 174 } 175 1 { 176 # get value 177 set index [lindex $args 0] 178 switch -- $index { 179 0 { 180 ::info args ::${ns}::${name} 181 } 182 1 { 183 ::info body ::${ns}::${name} 184 } 185 } 186 } 187 2 { 188 # set value 189 set index [lindex $args 0] 190 set val [lindex $args 1] 191 switch -- $index { 192 0 { 193 error "read-only" 194 } 195 1 { 196 error "unimplemented" 197 } 198 } 199 } 200 } 201} 202 203proc vfs::ns::utime {what name actime mtime} { 204 ::vfs::log "utime $name" 205 error "" 206} 207