1
2package provide vfs::tk 0.5
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::tk {}
13
14proc vfs::tk::Mount {tree local} {
15    if {![winfo exists $tree]} {
16	return -code error "No such window $tree"
17    }
18    ::vfs::log "tk widget hierarchy $tree mounted at $local"
19    if {$tree == "."} { set tree "" }
20    vfs::filesystem mount $local [list vfs::tk::handler $tree]
21    vfs::RegisterMount $local [list vfs::tk::Unmount]
22    return $local
23}
24
25proc vfs::tk::Unmount {local} {
26    vfs::filesystem unmount $local
27}
28
29proc vfs::tk::handler {widg cmd root relative actualpath args} {
30    regsub -all / $relative . relative
31    if {$cmd == "matchindirectory"} {
32	eval [list $cmd $widg $relative $actualpath] $args
33    } else {
34	eval [list $cmd $widg $relative] $args
35    }
36}
37
38# If we implement the commands below, we will have a perfect
39# virtual file system for namespaces.
40
41proc vfs::tk::stat {widg name} {
42    ::vfs::log "stat $name"
43    if {![winfo exists ${widg}.${name}]} {
44	return -code error "could not read \"$name\": no such file or directory"
45    }
46    set len [llength [winfo children ${widg}.${name}]]
47    if {$len || ([winfo class $widg.$name] == "Frame")} {
48	return [list type directory size $len mode 0777 \
49	  ino -1 depth 0 name $name atime 0 ctime 0 mtime 0 dev -1 \
50	  uid -1 gid -1 nlink 1]
51    } else {
52	return [list type file size 0 atime 0 ctime 0 mtime 0]
53    }
54}
55
56proc vfs::tk::access {widg name mode} {
57    ::vfs::log "access $name $mode"
58    if {[winfo exists ${widg}.${name}]} {
59	return 1
60    } else {
61	error "No such file"
62    }
63}
64
65proc vfs::tk::open {widg name mode permissions} {
66    ::vfs::log "open $name $mode $permissions"
67    # return a list of two elements:
68    # 1. first element is the Tcl channel name which has been opened
69    # 2. second element (optional) is a command to evaluate when
70    #    the channel is closed.
71    switch -- $mode {
72	"" -
73	"r" {
74	    set nfd [vfs::memchan]
75	    fconfigure $nfd -translation binary
76	    puts -nonewline $nfd [_generate ${widg}.${name}]
77	    fconfigure $nfd -translation auto
78	    seek $nfd 0
79	    return [list $nfd]
80	}
81	default {
82	    return -code error "illegal access mode \"$mode\""
83	}
84    }
85}
86
87proc vfs::tk::_generate {p} {
88    lappend a [string tolower [winfo class $p]]
89    lappend a $p
90    foreach arg [$p configure] {
91	set item [lindex $arg 0]
92	lappend a $item [$p cget $item]
93    }
94    return $a
95}
96
97proc vfs::tk::matchindirectory {widg path actualpath pattern type} {
98    ::vfs::log [list matchindirectory $widg $path $actualpath $pattern $type]
99    set res [list]
100
101    if {$widg == "" && $path == ""} {
102	set wp ""
103    } else {
104	set wp $widg.$path
105    }
106    if {$wp == ""} { set wpp "." } else { set wpp $wp }
107    set l [string length $wp]
108
109    if {$type == 0} {
110	foreach ch [winfo children $wpp] {
111	    if {[string match $pattern [string range $ch $l end]]} {
112		lappend res $ch
113	    }
114	}
115    } else {
116	if {[::vfs::matchDirectories $type]} {
117	    # add matching directories to $res
118	    if {[string length $pattern]} {
119		foreach ch [winfo children $wpp] {
120		    if {[string match $pattern [string range $ch $l end]]} {
121			if {[llength [winfo children $ch]]} {
122			    lappend res $ch
123			}
124		    }
125		}
126	    } else {
127		if {[string match $pattern $wpp]} {
128		    if {[llength [winfo children $wpp]]} {
129			lappend res $wpp
130		    }
131		}
132	    }
133	}
134	if {[::vfs::matchFiles $type]} {
135	    # add matching files to $res
136	    if {[string length $pattern]} {
137		foreach ch [winfo children $wpp] {
138		    if {[string match $pattern [string range $ch $l end]]} {
139			if {![llength [winfo children $ch]]} {
140			    lappend res $ch
141			}
142		    }
143		}
144	    } else {
145		if {[string match $pattern $wpp]} {
146		    if {![llength [winfo children $wpp]]} {
147			lappend res $wpp
148		    }
149		}
150	    }
151	}
152    }
153
154    set realres [list]
155    set l [expr {1 + [string length $wp]}]
156    foreach r $res {
157	lappend realres [file join ${actualpath} [string range $r $l end]]
158    }
159    #::vfs::log $realres
160
161    return $realres
162}
163
164proc vfs::tk::createdirectory {widg name} {
165    ::vfs::log "createdirectory $name"
166    frame ${widg}.${name}
167}
168
169proc vfs::tk::removedirectory {widg name recursive} {
170    ::vfs::log "removedirectory $name"
171    if {!$recursive} {
172	if {[llength [winfo children $widg.$name]]} {
173	    vfs::filesystem posixerror $::vfs::posix(ENOTEMPTY)
174	}
175    }
176    destroy $widg.$name
177}
178
179proc vfs::tk::deletefile {widg name} {
180    ::vfs::log "deletefile $name"
181    destroy $widg.$name
182}
183
184proc vfs::tk::fileattributes {widg name args} {
185    ::vfs::log "fileattributes $args"
186    switch -- [llength $args] {
187	0 {
188	    # list strings
189	    set res {}
190	    foreach c [$widg.$name configure] {
191		lappend res [lindex $c 0]
192	    }
193	    return $res
194	}
195	1 {
196	    # get value
197	    set index [lindex $args 0]
198	    set arg [lindex [lindex [$widg.$name configure] $index] 0]
199	    return [$widg.$name cget $arg]
200	}
201	2 {
202	    # set value
203	    set index [lindex $args 0]
204	    set val [lindex $args 1]
205	    set arg [lindex [lindex [$widg.$name configure] $index] 0]
206	    return [$widg.$name configure $arg $val]
207	}
208    }
209}
210
211proc vfs::tk::utime {what name actime mtime} {
212    ::vfs::log "utime $name"
213    error ""
214}
215