source: project/sbky/bky.scm @ 7185

Last change on this file since 7185 was 7185, checked in by felix winkelmann, 13 years ago

renamed update to revert

File size: 8.9 KB
Line 
1;;;; bky.scm
2
3
4(use posix utils srfi-1)
5
6
7(define bky-revert #f)
8(define bky-diff #f)
9(define bky-commit #f)
10(define bky-init #f)
11(define bky-log #f)
12(define bky-status #f)
13(define bky-tag #f)
14(define bky-branchname #f)
15(define bky-push #f)
16(define bky-pull #f)
17(define bky-export #f)
18(define bky-patchset #f)
19(define bky-save #f)
20(define bky-restore #f)
21
22(let ()
23
24(define *repo* ".bky")
25(define *commit* #f)
26
27(define (suffix? x str)
28  (let ((len (string-length str)))
29    (string=? x (substring str (max 0 (- len (string-length x)))))))
30
31(define (prefix? x str)
32  (let ((len (string-length x)))
33    (string=? x (substring str 0 (min (string-length str) len)))))
34
35(define (read1 f)
36  (with-input-from-file f read) )
37
38(define (write-to f str)
39  (when (run-verbose) (print "writing \"" str "\" to file " f " ..."))
40  (unless (dry-run) (with-output-to-file f (cut print str))))
41
42(define (commit)
43  (or *commit*
44      (begin
45        (set! *commit*
46          (if (file-exists? ".bkyfrom")
47              (read1 ".bkyfrom")
48              0) )
49        *commit*)))
50
51(define *bky-excl* 
52  "--exclude=.bky --exclude=.bkyfrom --exclude=.bkymsg --exclude=.bkyremote")
53
54(define *rsync-args* "-avcC --exclude=.bky --exclude=.bkyremote")
55
56(define (wet thunk)
57  (parameterize ((dry-run #f))
58    (thunk) ) )
59
60(define (do-list-changes from to)
61  ;; simulates (with -n) an rsync to store $1 into $2,
62  ;; stripping rsync information cruft
63  (let ((files (cdr (string-split 
64                     (wet
65                      (lambda ()
66                        (run < (rsync -avCn --delete ,*bky-excl* ,from ,to))) )
67                     "\n" #t) ) ) )
68    (map
69     (lambda (s)
70       (cond ((substring-index " -> " s) =>
71              (lambda (p) (substring s 0 p)))
72             ((prefix? "deleting " s)
73              (substring s (string-length "deleting ")) )
74             (else s) ) )
75     (take-while (lambda (s) (not (string=? "" s))) files) ) ) )
76
77(define (do-commit files)
78  (let* ((bkyfiles '(".bkyfrom" ".bkymsg"))
79         (ffile (file-exists? ".bkyfrom"))
80         (parent (and ffile (read1 ".bkyfrom")))
81         (args (if (file-exists? ".bkyfrom") 
82                   (conc "--link-dest=../" parent)
83                   "")))
84    (assert (or parent (null? files)))
85    (let ((files
86           (filter
87            (lambda (f)
88              (and (not (directory? s))
89                   (substring-index "text" (run < (file ,name)))
90                   (or (null? files) (member f files))
91                   (zero? (run* (cmp ,(conc *repo* "/" parent "/" f)
92                                     f >/dev/null))) ) )
93            files) ) )
94      (cond ((null? files)
95             (run (rsync ,*rsync-args* ,args "." ,(conc *repo* "/" *commit*))) )
96            (else
97             (run (rsync ,*rsync-args* ,args ,(conc *repo* "/" parent "/*")
98                         ,(conc *repo* "/" *commit*) >/dev/null) )
99             (run (rsync ,*rsync-args* ,args ,@files ,@bkyfiles
100                         ,(conc *repo* "/" *commit*))))))) )
101
102(define (do-next-commit-id)
103  (do () ((not (file-exists? (conc *repo* "/" (commit)))))
104    (set! *commit* (add1 *commit*))))
105
106(define (do-move-head)
107  (let ((head (conc *repo* "/HEAD")))
108    (if (file-exists? head)
109        (cond ((= (read1 ".bkyfrom")
110                  (read1 head)) 
111               (print "Moving HEAD ...")
112               (write-to head (commit)))
113              (else
114               (print "Commit to non-HEAD: effective branching") ) )
115        (write-to head 0))))
116
117(define (date-last-modified file)
118  (string-chomp (seconds->string (file-modification-time file))))
119
120(define (get-remote remote)
121  (lambda (remote)                      ; pass #f to use .bkyremote
122    (or remote
123        (cond ((file-exists? ".bkyremote")
124               (set! remote (with-input-from-file ".bkyremote" read-line)) )
125              (else
126               (print "A repository in " *repo* " already exists, so I won't go on.\n"
127                      "If you want to get rid of it, delete it and try again.")
128               (reset) ) ) ) ) )
129
130(set! bky-revert
131  (lambda (id)                          ; pass #f for HEAD
132    (let ((tag (or id (read1 (conc *repo* "/HEAD")))))
133      (run (rsync ,*rsync-args* --delete ,(conc *repo* "/" tag "/" " .")))
134      (write-to ".bkyfrom" tag))))
135
136(set! bky-diff
137  (lambda (id1 id2 style)               ; pass #f for id1 to diff HEAD
138    (let ((difforg ".")                 ; pass #t for id2 for parent
139          (diffdest (conc *repo* "/" (commit))) )
140      (when id1
141        (set! diffdest (conc *repo* "/" id1))
142        (when id2
143          (cond ((eq? id2 #t)
144                 (set! difforg (conc diffdest "/"))
145                 (set! diffdest 
146                   (conc
147                    *repo*
148                    "/"
149                    (read1 (conc difforg "/.bkyfrom")) ) ) )
150                (else
151                 (set! difforg (conc *repo* "/" id2 "/")) ) ) ) )
152      (let ((tmpfile (and style (run < (mktemp /tmp/bkydiff.XXXXXX)))))
153        (for-each
154         (lambda (f)
155           (let ((ddest (conc diffdest "/" f))
156                 (dorg (conc difforg "/" f)) )
157             (when (and (not (directory? ddest)) (not (directory? dorg)))
158               (run (diff -uN ',ddest ',dorg 2>/dev/null "|"
159                          sed -e "\"s|^--- .bky/[^/]*/*|--- ./| ; s|^+++ .bky/[^/]*/*|+++ ./|\""
160                          ,(if style (conc ">>" tmpfile) "") ) ) ) ) )
161         (do-list-changes difforg diffdest))
162        (when style
163          (case style
164            ((list) (run (diffstat -l ,tmpfile)))
165            ((histo) (run (diffstat ,tmpfile)))
166            (else (error 'bky-diff "invalid diff style" style)))
167          (run (rm -f ,tmpfile)))))) )
168
169(set! bky-commit
170  (lambda (files msg bname)             ; msg = #f: keep, #t: edit
171    (when bname (bky-branchname bname))
172    (cond ((and (not msg) (file-exists? ".bkymsg"))
173           (set! msg (read-all ".bkymsg")))
174          ((eq? #t msg)
175           (let ((tmpfile (run < (mktemp ./bky.XXXXXX))))
176             (run (,(or (getenv "EDITOR") "emacsclient") ,tmpfile))
177             (cond ((> (file-size tmpfile) 0)
178                    (run (mv ,tmpfile .bkymsg)) )
179                   (else
180                    (run (rm -f ,tmpfile))
181                    (print "Untouched commit message file; commit aborted")
182                    (reset)))))
183          ((and msg (file-exists? msg))
184           (set! msg (read-all msg)))
185          (msg (write-to ".bkymsg" msg))
186          (else
187           (print "no message available")
188           (reset) ) ) 
189    (do-next-commit-id)
190    (do-commit files)
191    (do-move-head)
192    (write-to ".bkyfrom" (commit))) )
193
194(set! bky-init
195  (lambda (bname msg)
196    (when (file-exists? *repo*)
197      (print "A repository in ${REPO} already exists, so I won't go on.\n"
198             "If you want to get rid of it, delete it and try again.")
199      (reset) )
200    (run (mkdir -p ,*repo*))
201    (bky-commit '() msg bname)))
202
203(set! bky-log
204  (lambda (id)                          ; pass #f for last commit or limit count
205    ;; loop the commits from head to toes
206    (let loop ((t (or (and (string? id) id) (commit)))
207               (count 0) )
208      (unless (and (number? id) (>= count id))
209        (let ((msgfile (conc *repo* "/" t "/.bkymsg")))
210          (cond ((file-exists? msgfile)
211                 (print (date-last-modified (conc *repo* "/" t "/.bkymsg")) 
212                        " [" t "]\n")
213                 (for-each
214                  (lambda (ln)
215                    (print " " ln) )
216                  (string-split 
217                   (read-all msgfile)
218                   "\n") ) 
219                 (newline))
220                (else (print "<no message>")) )
221          (let ((f (conc *repo* "/" t "/.bkyfrom")))
222            (when (file-exists? f)
223              (loop (read1 f) (add1 count)) ) ) ) ) ) ) )
224
225(set! bky-status
226  (lambda ()
227    (for-each
228     print
229     (do-list-changes "." (conc *repo* "/" (commit))) ) ) )
230
231(set! bky-tag
232  (lambda (tag)                 ; pass #f to list tags
233    (cond ((not tag)
234           (let ((fs (glob (make-pathname *repo* "*"))))
235             (for-each
236              (lambda (f)
237                (when (symbolic-link? f)
238                  (print (pathname-strip-directory f))))
239              fs) ) )
240          ((file-exists? (conc *repo* "/" tag))
241           (print "Tag exists: " tag)
242           (reset) )
243          (else
244           (run (ln -s ,(commit) ,(conc *repo* "/" tag)))))) )
245
246(set! bky-branchname
247  (lambda (name) ; pass #f to read branchname
248    (let ((bfile (conc *repo* "/BRANCH")))
249      (if name
250          (write-to bfile name)
251          (and (file-exists? bfile)
252               (print (with-input-from-file bfile read-line)))))))
253
254(set! bky-push
255  (lambda (remote . dry)                ; pass #f to use .bkyremote
256    (print "pushing to " remote " ...")
257    (let ((dry (optional dry (dry-run))))
258      (wet
259       (lambda ()
260         (run (rsync -azHC 
261                     ,(cond (dry "-vn")
262                            ((run-verbose) "-v")
263                            (else ""))
264                     --exclude=.bkyremote --delete "." ,remote)) ) ) ) ) )
265
266(set! bky-pull
267  (lambda (remote . dry)                ; pass #f to use .bkyremote
268    (print "pulling from " remote " ...")
269    (let ((dry (optional dry (dry-run))))
270      (wet
271       (lambda ()
272         (run (rsync -azHC 
273                     ,(cond (dry "-vn")
274                            ((run-verbose) "-v")
275                            (else ""))
276                     --exclude=.bkyremote --delete ,(conc remote "/") ".")))) ) ) )
277
278(set! bky-export
279  (lambda (dest)
280    (run (rsync -avC ,*bky-excl* ,(conc *repo* "/" (commit) "/") ,dest)) ) )
281
282(set! bky-patchset
283  (lambda (id)                          ; pass #f to use .bkyfrom
284    (let ((dest (or id (commit))))
285      (unless (file-exists? (conc *repo* "/" dest))
286        (print "Invalid commit id: " dest)
287        (reset) )
288      (run (cat ,(conc *repo* "/" dest "/.bkymsg")))
289      (print)
290      (let* ((ffile (conc *repo* "/" dest "/.bkyfrom"))
291             (org (cond ((file-exists? ffile) (read1 ffile))
292                        (else
293                         (run (mkdir -p ,(conc *repo* "/START")))
294                         "START") ) ) )
295        (bky-diff org dest #f) ) ) ) )
296
297(set! bky-save
298  (lambda (dest)
299    (let* ((name (pathname-strip-directory (current-directory)))
300           (dest (or dest "."))
301           (tar (if (directory? dest) 
302                    (make-pathname dest name ".tgz")
303                    dest) ) )
304      (run (tar -czf ,tar ".bky*"
305                ,(or (file-exists? ".cvsignore") "") ) ) ) ) )
306
307(set! bky-restore
308  (lambda (src)
309    (run (tar xfz ,src)) ) )
310
311)
Note: See TracBrowser for help on using the repository browser.