356 lines
11 KiB
Scheme
356 lines
11 KiB
Scheme
#| -*-Scheme-*-
|
||
|
||
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
||
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
||
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
||
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
||
|
||
This file is part of MIT/GNU Scheme.
|
||
|
||
MIT/GNU Scheme is free software; you can redistribute it and/or modify
|
||
it under the terms of the GNU General Public License as published by
|
||
the Free Software Foundation; either version 2 of the License, or (at
|
||
your option) any later version.
|
||
|
||
MIT/GNU Scheme is distributed in the hope that it will be useful, but
|
||
WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
General Public License for more details.
|
||
|
||
You should have received a copy of the GNU General Public License
|
||
along with MIT/GNU Scheme; if not, write to the Free Software
|
||
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
||
USA.
|
||
|
||
|#
|
||
|
||
;;;; Version Control: Subversion
|
||
|
||
|
||
|
||
(define vc-type:svn
|
||
(make-vc-type 'SVN "SVN" "\$Id\$"))
|
||
|
||
(define-vc-type-operation 'RELEASE vc-type:svn
|
||
(lambda ()
|
||
(and (= 0 (vc-run-command #f '() "svn" "--version"))
|
||
(re-search-forward "svn, version \\([0-9.]+\\)"
|
||
(buffer-start (get-vc-command-buffer)))
|
||
(extract-string (re-match-start 1) (re-match-end 1)))))
|
||
|
||
(define-vc-type-operation 'CONTROL-DIRECTORY vc-type:svn
|
||
(lambda (directory)
|
||
(let ((cd (svn-directory directory)))
|
||
(and (file-directory? cd)
|
||
cd))))
|
||
|
||
(define-vc-type-operation 'FIND-MASTER vc-type:svn
|
||
(lambda (workfile control-dir)
|
||
(and (not (let ((output (%get-svn-status workfile)))
|
||
(or (not output)
|
||
(string-null? output)
|
||
(string-prefix? "?" output)
|
||
(string-prefix? "I" output))))
|
||
(make-vc-master vc-type:svn
|
||
(merge-pathnames "entries" control-dir)
|
||
workfile))))
|
||
|
||
(define (svn-directory workfile)
|
||
(subdirectory-pathname workfile ".svn"))
|
||
|
||
(define-vc-type-operation 'VALID? vc-type:svn
|
||
(lambda (master)
|
||
(let ((status (get-svn-status (vc-master-workfile master))))
|
||
(and status
|
||
(svn-status-working-revision status)))))
|
||
|
||
(define-vc-type-operation 'DEFAULT-REVISION vc-type:svn
|
||
(lambda (master)
|
||
(let ((workfile (vc-master-workfile master)))
|
||
(let ((status (get-svn-status workfile #f)))
|
||
(and status
|
||
(svn-status-working-revision status))))))
|
||
|
||
(define-vc-type-operation 'WORKFILE-REVISION vc-type:svn
|
||
(lambda (master)
|
||
(let ((status (get-svn-status master #f)))
|
||
(and status
|
||
(svn-status-last-change-revision status)))))
|
||
|
||
(define-vc-type-operation 'LOCKING-USER vc-type:svn
|
||
(lambda (master revision)
|
||
;; The workfile is "locked" if it is modified.
|
||
;; We consider the workfile's owner to be the locker.
|
||
(let ((workfile (vc-master-workfile master)))
|
||
(let ((status (get-svn-status workfile)))
|
||
(and status
|
||
(or (not revision)
|
||
(equal? revision (svn-status-last-change-revision status)))
|
||
(svn-status-modified? status)
|
||
(unix/uid->string
|
||
(file-attributes/uid (file-attributes workfile))))))))
|
||
|
||
(define-vc-type-operation 'WORKFILE-MODIFIED? vc-type:svn
|
||
(lambda (master)
|
||
(let ((status (get-svn-status master)))
|
||
(and status
|
||
(svn-status-modified? status)))))
|
||
|
||
(define (svn-status-modified? status)
|
||
(memq (svn-status-type status)
|
||
'(ADDED CONFLICTED DELETED MERGED MODIFIED REPLACED)))
|
||
|
||
(define-vc-type-operation 'NEXT-ACTION vc-type:svn
|
||
(lambda (master)
|
||
(let ((status (get-svn-status master #t)))
|
||
(let ((type (svn-status-type status)))
|
||
(case type
|
||
((UNMODIFIED)
|
||
(if (vc-workfile-buffer-modified? master)
|
||
'CHECKIN
|
||
'UNMODIFIED))
|
||
((MODIFIED ADDED DELETED REPLACED) 'CHECKIN)
|
||
((CONFLICTED) 'RESOLVE-CONFLICT)
|
||
((MISSING) 'CHECKOUT)
|
||
(else (error "Unknown SVN status type:" type)))))))
|
||
|
||
(define-vc-type-operation 'KEEP-WORKFILES? vc-type:svn
|
||
(lambda (master)
|
||
master
|
||
#t))
|
||
|
||
(define-vc-type-operation 'WORKFILE-STATUS-STRING vc-type:svn
|
||
(lambda (master)
|
||
(let ((status (get-svn-status master)))
|
||
(and status
|
||
(let ((type (svn-status-type status)))
|
||
(case type
|
||
((ADDED) "added")
|
||
((CONFLICTED) "conflicted")
|
||
((DELETED) "deleted")
|
||
((MERGED) "merged")
|
||
((MODIFIED) "modified")
|
||
((REPLACED) "replaced")
|
||
((MISSING) "missing")
|
||
(else #f)))))))
|
||
|
||
(define-vc-type-operation 'REGISTER vc-type:svn
|
||
(lambda (workfile revision comment keep?)
|
||
revision comment keep?
|
||
(with-vc-command-message workfile "Registering"
|
||
(lambda ()
|
||
(vc-run-command workfile '() "svn" "add" (file-pathname workfile))))))
|
||
|
||
(define-vc-type-operation 'CHECKOUT vc-type:svn
|
||
(lambda (master revision lock? workfile)
|
||
lock?
|
||
(let ((workfile* (file-pathname (vc-master-workfile master))))
|
||
(with-vc-command-message master "Checking out"
|
||
(lambda ()
|
||
(cond (workfile
|
||
(delete-file-no-errors workfile)
|
||
(vc-run-shell-command master '() "svn" "cat"
|
||
(svn-rev-switch revision)
|
||
workfile*
|
||
">"
|
||
workfile))
|
||
(else
|
||
(vc-run-command master '() "svn" "update"
|
||
(svn-rev-switch revision)
|
||
workfile*))))))))
|
||
|
||
(define-vc-type-operation 'CHECKIN vc-type:svn
|
||
(lambda (master revision comment keep?)
|
||
keep?
|
||
(with-vc-command-message master "Checking in"
|
||
(lambda ()
|
||
(vc-run-command master '() "svn" "commit"
|
||
(svn-rev-switch revision)
|
||
"--message" comment
|
||
(file-pathname (vc-master-workfile master)))))))
|
||
|
||
(define-vc-type-operation 'REVERT vc-type:svn
|
||
(lambda (master)
|
||
(with-vc-command-message master "Reverting"
|
||
(lambda ()
|
||
(vc-run-command master '() "svn" "revert"
|
||
(file-pathname (vc-master-workfile master)))))))
|
||
|
||
(define-vc-type-operation 'STEAL vc-type:svn
|
||
(lambda (master revision)
|
||
master revision
|
||
(error "There are no Subversion locks to steal.")))
|
||
|
||
(define-vc-type-operation 'DIFF vc-type:svn
|
||
(lambda (master rev1 rev2 simple?)
|
||
(vc-run-command master
|
||
(get-vc-diff-options simple?)
|
||
"svn"
|
||
"diff"
|
||
(if simple?
|
||
#f
|
||
(let loop ((switches (gc-vc-diff-switches master)))
|
||
(if (pair? switches)
|
||
(cons* "-x" (car switches)
|
||
(loop (cdr switches)))
|
||
'())))
|
||
(and rev1 (string-append "-r" rev1))
|
||
(and rev2 (string-append "-r" rev2))
|
||
(file-pathname (vc-master-workfile master)))
|
||
(> (buffer-length (get-vc-diff-buffer simple?)) 0)))
|
||
|
||
(define-vc-type-operation 'PRINT-LOG vc-type:svn
|
||
(lambda (master)
|
||
(vc-run-command master '() "svn" "log"
|
||
(file-pathname (vc-master-workfile master)))))
|
||
|
||
(define-vc-type-operation 'CHECK-LOG-ENTRY vc-type:svn
|
||
(lambda (master log-buffer)
|
||
master log-buffer
|
||
unspecific))
|
||
|
||
(define-vc-type-operation 'CHECK-HEADERS vc-type:svn
|
||
(lambda (master buffer)
|
||
master
|
||
(check-rcs-headers buffer)))
|
||
|
||
(define (svn-rev-switch revision)
|
||
(and revision
|
||
(list "-r" revision)))
|
||
|
||
(define (get-svn-status workfile #!optional required?)
|
||
(let ((workfile
|
||
(if (vc-master? workfile)
|
||
(vc-master-workfile workfile)
|
||
workfile)))
|
||
(let ((status (parse-svn-status (%get-svn-status workfile))))
|
||
(if (and (not status) (if (default-object? required?) #f required?))
|
||
(error "Unable to determine SVN status of file:" workfile))
|
||
status)))
|
||
|
||
(define (%get-svn-status workfile)
|
||
(let ((directory (directory-pathname workfile)))
|
||
(let ((program (os/find-program "svn" directory #!default #f)))
|
||
(and program
|
||
(let ((port (open-output-string)))
|
||
(let ((status
|
||
(run-synchronous-subprocess
|
||
program
|
||
(list "status" "--verbose" (file-namestring workfile))
|
||
'output port
|
||
'working-directory directory)))
|
||
(and (eqv? status 0)
|
||
(get-output-string port))))))))
|
||
|
||
(define (parse-svn-status status)
|
||
(and status
|
||
(not (string-null? status))
|
||
(let ((type (decode-svn-status-0 (string-ref status 0))))
|
||
(if (or (eq? type 'UNVERSIONED)
|
||
(eq? type 'IGNORED))
|
||
type
|
||
(let ((regs (re-string-match svn-status-regexp status #f)))
|
||
(and regs
|
||
(make-svn-status
|
||
type
|
||
(decode-svn-status-1 (string-ref status 1))
|
||
(decode-svn-status-2 (string-ref status 2))
|
||
(decode-svn-status-3 (string-ref status 3))
|
||
(decode-svn-status-4 (string-ref status 4))
|
||
(decode-svn-status-5 (string-ref status 5))
|
||
(decode-svn-status-7 (string-ref status 7))
|
||
(decode-svn-working-revision
|
||
(re-match-extract status regs 1))
|
||
(decode-svn-last-change-revision
|
||
(re-match-extract status regs 2))
|
||
(re-match-extract status regs 3))))))))
|
||
|
||
(define svn-status-regexp
|
||
(string-append ".[ CM][ L][ +][ S][ KOTB] [ *]"
|
||
" +\\([0-9]+\\|-\\|\\?\\)"
|
||
" +\\([0-9]+\\|\\?\\)"
|
||
" +\\([^ ]+\\)"
|
||
" +"))
|
||
|
||
(define-record-type <svn-status>
|
||
(make-svn-status type properties locked? history? switched? lock-token
|
||
updated? working-revision
|
||
last-change-revision last-change-author)
|
||
svn-status?
|
||
(type svn-status-type)
|
||
(properties svn-status-properties)
|
||
(locked? svn-status-locked?)
|
||
(history? svn-status-history?)
|
||
(switched? svn-status-switched?)
|
||
(lock-token svn-status-lock-token)
|
||
(updated? svn-status-updated?)
|
||
(working-revision svn-status-working-revision)
|
||
(last-change-revision svn-status-last-change-revision)
|
||
(last-change-author svn-status-last-change-author))
|
||
|
||
(define (decode-svn-status-0 char)
|
||
(case char
|
||
((#\space) 'UNMODIFIED)
|
||
((#\A) 'ADDED)
|
||
((#\C) 'CONFLICTED)
|
||
((#\D) 'DELETED)
|
||
((#\G) 'MERGED)
|
||
((#\I) 'IGNORED)
|
||
((#\M) 'MODIFIED)
|
||
((#\R) 'REPLACED)
|
||
((#\X) 'USED-BY-EXTERNALS)
|
||
((#\?) 'UNVERSIONED)
|
||
((#\!) 'MISSING)
|
||
((#\~) 'OBSTRUCTED)
|
||
(else (error "Unknown status char 0:" char))))
|
||
|
||
(define (decode-svn-status-1 char)
|
||
(case char
|
||
((#\space) 'UNMODIFIED)
|
||
((#\C) 'CONFLICTED)
|
||
((#\M) 'MODIFIED)
|
||
(else (error "Unknown status char 1:" char))))
|
||
|
||
(define (decode-svn-status-2 char)
|
||
(case char
|
||
((#\space) #f)
|
||
((#\L) #t)
|
||
(else (error "Unknown status char 2:" char))))
|
||
|
||
(define (decode-svn-status-3 char)
|
||
(case char
|
||
((#\space) #f)
|
||
((#\+) #t)
|
||
(else (error "Unknown status char 3:" char))))
|
||
|
||
(define (decode-svn-status-4 char)
|
||
(case char
|
||
((#\space) #f)
|
||
((#\S) #t)
|
||
(else (error "Unknown status char 4:" char))))
|
||
|
||
(define (decode-svn-status-5 char)
|
||
(case char
|
||
((#\space) #f)
|
||
((#\K) 'PRESENT)
|
||
((#\O) 'ABSENT)
|
||
((#\T) 'STOLEN)
|
||
((#\B) 'BROKEN)
|
||
(else (error "Unknown status char 5:" char))))
|
||
|
||
(define (decode-svn-status-7 char)
|
||
(case char
|
||
((#\space) #f)
|
||
((#\*) #t)
|
||
(else (error "Unknown status char 7:" char))))
|
||
|
||
(define (decode-svn-working-revision string)
|
||
(if (string=? string "?")
|
||
#f
|
||
string))
|
||
|
||
(define (decode-svn-last-change-revision string)
|
||
(if (string=? string "?")
|
||
"0"
|
||
string))
|