svmk

2004-10-04 VI Short for Setok's and Venkat's make. A tcl based replacement for the traditional make. The concepts are the same as the great smake. Here's whats different. Also see smake musings

There is no setRule command. target accepts patterns as well as names and they're treated the same, resulting in shorter more elegant code.
There is no upTarget command. The whole stack of targets built is available in the local variable stack.
Exec is now called system and has options to be quiet and to ignore errors (a la make)
Target changed is more inline with the traditional make. There are four cases when a target is considered changed. (a) when the code does a return 1 (b) when any dependency is built. (c) when a dependency is not built, but is a file with an older timestamp than the target and (d) when the target does not exist as a file at the end of the code.
Targets built once are not built again in the same session (like make)
target allows multiple targets (for convenience), just like each of them had been specified separately with the same body.

And to a lesser extent:

(commentable) auto logging of commands run
accept multiple targets on command line
allow definition of global variables on the command line
single file (< 300 lines) with no external dependencies (other than tcl). Perfect for the wiki.
new commands dputs (for debug) and log (for logging) and tcl (print command before running).
no compile and link commands (not really core).

I have used it extensively. Hope it works for someone else too!

 #!/usr/local/tcl/8.4.5/bin/tclsh8.4
 ## Setok's and Venkat's Make. Provides similar functionality as 'make' but with TCL
 ## Authors: Kristoffer Lawson, [email protected], Venks I [email protected]
 
 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)"
         }
         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 $targets {
                 ::svmk::depend $target {}
             }
         } msg] {
             ::svmk::dputs -1 $msg
             ::svmk::dputs  1 "$::errorCode\n$::errorInfo"
             exit 1
         }
     }
 }
 
 svmk::svmk $::argv

Category Application

Category Dev. Tools