[Starkit] filleting tcllib

[Schofield, Bryan (GE Trans)]

> -----Original Message-----
> From: Andreas Kupries [mailto:andreask at ActiveState.com]
> Sent: Wednesday, May 04, 2005 12:12 PM
> To: Schofield, Bryan (GE Trans); starkit at equi4.com
> Cc: Tcllib Devel
> Subject: RE: [Starkit] filleting tcllib
> 
> 
> >
> > Below is simple tcl package that I use to find a package and it's
> > dependancies and collect them all as one big hunk of code. For
> > example, if you needed package foo, you could do the following to
> > collect foo and everything else it needs
> >
> > cd $myVfsLibDir
> > set c [open myfoo.tcl w]
> > puts $c [flatpkg::script foo]
> > close $c
> > pkg_mkIndex . myfoo.tcl
> >
> >
> > One thing to note, I don't think my "flatpkg" thing will work if
> > the package if the package source files try to read variables in
> > the global scope. It's implemented using slave interps with one
> > command, "unknown". But, a proper package shouldn't be doing
> > things in the global namespace anyhow, and from what I can tell,
> > it works just fine with tcllib.
> 
> The sak tool I mentioned in previous answers does things 
> similarly, but also
> aliases the 'package' command, a bit of 'namespace', ensures 
> that uses of
> 'if' are no problem, etc. Some of the tcllib packages have 
> conditions at the
> global level.
> 
> It also tries to extract the data first without executing the 
> code, i.e. by
> scanning the code on a textual basis. It only tries to 
> execute the code only
> if the text scan was unsucessful. The uncomplicated cases 
> simply do not
> require execution.
> 
> --
> 	Andreas Kupries <andreask at ActiveState.com>
> 	Developer @ http://www.ActiveState.com, a division of Sophos
> 	Tel: +1 604 484 6491
> 
> 

I've attached a slightly modified version of the package I originally posted earlier along with a test file. I added the ability to get a "required" package list in addition to the required source files.

   ::flatpkg::FindRequiredPackages {package {version ""}}

returns a list of required packages and version number (if required). List format:
  { {name ?version?} {name ?version?} ... }

Personally, I have no issue executing the code from the start versus trying to parse it manually and extract. Perhaps I'm just not seeing why it is better to try to extract it package info by scanning. Anyway, this is just what I do because it suits my needs. If it helps someone else, great, if not, that's fine too. Btw.. you'll need to turn on the userInteraction constraint when running the test and it can produce alot of output. From a unix terminal I usually do something like this to view the output:
  > echo struct | tclkit flatpkg.test -constraint userInteraction | less


Sorry about the huge post, this is last time I'll do it.
Regards.
-- bryan



# START OF flatpkg.tcl
package provide flatpkg 1.0
namespace eval ::flatpkg {
    variable script ""
}

proc ::flatpkg::script {pkg {version ""}} {
    variable script
    set script ""
    set interp [CreateSourcingInterp]
    foreach f [FindSourceFiles $pkg $version] {
        set chan [open $f r]
        set data [read $chan]
        close $chan
        $interp eval $data
    }
    return $script
}

proc ::flatpkg::AppendToScript {args} {
    variable script
    append script $args "\n"
}

proc ::flatpkg::CreateSourcingInterp {} {
    set interp [interp create]
    foreach c [$interp eval {info commands}] {
        if {$c eq "rename"} {continue}
        $interp eval [list rename $c ""]
    }
    $interp eval {rename rename ""}
    interp alias $interp unknown {} ::flatpkg::AppendToScript
    return $interp
}

proc ::flatpkg::FindSourceFiles {package {version ""}} {
    return [lindex [FindPackageDeps $package $version] 1]
}
proc ::flatpkg::FindRequiredPackages {package {version ""}} {
    return [lindex [FindPackageDeps $package $version] 0]
}
proc ::flatpkg::FindPackageDeps {package {version ""}} {
    set interp [interp create]
    $interp eval {
        namespace eval ::findsource {
            variable files {}
            variable package
            array set package {}
        }
        proc ::findsource::ignore {f} {
            if {[file tail $f] eq "pkgIndex.tcl"} { return 1}
            if {[string match $::tcl_library* $f]} { return 1 }
            if {[info exists ::tk_library] && [string match $::tk_library* $f]} {
                return 1
            }
            return 0
        }
        proc ::findsource::process {cmd code result op} {
            variable files
            set f [lindex [split $cmd] 1]
            if {![ignore $f]} {
                lappend files [file normalize $f]
            }
        }
        proc ::findsource::pkg {cmd op} {
            variable package
            set xCmd [split $cmd]
            if {[lindex $xCmd 1] eq "require"} {
                set i 2
                set exact 0
                if {[lindex $xCmd $i] eq "-exact"} {
                    incr i
                    set exact 1
                }
                set pkg [lindex $xCmd $i]
                set version [lindex $xCmd [incr i]]
                if {![info exists package($pkg)] || $exact
                    || (([info exists package($pkg)] && ($version ne ""))
                        && ($package($pkg) eq "" || ([package vcompare $version $package($pkg)] == 1)))
                } {
                    set package($pkg) $version
                }
            }
        }
        trace add execution source leave ::findsource::process
        trace add execution package enter ::findsource::pkg
    }
    $interp eval [list set auto_path $::auto_path]
    $interp eval "package forget $package $version"
    $interp eval "package require $package $version"
    set files [$interp eval "set ::findsource::files"]
    array set pkg [$interp eval "array get ::findsource::package"]
    set packages {}
    foreach n [lsort [array names pkg]] {
        lappend packages [expr {($pkg($n) eq "")?[list $n]:[list $n $pkg($n)]}]
    }
    interp delete $interp
    return [list $packages $files]
}

# END OF flatpkg.tcl


# START OF flatpkg.test
# -*- tcl -*-
package require tcltest 2.2
eval tcltest::configure $argv

set d [file dirname [file dirname [info script]]]
lappend auto_path $d [file join $d ..] [file join $d .. ..]


package require flatpkg

namespace eval ::flatpkg::test {
    namespace import ::tcltest::*
    variable pkg ""
    proc getPackage {} {
        variable pkg
        if {$pkg eq ""} {
            set pkg [input "Enter Package"]
        }
        return $pkg
    }
    proc input {prompt} {
        puts -nonewline "${prompt}: "
        flush stdout
        gets stdin
    }
    
    
    test findSources-1 "find sourced files for a package" \
          -constraints userInteraction \
          -result "" \
          -body {
        set files [flatpkg::FindSourceFiles [getPackage]]
        puts "Files for: [getPackage]"
        foreach f $files {
            puts \t$f
        }
        return
    }
    
    test findPkgs-1 "find dependant packages for a package" \
          -constraints userInteraction \
          -result "" \
          -body {
        set pkgs [::flatpkg::FindRequiredPackages [getPackage]]
        puts "Packages for: [getPackage]"
        foreach p $pkgs {
            puts \t[join $p]
        }
        return
    }

    
    test get-1 "get flattened package code" \
          -constraints userInteraction \
          -result "" \
          -body {
        set script [flatpkg::script [getPackage]]
        puts $script
        return
    }
    
    cleanupTests
}
namespace delete ::flatpkg::test

# END OF flatpkg.test