#!/usr/local/bin/tclsh
set brasBase |SRCBASE|
set VERSION 0.3.1
set INSTALLED 1111-11-11

########################################################################
#
# This file is part of bras, a program similar to the (in)famous
# `make'-utitlity, written in Tcl.
#
# Copyright (C) 1996 Harald Kirsch, (kir@iitb.fhg.de)
#                    Fraunhofer Institut IITB
#                    Fraunhoferstr. 1
#                    76131 Karlsruhe
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
# $Revision: 1.22 $, $Date: 1998/07/13 14:46:17 $
########################################################################

########################################################################
##
## ---- global vars -----
##
## VERDATE
##   date of the version. This is not maintained by cvs, but is edited
##   into this file whenever I run my pack-script, so that it refers
##   to the whole package and not only to this particular file. Does
##   anybody know how this can be done with cvs?
##
## brasBase
##   Directory holding files sourced in by this script
##
## brasFile
##   Name of the rule file. Used also for rule-files in other dirs.
##
## brasRule
##     database of rules. With integer <i>, the indices are as follows
##   <i>,type -- rule type (i.e. Newer, Exist, ...)
##   <i>,targ -- targets
##   <i>,deps -- dependencies
##   <i>,cmd  -- command
##   <i>,preq -- prerequisites
##   <i>,run  --  1: command already on command list
##               -1: command cannot be run due to missing prerequisites
##                0: not yet checked
##
##   nextID   -- next unique index to use
set brasRule(nextID) 0
##
## brasTinfo
##      array holding information about targets. With <t> a target,
##      <d> its directory, the indices used are:
##   <t>,<d>,rule -- index into brasRule denoting the rule for <t>,<d>
##   <t>,<d>,done -- set, if target was already considered.
##                   0: no need to make target
##                   1: target will be made
##                  -1: target needs to be made, but don't know how
##
## brasPrule
##   database of pattern-rules. Pattern rules are stored and accessed in
##   the same order as they are introduced. Therefore each one gets a
##   number. The indices are used as follows (<i> denotes an integer):
##   nextID     -- next unique index
##   <i>,target -- target
##   <i>,dep    -- the dependency of given target
##   <i>,cmd    -- command for target/dependency pair
##   <i>,type   -- Newer, Exist, Always ...
##   <i>,cure   -- used by lastMinuteRule, set to 1 if CUrrently
##                 REcursively considered.
set brasPrule(nextID) 0
##
## brasLastError
##   If it exists, it contains the deep reason, why the main target
##   cannot be made.
##
## brasKnown
##   array with an element for all files sourced either by following
##   an @-target or by an explicit `include'. The directory-part of
##   the filename is always normalized by means of [pwd].
##
## brasTargets
##   Either the default target, i.e. the first one found, or the list
##   of targets from the command line
##
## brasOpts
##   array holding command-line options
##
## brasLastInclude
##   just before a file is included with the `include'-command, this
##   variable is set to the name of the file. This allows the script
##   to know its own name (on request from jgg@debian.org).
##   (No longer supported as of 1998-07-12. He should use [info script])
##
## brasConsidering
##   array with an element for every target currently (recursively)
##   under consideration; used to detect dependency loops.
##
## brasCmdlist
##   list of commands to execute. Built up by bras.Consider. Howver,
##   only the topmost bras.Consider called finally sets the global
##   variable. All recursively called incarnations set the local
##   variable of their caller.
##
## brasIndent
##   string containing blanks, used for `-d'-reporting.
##
## brasPreqSeparator
##   the string that separates real dependencies from prerequisites in
##   dependency lists of rules
set brasPreqSeparator //
##
##
########################################################################

set argv0 [file tail $argv0]

## This if never succeeds after installation. I need it however run
## bras from my development directory.
if { "$brasBase"=="|SRCBASE|" } {
  set brasBase /home1/kir/work/bras
}
source $brasBase/evalCmds.tcl
source $brasBase/sourceDeps.tcl
source $brasBase/lastMinuteRule.tcl
source $brasBase/defaultCmd.tcl
source $brasBase/consider.tcl
source $brasBase/brasUtils.tcl

