source: project/chicken/trunk/scripts/svn2git @ 16091

Last change on this file since 16091 was 16091, checked in by felix, 10 years ago

added sv2git script; improvements in chicken-scheme script, fixed rename in manifest

  • Property svn:executable set to *
File size: 5.4 KB
Line 
1#!/usr/bin/env chicken-scheme
2;;;; git2svn.scm - Transfer subversion working copy into git -*- Scheme -*-
3
4
5(use extras utils posix regex srfi-13 srfi-1 htmlprag matchable data-structures)
6
7
8(define *dry-run* #f)
9(define *top-merged-svn-revision* 0)
10(define *svn-head-revision* #f)
11(define *force* #f)
12
13(define-syntax run
14  (syntax-rules ()
15    ((_ cmd) (execute `cmd))))
16
17(define (normalize cmd)
18  (string-intersperse
19   (map ->string (flatten cmd))))
20
21(define (execute cmd)
22  (let ((cmd (normalize cmd)))
23    (printf "  ~a~a~%~!" (if *dry-run* "[pretend] " "") cmd)
24    (unless *dry-run*
25      (let ((s (system cmd)))
26        (unless (zero? s)
27          (quit "Shell command terminated with non-zero exit status (~a): ~a" s cmd))))))
28
29(define-syntax run/sxml
30  (syntax-rules ()
31    ((_ cmd) (execute/sxml `cmd))))
32
33(define (execute/sxml cmd)
34  (let ((cmd (normalize cmd)))
35    (printf "  ~a~%~!" cmd)
36    (if *dry-run*
37        '(*TOP*)
38        (with-input-from-pipe cmd (cut html->sxml (current-input-port))))))
39
40(define-syntax operate
41  (syntax-rules ()
42    ((_ body ...)
43     (unless *dry-run*
44       (begin body ...)))))
45
46(define-syntax operate-always
47  (syntax-rules ()
48    ((_ body ...)
49     (fluid-let ((*dry-run* #f))
50       (begin body ...)))))
51
52(define (quit fstr . args)
53  (fprintf (current-error-port) "~%~?~%" fstr args)
54  (exit 70))
55
56(define (sxml-find track sxml)
57  (if (null? track)
58      (list sxml)
59      (match sxml
60        (('*TOP* . body)
61         (concatenate (map (lambda (x) (sxml-find track x)) body)))
62        (('*PI* . _) '())
63        ((tag . body)
64         (cond ((eq? tag (car track))
65                (if (null? (cdr track))
66                    (list sxml)
67                    (concatenate (map (lambda (x) (sxml-find (cdr track) x)) body))))
68               (else '())))
69        (x (if (null? track) (list x) '())))))
70
71(define (load-status)
72  (when (file-exists? ".svn2git")
73    (set! *top-merged-svn-revision* (car (read-file ".svn2git")))))
74
75(define (identify-wc)
76  (unless (file-exists? ".svn")
77    (quit "Not a subversion repository"))
78  (operate-always
79   (match (sxml-find '(info entry url) (run/sxml (svn info --xml)))
80     ((('url url))
81      (match (sxml-find '(info entry commit) (run/sxml (svn info --xml ,url)))
82        ((('commit ('@ ('revision rev)) . _))
83         (set! *svn-head-revision* (string->number rev)))))))
84  (cond ((file-exists? ".git")
85         (print "git repository exists")
86         (let ((s (with-input-from-file ".git/refs/heads/master" read-line)))
87           (printf "git top revision is ~a~%" s)
88           (string->number s)))
89        (else
90         (print "initializing git repository")
91         (with-output-to-file ".gitignore" (cut print ".svn*\n*/.svn\n") binary:)
92         (run (git init))
93         (run (git add .gitignore)))))
94
95(define (fixpath path)
96  (substring path 1))
97
98(define (update-wc rev)
99  (unless rev
100    (set! rev *svn-head-revision*))
101  (printf "merging revisions ~a to ~a~%~!" (add1 *top-merged-svn-revision*) rev)
102  (let loop ((revcount (add1 *top-merged-svn-revision*)))
103    (unless (> revcount rev)
104      (let ((newrev (min rev (+ revcount 500))))
105        (do ((log (operate-always
106                   (sxml-find
107                    '(log logentry)
108                    (run/sxml
109                     (svn log --xml -v -r ,(conc revcount ":" newrev))) ) )
110                  (cdr log)))
111            ((null? log))
112          (match log
113            ((('logentry ('@ ('revision r)) . _) . _)
114             (run (svn update -r ,r))
115             (let* ((sx (sxml-find '(logentry msg) (car log)))
116                    (msg (match sx
117                           ((('msg msg)) msg)
118                           (_ "<no commit message>")))
119                    (sx (sxml-find '(logentry author) (car log)))
120                    (author (match sx
121                              ((('author a)) a)
122                              (_ "<no author>")))
123                    (paths (sxml-find '(logentry paths path) (car log)))
124                    (added '())
125                    (removed '())
126                    (touched #f))
127               (for-each
128                (lambda (p)
129                  (match p
130                    (('path ('@ attrs ...) fpath)
131                     (let ((a (assq 'action attrs)))
132                       (case (string-ref (cadr a) 0)
133                         ((#\M) (set! touched #t))
134                         ((#\A) (set! added (cons fpath added)))
135                         ((#\D) (set! removed (cons fpath removed))))))))
136                paths)
137               (when (pair? added)
138                 (for-each
139                  (lambda (f)
140                    (let ((f2 (fixpath f)))
141                      (unless (and (directory? f2) (null? (directory f2)))
142                        (set! touched #t)
143                        (run (git add ,(qs f2))))))
144                  added))
145               (when (pair? removed)
146                 (for-each
147                  (lambda (f)
148                    (let ((f2 (fixpath f)))
149                      (when (file-exists? f2)
150                        (run (git rm -r ,(qs f2)))
151                        (set! touched #t))))
152                  removed))
153               (when touched
154                 (printf "Committing revision ~a: ~a~%" r msg)
155                 (operate
156                  (with-output-to-file ".svn2git-commit.tmp"
157                    (lambda ()
158                      (printf "~a~%(svn rev. ~a, author: ~a)~%" msg r author))))
159                 (run (git commit -a -F .svn2git-commit.tmp)))
160               (set! *top-merged-svn-revision* r)
161               (operate
162                (with-output-to-file ".svn2git"
163                  (cut display *top-merged-svn-revision*)) ) ) )
164            (_ (quit "invalid log entry: ~s" log))))
165        (loop (add1 newrev))))))
166
167(define (usage code)
168  (print "usage: svn2git [-h] [-n] [-r REVISION]")
169  (exit code))
170
171(let ((rev #f))
172  (let loop ((args (command-line-arguments)))
173    (match args
174      (()
175       (load-status)
176       (identify-wc)
177       (printf "top merged svn revision is ~a, HEAD is ~a~%"
178               *top-merged-svn-revision* *svn-head-revision*)
179       (when (< *top-merged-svn-revision* *svn-head-revision*)
180         (update-wc rev) )
181       (print "done."))
182      (("-f" . more)
183       (set! *force* #t)
184       (loop more))
185      (("-r" r . more)
186       (set! rev (string->number r))
187       (loop more))
188      (("-n" . more)
189       (set! *dry-run* #t)
190       (loop more))
191      (("-h" . _) (usage 0))
192      (_ (usage 1)))))
Note: See TracBrowser for help on using the repository browser.