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