You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
902 lines
34 KiB
902 lines
34 KiB
#!/bin/sh |
|
# the next line restarts using tclsh \ |
|
exec tclsh "$0" ${1+"$@"} |
|
|
|
if { ![package vsatisfies [package provide Tcl] 8.5] } {puts stdout "Tcl: >= 8.5 is required"; return} |
|
if { ![package vsatisfies [package require sha1] 2.0.3] } {puts stdout "sha1: >= 2.0.3 is required"; return} |
|
if { ![package vsatisfies [package require yaml] 0.3.6] } {puts stdout "yaml: >= 0.3.6 is required"; return} |
|
|
|
namespace eval ::tcltm::binary { |
|
proc readfile { dir file } { |
|
set b [open [file normalize [filename $dir $file]]] |
|
fconfigure $b -translation binary |
|
fconfigure $b -encoding binary |
|
set data [read $b] |
|
close $b |
|
return $data |
|
} |
|
proc filesize { dir file } { |
|
return [string length [readfile $dir $file]] |
|
} |
|
proc filename { dir file } { |
|
set f $file |
|
if { [string match {*\**} $f] } { |
|
set f [glob -directory $dir $f] |
|
return $f |
|
} |
|
return [file normalize [file join $dir $file]] |
|
} |
|
proc hash { dir file } { |
|
return [::sha1::sha1 -hex -file [filename $dir $file]] |
|
} |
|
proc encode { dir file } { |
|
set info [dict create] |
|
dict set info size [filesize $dir $file] |
|
dict set info hash [hash $dir $file] |
|
return $info |
|
} |
|
proc present { flist } { |
|
return [expr {[llength [files $flist]] > 0 ? 1 : 0}] |
|
} |
|
proc files { flist } { |
|
set filelist [list] |
|
for {set fidx 0} {$fidx < [llength $flist]} {incr fidx} { |
|
set fcfg [lindex $flist $fidx] |
|
if { ![dict exists $fcfg type] } { |
|
dict set fcfg type "script" |
|
} |
|
if { [string toupper [dict get $fcfg type]] eq "BINARY" } { |
|
lappend filelist $fcfg |
|
} |
|
} |
|
return $filelist |
|
} |
|
} |
|
namespace eval ::tcltm::config { |
|
proc exists { dir {cfg .tcltm} } { |
|
set fname [file normalize [file join $dir $cfg]] |
|
return [file exists $fname] |
|
} |
|
proc load { dir {cfg .tcltm} } { |
|
set fname [file normalize [file join $dir $cfg]] |
|
return [::yaml::yaml2dict -file $fname -m:true {1 {true on}} -m:false {0 {false off}}] |
|
} |
|
proc merge { cfg opts } { |
|
dict set cfg options $opts |
|
return $cfg |
|
} |
|
proc parse { cfg } { |
|
set pkgs [list] |
|
foreach p [dict get $cfg package] { |
|
if { [dict exists $p filter] } { |
|
set filter [list] |
|
foreach {k v} [dict get $p filter] { |
|
lappend filter "$k [::tcltm::env::resolve $v]" |
|
} |
|
dict set p filter $filter |
|
} |
|
set files [list] |
|
foreach f [dict get $p files] { |
|
if { [dict exists $f filter] } { |
|
set filter [list] |
|
foreach {k v} [dict get $f filter] { |
|
lappend filter "$k [::tcltm::env::resolve $v]" |
|
} |
|
dict set f filter $filter |
|
} |
|
lappend files $f |
|
} |
|
dict set p files $files |
|
if { [dict exists $p version] } { |
|
dict set p version [::tcltm::env::resolve [dict get $p version]] |
|
} |
|
if { [dict get $cfg options version-from-index] } { |
|
set idx [file normalize [file join [dict get $cfg options in] pkgIndex.tcl]] |
|
if { [file exists $idx] } { |
|
set results [::tcltm::scan $idx] |
|
foreach {f res} $results { |
|
if { $f eq $idx } { |
|
foreach pkg $res { |
|
if { [dict get $p name] eq [dict get $pkg package] && [dict get $pkg type] eq "ifneeded" } { |
|
dict set p version [dict get $pkg version] |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
lappend pkgs $p |
|
} |
|
dict set cfg package $pkgs |
|
return $cfg |
|
} |
|
} |
|
namespace eval ::tcltm::env { |
|
proc resolve { val } { |
|
set v {} |
|
if { [string tolower [string range $val 0 3]] eq "env:" } { |
|
set l [split $val ":"] |
|
if { [info exists ::env([lindex $l 1])] } { |
|
set v $::env([lindex $l 1]) |
|
} elseif { [llength $l] == 3 } { |
|
set v [lindex $l 2] |
|
} else { |
|
error "environment variable '[lindex $l 1]' does not exists" |
|
} |
|
} else { |
|
set v $val |
|
} |
|
return $v |
|
} |
|
} |
|
namespace eval ::tcltm::filter { |
|
proc line { str key value } { |
|
regsub -all -- "@${key}@" $str $value str |
|
return $str |
|
} |
|
proc lines { data key value } { |
|
set lines [list] |
|
foreach l [split $data "\n"] { |
|
lappend lines [line $l $key $value] |
|
} |
|
return [join $lines "\n"] |
|
} |
|
proc multi { data args } { |
|
set lines [list] |
|
foreach l [split $data "\n"] { |
|
set line $l |
|
foreach {k v} $args { |
|
set line [line $line $k $v] |
|
} |
|
lappend lines $line |
|
} |
|
return [join $lines "\n"] |
|
} |
|
proc lfile { pkg file } { |
|
set filter [list] |
|
if { [dict exists $pkg filter] } { |
|
lappend filter [dict get $pkg filter] |
|
} |
|
foreach f [dict get $pkg files] { |
|
if { [dict exists $f filter] && [dict get $f name] eq $file } { |
|
lappend filter [dict get $f filter] |
|
} |
|
} |
|
return $filter |
|
} |
|
} |
|
namespace eval ::tcltm::license { |
|
proc exists { dir {filename LICENSE} } { |
|
set fname [file normalize [file join $dir $filename]] |
|
return [file exists $fname] |
|
} |
|
proc load { dir {filename LICENSE} } { |
|
set fname [file normalize [file join $dir $filename]] |
|
set fh [open $fname RDONLY] |
|
set data [read $fh] |
|
close $fh |
|
return $data |
|
} |
|
proc format { data } { |
|
set license [list] |
|
lappend license $::tcltm::markup::divider |
|
foreach line [split $data "\n"] { |
|
if { $line eq {} } { |
|
lappend license "#" |
|
} else { |
|
lappend license [::tcltm::markup::comment $line] |
|
} |
|
} |
|
lappend license $::tcltm::markup::divider |
|
return $license |
|
} |
|
} |
|
namespace eval ::tcltm::loader { |
|
variable script { |
|
namespace eval ::tcltm::binary { |
|
variable path |
|
variable resources |
|
variable name |
|
proc loader {} { |
|
variable path |
|
variable resources [list] |
|
variable name |
|
if { ![info exists path] || [string length $path] == 0 } { |
|
set path [file normalize [file dirname [info script]]] |
|
} |
|
set bin [open [info script] {RDONLY BINARY}] |
|
set header 0 |
|
while { [gets $bin line] >= 0 } { |
|
if { [string match {*TCLTM*HEADER*BEGIN*} $line] } { |
|
set header 1 |
|
continue |
|
} |
|
if { [string match {*TCLTM*HEADER*END*} $line] } { |
|
break |
|
} |
|
if { [string match {*NAME*} $line] } { |
|
regexp {^# ([[:alpha:]]+): ([[:alpha:]]+$)} $line -> - name |
|
} |
|
if { [string match {*RESOURCE*} $line] } { |
|
set res {*}[string trimleft [lindex [split $line ":"] 1]] |
|
dict lappend resources files [dict get $res NAME] |
|
dict set resources [dict get $res NAME] $res |
|
} |
|
} |
|
seek $bin 0 |
|
set bindata [read $bin] |
|
close $bin |
|
set bindex [string first \\u001A $bindata] |
|
incr bindex |
|
foreach f [dict get $resources files] { |
|
set finfo [dict get $resources $f] |
|
set tmp [file normalize [file join $path [dict get $finfo NAME]]] |
|
if { ![file exists [file dirname $tmp]] } { |
|
file mkdir [file dirname $tmp] |
|
} |
|
set fh [open $tmp w] |
|
fconfigure $fh -translation binary |
|
fconfigure $fh -encoding binary |
|
puts -nonewline $fh [string range $bindata $bindex [incr bindex [dict get $finfo SIZE]]-1] |
|
flush $fh |
|
close $fh |
|
if { [package vsatisfies [package require sha1] 2.0.3] } { |
|
set hash [::sha1::sha1 -hex -file $tmp] |
|
if { $hash ne [dict get $finfo HASH] } { |
|
return -code error "[file tail [info script]]: Hash invalid for embedded binary [dict get $finfo NAME]" |
|
} |
|
} |
|
if { [dict exists $finfo ACTION] } { |
|
switch -exact -- [string toupper [dict get $finfo ACTION]] { |
|
NONE { |
|
} |
|
RUN { |
|
if { [catch {source $tmp} err] } { |
|
return -code error "Failed to run embedded resource: $tmp" |
|
} |
|
} |
|
LOAD { |
|
if { [catch {load $tmp}] } { |
|
if { [catch {load $tmp $name}] } { |
|
return -code error "[file tail [info script]]: failed to load embedded binary [dict get $finfo NAME]" |
|
} |
|
} |
|
} |
|
EXTRACT { |
|
} |
|
default { |
|
} |
|
} |
|
} |
|
incr bindex |
|
} |
|
} |
|
} |
|
} ; # END Variable script |
|
variable action { |
|
::tcltm::binary::loader |
|
}; |
|
variable interactive { |
|
if { $tcl_interactive } { |
|
::tcltm::binary::loader |
|
} |
|
} |
|
} ; # END Namespace |
|
namespace eval ::tcltm::markup { |
|
variable divider [string repeat "#" 80] |
|
proc comment { n args } { |
|
set line {} |
|
if { [llength $args] } { |
|
set line [format {# %s %s} $n [join $args]] |
|
} else { |
|
set line [format {# %s} $n] |
|
} |
|
return $line |
|
} |
|
proc iscomment { line } { |
|
if { [string index $line 0] eq "#" } { |
|
return 1 |
|
} |
|
return 0 |
|
} |
|
proc nl {} { |
|
return {} |
|
} |
|
proc meta { n args } { |
|
if { [llength $args] } { |
|
set line [format {# %s: %s} [string toupper $n] [join $args]] |
|
} else { |
|
set line [format {# %s} [string toupper $n]] |
|
} |
|
return $line |
|
} |
|
proc script { body args } { |
|
regsub -all "\n$" $body {} body |
|
return [string trimleft [format "[subst -nocommands -novariables $body]" {*}$args] "\n"] |
|
} |
|
} |
|
namespace eval ::tcltm::module { |
|
variable config [dict create] |
|
variable content [list] |
|
proc new { cfg pkg } { |
|
variable config $cfg |
|
variable content |
|
set config $cfg |
|
set content [list] |
|
if { [dict exists [pkgcfg $pkg] interp] } { |
|
lappend content "#!/usr/bin/env [dict get [pkgcfg $pkg] interp]" |
|
lappend content [::tcltm::markup::comment "Windows Magic Header \\"] |
|
lappend content "exec [dict get [pkgcfg $pkg] interp] \"\$0\" \"\$@\"" |
|
lappend content [::tcltm::markup::nl] |
|
} |
|
lappend content [::tcltm::markup::comment "Tcl Module Generated by tcltm; DO NOT EDIT"] |
|
lappend content [::tcltm::markup::nl] |
|
return -code ok |
|
} |
|
proc pkgcfg { pkg } { |
|
variable config |
|
foreach p [dict get $config package] { |
|
if { [dict get $p name] eq $pkg } { |
|
return $p |
|
} |
|
} |
|
return -code ok |
|
} |
|
proc write { pkg } { |
|
variable config |
|
variable content |
|
variable cfg [pkgcfg $pkg] |
|
set ext .tm |
|
if { [dict exists $cfg extension] } { |
|
set ext [dict get $cfg extension] |
|
} |
|
if { [dict exists $cfg finalname] && [string length [dict get $cfg finalname]] > 0 } { |
|
set filename [dict get $cfg finalname] |
|
} else { |
|
if { [dict exists $cfg fileversion] } { |
|
set fileversion [::tcltm::env::resolve [dict get $cfg fileversion]] |
|
set filename [format {%s-%s%s} [dict get $cfg name] $fileversion $ext] |
|
} else { |
|
set filename [format {%s-%s%s} [dict get $cfg name] [dict get $cfg version] $ext] |
|
} |
|
} |
|
regsub -all -- {::} $filename {/} filename |
|
set filepath [file normalize [file join [file normalize [dict get $config options out]] $filename]] |
|
if { [dict get $config options repo] } { |
|
set tcldir "tcl[lindex [split [dict get $cfg tcl] "."] 0]" |
|
set outdir [file normalize [file join [dict get $config options out] $tcldir [dict get $cfg tcl]]] |
|
if { [catch {file mkdir $outdir} err] } { |
|
puts stdout "Failed to create output directory ${outdir}: $err"; flush stdout |
|
exit 1 |
|
} |
|
set filepath [file join $outdir $filename] |
|
} |
|
if { [catch {file mkdir [file dirname $filepath]} err] } { |
|
puts stdout "Failed to create [file dirname $filepath]: $err" |
|
exit 1 |
|
} |
|
if { [::tcltm::binary::present [dict get $cfg files]] } { |
|
lappend content [::tcltm::markup::nl] |
|
lappend content [::tcltm::markup::comment "BINARY SECTION"] |
|
} |
|
set fh [open $filepath w] |
|
fconfigure $fh -translation lf |
|
set lines [join $content "\n"] |
|
regsub -all -- {\n\n\n+} $lines "\n\n" lines |
|
puts $fh $lines |
|
if { [::tcltm::binary::present [dict get $cfg files]] } { |
|
puts -nonewline $fh "\u001A" |
|
fconfigure $fh -translation binary |
|
set binfiles [::tcltm::binary::files [dict get $cfg files]] |
|
foreach f $binfiles { |
|
puts stdout "Encoding: [dict get $f name]" |
|
puts $fh [::tcltm::binary::readfile [dict get $config options in] [dict get $f name]] |
|
} |
|
} |
|
close $fh |
|
puts stdout "Module: $filename \[$filepath\]" |
|
return -code ok |
|
} |
|
proc license { pkg } { |
|
variable config |
|
variable content |
|
variable cfg [pkgcfg $pkg] |
|
if { ![dict exists $cfg license] || [string length [dict get $cfg license]] == 0 } { |
|
if { [::tcltm::license::exists [dict get $config options in]] } { |
|
dict set cfg license [::tcltm::license::load [dict get $config options in]] |
|
} |
|
} |
|
if { [dict exists $cfg license] && [string length [dict get $cfg license]] > 0 } { |
|
if { [llength [split [dict get $cfg license] "\n"]] == 1 } { |
|
dict set cfg license [::tcltm::license::load [dict get $config options in] [dict get $cfg license]] |
|
} |
|
} |
|
if { [dict exists $cfg license] && [string length [dict get $cfg license]] > 0 } { |
|
lappend content {*}[::tcltm::license::format [dict get $cfg license]] |
|
lappend content [::tcltm::markup::nl] |
|
} |
|
return -code ok |
|
} |
|
proc header { pkg } { |
|
variable config |
|
variable content |
|
variable cfg [pkgcfg $pkg] |
|
lappend content [::tcltm::markup::comment "TCLTM HEADER BEGIN"] |
|
foreach key {name version summary description Tcl} { |
|
if { [dict exists $cfg $key] && [string length [dict get $cfg $key]] > 0 } { |
|
if { [string tolower $key] eq "description" } { |
|
foreach line [split [dict get $cfg $key] "\n"] { |
|
lappend content [::tcltm::markup::meta "DESCRIPTION" $line] |
|
} |
|
} else { |
|
lappend content [::tcltm::markup::meta $key [dict get $cfg $key]] |
|
} |
|
} |
|
} |
|
if { [dict exists $cfg dependencies] && [string length [dict get $cfg dependencies]] > 0 } { |
|
foreach r [dict get $cfg dependencies] { |
|
lappend content [::tcltm::markup::meta "REQUIRE" $r] |
|
} |
|
} |
|
set files [list] |
|
set bidx 0 |
|
for {set fidx 0} {$fidx < [llength [dict get $cfg files]]} {incr fidx} { |
|
set fcfg [lindex [dict get $cfg files] $fidx] |
|
if { ![dict exists $fcfg type] } { |
|
dict set fcfg type "script" |
|
} |
|
if { [string toupper [dict get $fcfg type]] eq "BINARY" } { |
|
dict set fcfg id $bidx |
|
incr bidx |
|
if { [string match {*\**} [dict get $fcfg name]] } { |
|
set f [glob -directory [dict get $config options in] [dict get $fcfg name]] |
|
dict set fcfg name [file tail $f] |
|
} |
|
set enc [::tcltm::binary::encode [dict get $config options in] [dict get $fcfg name]] |
|
set fcfg [list {*}$fcfg {*}$enc] |
|
set name [dict get $fcfg name] |
|
if { [dict get $config options strip-resource-dir] } { |
|
set name [file tail $name] |
|
} |
|
set header [format {ID %s NAME %s SIZE %s HASH %s} \ |
|
[dict get $fcfg id] \ |
|
$name \ |
|
[dict get $fcfg size] \ |
|
[dict get $fcfg hash] \ |
|
] |
|
if { [dict exists $fcfg action] } { |
|
append header " ACTION [dict get $fcfg action]" |
|
} |
|
if { [dict exists $fcfg target] } { |
|
append header " TARGET [dict get $fcfg target]" |
|
} |
|
lappend content [::tcltm::markup::meta "RESOURCE" [format "{%s}" $header]] |
|
} |
|
lappend files $fcfg |
|
} |
|
lappend content [::tcltm::markup::comment "TCLTM HEADER END"] |
|
return -code ok |
|
} |
|
proc satisfy-tcl-version { pkg } { |
|
variable config |
|
variable content |
|
variable cfg [pkgcfg $pkg] |
|
if { ![dict get $config options exclude-satisfy-tcl] } { |
|
lappend content [::tcltm::markup::nl] |
|
lappend content [::tcltm::markup::script { |
|
if { ![package vsatisfies [package provide Tcl] %s] } { |
|
return -code error "Unable to load module '%s' Tcl: '%s' is required" |
|
} |
|
} [dict get $cfg tcl] [dict get $cfg name] [dict get $cfg tcl]] |
|
} |
|
return -code ok |
|
} |
|
proc deps { pkg } { |
|
variable config |
|
variable content |
|
variable cfg [pkgcfg $pkg] |
|
if { ![dict get $config options exclude-deps] } { |
|
if { [dict exists $cfg dependencies] && [string length [dict get $cfg dependencies]] > 0 } { |
|
lappend content [::tcltm::markup::nl] |
|
foreach r [dict get $cfg dependencies] { |
|
lappend content [::tcltm::markup::script {package require %s} $r] |
|
} |
|
} |
|
} |
|
return -code ok |
|
} |
|
proc script { pkg type } { |
|
variable config |
|
variable content |
|
variable cfg [pkgcfg $pkg] |
|
set filter [list] |
|
lappend filter "PNAME [dict get $cfg name]" |
|
if { [dict exists $cfg version] } { |
|
lappend filter "PVERSION \"[dict get $cfg version]\"" |
|
} |
|
if { [dict exists $pkg filter] } { |
|
lappend filter [dict get $pkg filter] |
|
} |
|
if { [dict exists $cfg $type] && [string length [dict get $cfg $type]] > 0 } { |
|
lappend content [::tcltm::markup::nl] |
|
lappend content [::tcltm::markup::comment "TCLTM [string toupper $type] BEGIN"] |
|
if { [llength [split [dict get $cfg $type] "\n"]] == 1 } { |
|
if { [string match "*.tcl" [lindex [split [dict get $cfg $type] "\n"] 0]] } { |
|
set bfile [lindex [split [dict get $cfg $type] "\n"] 0] |
|
foreach line [split [::tcltm::binary::readfile [dict get $config options in] [::tcltm::binary::filename [dict get $config options in] $bfile]] "\n"] { |
|
if { [dict get $config options strip] && [::tcltm::markup::iscomment $line] } { |
|
} else { |
|
foreach elm $filter { |
|
set k [lindex $elm 0] |
|
set v [lindex $elm 1] |
|
set line [::tcltm::filter::line $line $k "$v"] |
|
} |
|
lappend content $line |
|
} |
|
} |
|
} else { |
|
lappend content [::tcltm::markup::script [dict get $cfg $type]] |
|
} |
|
} else { |
|
foreach line [split [dict get $cfg $type] "\n"] { |
|
if { [dict get $config options strip] && [::tcltm::markup::iscomment $line] } { |
|
} else { |
|
foreach elm $filter { |
|
set k [lindex $elm 0] |
|
set v [lindex $elm 1] |
|
set line [::tcltm::filter::line $line $k $v] |
|
} |
|
lappend content [::tcltm::markup::script $line] |
|
} |
|
} |
|
} |
|
lappend content [::tcltm::markup::comment "TCLTM [string toupper $type] END"] |
|
} |
|
return -code ok |
|
} |
|
proc code { pkg } { |
|
variable config |
|
variable content |
|
variable cfg [pkgcfg $pkg] |
|
lappend content [::tcltm::markup::nl] |
|
lappend content [::tcltm::markup::comment "TCLTM SCRIPT SECTION BEGIN"] |
|
foreach f [dict get $cfg files] { |
|
set inc 0 |
|
if { [file extension [::tcltm::binary::filename [dict get $config options in] [dict get $f name]]] eq ".tcl" } { |
|
set inc 1 |
|
} elseif { [dict exists $f type] && [string tolower [dict get $f type]] eq "script" } { |
|
set inc 1 |
|
} |
|
set filter [list] |
|
if { [dict exists $f filtering] && [dict get $f filtering] } { |
|
set filter {*}[::tcltm::filter::lfile $cfg [dict get $f name]] |
|
lappend filter "PNAME [dict get $cfg name]" |
|
if { [dict exists $cfg version] } { |
|
lappend filter "PVERSION \"[dict get $cfg version]\"" |
|
} |
|
lappend filter "FILENAME [dict get $f name]" |
|
} |
|
if { $inc } { |
|
set ignore(block) 0 |
|
set ignore(next) 0 |
|
foreach line [split [::tcltm::binary::readfile [dict get $config options in] [dict get $f name]] "\n"] { |
|
if { [string match {*TCLTM*IGNORE*BEGIN*} [string toupper $line]] } { |
|
set ignore(block) 1 |
|
continue |
|
} |
|
if { [string match {*TCLTM*IGNORE*END*} [string toupper $line]] } { |
|
set ignore(block) 0 |
|
continue |
|
} |
|
if { $ignore(block) } { |
|
continue |
|
} |
|
if { [string match {*TCLTM*IGNORE*NEXT*} [string toupper $line]] } { |
|
set ignore(next) 1 |
|
continue |
|
} |
|
if { $ignore(next) } { |
|
set ignore(next) 0 |
|
continue |
|
} |
|
if { [string match {*TCLTM*IGNORE*} [string toupper $line]] } { |
|
continue |
|
} |
|
if { [dict get $config options strip] && [::tcltm::markup::iscomment $line] } { |
|
} else { |
|
if { ![regexp {^(?:([[:blank:]]+)?)package provide*} $line] } { |
|
if { ![dict get $config options preserve-require] && [regexp {^(?:([[:blank:]]+)?)package require*} $line] } { |
|
} |
|
if { [dict exists $f filtering] && [dict get $f filtering] } { |
|
foreach elm $filter { |
|
set k [lindex $elm 0] |
|
set v [lindex $elm 1] |
|
set line [::tcltm::filter::line $line $k $v] |
|
} |
|
} |
|
lappend content $line |
|
} |
|
} |
|
} |
|
} |
|
} |
|
lappend content [::tcltm::markup::comment "TCLTM SCRIPT SECTION END"] |
|
return -code ok |
|
} |
|
proc pkg-provide { pkg } { |
|
variable config |
|
variable content |
|
variable cfg [pkgcfg $pkg] |
|
if { ![dict get $config options exclude-provide] } { |
|
if { [dict exists $cfg version] } { |
|
lappend content [::tcltm::markup::nl] |
|
lappend content [::tcltm::markup::script {package provide %s %s} [dict get $cfg name] [dict get $cfg version]] |
|
} else { |
|
puts stdout "Skipping Package Provide due to missing version information" |
|
} |
|
} |
|
return -code ok |
|
} |
|
proc binaryloader { pkg } { |
|
variable config |
|
variable content |
|
variable cfg [pkgcfg $pkg] |
|
if { [::tcltm::binary::present [dict get $cfg files]] } { |
|
lappend content [::tcltm::markup::nl] |
|
lappend content [::tcltm::markup::comment "TCLTM BINARY LOADER BEGIN"] |
|
lappend content [::tcltm::markup::script $::tcltm::loader::script] |
|
if { [dict get $config options interactive-loader] } { |
|
lappend content [::tcltm::markup::script $::tcltm::loader::interactive] |
|
} else { |
|
lappend content [::tcltm::markup::script $::tcltm::loader::action] |
|
} |
|
lappend content [::tcltm::markup::comment "TCLTM BINARY LOADER END"] |
|
} |
|
return -code ok |
|
} |
|
} |
|
namespace eval ::tcltm { |
|
proc scan { args } { |
|
set results [dict create] |
|
set f [file normalize [lindex $args 0]] |
|
if { ![file exists $f] } { |
|
puts stdout "File '$f' does not exists" |
|
exit 1 |
|
} |
|
set files $f |
|
if { [file isdirectory $f] } { |
|
set files [glob -nocomplain -directory $f -types f -- *.tcl] |
|
} |
|
foreach f $files { |
|
set res [dict create] |
|
set b [open $f] |
|
fconfigure $b -translation binary |
|
fconfigure $b -encoding binary |
|
set data [read $b] |
|
close $b |
|
set pkgs [list] |
|
foreach line [split $data "\n"] { |
|
set r [dict create] |
|
if { [regexp {package (provide|require|ifneeded)(?:[[:blank:]]+)([_[:alpha:]][:_[:alnum:]]*)(?:\])?((?:[[:blank:]]+)?(?:(\d+\.)?(\d+\.)?(\*|\d+))?)} $line -> type pkg ver] } { |
|
dict set r type $type |
|
dict set r package $pkg |
|
dict set r version [string trim $ver] |
|
lappend pkgs $r |
|
} |
|
} |
|
dict set results $f $pkgs |
|
} |
|
return $results |
|
} |
|
} |
|
namespace eval ::tcltm { |
|
variable version |
|
variable commit |
|
|
|
proc usage {} { |
|
puts stdout [subst { |
|
NAME: |
|
tcltm - Tcl Module Builder |
|
|
|
USAGE: |
|
tcltm ?options? |
|
|
|
VERSION: |
|
$::tcltm::version ($::tcltm::commit) |
|
|
|
OPTIONS: |
|
-i DIR, --in DIR Input directory. (Defaults: current directory) |
|
-o DIR, --out DIR Output directory. (Defaults: current directory) |
|
-c FILE, --config FILE Alternate config file. (Defaults: .tcltm) |
|
-p NAME, --pkg NAME Only build package <NAME> from config. |
|
(Defaults: build all) |
|
|
|
--version-from-index Use package version from pkgIndex.tcl |
|
Only works when package name between config and |
|
pkgIndex.tcl is the same. |
|
--strip-comments Strip comments from source |
|
--strip-resource-dir Strip the directory from the source files. |
|
--exclude-satisfy-tcl Exclude Tcl vsatisfies command |
|
--exclude-deps Exclude package require commands for dependencies |
|
--exclude-provide Exclude package provide command |
|
|
|
--preserve-require Preserve 'package require' in source code. |
|
|
|
--interactive-loader Enable interactive loader. |
|
Interactive loader will only run the binary loader when |
|
the tcl interpreter is in interactive mode. |
|
|
|
--repository Create repository output directories. |
|
(tcl8/tcl<version>/module.tm) |
|
|
|
--scan FILE Scan FILE for Tcl dependencies. |
|
If file is a directory, all .tcl files in the |
|
directory will be scanned. |
|
|
|
--verbose Verbose logging |
|
--version Show version |
|
-h, --help Show help |
|
}] |
|
} |
|
|
|
proc main { args } { |
|
array set options { |
|
in {} |
|
out {} |
|
config {.tcltm} |
|
pkg {} |
|
strip 0 |
|
strip-resource-dir 0 |
|
version-from-index 0 |
|
exclude-satisfy-tcl 0 |
|
exclude-deps 0 |
|
exclude-provide 0 |
|
preserve-require 0 |
|
interactive-loader 0 |
|
repo 0 |
|
scan {} |
|
verbose 0 |
|
help 0 |
|
version 0 |
|
} |
|
|
|
while { [llength $args] } { |
|
switch -glob -- [lindex $args 0] { |
|
-i - |
|
--in {set args [lassign $args - options(in)]} |
|
-o - |
|
--out {set args [lassign $args - options(out)]} |
|
-c - |
|
--config {set args [lassign $args - options(config)]} |
|
-p - |
|
--pkg {set args [lassign $args - options(pkg)]} |
|
|
|
--version-from-index {set options(version-from-index) 1; set args [lrange $args 1 end]} |
|
--strip-comments {set options(strip) 1; set args [lrange $args 1 end]} |
|
--strip-resource-dir {set options(strip-resource-dir) 1; set args [lrange $args 1 end]} |
|
--exclude-satisfy-tcl {set options(exclude-satisfy-tcl) 1; set args [lrange $args 1 end]} |
|
--exclude-deps {set options(exclude-deps) 1; set args [lrange $args 1 end]} |
|
--exclude-provide {set options(exclude-provide) 1; set args [lrange $args 1 end]} |
|
--preserve-require {set options(preserve-require) 1; set args [lrange $args 1 end]} |
|
--repository {set options(repo) 1; set args [lrange $args 1 end]} |
|
--interactive-loader {set options(interactive-loader) 1; set args [lrange $args 1 end]} |
|
|
|
--scan {set args [lassign $args - options(scan)]} |
|
|
|
--verbose {set options(verbose) 1; set args [lrange $args 1 end]} |
|
--version {set options(version) 1; set args [lrange $args 1 end]} |
|
-h - |
|
--help {set options(help) 1; set args [lrange $args 1 end]} |
|
|
|
-- {set args [lrange $args 1 end]; break} |
|
-* {puts stdout "Unknown option [lindex $args 0]"; exit 1} |
|
default {break} |
|
} |
|
} |
|
|
|
# Show version |
|
if { $options(version) } { |
|
puts stdout "$::tcltm::version ($::tcltm::commit)"; flush stdout |
|
exit 0 |
|
} |
|
|
|
# Show help is requested |
|
if { $options(help) } { |
|
usage |
|
exit 1 |
|
} |
|
|
|
# Scan for dependencies |
|
if { [string length $options(scan)] > 0 } { |
|
set res [::tcltm::scan {*}$options(scan)] |
|
foreach {f r} $res { |
|
puts stdout "File: $f" |
|
foreach p $r { |
|
puts stdout " Type: [dict get $p type]" |
|
puts stdout " Package: [dict get $p package]" |
|
puts stdout " Version: [dict get $p version]\n" |
|
} |
|
} |
|
exit 0 |
|
} |
|
|
|
# input/output directory validation |
|
foreach dir {in out} { |
|
if { [string length $options($dir)] == 0 } { |
|
set options($dir) [file normalize [pwd]] |
|
if { $options(verbose) } { |
|
puts stdout "No ${dir}put directory provided" |
|
puts stdout " => Using current working directory \[[file normalize [pwd]]\]" |
|
flush stdout |
|
} |
|
} else { |
|
if { ![file isdirectory $options($dir)] } { |
|
puts stdout "$options($dir) is not a directory"; exit 1 |
|
} |
|
} |
|
} |
|
|
|
# Locate configuration |
|
if { ![::tcltm::config::exists $options(in) $options(config)] } { |
|
puts stdout "Missing configuration: $options(config)"; exit 1 |
|
} |
|
|
|
# Load configuration and merge with commandline options |
|
if { $options(verbose) } { puts stdout "Loading Configuration" } |
|
set config [::tcltm::config::load $options(in) $options(config)] |
|
set config [::tcltm::config::merge $config [array get options]] |
|
set config [::tcltm::config::parse $config] |
|
|
|
if { $options(verbose) } { puts stdout $config } |
|
|
|
# Compile all packages wihtin configuration |
|
foreach p [dict get $config package] { |
|
set pkg [dict get $p name] |
|
if { [string length $options(pkg)] > 0 } { |
|
if { $pkg ne $options(pkg) } { |
|
continue |
|
} |
|
} |
|
|
|
puts stdout "Building: $pkg" |
|
|
|
# New Module |
|
::tcltm::module::new $config $pkg |
|
|
|
# Handle LICENSE |
|
::tcltm::module::license $pkg |
|
|
|
# Module Header |
|
::tcltm::module::header $pkg |
|
|
|
# Module Satify Tcl Version |
|
::tcltm::module::satisfy-tcl-version $pkg |
|
|
|
# Module Dependencies |
|
::tcltm::module::deps $pkg |
|
|
|
# Module Bootstrap |
|
::tcltm::module::script $pkg bootstrap |
|
|
|
# Binary Loader |
|
::tcltm::module::binaryloader $pkg |
|
|
|
# Module Source Code |
|
::tcltm::module::code $pkg |
|
|
|
# Module Init Script |
|
::tcltm::module::script $pkg init |
|
|
|
# Module Provide |
|
::tcltm::module::pkg-provide $pkg |
|
|
|
# Module Finalize |
|
::tcltm::module::script $pkg finalize |
|
|
|
# Write Module |
|
::tcltm::module::write $pkg |
|
} |
|
} |
|
} |
|
|
|
::tcltm::main {*}$::argv
|
|
|