Missed a paren. Un-`toys'-ify.

[misc] / splitconf

#! /usr/bin/tclsh

#----- Miscellaneous utilities ----------------------------------------------

# die MSG
#
# Something didn't work.  Exit right now.

proc die {msg} {
  global argv0
  puts stderr "$argv0: $msg"
  exit 1
}

# usage FILE
#
# Write a usage message to FILE, which is a file handle.

proc usage {file} {
  global argv0
  puts $file "Usage: \n\
	$argv0 [-s] FILE\n
	$argv0 -u OUTPUT FILE FILE ..."
}

# clear-arrays ARRAY ...
#
# Make each named ARRAY exist and be empty.

proc clear-arrays {args} {
  foreach i $args {
    upvar 1 $i v
    unset i
    array set v {}
  }
}

#------ Write-safe ----------------------------------------------------------

# write-safe STUFF [TIDY]
#
# Do some safe I/O.  If STUFF succeeds, do TIDY and commit the modifications;
# otherwise, do TIDY and back out all the changes.  See also write-safe-open,
# write-safe-file and write-safe-delete.

proc write-safe {stuff {tidy {}}} {
  global _ws_close _ws_del _ws_new
  clear-arrays _ws_del _ws_new
  set _ws_close {}

  if {[set rc [catch {
    uplevel 1 $stuff
  } err]]} {
    foreach f $_ws_close { catch { close $f } }
    foreach f [array names _ws_new] { catch { file delete -- $f.new } }
    catch { uplevel 1 $tidy }
    return -code $rc $err
  }
  foreach f $_ws_close { catch { close $f } }
  clear-arrays all
  foreach f [concat [array names _ws_old] [array names _ws_del]] {
    set all($f) 0
  }
  if {[set rc [catch {
    foreach f [array names all] {
      if {[file exists $f]} {
	file delete -- $f.old
	file copy -force -- $f $f.old
      }
      set old($f) 0
    }
    foreach f [array names _ws_new] { file rename -force -- $f.new $f }
    foreach f [array names _ws_del] { file delete -- $f }
  } err]]} {
    foreach f [array names _ws_new] { catch { file delete -- $f.new } }
    foreach f [array names old] { file rename -force -- $f.old $f }
    catch { uplevel 1 $tidy }
    return -code $rc $err
  }
  foreach i [array names all] { catch { file delete -- $i.old } }
  catch { uplevel 1 $tidy }
  return {}
}

# write-safe-open NAME [TRANS]
#
# Open file NAME for writing, with the translation mode TRANS (default is
# `auto'); return the file handle.  The file NAME is not destroyed until the
# changes are committed by an enclosing write-safe completing.  You can close
# the file handle if you like; write-safe will close it automatically anyway.

proc write-safe-open {name {trans auto}} {
  global _ws_close _ws_new
  if {[file isdirectory $name]} { error "`$name' is a directory" }
  set f [open $name.new w]
  fconfigure $f -translation $trans
  lappend _ws_close $f
  set _ws_new($name) 0
  return $f
}

# write-safe-delete NAME
#
# Delete file NAME.  The file isn't actually removed until the enclosing
# write-safe completes.

proc write-safe-delete {name} {
  global _ws_del
  set _ws_del($name) 0
}

# write-safe-file NAME CONTENTS [TRANS]
#
# Write CONTENTS to FILE, using translation mode TRANS (default `auto').  The
# file isn't actually replaced until the changes are committed by an
# enclosing write-safe completing.

proc write-safe-file {name contents {trans auto}} {
  set f [write-safe-open $name $trans]
  puts -nonewline $f $contents
  close $f
}

# read-file NAME [TRANS]
#
# Evaluates to the contents of the file NAME under translation mode TRANS
# (default `auto').

proc read-file {name {trans auto}} {
  set f [open $name]
  fconfigure $f -translation $trans
  set c [read $f]
  close $f
  return $c
}

#----- Splitconf-specific stuff ---------------------------------------------

# write-safe-manifest F L
#
# Writes the list of filenames L to the manifest file associated with config
# file F.

proc write-safe-manifest {f l} {
  set f [write-safe-open $f.files]
  foreach i $l { puts $f $i }
  close $f
}

