1#| -*-Scheme-*-
2
3Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6    Institute of Technology
7
8This file is part of MIT/GNU Scheme.
9
10MIT/GNU Scheme is free software; you can redistribute it and/or modify
11it under the terms of the GNU General Public License as published by
12the Free Software Foundation; either version 2 of the License, or (at
13your option) any later version.
14
15MIT/GNU Scheme is distributed in the hope that it will be useful, but
16WITHOUT ANY WARRANTY; without even the implied warranty of
17MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18General Public License for more details.
19
20You should have received a copy of the GNU General Public License
21along with MIT/GNU Scheme; if not, write to the Free Software
22Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23USA.
24
25|#
26
27;;;; Version Control: Subversion
28
29(declare (usual-integrations))
30
31(define vc-type:svn
32  (make-vc-type 'SVN "SVN" "\$Id\$"))
33
34(define-vc-type-operation 'RELEASE vc-type:svn
35  (lambda ()
36    (and (= 0 (vc-run-command #f '() "svn" "--version"))
37	 (re-search-forward "svn, version \\([0-9.]+\\)"
38			    (buffer-start (get-vc-command-buffer)))
39	 (extract-string (re-match-start 1) (re-match-end 1)))))
40
41(define-vc-type-operation 'CONTROL-DIRECTORY vc-type:svn
42  (lambda (directory)
43    (let ((cd (svn-directory directory)))
44      (and (file-directory? cd)
45	   cd))))
46
47(define-vc-type-operation 'FIND-MASTER vc-type:svn
48  (lambda (workfile control-dir)
49    (and (not (let ((output (%get-svn-status workfile)))
50		(or (not output)
51		    (string-null? output)
52		    (string-prefix? "?" output)
53		    (string-prefix? "I" output))))
54	 (make-vc-master vc-type:svn
55			 (merge-pathnames "entries" control-dir)
56			 workfile))))
57
58(define (svn-directory workfile)
59  (subdirectory-pathname workfile ".svn"))
60
61(define-vc-type-operation 'VALID? vc-type:svn
62  (lambda (master)
63    (let ((status (get-svn-status (vc-master-workfile master))))
64      (and status
65	   (svn-status-working-revision status)))))
66
67(define-vc-type-operation 'DEFAULT-REVISION vc-type:svn
68  (lambda (master)
69    (let ((workfile (vc-master-workfile master)))
70      (let ((status (get-svn-status workfile #f)))
71	(and status
72	     (svn-status-working-revision status))))))
73
74(define-vc-type-operation 'WORKFILE-REVISION vc-type:svn
75  (lambda (master)
76    (let ((status (get-svn-status master #f)))
77      (and status
78	   (svn-status-last-change-revision status)))))
79
80(define-vc-type-operation 'LOCKING-USER vc-type:svn
81  (lambda (master revision)
82    ;; The workfile is "locked" if it is modified.
83    ;; We consider the workfile's owner to be the locker.
84    (let ((workfile (vc-master-workfile master)))
85      (let ((status (get-svn-status workfile)))
86	(and status
87	     (or (not revision)
88		 (equal? revision (svn-status-last-change-revision status)))
89	     (svn-status-modified? status)
90	     (unix/uid->string
91	      (file-attributes/uid (file-attributes workfile))))))))
92
93(define-vc-type-operation 'WORKFILE-MODIFIED? vc-type:svn
94  (lambda (master)
95    (let ((status (get-svn-status master)))
96      (and status
97	   (svn-status-modified? status)))))
98
99(define (svn-status-modified? status)
100  (memq (svn-status-type status)
101	'(ADDED CONFLICTED DELETED MERGED MODIFIED REPLACED)))
102
103(define-vc-type-operation 'NEXT-ACTION vc-type:svn
104  (lambda (master)
105    (let ((status (get-svn-status master #t)))
106      (let ((type (svn-status-type status)))
107	(case type
108	  ((UNMODIFIED)
109	   (if (vc-workfile-buffer-modified? master)
110	       'CHECKIN
111	       'UNMODIFIED))
112	  ((MODIFIED ADDED DELETED REPLACED) 'CHECKIN)
113	  ((CONFLICTED) 'RESOLVE-CONFLICT)
114	  ((MISSING) 'CHECKOUT)
115	  (else (error "Unknown SVN status type:" type)))))))
116
117(define-vc-type-operation 'KEEP-WORKFILES? vc-type:svn
118  (lambda (master)
119    master
120    #t))
121
122(define-vc-type-operation 'WORKFILE-STATUS-STRING vc-type:svn
123  (lambda (master)
124    (let ((status (get-svn-status master)))
125      (and status
126	   (let ((type (svn-status-type status)))
127	     (case type
128	       ((ADDED) "added")
129	       ((CONFLICTED) "conflicted")
130	       ((DELETED) "deleted")
131	       ((MERGED) "merged")
132	       ((MODIFIED) "modified")
133	       ((REPLACED) "replaced")
134	       ((MISSING) "missing")
135	       (else #f)))))))
136
137(define-vc-type-operation 'REGISTER vc-type:svn
138  (lambda (workfile revision comment keep?)
139    revision comment keep?
140    (with-vc-command-message workfile "Registering"
141      (lambda ()
142	(vc-run-command workfile '() "svn" "add" (file-pathname workfile))))))
143
144(define-vc-type-operation 'CHECKOUT vc-type:svn
145  (lambda (master revision lock? workfile)
146    lock?
147    (let ((workfile* (file-pathname (vc-master-workfile master))))
148      (with-vc-command-message master "Checking out"
149	(lambda ()
150	  (cond (workfile
151		 (delete-file-no-errors workfile)
152		 (vc-run-shell-command master '() "svn" "cat"
153				       (svn-rev-switch revision)
154				       workfile*
155				       ">"
156				       workfile))
157		(else
158		 (vc-run-command master '() "svn" "update"
159				 (svn-rev-switch revision)
160				 workfile*))))))))
161
162(define-vc-type-operation 'CHECKIN vc-type:svn
163  (lambda (master revision comment keep?)
164    keep?
165    (with-vc-command-message master "Checking in"
166      (lambda ()
167	(vc-run-command master '() "svn" "commit"
168			(svn-rev-switch revision)
169			"--message" comment
170			(file-pathname (vc-master-workfile master)))))))
171
172(define-vc-type-operation 'REVERT vc-type:svn
173  (lambda (master)
174    (with-vc-command-message master "Reverting"
175      (lambda ()
176	(vc-run-command master '() "svn" "revert"
177			(file-pathname (vc-master-workfile master)))))))
178
179(define-vc-type-operation 'STEAL vc-type:svn
180  (lambda (master revision)
181    master revision
182    (error "There are no Subversion locks to steal.")))
183
184(define-vc-type-operation 'DIFF vc-type:svn
185  (lambda (master rev1 rev2 simple?)
186    (vc-run-command master
187		    (get-vc-diff-options simple?)
188		    "svn"
189		    "diff"
190		    (if simple?
191			#f
192			(let loop ((switches (gc-vc-diff-switches master)))
193			  (if (pair? switches)
194			      (cons* "-x" (car switches)
195				     (loop (cdr switches)))
196			      '())))
197		    (and rev1 (string-append "-r" rev1))
198		    (and rev2 (string-append "-r" rev2))
199		    (file-pathname (vc-master-workfile master)))
200    (> (buffer-length (get-vc-diff-buffer simple?)) 0)))
201
202(define-vc-type-operation 'PRINT-LOG vc-type:svn
203  (lambda (master)
204    (vc-run-command master '() "svn" "log"
205		    (file-pathname (vc-master-workfile master)))))
206
207(define-vc-type-operation 'CHECK-LOG-ENTRY vc-type:svn
208  (lambda (master log-buffer)
209    master log-buffer
210    unspecific))
211
212(define-vc-type-operation 'CHECK-HEADERS vc-type:svn
213  (lambda (master buffer)
214    master
215    (check-rcs-headers buffer)))
216
217(define (svn-rev-switch revision)
218  (and revision
219       (list "-r" revision)))
220
221(define (get-svn-status workfile #!optional required?)
222  (let ((workfile
223	 (if (vc-master? workfile)
224	     (vc-master-workfile workfile)
225	     workfile)))
226    (let ((status (parse-svn-status (%get-svn-status workfile))))
227      (if (and (not status) (if (default-object? required?) #f required?))
228	  (error "Unable to determine SVN status of file:" workfile))
229      status)))
230
231(define (%get-svn-status workfile)
232  (let ((directory (directory-pathname workfile)))
233    (let ((program (os/find-program "svn" directory #!default #f)))
234      (and program
235	   (let ((port (open-output-string)))
236	     (let ((status
237		    (run-synchronous-subprocess
238		     program
239		     (list "status" "--verbose" (file-namestring workfile))
240		     'output port
241		     'working-directory directory)))
242	       (and (eqv? status 0)
243		    (get-output-string port))))))))
244
245(define (parse-svn-status status)
246  (and status
247       (not (string-null? status))
248       (let ((type (decode-svn-status-0 (string-ref status 0))))
249	 (if (or (eq? type 'UNVERSIONED)
250		 (eq? type 'IGNORED))
251	     type
252	     (let ((regs (re-string-match svn-status-regexp status #f)))
253	       (and regs
254		    (make-svn-status
255		     type
256		     (decode-svn-status-1 (string-ref status 1))
257		     (decode-svn-status-2 (string-ref status 2))
258		     (decode-svn-status-3 (string-ref status 3))
259		     (decode-svn-status-4 (string-ref status 4))
260		     (decode-svn-status-5 (string-ref status 5))
261		     (decode-svn-status-7 (string-ref status 7))
262		     (decode-svn-working-revision
263		      (re-match-extract status regs 1))
264		     (decode-svn-last-change-revision
265		      (re-match-extract status regs 2))
266		     (re-match-extract status regs 3))))))))
267
268(define svn-status-regexp
269  (string-append ".[ CM][ L][ +][ S][ KOTB] [ *]"
270		 " +\\([0-9]+\\|-\\|\\?\\)"
271		 " +\\([0-9]+\\|\\?\\)"
272		 " +\\([^ ]+\\)"
273		 " +"))
274
275(define-record-type <svn-status>
276    (make-svn-status type properties locked? history? switched? lock-token
277		     updated? working-revision
278		     last-change-revision last-change-author)
279    svn-status?
280  (type svn-status-type)
281  (properties svn-status-properties)
282  (locked? svn-status-locked?)
283  (history? svn-status-history?)
284  (switched? svn-status-switched?)
285  (lock-token svn-status-lock-token)
286  (updated? svn-status-updated?)
287  (working-revision svn-status-working-revision)
288  (last-change-revision svn-status-last-change-revision)
289  (last-change-author svn-status-last-change-author))
290
291(define (decode-svn-status-0 char)
292  (case char
293    ((#\space) 'UNMODIFIED)
294    ((#\A) 'ADDED)
295    ((#\C) 'CONFLICTED)
296    ((#\D) 'DELETED)
297    ((#\G) 'MERGED)
298    ((#\I) 'IGNORED)
299    ((#\M) 'MODIFIED)
300    ((#\R) 'REPLACED)
301    ((#\X) 'USED-BY-EXTERNALS)
302    ((#\?) 'UNVERSIONED)
303    ((#\!) 'MISSING)
304    ((#\~) 'OBSTRUCTED)
305    (else (error "Unknown status char 0:" char))))
306
307(define (decode-svn-status-1 char)
308  (case char
309    ((#\space) 'UNMODIFIED)
310    ((#\C) 'CONFLICTED)
311    ((#\M) 'MODIFIED)
312    (else (error "Unknown status char 1:" char))))
313
314(define (decode-svn-status-2 char)
315  (case char
316    ((#\space) #f)
317    ((#\L) #t)
318    (else (error "Unknown status char 2:" char))))
319
320(define (decode-svn-status-3 char)
321  (case char
322    ((#\space) #f)
323    ((#\+) #t)
324    (else (error "Unknown status char 3:" char))))
325
326(define (decode-svn-status-4 char)
327  (case char
328    ((#\space) #f)
329    ((#\S) #t)
330    (else (error "Unknown status char 4:" char))))
331
332(define (decode-svn-status-5 char)
333  (case char
334    ((#\space) #f)
335    ((#\K) 'PRESENT)
336    ((#\O) 'ABSENT)
337    ((#\T) 'STOLEN)
338    ((#\B) 'BROKEN)
339    (else (error "Unknown status char 5:" char))))
340
341(define (decode-svn-status-7 char)
342  (case char
343    ((#\space) #f)
344    ((#\*) #t)
345    (else (error "Unknown status char 7:" char))))
346
347(define (decode-svn-working-revision string)
348  (if (string=? string "?")
349      #f
350      string))
351
352(define (decode-svn-last-change-revision string)
353  (if (string=? string "?")
354      "0"
355      string))