#!/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