Posted to tcl by dbohdan at Wed Nov 04 12:25:27 GMT 2020view raw

  1. #! /usr/bin/env tclsh
  2. #
  3. # A configuration deployment script.
  4. # Requires: Tcl 8.6 or later, rsync(1).
  5. #
  6. # Copyright (c) 2020 D. Bohdan.
  7. #
  8. # Permission to use, copy, modify, and distribute this software for any
  9. # purpose with or without fee is hereby granted, provided that the above
  10. # copyright notice and this permission notice appear in all copies.
  11. #
  12. # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  13. # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  14. # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  15. # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  16. # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  17. # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  18. # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  19.  
  20. proc main home {
  21. cd [file dirname [info script]]
  22.  
  23. set vars [dict create \
  24. hostname [exec hostname] \
  25. ]
  26.  
  27. foreach src {
  28. config/awesome/
  29. config/gxkb/
  30. config/icewm/
  31. config/mc/
  32. config/tclsh/
  33. config/udiskie/
  34. } {
  35. sync $src {} --delete
  36. }
  37.  
  38. foreach src {
  39. config/fish/
  40. config/mpv/
  41. gitconfig
  42. gitignore
  43. jimrc
  44. tclshrc
  45. tmux.conf
  46. xinitrc
  47. xscreensaver.template
  48. } {
  49. sync $src
  50. }
  51. }
  52.  
  53.  
  54. proc with-path {path script} {
  55. set prev [pwd]
  56.  
  57. try {
  58. cd $path
  59. uplevel 1 $script
  60. } finally {
  61. cd $prev
  62. }
  63. }
  64.  
  65.  
  66. proc sync {src {dst {}} args} {
  67. upvar 1 home home
  68. upvar 1 vars vars
  69.  
  70. if {$dst eq {}} {
  71. set dst $home/.$src
  72. }
  73.  
  74. exec rsync -av {*}$args $src $dst >@ stdout 2>@ stderr
  75.  
  76. foreach template [find $dst -iname *.template] {
  77. puts stderr [list expanding template $template]
  78. expand-template $template {} $vars
  79. }
  80. }
  81.  
  82.  
  83. proc find args {
  84. set paths [split [exec find {*}$args -print0] \0]
  85.  
  86. lrange $paths 0 end-1
  87. }
  88.  
  89.  
  90. proc expand-template {src {dst {}} {vars {}}} {
  91. if {$dst eq {}} {
  92. set dst [file rootname $src]
  93. }
  94.  
  95. set ch [open $src r]
  96. set template [read $ch]
  97. set contents [safe-eval [template::parse $template] $vars]
  98.  
  99. set ch2 [open $dst w]
  100. puts -nonewline $ch2 $contents
  101.  
  102. file delete $src
  103.  
  104. close $ch2
  105. close $ch
  106. }
  107.  
  108.  
  109. proc safe-eval {script vars} {
  110. ::safe::interpCreate templateInterp
  111. dict for {k v} $vars {
  112. templateInterp eval [list set $k $v]
  113. }
  114. set result [templateInterp eval $script]
  115. ::safe::interpDelete templateInterp
  116.  
  117. return $result
  118. }
  119.  
  120.  
  121. namespace eval template {}
  122.  
  123. # Convert a template into Tcl code.
  124. proc template::parse template {
  125. set result {}
  126. set regExpr {^(.*?)<%(.*?)%>(.*)$}
  127. set listing "set _output {}\n"
  128. while {[regexp $regExpr $template match preceding token template]} {
  129. append listing [list append _output $preceding]\n
  130.  
  131. switch -exact -- [string index $token 0] {
  132. = {
  133. set code [list [string range $token 1 end]]
  134. append listing [format {append _output [expr %s]} $code]
  135. }
  136. ! {
  137. set code [string range $token 1 end]
  138. append listing [format {append _output [%s]} $code]
  139. }
  140. default {
  141. append listing $token
  142. }
  143. }
  144. append listing \n
  145. }
  146.  
  147. append listing [list append _output $template]\n
  148.  
  149. return $listing
  150. }
  151.  
  152.  
  153. main $env(HOME)