luckvfs.tcl at tip
Not logged in

File undroid/luck/cgi-bin/luckvfs.tcl from the latest check-in


#!/usr/bin/env vanillatclsh
#############################################################################
#
#             LUCK: Lean Undroidwish Construction Kit
#
# Copyright (c) 2021 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
#      contents of undroidwish-xxx    files of ZIP part
#  /vanillawish-yyy                   plain file, executable part
#      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:
#
#  * 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 $from}]} {
	    vfs::unmount $from
	}
	if {![file isdirectory $from]} {
	    unset -nocomplain index
	    array set index {}
	    sqlite3 [namespace current]::db $from -readonly 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
	    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
	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]
			    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]
	    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);
		}
		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);
		    }
		    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;
		}
	    }
	    tdd eval {
		drop table if exists files;
		drop table if exists data;
		create table files(
		    zip varchar,
		    file varchar,
		    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 zip, file, mtime, size, inode from tmp_files;
		insert into data(rowid, data)
		    select rowid, data from tmp_data;
		drop table tmp_files;
		drop table tmp_data;
		create table deps(
		     zip varchar,
		     item varchar,
		     data varchar,
		     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
}