chiark - git - mdw - misc/blob - splitconf

   1 #! /usr/bin/tclsh
   2
   3 #----- Miscellaneous utilities ----------------------------------------------
   4
   5 # die MSG
   6 #
   7 # Something didn't work.  Exit right now.
   8
   9 proc die {msg} {
  10   global argv0
  11   puts stderr "$argv0: $msg"
  12   exit 1
  13 }
  14
  15 # usage FILE
  16 #
  17 # Write a usage message to FILE, which is a file handle.
  18
  19 proc usage {file} {
  20   global argv0
  21   puts $file "Usage: \n\
  22         $argv0 [-s] FILE\n
  23         $argv0 -u OUTPUT FILE FILE ..."
  24 }
  25
  26 # clear-arrays ARRAY ...
  27 #
  28 # Make each named ARRAY exist and be empty.
  29
  30 proc clear-arrays {args} {
  31   foreach i $args {
  32     upvar 1 $i v
  33     unset i
  34     array set v {}
  35   }
  36 }
  37
  38 #------ Write-safe ----------------------------------------------------------
  39
  40 # write-safe STUFF [TIDY]
  41 #
  42 # Do some safe I/O.  If STUFF succeeds, do TIDY and commit the modifications;
  43 # otherwise, do TIDY and back out all the changes.  See also write-safe-open,
  44 # write-safe-file and write-safe-delete.
  45
  46 proc write-safe {stuff {tidy {}}} {
  47   global _ws_close _ws_del _ws_new
  48   clear-arrays _ws_del _ws_new
  49   set _ws_close {}
  50
  51   if {[set rc [catch {
  52     uplevel 1 $stuff
  53   } err]]} {
  54     foreach f $_ws_close { catch { close $f } }
  55     foreach f [array names _ws_new] { catch { file delete -- $f.new } }
  56     catch { uplevel 1 $tidy }
  57     return -code $rc $err
  58   }
  59   foreach f $_ws_close { catch { close $f } }
  60   clear-arrays all
  61   foreach f [concat [array names _ws_old] [array names _ws_del]] {
  62     set all($f) 0
  63   }
  64   if {[set rc [catch {
  65     foreach f [array names all] {
  66       if {[file exists $f]} {
  67         file delete -- $f.old
  68         file copy -force -- $f $f.old
  69       }
  70       set old($f) 0
  71     }
  72     foreach f [array names _ws_new] { file rename -force -- $f.new $f }
  73     foreach f [array names _ws_del] { file delete -- $f }
  74   } err]]} {
  75     foreach f [array names _ws_new] { catch { file delete -- $f.new } }
  76     foreach f [array names old] { file rename -force -- $f.old $f }
  77     catch { uplevel 1 $tidy }
  78     return -code $rc $err
  79   }
  80   foreach i [array names all] { catch { file delete -- $i.old } }
  81   catch { uplevel 1 $tidy }
  82   return {}
  83 }
  84
  85 # write-safe-open NAME [TRANS]
  86 #
  87 # Open file NAME for writing, with the translation mode TRANS (default is
  88 # `auto'); return the file handle.  The file NAME is not destroyed until the
  89 # changes are committed by an enclosing write-safe completing.  You can close
  90 # the file handle if you like; write-safe will close it automatically anyway.
  91
  92 proc write-safe-open {name {trans auto}} {
  93   global _ws_close _ws_new
  94   if {[file isdirectory $name]} { error "`$name' is a directory" }
  95   set f [open $name.new w]
  96   fconfigure $f -translation $trans
  97   lappend _ws_close $f
  98   set _ws_new($name) 0
  99   return $f
 100 }
 101
 102 # write-safe-delete NAME
 103 #
 104 # Delete file NAME.  The file isn't actually removed until the enclosing
 105 # write-safe completes.
 106
 107 proc write-safe-delete {name} {
 108   global _ws_del
 109   set _ws_del($name) 0
 110 }
 111
 112 # write-safe-file NAME CONTENTS [TRANS]
 113 #
 114 # Write CONTENTS to FILE, using translation mode TRANS (default `auto').  The
 115 # file isn't actually replaced until the changes are committed by an
 116 # enclosing write-safe completing.
 117
 118 proc write-safe-file {name contents {trans auto}} {
 119   set f [write-safe-open $name $trans]
 120   puts -nonewline $f $contents
 121   close $f
 122 }
 123
 124 # read-file NAME [TRANS]
 125 #
 126 # Evaluates to the contents of the file NAME under translation mode TRANS
 127 # (default `auto').
 128
 129 proc read-file {name {trans auto}} {
 130   set f [open $name]
 131   fconfigure $f -translation $trans
 132   set c [read $f]
 133   close $f
 134   return $c
 135 }
 136
 137 #----- Splitconf-specific stuff ---------------------------------------------
 138
 139 # write-safe-manifest F L
 140 #
 141 # Writes the list of filenames L to the manifest file associated with config
 142 # file F.
 143
 144 proc write-safe-manifest {f l} {
 145   set f [write-safe-open $f.files]
 146   foreach i $l { puts $f $i }
 147   close $f
 148 }
 149
 150 # old-files CONF
 151 #
 152 # Returns the filenames in the current manifest of the config file CONF.
 153
 154 proc old-files {conf} {
 155   set old {}
 156   if {[file exists $conf.files]} {
 157     set f [open $conf.files]
 158     while {[gets $f line] >= 0} { lappend old $line }
 159     close $f
 160   }
 161   return $old
 162 }
 163
 164 #----- Main code ------------------------------------------------------------
 165
 166 set job "split"
 167 while {[llength $argv]} {
 168   switch -glob -- [lindex $argv 0] {
 169     "-u" - "--unsplit" {
 170       set job "unsplit"
 171       if {[llength $argv] < 2} { die "option `-u' needs an argument" }
 172       set output [lindex $argv 1]
 173       set argv [lrange $argv 1 end]
 174     }
 175     "-d" - "--delete" { set job "delete" }
 176     "-s" - "--split" { set job "split" }
 177     "-h" - "--help" { usage stdout; exit 0 }
 178     "-" { break }
 179     "--" { set argv [lrange $argv 1 end]; break }
 180     "-*" { die "unknown option `[lindex $argv 0]'"; exit 1 }
 181     default { break }
 182   }
 183   set argv [lrange $argv 1 end]
 184 }
 185
 186 set rc 0
 187 clear-arrays opt
 188 array set opt {
 189   prefix ""
 190   before ""
 191   after ""
 192 }
 193 switch $job {
 194   "unsplit" {
 195     set f "\#\# automatically generated by splitconf\n\n"
 196     set ff {}
 197     foreach i $argv {
 198       if {[catch {
 199         set c [read-file $i]
 200         append f "\[$i\]\n$c\n"
 201         lappend ff $i
 202       } msg]} {
 203         set rc 1
 204       }
 205     }
 206     write-safe {
 207       write-safe-file $output $f
 208       write-safe-manifest $output $ff
 209     }
 210   }
 211   "delete" {
 212     if {[llength $argv] != 1} { die "need exactly one filename" }
 213     set conf [lindex $argv 0]
 214     set old [old-files $conf]
 215     write-safe {
 216       foreach i $old { write-safe-delete $i }
 217       write-safe-delete $conf.files
 218     }
 219   }
 220   "split" {
 221     if {[llength $argv] != 1} { die "need exactly one filename" }
 222     set conf [lindex $argv 0]
 223     set old [old-files $conf]
 224     set c [open $conf r]
 225     catch { unset o }
 226     set spill ""
 227     set donebefore 0
 228     array set new {}
 229     write-safe {
 230       while {[gets $c line] >= 0} {
 231         if {[regexp -- {^\[(.*)\]\s*$} $line . name]} {
 232           if {[info exists o]} {
 233             close $o
 234           } elseif {!$donebefore} {
 235             exec "sh" "-c" $opt(before) <@ stdin >@ stdout 2>@ stderr
 236             set donebefore 1
 237           }
 238           if {[string equal $name ""]} {
 239             catch { unset o }
 240           } else {
 241             set name "$opt(prefix)$name"
 242             set o [write-safe-open $name]
 243             set new($name) 1
 244             set spill ""
 245           }
 246         } elseif {[info exists o]} {
 247           switch -regexp -- $line {
 248             {^\s*$} { append spill "$line\n" }
 249             {^\#\#} { }
 250             {^\!} {
 251               puts -nonewline $o "$spill[string range $line 1 end]\n"
 252               set spill ""
 253             }
 254             default { puts -nonewline $o "$spill$line\n"; set spill "" }
 255           }
 256         } elseif {[regexp -- {^\s*(\#|$)} $line]} {
 257           continue
 258         } elseif {[regexp -- \
 259                        {^\s*([-./\w]+)\s*=\s*(.*\S|)\s*$} $line . k v]} {
 260           if {![info exists opt($k)]} {
 261             error "unknown configuration option `$k'"
 262           } else {
 263             set opt($k) $v
 264           }
 265         } elseif {[regexp -- \
 266                        {^\s*([-./\w]+)\s*:\s*(.*\S|)\s*$} $line . name d]} {
 267           if {!$donebefore} {
 268             exec "sh" "-c" $opt(before) <@ stdin >@ stdout 2>@ stderr
 269             set donebefore 1
 270           }
 271           set name "$opt(prefix)$name"
 272           set new($name) 1
 273           write-safe-file $name "$d\n"
 274         } else {
 275           error "unknown preamble directive"
 276         }
 277       }
 278       if {[info exists o]} {
 279         close $o
 280       }
 281       close $c
 282       foreach i $old {
 283         if {![info exists new($i)]} { write-safe-delete $i }
 284       }
 285       write-safe-manifest $conf [array names new]
 286     } {
 287       exec "sh" "-c" $opt(after) <@ stdin >@ stdout 2>@ stderr
 288     }
 289   }
 290 }
 291
 292 #----- That's all, folks ----------------------------------------------------