chiark - git - mdw - misc/blob - splitconf.in

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