Version 2 of Ultimate Package Blast-o-rama

Updated 2009-11-09 13:35:12 by CMcC

Goals

To be the best package management system ever. To change the nature of package creation/distribution. To simplify all aspects of the process of writing and disseminating a library. To speed up parts of the system that are slow.

Subgoals for package writers

It should be easy to submit a package to the repository.

Subgoals for application writers

It should be easy to access a package listed in the repository. The repository should handle dependencies automatically.

Subgoals for end-users

It should be faster than the current tcl library load times. Root access shouldn't be necessary to add packages to one's local set of packages.

First cut at code

(it should be called pkgIndex.tcl, you can package require Package)

package ifneeded Package 1.0 {
    package require sqlite3
    package require tdbc::sqlite3

    package provide Package 1.0

    namespace eval ::tcl::package {
        # calculate old-school package subcommands
        catch {package moop} e eo
        set e [split [lindex [split [dict get $eo -errorinfo] \n] 0] ,]
        set e [lreplace $e 0 0 [lindex [split [lindex $e 0]] end]]
        set e [lreplace $e end end [lindex [split [lindex $e end]] end]]
        variable orgsubs {}
        foreach eo $e {
            lappend orgsubs [string trim $eo]
        }
        unset e; unset eo

        tdbc::sqlite3::connection create pdb ~/.tclpkg
        variable live [catch {
            [pdb prepare {
                CREATE TABLE package (package TEXT NOT NULL,
                                      version TEXT NOT NULL,
                                      script TEXT NOT NULL
                                      );
            }] execute
            [pdb prepare {
                CREATE INDEX pindex ON package (package,version);
            }] execute
        }]

        # construct statements
        foreach {name stmt} {
            del {DELETE from package WHERE package = :package AND version = :version}
            add {INSERT INTO package (package, version, script) VALUES (:package, :version, :script)}
            replace {REPLACE INTO package (package, version, script) VALUES (:package, :version, :script)}
            version {SELECT script FROM package WHERE package = :package AND version = :version}
            atleast {SELECT script FROM package WHERE package = :package AND version >= :version}
            all {SELECT package FROM package LIMIT 1}
            find {SELECT * FROM package WHERE package = :package}
            findU {SELECT * FROM package WHERE package = :package ORDER BY version }
            findD {SELECT * FROM package WHERE package = :package ORDER BY version DESC}
        } {
            set statement($name) [pdb prepare $stmt]
        }

        variable unknown [package unknown]
        proc unknown {args} {
            puts stderr "UNKNOWN: $args"
            variable unknown
            return [{*}$unknown {*}$args]
        }
        package unknown [namespace code unknown]

        foreach n $orgsubs {
            if {"::tcl::package::$n" ni [info commands ::tcl::package::*]} {
                {*}[string map [list %N% $n] {
                    proc %N% {args} {
                        set result [uplevel [list [namespace current]::_package %N% {*}$args]]
                        puts stderr "called package %N% $args -> $result"
                        return $result
                    }
                }]
            }
            
        }

        proc _unknown {cmd subcmd args} {
            variable orgsubs
            if {$subcmd in $orgsubs} {
                set result [list [namespace current]::_package $subcmd {*}$args]
                puts stderr "$cmd $subcmd $args -> $result"
                return $result
            } else {
                error "bad option $subcmd: must be [join $orgsubs ,]"
            }
        }

        # install the contents of this ns as an ensemble over ::package
        rename ::package ::tcl::package::_package

        namespace export -clear *
        namespace ensemble create -command ::package -subcommands {} -unknown ::tcl::package::_unknown

        if {!$live} {
            # force the traversal of the whole fs, collecting ifneeded
            proc ifneeded {package version script} {
                variable statement
                $statement(replace) execute
                puts stderr "Priming ifneeded $package $version $script"
            }

            foreach package [_package names] {
                set script ""
                set versions [_package versions $package]
                if {[llength $versions]} {
                    foreach version $versions {
                        set script [_package ifneeded $package $version]
                        puts stderr "PRELOAD: $package $version $script"
                        $statement(replace) execute
                    }
                } else {
                    puts stderr "BUILTIN $package"
                    set script ""
                    set version [_package present $package]
                    $statement(replace) execute
                }
            }
            catch {package require __MOOOP____}
        }

        proc ifneeded {package version {script ""}} {
            if {$script eq ""} {
                set d [$statement(version) -as dict]
                if {[dict size $d]} {
                    puts stderr "Package ifneeded $package $version -> [dict get $d script]"
                    return [dict get $d script]
                } else {
                    puts stderr "Package ifneeded $package $version -> UNREGISTERED"
                    return ""
                }
            } else {
                $statement(replace) execute
                puts stderr "Package ifneeded $package $version -> [dict get $d script]"
                return ""
            }
        }
        
        proc versions {package} {
            variable statement
            set v {}
            $statement(find) foreach -as dicts d {
                lappend v [dict get $d version]
            }
            puts stderr "Package versions $package -> $v"
            return $v
        }

        variable loaded {}
        proc require {args} {
            variable loaded

            # parse args
            if {[string match -exact [lindex $args 0]]} {
                set exact 1
                set package [lindex $args end-1]
                set version [lindex $args end]

                puts stderr "Package require -exact $package '$version'"
                if {[dict exists $loaded $package $version]} {
                    return $version
                } elseif {![catch {_package present $package} present]} {
                    return $present
                }

                set match [$statement(version) allrows -as dicts]
                if {[llength $match]} {
                    uplevel #0 [dict get [lindex $match 0] script]
                    return $version
                } else {
                    return ""
                }
            }

            set package [lindex $args 0]
            if {[llength $args] > 1} {
                set version [lindex $args end]
            }

            variable statement
            if {[info exists version]} {
                # run query over all matches, check requirement
                set ds [$statement(findD) allrows -as dicts]
                if {![llength $ds]} {
                    error "no package $package"
                }
                foreach d $ds {
                    if {[_package vsatisfies [dict get $d version] $version]} {
                        puts stderr "$package,$version is vsatisfied by ($d)"
                        break
                    } else {
                        puts stderr "($d) does not satisfy $package,$version"
                    }
                }
            } elseif {![catch {_package present $package} present]} {
                return $present
            } else {
                # no version, get highest available
                set d [$statement(findD) allrows -as dicts]
                if {![llength $d]} {
                    error "no package $package"
                } else {
                    set d [lindex $d 0]
                    puts stderr "no version of $package specified, found ($d)"
                }
            }

            dict with d {
                if {$script ne ""} {
                    puts stderr "Running: $d"
                    uplevel #0 $script
                }
                return $version
            }
        }

        proc ifneeded {package version {script ""}} {
            if {$script eq ""} {
                set d [$statement(version) -as dict]
                if {[dict size $d]} {
                    puts stderr "Package ifneeded $package $version -> [dict get $d script]"
                    return [dict get $d script]
                } else {
                    puts stderr "Package ifneeded $package $version -> UNREGISTERED"
                    return ""
                }
            } else {
                $statement(replace) execute
                puts stderr "Package ifneeded $package $version -> [dict get $d script]"
                return ""
            }
        }
    }
}
package require Package
puts stderr "DONE PRIMING"
package require Tcl
package require fileutil
package require moop