## source rule types
source $brasBase/defrule.tcl
source $brasBase/alwaysRule.tcl
source $brasBase/existRule.tcl
source $brasBase/newerRule.tcl
#source $brasBase/uptodateOCRule.tcl
source $brasBase/dependsFileRule.tcl

########################################################################
#
# tcl (as of 8.0b1 and previous) does execute a `cd .' thereby
# spoiling its cache for pwd. Since bras happens to execute quite some
# `cd .', calling pwd afterwards, I trick it myself.
#
rename cd _cd
proc cd {dir} {
  if {"$dir"=="."} return
  _cd $dir
}
########################################################################
##
## bras.gobble
##   a wrapper around `source $file' to handle errors gracefully
##
proc bras.gobble {file} {
  global errorInfo

  if [catch "uplevel #0 source $file" msg] {
    ## strip the last 5 lines off the error stack
    set ei [split $errorInfo \n]
    set l [llength $ei]
    set lastLine [lindex $ei [expr $l-6]]
    regsub {\".*\"} $lastLine "\"[pwd]/$file\"" lastLine
    puts stderr [join [lrange $ei 0 [expr $l-7]] \n]
    puts stderr $lastLine
    exit 1
  }
}
########################################################################
##
## include
##   an alias for `source', however we take care to not source any
##   file more than once.
##  
##   If the `name' starts with an `@' it must be a directory. In that
##   case, the $brasFile of that directory is sourced in the same way
##   as if an `@'-target had let to that directory.
##
##   If the `name' does not start with `@', it must be the name of an
##   existing readable file. This one is simpy sourced in.
##
proc include {name} {
  global brasKnown
  
  if [string match @* $name] {
    cd [bras.followTarget $name/.]
    return
  }

  ## To be compatible with followTarget, we first have to move to the
  ## destination directory to get the correct answer from [pwd]. _NO_,
  ## just stripping the directory part from $name is useless, because
  ## it may contain relative parts and parts leading through one or
  ## more soft-links.
  set dir [file dir $name]
  set file [file tail $name]

  set oldpwd [pwd]
  if [catch "cd $dir" msg] {
    set err "bras: include of `$name' tried in directory `$oldpwd'"
    append err " leads to non-existing directory `$dir'"
    puts stderr $err
    exit 1
  }
  set pwd [pwd]
  cd $oldpwd

  if [info exist brasKnown($pwd/$file)] return

  bras.gobble $name
}
########################################################################
##
## bras.followTarget
##  
## Handle all what is necessary to follow an @-target to its
## home. In particular:
## - change directory
## - read brasfile
## And do all this with the necessary error handling.  
##
## RETURN
##   The current directory (before cd) is returned.
##
proc bras.followTarget {target} {
  global brasFile brasKnown
  #puts "followTarget $target"

  set oldpwd [pwd]
  set dir [file dir [string range $target 1 end]]

  ## carefully change directory
  if [catch "cd $dir" msg] {
    set err "bras: dependency `$target' in `$oldpwd/${brasFile}'"
    append err " leads to non-existing directory `$dir'"
    puts stderr $err
    exit 1
  }

  ## check, if we know already the brasfile here
  if [info exist brasKnown([pwd]/$brasFile)] {
    return $oldpwd
  }

  ## before really reading the file, mark the current dir as known,
  ## because the file to be read may lead back here again.
  set brasKnown([pwd]/$brasFile) 1

  ## If the brasfile does not exist, print a warning. There is no need
  ## to terminate immediately, because things might be handled by
  ## default rules.
  if ![file exists ${brasFile}] {
    puts stderr \
    "bras warning: no `${brasFile}' found in `[pwd]', so hold your breath"
  } else {
    bras.gobble ${brasFile}
  }
  return $oldpwd
}
########################################################################
##
## bras.MatchDepDefault
##   Default function used to match a dependency list when looking for
##   a default command. Used implicitely by bras.defaultCommand
##
proc bras.MatchDepDefault {suffix deps} {
  set res {}
  foreach x $deps {
    if [string match *$suffix $x] {
      lappend res $x
    }
  }
  return $res
}
########################################################################
##
## bras.PatternRule
##   Declare a pattern-rule.
##
proc bras.PatternRule {type target dep cmd} {
  global brasPrule argv0

  ## Emtpy commands are rather useless here
  if { ![llength $cmd] } {
    return -code error \
	-error "empty commands are not allowed in pattern rules"
  }

  ## enter the rule
  set id $brasPrule(nextID)
  incr brasPrule(nextID)
  set brasPrule($id,target) $target
  set brasPrule($id,dep)    $dep
  set brasPrule($id,cmd)    $cmd
  set brasPrule($id,type)   $type
  set brasPrule($id,cure)   0

  ## create pattern replacement commands for the dependency
  if { 0==[llength [info commands GenDep$dep]] } {
    proc GenDep$dep {target} "return \[file root \$target\]$dep"
  }

  ## create the depenceny matching command
  if { 0==[llength [info commands MatchDep$dep]] } {
    proc MatchDep$dep {target realDeps} "
      return \[bras.MatchDepDefault $dep \$realDeps\]
    "
  }
}
########################################################################
##
## bras.enterRule
##    declare a rule
##
proc bras.enterRule {type targets deps cmd} {
  global brasRule brasTinfo brasFile brasTargets argv0
  global brasPreqSeparator brasOpts

  #parray brasCmd
  ## newline characters and semicolons are poisonous for `eval' so
  ## they have no business being in `deps'. Then separate dependencies
  ## into real dependencies and prerequisites
  regsub -all ";" $deps {\\;} d
  set deps {}
  foreach x $d {
    if {"$x"=="$brasPreqSeparator"} {
      set preq {}
      continue
    }
    if {[info exist preq]} {
      lappend preq $x
    } else {
      lappend deps $x
    }
  }

  ## If preq is not set, make it equal to deps
  if {![info exist preq]} {
    set preq $deps
  }

  ## if this is the very first explicit rule seen, and if no target was
  ## specified on the command line, this is the default target-list.
  if { ![info exist brasTargets] } {
    set brasTargets [lindex $targets 0]
  }

  ## Some targets may already have a rule. If so, those must all have
  ## the same rule.
  set rid {}
  foreach t $targets {
    if [info exist brasTinfo($t,[pwd],rule)] {
      lappendUnique rid $brasTinfo($t,[pwd],rule)
      lappend tmp $t
    }
  }
  if {[llength $rid]>1} {
    append msg "The targets `$tmp' all have already a rule, and "\
	"these rules are not the same."
    return -code error -errorinfo $msg
  }

  ## If rid is not set now, initialize a rule 
  if {[llength $rid]==0} {
    set rid $brasRule(nextID)
    incr brasRule(nextID)
    foreach t $targets {
      set brasTinfo($t,[pwd],rule) $rid
    }
    set brasRule($rid,type) $type
    set brasRule($rid,targ) {}
    set brasRule($rid,deps) {}
    set brasRule($rid,preq) {}
    set brasRule($rid,cmd) {}
  } else {
    ## The type of the old rule must match the new type
    if {"$type"!="$brasRule($rid,type)"} {
      append msg "Ruletype `$type' for targets `$targets' "\
	  "does not match type `$brasRule($rid,type)' "\
	  "of a rule entered previously for this target."
      return -code error -errorinfo $msg
    }
  }
  

  ## Add the new information into brasRule($rid,...)
  concatUnique brasRule($rid,targ) $t
  concatUnique brasRule($rid,deps) $deps
  concatUnique brasRule($rid,preq) $preq
  if {"$cmd"!=""} {
    append brasRule($rid,cmd) "\n$cmd"
  }
  set brasRule($rid,run) 0



  ## Source rule-files for dependencies and prerequisites if
  ## necessary. This is necessary only for dependencies starting with
  ## `@'. Since 1997-07-19, the code below is only executed if
  ## specifically requested with option -es (early sourcing).
  if {!$brasOpts(-es)} return

  foreach x "$deps $preq" {
    if ![string match @* $x] continue
    set backHere [bras.followTarget $x]
    cd $backHere
  }
}
########################################################################
##
## bras.ClearList -- clear one of the lists associated with a target
##
proc bras.ClearList {target listName} {
  global brasTinfo brasRule

  if [info exist brasTinfo($target,[pwd],rule)] {
    set rid $brasTinfo($target,[pwd],rule)
    set brasRule($rid,$listName) {}
  }
}
########################################################################
##
## ClearDeps -- remove all elements from the dependency list of the
## given target.
##
## If this target shares a rule with other targets, those targets'
## dependency list is also wiped out.
##
proc ClearDeps {target} {
  bras.ClearList $target deps
}
########################################################################
##
## ClearCmd -- clear the command(-list) of the given target
##
## If this target shares a rule with other targets, those targets'
## list is also wiped out.
##
proc ClearCmd {target} {
  bras.ClearList $target cmd
}
########################################################################
##
## ClearPreqs -- clear the list of prerequisites of the given target
##
## If this target shares a rule with other targets, those targets'
## list is also wiped out.
##
proc ClearPreqs {target} {
  bras.ClearList $target preq
}
########################################################################
##
## bras.GetList -- return one of the lists associated with a target's
## rule. 
##
proc bras.GetList {target listName} {
  global brasTinfo brasRule

  if [info exist brasTinfo($target,[pwd],rule)] {
    set rid $brasTinfo($target,[pwd],rule)
    return $brasRule($rid,$listName)
  } else {
    return {}
  }
}
########################################################################
##
## GetDeps, GetPreqs, GetCmd -- get respective list of a target
##
proc GetDeps {target} {
  return [bras.GetList $target deps]
}
proc GetPreqs {target} {
  return [bras.GetList $target preq]
}
proc GetCmd {target} {
  return [bras.GetList $target cmd]
}
########################################################################
##
## debugging only!
##
proc bras.showCmds {cmds} {
  foreach x $cmds {
    puts "$x"
  }
}
########################################################################
proc usage {} {
  global argv0 VERSION INSTALLED
  puts stderr \
      "usage: $argv0 \[-f brasfile\] \[-d\] \[-e\] \[-es\] \[-h\] \[-n\]\
\[-N\] \[-r\] \[-s\] \[-ss\] \[-v\] \[var=value]\
\[--\] \[target ...\]
construct files based on a rule-file
  brasfile - rule-file to use (defaults: Brasfile or brasfile)
        -d - execute nothing, show reasoning
        -e - variables from the environment have precedence over
             variables in brasfiles
       -es - early sourcing: read brasfiles of foreign directories as soon
             as a @-dependency is encountered.
        -N - don't execute external commands (precludes -s, -ss)
        -n - don't execute any commands (implies -v)
        -r - don't read system standard rule file
        -s - don't show external commands as they are executed
       -ss - don't show anything except error messages
        -v - show all commands
        -- - use the rest of the command-line as target list
             (necessary, if a target starts with `-')
 var=value - just before starting to evaluate rules, global variable
             var ist set to value
    target - target to be rebuilt (default: the target of the first
             rule in brasfile)

This is version $VERSION installed on $INSTALLED.
"
  exit 1
}
########################################################################
proc bras.mapEnvironment {} {
  global env
  foreach name [array names env] {
    global $name
    set $name $env($name)
  }
}
########################################################################
proc bras.main {argc args} {
  global argv0 brasFile brasTargets brasPrule brasOpts
  global brasKnown brasBase brasLastError
  global brasIndent brasCmdlist
  
  set brasOpts(-d) 0
  set brasOpts(-e) 0
  set brasOpts(-es) 0
  set brasOpts(-n) 0
  set brasOpts(-N) 0
  set brasOpts(-r) 0
  set brasOpts(-s) 0
  set brasOpts(-ss) 0
  set brasOpts(-v) 0
  set brasOpts(=) {}
  for {set i 0} {$i<$argc } {} {
    set opt [lindex $args $i]
    incr i
    switch -glob -- $opt {
      -d {set brasOpts(-d) 1}
      -e {set brasOpts(-e) 1}
      -es {set brasOpts(-es) 1}
      -f {
	if {$i>=$argc } {
	  puts stderr "$argv0: missing file name after option `$opt'"
	  exit 1
	}
	set brasFile [lindex $args $i]
	incr i
      }
      -n {set brasOpts(-n) 1}
      -N {set brasOpts(-N) 1}
      -s {set brasOpts(-s) 1}
      -ss {set brasOpts(-ss) 1}
      -r {set brasOpts(-r) 1}
      -v {set brasOpts(-v) 1}
      -- {
	for {} {$i<$argc} {incr i} {
	  lappend brasTargets [lindex $args $i]
	}
      }
      -* usage
      default {
	if [string match *=* $opt] {
	  lappend brasOpts(=) $opt
	} else {
	  lappend brasTargets $opt
	}
      }
    }
  }

  if $brasOpts(-N) {
    set brasOpts(-s) 0
    set brasOpts(-ss) 0
  }
  if $brasOpts(-n) {
    set brasOpts(-v) 1
  }
  if { ![info exists brasFile] } {
    if { [file exists brasfile] } {
      set brasFile brasfile
    } elseif { [file exists Brasfile] } {
      set brasFile Brasfile
    } else {
      puts stderr "$argv0: no brasfile found"
      exit 1
    }
  }

  ## If not suppressed with -r, read default rule files
  if { !$brasOpts(-r) } {
    set sys $brasBase/rules.[exec uname -s]
    if ![file readable $sys] {
      puts stderr \
	  "bras: no system specific rules file, leaves me stupid!"
    } else {
      bras.gobble $sys
    }
  }

  ## If not postponed with -e, map environment now
  if { !$brasOpts(-e) } {
    bras.mapEnvironment
  }

  ## Read the rule file and whatever it includes
  if { [info exist brasFile] } {
    set brasKnown([pwd]/$brasFile) 1
    bras.gobble $brasFile
  }

  ## Check if there is a target to consider
  if ![info exist brasTargets] {
    puts -nonewline stderr "$argv0: no target given"
    if [info exist brasFile] {
      puts stderr ""
    } else {
      puts stderr " and no brasfile found"
    }
    exit 1
  }

  ## If so requested, map environment now
  if { $brasOpts(-e) } {
    bras.mapEnvironment
  }

  ## Set global variables from the command line
  foreach equ $brasOpts(=) {
    set var {}
    set value {}
    regexp {(.*)=(.*)} $equ dummy var value
    if {$brasOpts(-v)} {puts "setting `$var' to `$value'"}
    global $var
    set $var $value
  }

  #parray brasRules
  #parray brasPrule
  foreach target $brasTargets {
    set brasIndent ""
    set brasCmdlist {}
    set r [bras.Consider $target]
    #bras.showCmds $brasCmdlist
    if $brasOpts(-d) continue
    #global brasRule;parray brasRule
    if {$r==-1} {
      puts "bras: cannot make $target because$brasLastError"
      puts "      try to use -d to find out more"
      exit 1
    }
    if {![llength $brasCmdlist]} {
      puts "$argv0: nothing to be done for `$target'"
    } else {
      bras.evalCmds $brasCmdlist
    }
  } 

  if { $brasOpts(-s) && !$brasOpts(-ss) } {
    puts stdout ""
  }
}
########################################################################

if { [catch "bras.main $argc $argv" result] } {
  puts $errorInfo
}
########################################################################

##### Local Variables: #
##### mode:tcl #
##### End: #
