#!/usr/bin/env vanillatclsh
#############################################################################
#
# LUCK: Lean Undroidwish Construction Kit
#
# Copyright (c) 2021-22 Christian Werner <chw at ch minus werner dot de>
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#############################################################################
#
# Implementation of a VFS which deals with a *.tdd file, which is
# an SQLite database made of undroidwish/vanillawish/vanillatclsh
# binaries, but deduplicated. A utility function to create this
# kind of database is included, too.
#
# Filesystem layout when SQLite database is mounted:
#
# /undroidwish-xxx plain file, executable part
# /dir.undroidwish-xxx directory (version 2 only)
# contents of undroidwish-xxx files of ZIP part
# /vanillawish-yyy plain file, executable part
# /dir.vanillawish-xxx directory (version 2 only)
# contents of vanillawish-yyy files of ZIP part
# /..meta meta information (array get)
# /..{requires,provides,toprequires} dependency information (array get)
# /..[1-9][0-9]* gzip'ed file contents, filename
# is inode number relative to
# meta information
#
# Filesystem layout when embedded into a (undroid|vanilla)wish ZIP:
#
# /luck/data toplevel of filesystem
# meta meta information (array get)
# {requires,provides,toprequires} dependency information (array get)
# [1-9][0-9]* plain file contents, filename
# is inode number relative to
# meta information
#
# The mount function automatically selects between the database
# or filesystem representation. If it is given a directory, it
# uses the latter.
#
# Layout of meta information describing plain files only:
#
# pathname { mtime size inode } ...
#
# Layout of "requires" array:
#
# pkgname { toplevel-dirname ... } ...
#
# Layout of "provides" array:
#
# pkgname { toplevel-dirname } ...
#
# Layout of "toprequires" array:
#
# toplevel-dirname { toplevel-dirname ... } ...
#
# WARNING: vfs::luckfs is a singleton filesystem, i.e. only one
# mount at a single point in time is possible.
#
# Performance figures (version 1):
#
# * 34 (undroid|vanilla)wish input files for various platforms
# require about 920 MByte
# * overall, their ZIPs make up about 168000 files
# * only about 8900 files are unique
# * the size of the dedup'ed SQLite database is about 260 MByte
# with gzip'ed file data
#
#############################################################################
package require vfs
package require Memchan
namespace eval vfs::luckfs {
variable isdb
variable index
variable topdir
variable dcache
variable mount
# for dependencies: toplevel directory black list
variable dir_black_list {
tcl tcl8 tcl8.6 sdl2tk8.6 VecTcLab TDK gentclsh mkappimg
tkcon2.7 tkchat1.489 critcl3.1.18 ased3 vtcl8 tkinspect5.1.6
}
# for dependencies: package black list
variable pkg_black_list {
tcl tcl8.6 Tcl Tk tk sdl2tk tkcon
}
proc mount {from mntpt} {
variable isdb
variable topdir
variable index
variable mount
if {[file isdirectory $from]} {
if {![file readable [file join $from meta]]} {
error "missing meta information"
}
} else {
package require sqlite3
}
if {![catch {vfs::filesystem info $mntpt}]} {
vfs::unmount $mntpt
}
if {![file isdirectory $from]} {
unset -nocomplain index
array set index {}
sqlite3 [namespace current]::db $from -readonly 1
# check for old vs. new format, old format has no "names" table
if {[catch {db eval {select name from names limit 1;}}]} {
db eval {
select zip || '/' || file as name, mtime, size, inode
from files;
} {
set name [string trimright $name /]
set index($name) [list $mtime $size $inode]
}
set isdb 1
} else {
db eval {
select
((select n.name from names as n where n.rowid = f.zip)
|| '/' ||
(select n.name from names as n where n.rowid = f.file))
as name,
f.mtime as mtime,
f.size as size,
f.inode as inode
from files as f;
} {
set name [string trimright $name /]
set index($name) [list $mtime $size $inode]
}
set isdb 2
}
set topdir [file normalize $mntpt]
set mount $topdir
} else {
unset -nocomplain index
array set index {}
set topdir $from
set mount [file normalize $mntpt]
set f [::open [file join $from meta] r]
catch {array set index [read $f]}
close $f
set isdb 0
}
vfs::filesystem mount $mntpt \
[list [namespace current]::handler $mntpt]
vfs::RegisterMount $mntpt [namespace current]::unmount
if {$isdb} {
# this seems to fix vfs startup glitches...
catch {glob -nocomplain [file join $mntpt *]}
}
return $mntpt
}
proc unmount {mntpt} {
variable isdb
variable index
variable topdir
variable dcache
variable mount
vfs::filesystem unmount $mntpt
if {[info exists $isdb] && $isdb} {
db close
}
unset -nocomplain isdb
unset -nocomplain index
unset -nocomplain topdir
unset -nocomplain dcache
unset -nocomplain mount
}
proc handler {mntpt cmd root relative actualpath args} {
if {$cmd eq "matchindirectory"} {
[namespace current]::$cmd $mntpt $relative $actualpath {*}$args
} else {
[namespace current]::$cmd $mntpt $relative {*}$args
}
}
proc attributes {mntpt} {
return [list "state"]
}
proc state {mntpt args} {
vfs::attributeCantConfigure "state" "readonly" $args
}
proc _fixglob {string} {
return [string map {\\ \\\\ ? \\? * \\* [ \\[ ] \\]} $string]
}
proc _fixre {string} {
set ret ""
foreach c [split $string {}] {
scan $c %c cc
if {$cc > 0x20 && $cc < 0x80} {
append ret [format "\\x%02x" $cc]
} else {
append ret $c
}
}
return $ret
}
proc _getdir {mntpt path actualpath {pattern *}} {
variable index
variable dcache
if {$path eq "." || $path eq ""} {
set path ""
}
if {$pattern eq ""} {
if {[info exists index($path)]} {
return [list $path]
}
return [list]
}
set res [list]
if {$path eq ""} {
set strip 0
set depth 1
} else {
set strip [string length ${path}/]
set depth [llength [file split $path]]
incr depth 1
}
if {$path ne "" && ![info exists index($path)]} {
# speed up array searches by dcache array
if {![info exists dcache($path)]} {
set dcache($path) [array names index [_fixglob $path]/*]
}
if {$dcache($path) eq {}} {
# no leaves, we're done
return $res
}
}
array set did {}
if {![info exists dcache()]} {
set dcache() [array names index -regexp {^[^/]+$}]
}
# try to speed up for files which are leaves in the tree
if {[info exists index($path)] && ([string first "/" $path] >= 0)} {
lassign $index($path) mtime size ino
if {$ino != 0} {
return $res
}
}
if {$strip} {
# speed up array searches by dcache array
if {![info exists dcache($path)]} {
set dcache($path) [array names index [_fixglob $path]/*]
}
set names $dcache($path)
} else {
set names $dcache()
}
foreach name $names {
set flist [file split $name]
set fllen [llength $flist]
if {$fllen != $depth} {
set flist [lrange $flist 0 $depth-1]
if {$fllen < $depth || [info exists did($flist)]} {
continue
}
incr did($flist)
set name [file join {*}$flist]
if {![info exists index($name)]} {
set index($name) {0 0 0}
}
} elseif {[info exists did($flist)]} {
continue
} else {
incr did($flist)
}
if {[string match $pattern [lindex $flist end]]} {
lappend res [string range $name $strip end]
}
}
return $res
}
proc matchindirectory {mntpt path actualpath pattern type} {
variable index
set res [_getdir $mntpt $path $actualpath $pattern]
if {$pattern eq ""} {
if {![info exists index($path)]} {
return {}
}
set res [list $actualpath]
set actualpath ""
}
set newres [list]
foreach name [::vfs::matchCorrectTypes $type $res $actualpath] {
lappend newres [file join $actualpath $name]
}
return $newres
}
proc stat {mntpt name} {
variable isdb
variable index
variable dcache
if {$name eq ""} {
return [list type directory mtime 0 size 0 mode 0555 ino -1 \
depth 0 name "" dev -1 uid -1 gid -1 nlink 1]
}
if {[info exists index($name)]} {
lassign $index($name) mtime size ino
if {$ino == 0} {
return [list type directory mtime 0 size 0 mode 0555 ino -1 \
depth 0 name $name dev -1 uid -1 gid -1 nlink 1]
}
return [list type file mtime $mtime mode 0444 ino $ino \
size $size atime $mtime ctime $mtime -nlink 1]
}
# speed up array searches by dcache array
if {![info exists dcache($name)]} {
set dcache($name) [array names index [_fixglob $name]/*]
}
if {$dcache($name) ne {}} {
if {![info exists index($name)]} {
set index($name) {0 0 0}
}
return [list type directory mtime 0 size 0 mode 0555 ino -1 \
depth 0 name $name dev -1 uid -1 gid -1 nlink 1]
}
if {$isdb} {
set mtime 1000000000
set ino 0
if {$name in {..meta ..requires ..provides ..toprequires}} {
set query {select max(mtime) as mtime from files;}
} elseif {[scan $name "..%d" ino]} {
set query {select mtime from files where inode = $ino;}
}
if {[info exists query]} {
db eval $query
return [list type file mtime $mtime mode 0444 ino $ino \
size 0 atime $mtime ctime $mtime -nlink 1]
}
}
vfs::filesystem posixerror $::vfs::posix(ENOENT)
}
proc access {mntpt name mode} {
variable isdb
variable index
variable dcache
if {$mode & 2} {
vfs::filesystem posixerror $::vfs::posix(EROFS)
}
if {[info exists index($name)]} {
return 1
}
# speed up array searches by dcache array
if {![info exists dcache($name)]} {
set dcache($name) [array names index [_fixglob $name]/*]
}
if {$dcache($name) ne {}} {
if {![info exists index($name)]} {
set index($name) {0 0 0}
}
return 1
}
vfs::filesystem posixerror $::vfs::posix(ENOENT)
}
proc open {mntpt name mode permission} {
variable isdb
variable index
variable topdir
switch -glob -- $mode {
"" - "r" {
if {![info exists index($name)]} {
# these are not visible by stat/access/matchindirectory
if {$isdb} {
if {$name eq "..meta"} {
set data [list]
if {$isdb > 1} {
db eval {
select
((select n.name from names as n
where n.rowid = f.zip)
|| '/' ||
(select n.name from names as n
where n.rowid = f.file)) as name,
f.mtines as mtime,
f.size as size,
f.inode as inode
from files as f order by name;
} {
set name [string trimright $name /]
lappend data $name \
[list $mtime $size $inode]
}
} else {
db eval {
select
zip || '/' || file as name,
mtime, size, inode
from files order by name;
} {
set name [string trimright $name /]
lappend data $name \
[list $mtime $size $inode]
}
}
} elseif {$name in {
..provides ..requires ..toprequires
}} {
set data ""
set item [string range $name 2 end]
db eval {
select zip, data as d from deps
where item = $item;
} {
lappend data $zip $d
}
} elseif {[string first ".." $name] == 0} {
scan $name "..%d" ino
db eval {
select data from data where rowid = $ino;
} {
set data [zlib gunzip $data]
}
}
if {[info exists data]} {
set mc [memchan]
fconfigure $mc -translation binary -encoding binary
puts -nonewline $mc $data
seek $mc 0
return $mc
}
}
vfs::filesystem posixerror $::vfs::posix(ENOENT)
}
lassign $index($name) mtime size ino
if {$ino == 0} {
vfs::filesystem posixerror $::vfs::posix(EPERM)
}
if {$isdb} {
db eval {
select data from data where rowid = $ino;
} {
set data [zlib gunzip $data]
}
set mc [memchan]
fconfigure $mc -translation binary -encoding binary
puts -nonewline $mc $data
seek $mc 0
return $mc
}
set f [::open [file join $topdir $ino] rb]
return $f
}
default {
vfs::filesystem posixerror $::vfs::posix(EROFS)
}
}
}
proc createdirectory {mntpt name} {
vfs::filesystem posixerror $::vfs::posix(EROFS)
}
proc removedirectory {mntpt name recursive} {
vfs::filesystem posixerror $::vfs::posix(EROFS)
}
proc deletefile {mntpt name} {
vfs::filesystem posixerror $::vfs::posix(EROFS)
}
proc fileattributes {mntpt name args} {
switch -- [llength $args] {
0 {
# list strings
return [list]
}
1 {
# get value
return ""
}
2 {
# set value
vfs::filesystem posixerror $::vfs::posix(EROFS)
}
}
}
proc utime {mntpt path actime mtime} {
vfs::filesystem posixerror $::vfs::posix(EROFS)
}
# Helper to speed up a search similar to what zipfs::find does,
# the speed gain is remarkable.
proc ffind {dir} {
variable index
variable mount
variable dcache
set res [list]
set strip [string length $mount]
incr strip
set dir [string range $dir $strip end]
# speed up array searches by dcache array
if {![info exists dcache($dir)]} {
set dcache($dir) [array names index [_fixglob $dir]/*]
}
foreach name $dcache($dir) {
lassign $index($name) mtime size ino
if {$ino != 0} {
lappend res ${mount}/${name}
}
}
return [lsort $res]
}
# Retrieve a list made up of source target pairs for the
# zipfs::lmkzip and zipfs::lmkimg procedures to allow to
# copy all of the mounted vfs::luckfs file system.
proc getzipfslist {{basedir {}}} {
variable isdb
variable index
variable topdir
set ret [list]
if {![info exists isdb]} {
return $ret
}
if {$isdb} {
set pfx ".."
} else {
set pfx ""
}
foreach name {meta requires provides toprequires} {
lappend ret [file join $topdir ${pfx}$name] \
[file join $basedir $name]
}
foreach name [array names index] {
lassign $index($name) mtime size ino
incr did($ino)
if {$did($ino) > 1} {
continue
}
if {$ino == 0} {
continue
}
lappend ret [file join $topdir ${pfx}$ino] \
[file join $basedir $ino]
}
return $ret
}
# Helper to build a dedup'ed database out of a bunch of
# (undroid|vanilla)wishes with added dependency information.
proc maketdd {{fromdir {}} {dbname {}}} {
variable dir_black_list
variable pkg_black_list
package require sqlite3
package require sha256
sqlite3 [namespace current]::tdd :memory:
tdd eval {
create temporary table tmp_files(
zip varchar,
file varchar,
hash varchar,
mtime integer default 0,
size integer default 0,
inode integer default 0,
primary key(zip, file)
);
create temporary table tmp_data(
hash varchar,
data blob,
primary key(hash)
);
}
if {$fromdir eq {}} {
set fromdir [file dirname [info nameofexecutable]]
}
set zips [glob -nocomplain -dir $fromdir vanilla*-* undroidwish-*]
set zips [lsort -nocase -dictionary $zips]
foreach zip $zips {
set mtime [file mtime $zip]
set topdir /tmpmnt
set unmount 1
if {[file normalize $zip] eq [info nameofexecutable]} {
set topdir [info nameofexecutable]
set unmount 0
} elseif {![file isfile $zip] ||
[catch {zipfs::mount -file $zip $topdir}]} {
continue
}
set strip [string length ${topdir}/]
set zip [file tail $zip]
set dirzip dir.$zip
puts -nonewline stdout "Importing '$zip' ... "
flush stdout
# tdd transaction ???
if {1} {
set exe [::open $topdir rb]
set data [read $exe]
set size [string length $data]
close $exe
set hash [sha2::sha256 -hex $data]
tdd eval {
insert into tmp_files(zip, file, hash, mtime, size)
values($zip, '', $hash, $mtime, $size);
insert into tmp_files(zip, file, hash, mtime, size)
values($dirzip, '', '', $mtime, 0);
}
incr has($hash)
if {$has($hash) == 1} {
set data [zlib gzip $data]
tdd eval {
insert into tmp_data(hash, data) values($hash, $data);
}
}
foreach file [zipfs::find $topdir] {
if {[file isdirectory $file]} {
continue
}
set name [string range $file $strip end]
set mtime [file mtime $file]
set f [::open $file rb]
set data [read $f]
set size [string length $data]
close $f
set hash [sha2::sha256 -hex $data]
tdd eval {
insert or ignore
into tmp_files(zip, file, hash, mtime, size)
values($zip, $name, $hash, $mtime, $size);
insert or ignore
into tmp_files(zip, file, hash, mtime, size)
values($dirzip, $name, $hash, $mtime, $size);
}
incr has($hash)
if {$has($hash) == 1} {
set data [zlib gzip $data]
tdd eval {
insert into tmp_data(hash, data)
values($hash, $data);
}
}
}
}
if {$unmount} {
zipfs::unmount $zip
}
puts stdout "done"
flush stdout
}
# tdd transaction ???
puts -nonewline stdout "Compacting database ... "
flush stdout
if {1} {
tdd eval {
create index tmp_files_index on tmp_files(hash);
}
foreach {hash rowid} [tdd eval {
select hash, rowid from tmp_data;
}] {
tdd eval {
update tmp_files set inode = $rowid where hash = $hash;
}
}
# Version 2 uses extra "names" table to squeeze out space
# for zip and file name columns in "files" table, where the
# columns are integer rowids into the "names" table now.
tdd eval {
create table names(
name varchar not null,
primary key(name)
);
}
tdd eval {insert into names(name) values('');}
foreach zip [tdd eval {
select distinct zip from tmp_files;
}] {
tdd eval {insert into names(name) values($zip);}
}
foreach file [tdd eval {
select distinct file from tmp_files;
}] {
tdd eval {insert or ignore into names(name) values($file);}
}
tdd eval {
drop table if exists files;
drop table if exists data;
create table files(
zip integer not null,
file integer not null,
mtime integer default 0,
size integer default 0,
inode integer default 0,
primary key(zip, file)
);
create table data(data blob);
insert into files(zip, file, mtime, size, inode)
select
(select n.rowid from names as n where n.name = t.zip),
(select n.rowid from names as n where n.name = t.file),
t.mtime, t.size, t.inode from tmp_files as t;
insert into data(rowid, data)
select rowid, data from tmp_data;
drop table tmp_files;
drop table tmp_data;
create table deps(
zip varchar not null,
item varchar not null,
data varchar not null,
primary key(zip, item)
);
}
}
puts stdout "done"
foreach zip $zips {
set topdir /tmpmnt
set unmount 1
if {[file normalize $zip] eq [info nameofexecutable]} {
set topdir [info nameofexecutable]
set unmount 0
} elseif {![file isfile $zip] ||
[catch {zipfs::mount -file $zip $topdir}]} {
continue
}
set zip [file tail $zip]
puts -nonewline stdout "Find dependencies in '$zip' ... "
flush stdout
unset -nocomplain requires
unset -nocomplain provides
unset -nocomplain toprequires
_find_deps $topdir $dir_black_list $pkg_black_list \
requires provides toprequires
set data [array get requires]
set dlen [string length $data]
tdd eval {
insert into deps(zip, item, data)
values($zip, 'requires', $data)
}
set data [array get provides]
set dlen [string length $data]
tdd eval {
insert into deps(zip, item, data)
values($zip, 'provides', $data)
}
set data [array get toprequires]
set dlen [string length $data]
tdd eval {
insert into deps(zip, item, data)
values($zip, 'toprequires', $data)
}
if {$unmount} {
zipfs::unmount $zip
}
puts stdout "done"
flush stdout
}
if {$dbname ne {}} {
catch {file delete -- $dbname}
puts -nonewline stdout "Writing to '$dbname' ... "
flush stdout
tdd backup $dbname
puts stdout "done"
flush stdout
tdd close
} else {
return [namespace current]::tdd
}
}
# Try to find out dependencies by analyzing content for "package...".
# WARNING: this is a heuristic far from being accurate.
#
# dir: start search here
# bl_dirs: black listed directories to ignore
# bl_pkgs: black listed package names to ignore
# rvar: requires array, key: package name, value: list of directories
# pvar: provides array, key: package name, value: list of directories
# tvar: top level requires array, key: directory,
# value: list of directories
#
# If tvar is empty, only rvar is reported and the base of directories is
# the parent of "dir", otherwise, reported directories are toplevel
# descendants of "dir" without prefix.
#
# Dependency resolution strategy:
#
# (1) find_deps template-dir ... requires provides toprequires
# (2) find_deps app-dir ... requires
# foreach key of requires try provides from (1)
# (3) foreach enabled provides from (2) add enables from toprequire
#
# When using a mounted luckvfs, the provides/toprequires for a
# template can be precomputed in order to speed things up.
proc _find_deps {dir bl_dirs bl_pkgs rvar {pvar {}} {tvar {}}} {
if {$rvar ne {}} {
upvar $rvar requires
}
if {$pvar ne {}} {
upvar $pvar provides
}
if {$tvar ne {}} {
upvar $tvar toprequires
}
array set provides {}
array set requires {}
array set toprequires {}
set dir [file normalize $dir]
# ignore native code and other stuff
lappend libexts .so .dylib .dll .exe .a .gif .jpg .png
lappend libexts .html .htm .pdf .ico
if {$tvar ne {}} {
set strip [string length ${dir}/]
} else {
set parent [file dirname $dir]/
if {[string match *// $parent]} {
set parent [file dirname $dir]
}
set strip [string length $parent]
}
foreach file [zipfs::find $dir] {
if {$tvar ne {} && [file isdirectory $file]} {
continue
}
if {[string tolower [file extension $file]] in $libexts} {
continue
}
set top [string range $file $strip end]
set top [lindex [file split $top] 0]
if {$tvar ne {} && ![file isdirectory [file join $dir $top]]} {
continue
}
if {[catch {::open $file r} f]} {
continue
}
set lno 0
while {1} {
incr lno
if {[catch {gets $f line} count] || $count < 0} {
break
}
# accumulate continuation lines
if {[string index $line end] eq "\\"} {
while {1} {
if {[gets $f cline] < 0} {
break
}
incr lno
append line " " [string trimleft $cline]
if {[string index $line end] ne "\\"} {
break
}
}
}
if {[regexp -- \
{package\s+(provide|require|ifneeded)\s+([\w:]+)} \
$line all verb pkg]} {
switch -exact -- $verb {
provide {
# heuristic for package provide which is
# used in very different situations
switch -glob -- $line {
*if*package* -
*expr*package* -
*vsatisfies* -
*#*package* {
# ignore
}
default {
if {$top ni $bl_dirs && $pkg ni $bl_pkgs} {
lappend provides($top) $pkg
}
}
}
}
ifneeded {
# most occurrences in pkgIndex.tcl
if {$top ni $bl_dirs} {
lappend provides($top) $pkg
}
}
require {
# most occurrences packge in sources
if {$pkg ni $bl_pkgs} {
lappend requires($pkg) $top
}
}
}
}
}
close $f
}
# dedup provides
foreach top [array names provides] {
array set has {}
foreach pkg $provides($top) {
incr has($pkg)
}
set provides($top) [array names has]
unset has
}
# dedup requires
foreach pkg [array names requires] {
foreach top $requires($pkg) {
incr has($top)
}
set requires($pkg) [array names has]
unset -nocomplain has
if {$tvar ne {} && $requires($pkg) eq {}} {
unset requires($pkg)
}
}
if {$tvar ne {}} {
# resolve requires to top dirs
array set rreqs {}
foreach pkg [array names requires] {
foreach top $requires($pkg) {
lappend rreqs($top) $pkg
}
}
foreach top [array names rreqs] {
foreach pkg $rreqs($top) {
incr has($pkg)
}
set rreqs($top) [array names has]
unset -nocomplain has
if {$rreqs($top) eq {}} {
unset rreqs($top)
}
}
array set toprequires {}
foreach top [array names rreqs] {
set toprequires($top) {}
foreach pkg $rreqs($top) {
foreach top2 [array names provides] {
if {$pkg in $provides($top2)} {
if {$top2 ni $toprequires($top)} {
lappend toprequires($top) $top2
}
}
}
}
if {$toprequires($top) eq {}} {
unset toprequires($top)
}
}
unset rreqs
# invert provides
array set rprov {}
foreach top [array names provides] {
foreach pkg $provides($top) {
lappend rprov($pkg) $top
}
}
unset provides
array set provides [array get rprov]
unset rprov
# final fixups
set toprequires(tk8.6) tcl8.6
set toprequires(itk4.1.0) {itcl4.2.0 tk8.6}
}
return ""
}
# Public interface e.g. for LUCK CGI script.
#
# top: template, e.g. /luckfs/vanillatclsh-win32.exe or /tmpmnt
# (mounted ZIP of a binary)
# appdirs: zero or more application directories
# presel: list of preselected extensions (toplevel directories,
# i.e. directory names like in the keys of "toprequires"
#
# Returns list of required toplevel package directories from the
# template which are required by the things in the application
# directories and the preselection.
proc find_deps {top appdirs {presel {}}} {
variable mount
variable topdir
variable isdb
variable dir_black_list
variable pkg_black_list
if {[info exists mount]} {
# the fast way by using precomputed dependency information
set tpl [lindex [file split $top] end]
foreach name {requires provides toprequires} {
if {$isdb} {
set fn [file join $mount ..$name]
} else {
set fn [file join $topdir $name]
}
catch {
set f [::open $fn r]
array set tmp [read $f]
catch {array set $name $tmp($tpl)}
unset tmp
}
catch {close $f}
}
}
if {![info exists toprequires]} {
# the long way by inspecting the mounted template
_find_deps $top $dir_black_list $pkg_black_list \
requires provides toprequires
}
array set appreqs {}
foreach dir $appdirs {
_find_deps $dir {} {} appreqs
}
array set wants {}
foreach pkg [array names appreqs] {
if {[info exists provides($pkg)]} {
foreach top $provides($pkg) {
incr wants($top)
}
}
}
foreach top $presel {
incr wants($top)
}
set app_wants_list [array names wants]
foreach top $app_wants_list {
if {[info exists toprequires($top)]} {
_add_deps $toprequires($top) toprequires wants
}
}
return [lsort -dictionary [array names wants]]
}
# Helper for find_deps above.
proc _add_deps {deps tvar wvar} {
upvar $tvar toprequires
upvar $wvar wants
foreach top $deps {
incr wants($top)
if {[info exists toprequires($top)]} {
foreach top2 $toprequires($top) {
if {![info exists wants($top2)]} {
_add_deps $top2 toprequires wants
}
}
}
}
}
}
# If invoked directly, provide the maketdd helper.
if {[info exists argv0] && ($argv0 eq [info script])} {
if {![info exists argv] || ([llength $argv] < 2)} {
puts stderr "usage: $argv0 source-dir name-of-tdd-file"
exit 1
}
vfs::luckfs::maketdd {*}[lrange $argv 0 1]
exit 0
}