#!/bin/env tclsh
## Setok's and Venkat's Make. Provides similar functionality as 'make' but with TCL
## Authors: Kristoffer Lawson, setok@fishpool.com, Venks I venksi@yahoo.com
package require Tcl 8.3
namespace eval ::svmk {
namespace export target depend system tcl log dputs
}
set ::svmk::dbglevel 0
proc ::svmk::dputs {lvl txt} {
if {$lvl<=$::svmk::dbglevel} {
puts stderr "[string repeat " " $lvl]* $txt"
}
}
proc ::svmk::system {args} { # wrapper around exec
set ignore_err 0
set quiet 0
set newargs ""
if {![regexp {[^2]>} $args] && ![regexp {[|]} $args]} {
append newargs " >@ stdout"
}
if {![regexp {>&} $args] && ![regexp {[|][&]} $args] && ![regexp {2>} $args]} {
append newargs " 2>@ stderr"
}
while {[string match {\-*} [set opt [lindex $args 0]]]} {
set args [lrange $args 1 end]
if [string match "--" $opt] break
switch -- $opt {
"-i" - "-ignore" {set ignore_err 1}
"-q" - "-quiet" {set quiet 1}
default {error "Unknown option $opt to exec in $args"}
}
}
append args $newargs
if {$quiet == 0} {
::svmk::dputs 0 $args
}
set rc [catch {
eval [concat exec $args]
} errmsg]
if {$rc} { # failed
if {$ignore_err} { # ignore flag set
if {!$quiet} { # Not quiet print messages
::svmk::dputs 0 "$errmsg"
::svmk::dputs 1 "$::errorCode\n$::errorInfo"
::svmk::dputs 0 "Error from \"$args\" Ignored"
}
} else { # not ignored. Die
::svmk::dputs 0 "Failed: $::errorCode"
error $errmsg $::errorInfo $::errorCode
}
}
return $rc; # return the output of the command.
}
proc ::svmk::tcl {args} { # simple proc to print a command before running it, like system
::svmk::dputs 0 $args
uplevel $args
}
proc ::svmk::countchars {str char} { # count number of char in string
return [llength [regexp -inline -all \[$char\] $str]]
}
# Determines if pattern 1 is a child of pattern 2
proc ::svmk::ischild {pat1 pat2} {
# puts "[string match $pat2 $pat1],[string match $pat1 pat2],[countchars $pat1 "?"],[countchars $pat2 "?"]"
if {[string match $pat2 $pat1] && ![string match $pat1 $pat2]} {
return 1; # one way only match means it is a child
}
if {[string match $pat2 $pat1] && [string match $pat1 $pat2] &&
[countchars $pat1 "?"] > [countchars $pat2 "?"]} {
return 1; # two way match and lesser question marks means a child
}
return 0
}
# Returns 1 if the pattern was added, returns 0 if the pattern could not be added
proc ::svmk::addpattern {pattern {opattern *}} {
variable children
if {[string compare $pattern $opattern] == 0} {
return 1; # if identical, pretend we added
}
if ![::svmk::ischild $pattern $opattern] {
return 0; # can't be added under current opattern
}
::svmk::dputs 6 "Adding pattern <$pattern> under pattern <$opattern>"
set oldchildren $children($opattern)
foreach child $oldchildren { # check children against pattern
if [::svmk::addpattern $pattern $child] {
return 1; # got added as child somewhere our work is done
}
}
if ![info exists children($pattern)] {
set children($pattern) [list]; # children start off empty
}
# Check if current children of opattern need to be pushed under pattern
set children($opattern) [list $pattern]; # this is rebuilt with the ones that arent pushed
foreach child $oldchildren { # check children against pattern
if ![::svmk::addpattern $child $pattern] {
lappend children($opattern) $child; # wasn't added keep here.
}
}
return 1
}
# Returns most specific pattern for a particular target.
proc ::svmk::getpattern {target {pattern *}} {
foreach child $::svmk::children($pattern) { # check children against pattern
if [string match $child $target] {
return [::svmk::getpattern $target $child]
}
}
return $pattern
}
set ::svmk::children(*) [list]
# Debug Routine to print the children tree. Not used internally.
proc ::svmk::printchildren {{indentlevel 0} {pattern *}} {
::svmk::dputs 5 "[string repeat "--" $indentlevel]: <$pattern>"
incr indentlevel
foreach child $::svmk::children($pattern) {
::svmk::printchildren $indentlevel $child
}
}
proc ::svmk::target {targets code} { # define a new target, compiletime
foreach target $targets {
::svmk::addpattern $target
set ::svmk::code($target) $code
}
}
proc ::svmk::build {pattern target stack} { # run the code for a target, run time
::svmk::dputs 5 "Code is $::svmk::code($pattern)"
eval $::svmk::code($pattern)
return 0
}
proc ::svmk::depend {targets op} { # check dependencies for current target.
upvar target uptarget
foreach target $targets {
if {![info exists ::svmk::built($target)]} {
set ::svmk::built($target) 0
lappend ::svmk::stack $target
dputs 4 "Building <$target> ([::svmk::getpattern $target]), stack <$::svmk::stack>"
set ::svmk::built($target) [::svmk::build [::svmk::getpattern $target] $target $::svmk::stack]
set ::svmk::stack [lreplace $::svmk::stack end end]
::svmk::dputs 4 "After code for <$target>, update is $::svmk::built($target)"
} else {
dputs 4 "Not rebuilding <$target> because it has been built before, update is $::svmk::built($target)"
}
if {![info exists ::svmk::built($uptarget)]} {
set ::svmk::built($uptarget) $::svmk::built($target)
}
set ::svmk::built($uptarget) [expr $::svmk::built($target) || $::svmk::built($uptarget)]
if {!$::svmk::built($uptarget) && [file exists $uptarget] && [file exists $target]} {
if {[file mtime $uptarget] < [file mtime $target]} {
::svmk::dputs 2 "Dependency <$target> ([clock format [file mtime $target]]) was not rebuilt but is newer than target <$uptarget> ([clock format [file mtime $uptarget]]), rebuild
<$uptarget>"
set ::svmk::built($uptarget) 1
}
}
}
if {!$::svmk::built($uptarget) && ![file exists $uptarget]} {
::svmk::dputs 2 "Target <$uptarget> does not exist yet, rebuild"
set ::svmk::built($uptarget) 1
}
if {$::svmk::built($uptarget)} {
uplevel 1 $op
}
}
proc ::svmk::parse_opt {argv} { # Parse options from argv and return the rest of the arguments
set usage {
svmk [options] [VAR=value]* [target]*
Options:
-f <file> Read this file instead of default Smakefile
-d <level> Message Level (0 default, lower is quieter, higher is noisier)
--help Display this message
--version Display Version
VAR=value Presets global VAR before making any target
}
set ::svmk::makefile Smakefile; # default makefile name
set parsed_args [list]; # ends up with list of targets
set i 0
while {$i < [llength $argv]} {
set arg [lindex $argv $i]
if {[string equal $arg "-f"]} {
incr i
if {$i == [llength $argv]} {
error "-f requires filename as an argument\n$usage"
}
set ::svmk::makefile [lindex $argv $i]
} elseif {[string equal $arg "-d"]} {
incr i
if {$i == [llength $argv]} {
error "-d requires debug level as an argument\n$usage"
}
set ::svmk::dbglevel [lindex $argv $i]
} elseif {[string match "--help" $arg]} {
puts $usage
exit
} elseif {[string equal $arg "--version"]} {
regsub -all {\$([A-Za-z]+:)?} {$Revision: 1.4 $ $Date: 2004-10-05 06:00:30 $} {} version
puts "Version $version"
exit
} elseif {[regexp {^([^=]*)=(.*)$} $arg => name value]} {
set ::$name $value
} else {
lappend parsed_args $arg
}
incr i
}
if {![llength $parsed_args]} {
set parsed_args [list all]; # default target
}
return $parsed_args
}
proc ::svmk::log {str} { # procedure for logging
set fo [open [file rootname $::svmk::makefile].log a]
puts $fo "[clock format [clock seconds] -format "%Y/%m/%d.%H:%M:%S"]|$str"
close $fo
}
::svmk::target log {::svmk::log $::argv; exit}; # The Log Target - used to enter comments into the log
# Default Rule for no matches, target "*"
::svmk::target * {
set uptarget [lindex $stack end-1]
if {[file exists $target]} {
if {[file exists $uptarget]} {
set ttime [file mtime $target]
set utime [file mtime $uptarget]
if { $ttime < $utime} {
::svmk::dputs 3 "Dependency <$target> ([clock format $ttime]) < Target <$uptarget> ([clock format $utime]), No update"
return 0
} else {
::svmk::dputs 2 "Dependency <$target> ([clock format $ttime]) > Target <$uptarget> ([clock format $utime]), Update"
return 1
}
} else {
::svmk::dputs 2 "File <$uptarget> does not exist, force update"
return 1
}
} else {
error "do not know how to build <$target>"
}
}
proc svmk::svmk {argv} {
namespace eval :: {
namespace import ::svmk::*
interp alias {} setRule {} ::svmk::target
if [catch {
set targets [::svmk::parse_opt $argv]
source $::svmk::makefile
::svmk::printchildren
::svmk::log $::argv; # Comment this if you don't want logging
foreach target [list $targets] {
::svmk::depend $target {}
}
} msg] {
::svmk::dputs -1 $msg
::svmk::dputs 1 "$::errorCode\n$::errorInfo"
exit 1
}
}
}
svmk::svmk $::argv