Check-in [f125b3dc59]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:add logic to load/mount kit from non-native filesystem
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: f125b3dc59cd3ca8801593e3057608fc785bee8d
User & Date: chw 2019-07-06 19:28:19
References
2019-07-13
20:55
better error handling w.r.t. check-in [f125b3dc59] check-in: 4dcaf5f047 user: chw tags: trunk
Context
2019-07-07
04:17
add selected nsf upstream changes check-in: 3ac37b54a8 user: chw tags: trunk
2019-07-06
19:28
add logic to load/mount kit from non-native filesystem check-in: f125b3dc59 user: chw tags: trunk
08:48
fix encoding issues in tclcompiler check-in: d74c9c42c0 user: chw tags: trunk
Changes

Changes to jni/tclkit/vqtcl/library/mkclvfs.tcl.

1
2
3
4
5
6
7
8
9
..
12
13
14
15
16
17
18

19
20
21
22
23
24
25
26
27
28
29
30











31

32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
..
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
...
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
...
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
# mkclvfs.tcl -- Metakit Compatibility Layer Virtual File System driver
# Rewritten from mk4vfs.tcl, orig by Matt Newman and Jean-Claude Wippler 

# 1.0 initial release
# 1.1 view size renamed to count
# 1.2 replace view calls by vget (simpler and faster)
# 1.3 modified to use the vlerq extension i.s.o. thrive
# 1.4 minor cleanup
# 1.5 adjusted for vlerq 4
................................................................................

package require vfs
package require vlerq

namespace eval ::vfs::mkcl {
    interp alias {} ::vfs::mkcl::vopen {} ::vlerq open
    interp alias {} ::vfs::mkcl::vget {} ::vlerq get

        
    namespace eval v {
        variable seq 0  ;# used to generate a unique db handle
        variable rootv  ;# maps handle to the "dirs" root view
        variable dname  ;# maps handle to cached list of directory names
        variable prows  ;# maps handle to cached list of parent row numbers
    }

# public

    proc Mount {mkfile local args} {
        set db mkclvfs[incr v::seq]











        set v::rootv($db) [vget [vopen $mkfile] 0 dirs]

        set v::dname($db) [vget $v::rootv($db) * name]
        set v::prows($db) [vget $v::rootv($db) * parent]
        #parray v::dname
        #parray v::prows
        ::vfs::filesystem mount $local [list ::vfs::mkcl::handler $db]
        ::vfs::RegisterMount $local [list ::vfs::mkcl::Unmount $db]
        return $db
    }
    
    proc Unmount {db local} {
        ::vfs::filesystem unmount $local
        unset v::rootv($db) v::dname($db) v::prows($db)
    }
    
# private

    proc handler {db cmd root path actual args} {
        #puts [list MKCL $db <$cmd> r: $root p: $path a: $actual $args]
        switch $cmd {
            matchindirectory { eval [linsert $args 0 $cmd $db $path $actual] }
            fileattributes   { eval [linsert $args 0 $cmd $db $root $path] } 
            default          { eval [linsert $args 0 $cmd $db $path] }
        }
    }
    
    proc fail {code} {
        ::vfs::filesystem posixerror $::vfs::posix($code)
    }
    
    proc lookUp {db path} {
        set dirs $v::rootv($db)
        set parent 0
        set elems [file split $path]
        set remain [llength $elems]
        foreach e $elems {
            set r ""
................................................................................
                }
                fail ENOENT
            }
        }
        # evaluating this 4-item result returns the files subview
        list vget $dirs $parent files
    }
    
    proc isDir {tag} {
        expr {[llength $tag] == 4}
    }
    
    if {$::tcl_version eq "8.4"} {
            proc apply {cmd args} { eval [concat $cmd $args] }
    } else {
            proc apply {cmd args} { {*}$cmd {*}$args }
    }
    
