source: project/sbky/bky.scm @ 7273

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

updates

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