Posted to tcl by aspect at Thu Feb 02 22:07:12 GMT 2017view raw

  1. # main as an ensemble is sweet
  2.  
  3. variable START
  4. set START [clock seconds]
  5.  
  6. # ----- private commands:
  7. set fossil_dir $env(HOME)/.fossils ;# keep all our fossils in one place
  8. set fossil_bin fossil ;# rely on $PATH
  9.  
  10. proc Find {name} {
  11. variable fossil_dir
  12. file join $fossil_dir $name
  13. }
  14.  
  15. proc Fossil {args} { ;# use this for the shell command
  16. variable fossil_bin
  17. # FIXME: quote args a la lexec?
  18. Exec $fossil_bin {*}$args
  19. }
  20.  
  21. # some silly helpers:
  22. # FIXME: need a better [exec]-like pattern for this stuff
  23. proc F:current-branch {} {
  24. variable fossil_bin
  25. exec $fossil_bin branch | awk {/^*/ {print $2}}
  26. }
  27. proc F:parent {hash} {
  28. variable fossil_bin
  29. exec $fossil_bin info $hash | awk {/^parent:/ {print $2}}
  30. }
  31.  
  32. # ----- utilities:
  33. # Make errors and logging easier
  34. proc Error {args} {
  35. tailcall return -code error $args
  36. }
  37. proc Log {args} {
  38. puts stderr "[TS] $args"
  39. }
  40. proc TS {} {
  41. variable START
  42. set elapsed [expr {[clock seconds] - $START}]
  43. set secs [expr {$elapsed / 1000}]
  44. set ms [expr {$elapsed % 1000}]
  45. format %s:%.03d [
  46. clock format $secs -format %M:%S
  47. ] $ms
  48. }
  49.  
  50. # Namespace unknowns are weird.
  51. proc Unknown {_ cmd args} {
  52. list [namespace which Fossil] $cmd
  53. }
  54.  
  55. # A more shell-script like [exec]. Passes stdout/err through,
  56. # and returns the exit code.
  57. proc Exec {args} {
  58. # FIXME: handle redirections. Use >$ 2>$ for variables
  59. set rc [catch {
  60. exec {*}$args >@ stdout 2>@ stderr
  61. } e o]
  62. if {$rc == 0} {
  63. return $rc
  64. } else {
  65. return [lindex [dict get $o -errorcode] 2]
  66. }
  67. }
  68.  
  69. # create directory/ies, unless they already exist
  70. # BEWARE: race-prone. Tcl's [file mkdir] is already race-prone
  71. # so this can't be fixed in Tcl. Just be careful.
  72. proc Mkdir {args} {
  73. foreach dir $args {
  74. if {[file exists $dir]} {
  75. if {[file isdirectory]} {
  76. Error "Directory already exists" $dir
  77. } else {
  78. Error "File exists" $dir
  79. }
  80. }
  81. }
  82. file mkdir {*}$args
  83. }
  84.  
  85. # ----- aliases and wrappers for fossil commands
  86.  
  87. proc clone {url} {
  88. foreach name [lreverse [split $url /]] { ;# FIXME: support same repo name from multiple sources .. aliases?
  89. if {$name ne ""} break
  90. }
  91. if {$name eq "" || [string match *: $name]} {
  92. Error "Unable to derive name for $url: got [list $name]!"
  93. }
  94.  
  95. set fsl [Find $name]
  96. if {[file exists $fsl]} {
  97. Error "File already exists! $fsl"
  98. }
  99. Mkdir $name
  100. Log "Cloning" $url $fsl
  101. Fossil clone $url $fsl
  102. cd $name
  103. Log "Opening in" [pwd]
  104. Fossil open $fsl
  105. }
  106.  
  107. proc open {name} {
  108. Mkdir $name
  109. cd $name
  110. Log "Opening in" [pwd]
  111. Fossil open [Find $name]
  112. }
  113.  
  114. proc commit {args} {
  115. # strip git-ism:
  116. if {[lindex $args 0] eq "-am" && [llength $args] eq 2} {
  117. lset args 0 "-m"
  118. }
  119. # move -m to the front
  120. set i [lsearch -exact $args -m]
  121. if {$i > 0} {
  122. set a0 [lrange $args $i $i+1]
  123. set args [lreplace $args $i $i+1]
  124. set args [linsert $args 0 {*}$a0]
  125. }
  126. Fossil commit {*}$args
  127. }
  128.  
  129. # pull might as well checkout current branch's leaf:
  130. proc pull {args} {
  131. if {$args eq ""} {
  132. Fossil pull
  133. Fossil checkout [F:currrent-branch]
  134. }
  135. }
  136.  
  137. # support a really useful git-ism
  138. proc show {hash} {
  139. set parent [F:parent $hash]
  140. Fossil diff --from $parent --to $hash
  141. }
  142.  
  143. namespace export {[a-z]*}
  144. namespace ensemble create -unknown [namespace which Unknown]
  145. }
  146.  
  147. exit [main {*}$argv]
  148.  
  149.