# methods

    proc matchindirectory {db path actual pattern type} {
        set o {}
        if {$type == 0} { set type 20 }
        if {[catch {set tag [lookUp $db $path]} err]} { return {} }
        if {$pattern ne ""} {
................................................................................
                }
            }
        } elseif {$type & ([isDir $tag]?4:16)} {
            set o [list $actual]
        }
        return $o
    }
    
    proc fileattributes {db root path args} {
        switch -- [llength $args] {
            0 { return [::vfs::listAttributes] }
            1 { set index [lindex $args 0]
                    return [::vfs::attributesGet $root $path $index] }
            2 { fail EROFS }
        }
    }
    
    proc open {db file mode permissions} {
        if {$mode ne "" && $mode ne "r"} { fail EROFS }
        set tag [lookUp $db $file]
        if {[isDir $tag]} { fail ENOENT }
        foreach {name size date contents} [apply $tag *] break
        if {[string length $contents] != $size} {
            set contents [::vfs::zip -mode decompress $contents]
................................................................................
        set fd [::vfs::memchan]
        fconfigure $fd -translation binary
        puts -nonewline $fd $contents
        fconfigure $fd -translation auto -encoding [encoding system]
        seek $fd 0
        list $fd
    }
    
    proc access {db path mode} {
        if {$mode & 2} { fail EROFS }
        lookUp $db $path
    }
    
    proc stat {db path} {
        set tag [lookUp $db $path]
        set l 1
        if {[isDir $tag]} {
            set t directory
            set s 0
            set d 0

|







 







>
|











>
>
>
>
>
>
>
>
>
>
>
|
>








|




|






|



|



|







 







|



|





|







 







|








|







 







|




|







1
2
3
4
5
6
7
8
9
..
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
..
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
...
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
...
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
# mkclvfs.tcl -- Metakit Compatibility Layer Virtual File System driver
# Rewritten from mk4vfs.tcl, orig by Matt Newman and Jean-Claude Wippler

# 1.0 initial release
# 1.1 view size renamed to count
# 1.2 replace view calls by vget (simpler and faster)
# 1.3 modified to use the vlerq extension i.s.o. thrive
# 1.4 minor cleanup
# 1.5 adjusted for vlerq 4
................................................................................

package require vfs
package require vlerq

namespace eval ::vfs::mkcl {
    interp alias {} ::vfs::mkcl::vopen {} ::vlerq open
    interp alias {} ::vfs::mkcl::vget {} ::vlerq get
    interp alias {} ::vfs::mkcl::vload {} ::vlerq load

    namespace eval v {
        variable seq 0  ;# used to generate a unique db handle
        variable rootv  ;# maps handle to the "dirs" root view
        variable dname  ;# maps handle to cached list of directory names
        variable prows  ;# maps handle to cached list of parent row numbers
    }

# public

    proc Mount {mkfile local args} {
        set db mkclvfs[incr v::seq]
        set done 0
        if {![catch {::file system $mkfile} fs] && ($fs ne "native")} {
            if {![catch {::open $mkfile rb} f]} {
                if {![catch {::read $f} data]} {
                    ::close $f
                    set v::rootv($db) [vget [vload $data] 0 dirs]
                    set done 1
                }
            }
        }
        if {!$done} {
            set v::rootv($db) [vget [vopen $mkfile] 0 dirs]
        }
        set v::dname($db) [vget $v::rootv($db) * name]
        set v::prows($db) [vget $v::rootv($db) * parent]
        #parray v::dname
        #parray v::prows
        ::vfs::filesystem mount $local [list ::vfs::mkcl::handler $db]
        ::vfs::RegisterMount $local [list ::vfs::mkcl::Unmount $db]
        return $db
    }

    proc Unmount {db local} {
        ::vfs::filesystem unmount $local
        unset v::rootv($db) v::dname($db) v::prows($db)
    }

# private

    proc handler {db cmd root path actual args} {
        #puts [list MKCL $db <$cmd> r: $root p: $path a: $actual $args]
        switch $cmd {
            matchindirectory { eval [linsert $args 0 $cmd $db $path $actual] }
            fileattributes   { eval [linsert $args 0 $cmd $db $root $path] }
            default          { eval [linsert $args 0 $cmd $db $path] }
        }
    }

    proc fail {code} {
        ::vfs::filesystem posixerror $::vfs::posix($code)
    }

    proc lookUp {db path} {
        set dirs $v::rootv($db)
        set parent 0
        set elems [file split $path]
        set remain [llength $elems]
        foreach e $elems {
            set r ""
................................................................................
                }
                fail ENOENT
            }
        }
        # evaluating this 4-item result returns the files subview
        list vget $dirs $parent files
    }

    proc isDir {tag} {
        expr {[llength $tag] == 4}
    }

    if {$::tcl_version eq "8.4"} {
            proc apply {cmd args} { eval [concat $cmd $args] }
    } else {
            proc apply {cmd args} { {*}$cmd {*}$args }
    }

# methods

    proc matchindirectory {db path actual pattern type} {
        set o {}
        if {$type == 0} { set type 20 }
        if {[catch {set tag [lookUp $db $path]} err]} { return {} }
        if {$pattern ne ""} {
................................................................................
                }
            }
        } elseif {$type & ([isDir $tag]?4:16)} {
            set o [list $actual]
        }
        return $o
    }

    proc fileattributes {db root path args} {
        switch -- [llength $args] {
            0 { return [::vfs::listAttributes] }
            1 { set index [lindex $args 0]
                    return [::vfs::attributesGet $root $path $index] }
            2 { fail EROFS }
        }
    }

    proc open {db file mode permissions} {
        if {$mode ne "" && $mode ne "r"} { fail EROFS }
        set tag [lookUp $db $file]
        if {[isDir $tag]} { fail ENOENT }
        foreach {name size date contents} [apply $tag *] break
        if {[string length $contents] != $size} {
            set contents [::vfs::zip -mode decompress $contents]
................................................................................
        set fd [::vfs::memchan]
        fconfigure $fd -translation binary
        puts -nonewline $fd $contents
        fconfigure $fd -translation auto -encoding [encoding system]
        seek $fd 0
        list $fd
    }

    proc access {db path mode} {
        if {$mode & 2} { fail EROFS }
        lookUp $db $path
    }

    proc stat {db path} {
        set tag [lookUp $db $path]
        set l 1
        if {[isDir $tag]} {
            set t directory
            set s 0
            set d 0