Version 1 of Ultimate Package Blast-o-rama

Updated 2009-11-09 13:34:05 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.

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