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))