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