# old-files CONF
#
# Returns the filenames in the current manifest of the config file CONF.

proc old-files {conf} {
  set old {}
  if {[file exists $conf.files]} {
    set f [open $conf.files]
    while {[gets $f line] >= 0} { lappend old $line }
    close $f
  }
  return $old
}

#----- Main code ------------------------------------------------------------

set job "split"
while {[llength $argv]} {
  switch -glob -- [lindex $argv 0] {
    "-u" - "--unsplit" {
      set job "unsplit"
      if {[llength $argv] < 2} { die "option `-u' needs an argument" }
      set output [lindex $argv 1]
      set argv [lrange $argv 1 end]
    }
    "-d" - "--delete" { set job "delete" }
    "-s" - "--split" { set job "split" }
    "-h" - "--help" { usage stdout; exit 0 }
    "-" { break }
    "--" { set argv [lrange $argv 1 end]; break }
    "-*" { die "unknown option `[lindex $argv 0]'"; exit 1 }
    default { break }
  }
  set argv [lrange $argv 1 end]
}

set rc 0
clear-arrays opt
array set opt {
  prefix ""
  before ""
  after ""
}
switch $job {
  "unsplit" {
    set f "\#\# automatically generated by splitconf\n\n"
    set ff {}
    foreach i $argv {
      if {[catch {
	set c [read-file $i]
	append f "\[$i\]\n$c\n"
	lappend ff $i
      } msg]} {
	set rc 1
      }
    }
    write-safe {
      write-safe-file $output $f
      write-safe-manifest $output $ff
    }
  }
  "delete" {
    if {[llength $argv] != 1} { die "need exactly one filename" }
    set conf [lindex $argv 0]
    set old [old-files $conf]
    write-safe {
      foreach i $old { write-safe-delete $i }
      write-safe-delete $conf.files
    }
  }
  "split" {
    if {[llength $argv] != 1} { die "need exactly one filename" }
    set conf [lindex $argv 0]
    set old [old-files $conf]
    set c [open $conf r]
    catch { unset o }
    set spill ""
    set donebefore 0
    array set new {}
    write-safe {
      while {[gets $c line] >= 0} {
	if {[regexp -- {^\[(.*)\]\s*$} $line . name]} {
	  if {[info exists o]} {
	    close $o
	  } elseif {!$donebefore} {
	    exec "sh" "-c" $opt(before) <@ stdin >@ stdout 2>@ stderr
	    set donebefore 1
	  }
	  if {[string equal $name ""]} {
	    catch { unset o }
	  } else {
	    set name "$opt(prefix)$name"
	    set o [write-safe-open $name]
	    set new($name) 1
	    set spill ""
	  }
	} elseif {[info exists o]} {
	  switch -regexp -- $line {
	    {^\s*$} { append spill "$line\n" }
	    {^\#\#} { }
	    {^\!} {
	      puts -nonewline $o "$spill[string range $line 1 end]\n"
	      set spill ""
	    }
	    default { puts -nonewline $o "$spill$line\n"; set spill "" }
	  }
	} elseif {[regexp -- {^\s*(\#|$)} $line]} {
	  continue
	} elseif {[regexp -- \
		       {^\s*([-./\w]+)\s*=\s*(.*\S|)\s*$} $line . k v]} {
	  if {![info exists opt($k)]} {
	    error "unknown configuration option `$k'"
	  } else {
	    set opt($k) $v
	  }
	} elseif {[regexp -- \
		       {^\s*([-./\w]+)\s*:\s*(.*\S|)\s*$} $line . name d]} {
	  if {!$donebefore} {
	    exec "sh" "-c" $opt(before) <@ stdin >@ stdout 2>@ stderr
	    set donebefore 1
	  }
	  set name "$opt(prefix)$name"
	  set new($name) 1
	  write-safe-file $name "$d\n"
	} else {
	  error "unknown preamble directive"
	}
      }
      if {[info exists o]} {
	close $o
      }
      close $c
      foreach i $old {
	if {![info exists new($i)]} { write-safe-delete $i }
      }
      write-safe-manifest $conf [array names new]
    } {
      exec "sh" "-c" $opt(after) <@ stdin >@ stdout 2>@ stderr
    }
  }
}

#----- That's all, folks ----------------------------------------------------