#| -*-Scheme-*-
-$Id: decls.scm,v 1.83 2008/01/30 20:02:00 cph Exp $
+$Id$
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(list (scm-file source))
'())
(map bin-file
- (list-transform-positive dependencies
- (if source-time
- (lambda (dependency)
- (let ((bin-time (bin-time dependency)))
- (or (not bin-time)
- (< source-time bin-time))))
- (lambda (dependency)
- dependency ;ignore
- true))))))))
+ (if source-time
+ (filter (lambda (dependency)
+ (let ((bin-time
+ (bin-time dependency)))
+ (or (not bin-time)
+ (< source-time bin-time))))
+ dependencies)
+ dependencies))))))
(if (not (null? reasons))
(begin
#|
"undo"
"unix"
"vc"
+ "vc-rcs"
+ "vc-cvs"
+ "vc-svn"
+ "vc-bzr"
"verilog"
"vhdl"
"webster"
#| -*-Scheme-*-
-$Id: edwin.ldr,v 1.81 2008/01/30 20:02:00 cph Exp $
+$Id$
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
(load "diff" (->environment '(EDWIN DIFF)))
(load "rcsparse" (->environment '(EDWIN RCS-PARSE)))
(load "vc" (->environment '(EDWIN VC)))
+ (load "vc-rcs" (->environment '(EDWIN VC)))
+ (load "vc-cvs" (->environment '(EDWIN VC)))
+ (load "vc-svn" (->environment '(EDWIN VC)))
+ (load "vc-bzr" (->environment '(EDWIN VC)))
(load "wincom" environment)
(load "scrcom" environment)
(load "modefs" environment)
#| -*-Scheme-*-
-$Id: edwin.pkg,v 1.310 2008/08/15 20:46:12 riastradh Exp $
+$Id$
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
edwin-variable$diff-switches))
(define-package (edwin vc)
- (files "vc")
+ (files "vc"
+ "vc-rcs"
+ "vc-cvs"
+ "vc-svn"
+ "vc-bzr")
(parent (edwin))
(export (edwin)
edwin-command$vc-diff
--- /dev/null
+#| -*-Scheme-*-
+
+$Id$
+
+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 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: Bazaar
+
+(declare (usual-integrations))
+\f
+(define vc-type:bzr
+ (make-vc-type 'BZR "bzr" "\$Id\$"))
+
+(define-vc-type-operation 'RELEASE vc-type:bzr
+ (lambda ()
+ (and (= 0 (vc-run-command #f '() "bzr" "--version"))
+ (let ((m (buffer-start (get-vc-command-buffer))))
+ (re-match-forward "Bazaar (bzr) \\(.+\\)$"
+ m
+ (line-end m 0)))
+ (extract-string (re-match-start 1) (re-match-end 1)))))
+
+(define-vc-type-operation 'CONTROL-DIRECTORY vc-type:bzr
+ (lambda (directory)
+ (let ((cd (subdirectory-pathname directory ".bzr")))
+ (if (file-directory? cd)
+ cd
+ 'SEARCH-PARENT))))
+
+(define-vc-type-operation 'FIND-MASTER vc-type:bzr
+ (lambda (workfile control-dir)
+ (let ((master
+ (make-vc-master vc-type:bzr
+ (merge-pathnames "README" control-dir)
+ workfile)))
+ (and (%bzr-master-valid? master)
+ master))))
+
+(define-vc-type-operation 'VALID? vc-type:bzr
+ (lambda (master)
+ (%bzr-master-valid? master)))
+
+(define (%bzr-master-valid? master)
+ (%bzr-workfile-cache master 'WORKFILE-VERSIONED? %bzr-workfile-versioned?))
+
+(define-vc-type-operation 'DEFAULT-REVISION vc-type:bzr
+ (lambda (master)
+ master
+ #f))
+
+(define-vc-type-operation 'WORKFILE-REVISION vc-type:bzr
+ (lambda (master)
+ (bzr-workfile-revision master)))
+
+(define-vc-type-operation 'LOCKING-USER vc-type:bzr
+ (lambda (master revision)
+ revision ;ignore
+ ;; The workfile is "locked" if it is modified.
+ ;; We consider the workfile's owner to be the locker.
+ (let ((status (get-bzr-status master)))
+ (and status
+ (bzr-status-modified? status)
+ (unix/uid->string
+ (file-attributes/uid
+ (file-attributes (vc-master-workfile master))))))))
+
+(define (bzr-workfile-revision master)
+ (let ((result
+ (%bzr-cached-command master 'WORKFILE-REVISION
+ "log" "--limit=1" "--line"
+ (file-namestring (vc-master-workfile master)))))
+ (and result
+ (let ((regs (re-string-match "\\([0-9]+\\): \\([^ ]+\\) " result)))
+ (and regs
+ (re-match-extract result regs 1))))))
+
+(define-vc-type-operation 'WORKFILE-MODIFIED? vc-type:bzr
+ (lambda (master)
+ (let ((status (get-bzr-status master)))
+ (and status
+ (bzr-status-modified? status)))))
+\f
+(define-vc-type-operation 'NEXT-ACTION vc-type:bzr
+ (lambda (master)
+ (let ((status (get-bzr-status master #t)))
+ (let ((type (bzr-status-mod-type status)))
+ (case type
+ ((UNMODIFIED)
+ (let ((type (bzr-status-type status)))
+ (case type
+ ((VERSIONED)
+ (if (vc-workfile-buffer-modified? master)
+ 'CHECKIN
+ 'UNMODIFIED))
+ ((UNVERSIONED UNKNOWN) #f)
+ ((RENAMED) 'CHECKIN)
+ ((CONFLICTED) 'RESOLVE-CONFLICT)
+ ((PENDING-MERGE) 'PENDING-MERGE)
+ (else (error "Unknown Bazaar status type:" type)))))
+ ((CREATED DELETED KIND-CHANGED MODIFIED) 'CHECKIN)
+ (else (error "Unknown Bazaar status type:" type)))))))
+
+(define-vc-type-operation 'KEEP-WORKFILES? vc-type:bzr
+ (lambda (master)
+ master
+ #t))
+
+(define-vc-type-operation 'WORKFILE-STATUS-STRING vc-type:bzr
+ (lambda (master)
+ (let ((status (get-bzr-status master)))
+ (and status
+ (let ((type (bzr-status-type status)))
+ (case type
+ ((VERSIONED)
+ (case (bzr-status-mod-type status)
+ ((CREATED) "created")
+ ((DELETED) "deleted")
+ ((KIND-CHANGED) "kind-changed")
+ ((MODIFIED) "modified")
+ (else #f)))
+ ((UNVERSIONED) "unversioned")
+ ((RENAMED) "renamed")
+ ((UNKNOWN) "unknown")
+ ((CONFLICTED) "conflicted")
+ ((PENDING-MERGE) "pending-merge")
+ (else #f)))))))
+
+(define-vc-type-operation 'REGISTER vc-type:bzr
+ (lambda (workfile revision comment keep?)
+ revision comment keep?
+ (with-vc-command-message workfile "Registering"
+ (lambda ()
+ (vc-run-command workfile '() "bzr" "add" (file-pathname workfile))))))
+
+(define-vc-type-operation 'CHECKOUT vc-type:bzr
+ (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 '() "bzr" "cat"
+ (bzr-rev-switch revision)
+ workfile*
+ ">"
+ workfile))
+ (else
+ (vc-run-command master '() "bzr" "update"
+ (bzr-rev-switch revision)
+ workfile*))))))))
+
+(define-vc-type-operation 'CHECKIN vc-type:bzr
+ (lambda (master revision comment keep?)
+ keep?
+ (with-vc-command-message master "Checking in"
+ (lambda ()
+ (vc-run-command master '() "bzr" "commit"
+ (bzr-rev-switch revision)
+ "--message" comment
+ (file-pathname (vc-master-workfile master)))))))
+\f
+(define-vc-type-operation 'REVERT vc-type:bzr
+ (lambda (master)
+ (with-vc-command-message master "Reverting"
+ (lambda ()
+ (vc-run-command master '() "bzr" "revert"
+ (file-pathname (vc-master-workfile master)))))))
+
+(define-vc-type-operation 'STEAL vc-type:bzr
+ (lambda (master revision)
+ master revision
+ (error "There are no Bazaar locks to steal.")))
+
+(define-vc-type-operation 'DIFF vc-type:bzr
+ (lambda (master rev1 rev2 simple?)
+ (vc-run-command master
+ (get-vc-diff-options simple?)
+ "bzr"
+ "diff"
+ (and (not simple?)
+ (decorated-string-append "--diff-options="
+ " "
+ ""
+ (gc-vc-diff-switches master)))
+ (and (or rev1 rev2)
+ (if (and rev1 rev2)
+ (string-append "-r" rev1 ".." rev2)
+ (string-append "-r" (or rev1 rev2) "..")))
+ (file-pathname (vc-master-workfile master)))
+ (> (buffer-length (get-vc-diff-buffer simple?)) 0)))
+
+(define-vc-type-operation 'PRINT-LOG vc-type:bzr
+ (lambda (master)
+ (vc-run-command master '() "bzr" "log"
+ (file-pathname (vc-master-workfile master)))))
+
+(define-vc-type-operation 'CHECK-LOG-ENTRY vc-type:bzr
+ (lambda (master log-buffer)
+ master log-buffer
+ unspecific))
+
+(define-vc-type-operation 'CHECK-HEADERS vc-type:bzr
+ (lambda (master buffer)
+ master buffer
+ #f))
+
+(define-vc-type-operation 'MODE-LINE-STATUS vc-type:bzr
+ (lambda (master buffer)
+ buffer
+ (if (vc-backend-workfile-modified? master)
+ " bzr **"
+ " bzr --")))
+\f
+(define (bzr-rev-switch revision)
+ (and revision
+ (list "-r" revision)))
+
+(define (bzr-directory workfile)
+ (let ((dir (merge-pathnames (directory-pathname workfile)))
+ (bzr (pathname-as-directory ".bzr")))
+ (let loop ((path (pathname-directory dir)))
+ (let ((dir* (merge-pathnames bzr (pathname-new-directory dir path))))
+ (cond ((file-directory? dir*) dir*)
+ ((pair? (cdr path)) (loop (except-last-pair path)))
+ (else #f))))))
+
+(define (%bzr-workfile-versioned? workfile)
+ (%bzr-ls-test workfile "--versioned"))
+
+(define (%bzr-workfile-ignored? workfile)
+ (%bzr-ls-test workfile "--ignored"))
+
+(define (%bzr-ls-test workfile option)
+ (let ((result (%bzr-run-command workfile "ls" "--non-recursive" option)))
+ (and result
+ (re-string-search-forward (string-append "^"
+ (re-quote-string
+ (file-namestring workfile))
+ "$")
+ result))))
+
+(define (%bzr-cached-command master key command . args)
+ (%bzr-workfile-cache master key
+ (lambda (workfile)
+ (apply %bzr-run-command workfile command args))))
+
+(define (%bzr-run-command workfile command . args)
+ (let ((directory (directory-pathname workfile)))
+ (let ((program (os/find-program "bzr" directory #!default #f)))
+ (and program
+ (let ((port (open-output-string)))
+ (let ((status
+ (run-synchronous-subprocess
+ program
+ (cons command args)
+ 'output port
+ 'working-directory directory)))
+ (and (eqv? status 0)
+ (get-output-string port))))))))
+
+(define (%bzr-workfile-cache master key procedure)
+ (let ((workfile (vc-master-workfile master)))
+ (read-cached-value-1 master key workfile
+ (lambda (time)
+ time
+ (procedure workfile)))))
+\f
+(define (get-bzr-status master #!optional required?)
+ (%bzr-workfile-cache master 'GET-STATUS
+ (lambda (workfile)
+ (or (parse-bzr-status
+ (%bzr-run-command workfile "status" "--short"
+ (file-namestring workfile)))
+ (cond ((%bzr-master-valid? master)
+ (make-bzr-status 'VERSIONED 'UNMODIFIED #f))
+ (else
+ (if (if (default-object? required?) #f required?)
+ (error "Unable to determine Bazaar status of file:"
+ workfile))
+ #f))))))
+
+(define (parse-bzr-status status)
+ (and status
+ (not (string-null? status))
+ (let ((regs (re-string-match "[ +---R?CP][ NDKM][ *] " status #f)))
+ (and regs
+ (make-bzr-status
+ (decode-bzr-status-0 (string-ref status 0))
+ (decode-bzr-status-1 (string-ref status 1))
+ (decode-bzr-status-2 (string-ref status 2)))))))
+
+(define-record-type <bzr-status>
+ (make-bzr-status type mod-type execute-changed?)
+ bzr-status?
+ (type bzr-status-type)
+ (mod-type bzr-status-mod-type)
+ (execute-changed? bzr-status-execute-changed?))
+
+(define (bzr-status-modified? status)
+ (not (eq? (bzr-status-mod-type status) 'UNMODIFIED)))
+
+(define (decode-bzr-status-0 char)
+ (case char
+ ((#\space #\+) 'VERSIONED)
+ ((#\-) 'UNVERSIONED)
+ ((#\R) 'RENAMED)
+ ((#\?) 'UNKNOWN)
+ ((#\C) 'CONFLICTED)
+ ((#\P) 'PENDING-MERGE)
+ (else (error "Unknown status char 0:" char))))
+
+(define (decode-bzr-status-1 char)
+ (case char
+ ((#\space) 'UNMODIFIED)
+ ((#\N) 'CREATED)
+ ((#\D) 'DELETED)
+ ((#\K) 'KIND-CHANGED)
+ ((#\M) 'MODIFIED)
+ (else (error "Unknown status char 1:" char))))
+
+(define (decode-bzr-status-2 char)
+ (case char
+ ((#\space) #f)
+ ((#\*) #t)
+ (else (error "Unknown status char 2:" char))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id$
+
+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 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: CVS
+
+(declare (usual-integrations))
+\f
+(define vc-type:cvs
+ (make-vc-type 'CVS "CVS" "\$Id\$"))
+
+(define (cvs-master? master)
+ (eq? vc-type:cvs (vc-master-type master)))
+
+(define (cvs-directory workfile)
+ (subdirectory-pathname workfile "CVS"))
+
+(define (get-cvs-workfile-revision master error?)
+ (let ((tokens (find-cvs-entry master)))
+ (if tokens
+ (cadr tokens)
+ (and error?
+ (error "Workfile has no version:" (vc-master-workfile master))))))
+
+(define (find-cvs-entry master)
+ (let ((pathname (vc-master-pathname master)))
+ (read-cached-value-1 master 'CVS-ENTRY pathname
+ (lambda (time)
+ time
+ (%find-cvs-entry pathname (vc-master-workfile master))))))
+
+(define (%find-cvs-entry pathname workfile)
+ (let ((line
+ (find-cvs-line pathname
+ (string-append "/" (file-namestring workfile) "/"))))
+ (and line
+ (let ((tokens (cdr (burst-string line #\/ #f))))
+ (and (fix:= 5 (length tokens))
+ tokens)))))
+
+(define (cvs-workfile-protected? workfile)
+ (string-prefix? "-r-"
+ (file-attributes/mode-string (file-attributes workfile))))
+
+(define (cvs-file-edited? master)
+ (let ((pathname
+ (merge-pathnames "Baserev"
+ (directory-pathname (vc-master-pathname master)))))
+ (read-cached-value-1 master 'CVS-FILE-EDITED? pathname
+ (lambda (time)
+ time
+ (find-cvs-line pathname
+ (string-append
+ "B"
+ (file-namestring (vc-master-workfile master))
+ "/"))))))
+
+(define (find-cvs-line pathname prefix)
+ (and (file-readable? pathname)
+ (call-with-input-file pathname
+ (lambda (port)
+ (let loop ()
+ (let ((line (read-line port)))
+ (and (not (eof-object? line))
+ (if (string-prefix? prefix line)
+ line
+ (loop)))))))))
+\f
+(define (cvs-status master)
+ (if (vc-cvs-stay-local? master)
+ (if (vc-backend-workfile-modified? master)
+ 'LOCALLY-MODIFIED
+ 'UP-TO-DATE)
+ (get-cvs-status master
+ (lambda (m)
+ (if (re-search-forward "^File: [^ \t]+[ \t]+Status: \\(.*\\)" m)
+ (convert-cvs-status
+ (extract-string (re-match-start 1) (re-match-end 1)))
+ 'UNKNOWN)))))
+
+(define (cvs-default-revision master)
+ (get-cvs-status master
+ (lambda (m)
+ (and (re-search-forward cvs-status-regexp m)
+ (extract-string (re-match-start 2) (re-match-end 2))))))
+
+(define cvs-status-regexp
+ "\\(RCS Version\\|RCS Revision\\|Repository revision\\):[ \t]+\\([0-9.]+\\)")
+
+(define (get-cvs-status master parse-output)
+ (vc-run-command master
+ `((BUFFER " *vc-status*"))
+ "cvs" "status"
+ (file-pathname (vc-master-workfile master)))
+ (parse-output (buffer-start (find-or-create-buffer " *vc-status*"))))
+
+(define (convert-cvs-status status)
+ (cond ((string-ci=? status "Up-to-date")
+ 'UP-TO-DATE)
+ ((string-ci=? status "Locally Modified")
+ 'LOCALLY-MODIFIED)
+ ((or (string-ci=? status "Locally Added")
+ (string-ci=? status "New file!"))
+ 'LOCALLY-ADDED)
+ ((string-ci=? status "Locally Removed")
+ 'LOCALLY-REMOVED)
+ ((or (string-ci=? status "Needs Checkout")
+ (string-ci=? status "Needs Patch"))
+ 'NEEDS-CHECKOUT)
+ ((string-ci=? status "Needs Merge")
+ 'NEEDS-MERGE)
+ ((or (string-ci=? status "File had conflicts on merge")
+ (string-ci=? status "Unresolved Conflict"))
+ 'UNRESOLVED-CONFLICT)
+ (else
+ 'UNKNOWN)))
+
+(define (cvs-rev-switch revision)
+ (and revision
+ (list "-r" revision)))
+
+(define (vc-cvs-stay-local? master)
+ (ref-variable vc-cvs-stay-local (vc-workfile-buffer master #f)))
+
+(define (vc-cvs-workfile-mtime-string master)
+ (read-cached-value-2 master 'CVS-MTIME-STRING
+ (vc-master-pathname master)
+ (vc-master-workfile master)
+ (lambda (tm tw)
+ (and tm tw
+ (let ((entry (find-cvs-entry master)))
+ (and entry
+ (caddr entry)))))))
+
+(define (set-vc-cvs-workfile-mtime-string! master tm tw modified?)
+ (if (and tm tw (not modified?))
+ (begin
+ ;; This breaks the READ-CACHED-VALUE-2 abstraction:
+ (vc-master-put! master 'CVS-MTIME-STRING
+ (vector (file-time->global-ctime-string tw) tm tw))
+ (let ((buffer (pathname->buffer (vc-master-workfile master))))
+ (if buffer
+ (vc-mode-line master buffer))))))
+\f
+(define-vc-type-operation 'RELEASE vc-type:cvs
+ (lambda ()
+ (and (= 0 (vc-run-command #f '() "cvs" "-v"))
+ (re-search-forward "^Concurrent Versions System (CVS) \\([0-9.]+\\)"
+ (buffer-start (get-vc-command-buffer)))
+ (extract-string (re-match-start 1) (re-match-end 1)))))
+
+(define-vc-type-operation 'FIND-MASTER vc-type:cvs
+ (lambda (workfile control-dir)
+ (let ((entries-file (merge-pathnames "Entries" control-dir)))
+ (and (%find-cvs-entry entries-file workfile)
+ (make-vc-master vc-type:cvs entries-file workfile)))))
+
+(define-vc-type-operation 'VALID? vc-type:cvs
+ (lambda (master)
+ (get-cvs-workfile-revision master #f)))
+
+(define-vc-type-operation 'DEFAULT-REVISION vc-type:cvs
+ (lambda (master)
+ (cvs-default-revision master)))
+
+(define-vc-type-operation 'WORKFILE-REVISION vc-type:cvs
+ (lambda (master)
+ (get-cvs-workfile-revision master #t)))
+
+(define-vc-type-operation 'LOCKING-USER vc-type:cvs
+ (lambda (master revision)
+ ;; The workfile is "locked" if it is modified.
+ ;; We consider the workfile's owner to be the locker.
+ (and (or (not revision)
+ (equal? revision (vc-backend-workfile-revision master)))
+ (or (not
+ (let ((t1 (file-modification-time (vc-master-workfile master)))
+ (t2 (vc-cvs-workfile-mtime-string master)))
+ (and t1 t2
+ (string=? (file-time->global-ctime-string t1) t2))))
+ (cvs-file-edited? master))
+ (let ((attributes (file-attributes (vc-master-workfile master))))
+ (and attributes
+ (unix/uid->string (file-attributes/uid attributes)))))))
+
+(define-vc-type-operation 'WORKFILE-MODIFIED? vc-type:cvs
+ (lambda (master)
+ (read-cached-value-2 master 'MODIFIED?
+ (vc-master-pathname master)
+ (vc-master-workfile master)
+ (lambda (tm tw)
+ (if (and tm tw
+ (let ((ts (vc-cvs-workfile-mtime-string master)))
+ (and ts
+ (string=? ts (file-time->global-ctime-string tw)))))
+ #f
+ (or (vc-cvs-stay-local? master)
+ (let ((modified? (vc-backend-diff master #f #f #t)))
+ (set-vc-cvs-workfile-mtime-string! master tm tw modified?)
+ modified?)))))))
+\f
+(define-vc-type-operation 'NEXT-ACTION vc-type:cvs
+ (lambda (master)
+ (case (cvs-status master)
+ ((UP-TO-DATE)
+ (if (or (vc-workfile-buffer-modified? master)
+ (cvs-file-edited? master))
+ 'CHECKIN
+ 'UNMODIFIED))
+ ((NEEDS-CHECKOUT NEEDS-MERGE) 'MERGE)
+ ((LOCALLY-MODIFIED LOCALLY-ADDED LOCALLY-REMOVED) 'CHECKIN)
+ ((UNRESOLVED-CONFLICT) 'RESOLVE-CONFLICT)
+ (else
+ (error "Unable to determine CVS status of file:"
+ (vc-master-workfile master))))))
+
+(define-vc-type-operation 'KEEP-WORKFILES? vc-type:cvs
+ (lambda (master)
+ master
+ #t))
+
+(define-vc-type-operation 'WORKFILE-STATUS-STRING vc-type:cvs
+ (lambda (master)
+ (case (cvs-status master)
+ ((LOCALLY-MODIFIED) "modified")
+ ((LOCALLY-ADDED) "added")
+ ((NEEDS-CHECKOUT) "patch")
+ ((NEEDS-MERGE) "merge")
+ ((UNRESOLVED-CONFLICT) "conflict")
+ (else #f))))
+
+(define-vc-type-operation 'CONTROL-DIRECTORY vc-type:cvs
+ (lambda (directory)
+ (let ((cd (cvs-directory directory)))
+ (and (file-directory? cd)
+ cd))))
+
+(define-vc-type-operation 'STEAL vc-type:cvs
+ (lambda (master revision)
+ master revision
+ (error "You cannot steal a CVS lock; there are no CVS locks to steal.")))
+
+(define-vc-type-operation 'REGISTER vc-type:cvs
+ (lambda (workfile revision comment keep?)
+ revision keep? ;always keep file.
+ (with-vc-command-message workfile "Registering"
+ (lambda ()
+ (vc-run-command workfile '() "cvs" "add"
+ "-m" comment
+ (file-pathname workfile))))))
+\f
+(define-vc-type-operation 'CHECKOUT vc-type:cvs
+ (lambda (master revision lock? workfile)
+ (let ((workfile* (file-pathname (vc-master-workfile master))))
+ (with-vc-command-message master "Checking out"
+ (lambda ()
+ (cond (workfile
+ ;; CVS makes it difficult to check a file out into
+ ;; anything but the working file.
+ (delete-file-no-errors workfile)
+ (vc-run-shell-command master '() "cvs" "update" "-p"
+ (cvs-rev-switch revision)
+ workfile*
+ ">"
+ workfile))
+ (revision
+ (vc-run-command master '() "cvs" (and lock? "-w") "update"
+ (cvs-rev-switch revision)
+ workfile*))
+ (else
+ (vc-run-command master '() "cvs" "edit" workfile*))))))))
+
+(define-vc-type-operation 'CHECKIN vc-type:cvs
+ (lambda (master revision comment keep?)
+ keep?
+ (with-vc-command-message master "Checking in"
+ (lambda ()
+ (bind-condition-handler (list condition-type:editor-error)
+ (lambda (condition)
+ condition
+ (if (eq? 'NEEDS-MERGE (cvs-status master))
+ ;; The CVS output will be on top of this message.
+ (error "Type C-x 0 C-x C-q to merge in changes.")))
+ (lambda ()
+ ;; Explicit check-in to the trunk requires a double check-in
+ ;; (first unexplicit) (CVS-1.3). [This is copied from Emacs
+ ;; 20.6, but I don't understand it. -- CPH]
+ (if (and revision
+ (not (equal? revision
+ (vc-backend-workfile-revision master)))
+ (trunk-revision? revision))
+ (vc-run-command master '() "cvs" "commit"
+ "-m" "#intermediate"
+ (file-pathname (vc-master-workfile master))))
+ (vc-run-command master '() "cvs" "commit"
+ (cvs-rev-switch revision)
+ "-m" comment
+ (file-pathname (vc-master-workfile master)))))
+ ;; If this was an explicit check-in, remove the sticky tag.
+ (if revision
+ (vc-run-command master '() "cvs" "update" "-A"
+ (file-pathname (vc-master-workfile master))))))))
+
+(define-vc-type-operation 'REVERT vc-type:cvs
+ (lambda (master)
+ (with-vc-command-message master "Reverting"
+ (lambda ()
+ (let ((workfile (vc-master-workfile master)))
+ (if (cvs-file-edited? master)
+ (vc-run-command master '() "cvs" "unedit"
+ (file-pathname workfile))
+ (begin
+ (delete-file-no-errors workfile)
+ (vc-run-command master '() "cvs" "update"
+ (file-pathname workfile)))))))))
+\f
+(define-vc-type-operation 'DIFF vc-type:cvs
+ (lambda (master rev1 rev2 simple?)
+ (= 1
+ (vc-run-command master
+ (get-vc-diff-options simple?)
+ "cvs"
+ "diff"
+ (if simple?
+ (and (diff-brief-available?) "--brief")
+ (gc-vc-diff-switches master))
+ (and rev1 (string-append "-r" rev1))
+ (and rev2 (string-append "-r" rev2))
+ (file-pathname (vc-master-workfile master))))))
+
+(define-vc-type-operation 'PRINT-LOG vc-type:cvs
+ (lambda (master)
+ (vc-run-command master '() "cvs" "log"
+ (file-pathname (vc-master-workfile master)))))
+
+(define-vc-type-operation 'CHECK-LOG-ENTRY vc-type:cvs
+ (lambda (master log-buffer)
+ master log-buffer
+ unspecific))
+
+(define-vc-type-operation 'CHECK-HEADERS vc-type:cvs
+ (lambda (master buffer)
+ master
+ (check-rcs-headers buffer)))
+
+(define (cvs-backend-merge-news master)
+ (with-vc-command-message master "Merging changes into"
+ (lambda ()
+ (let ((workfile (vc-master-workfile master)))
+ (vc-run-command master '() "cvs" "update" (file-pathname workfile))
+ (let ((buffer (get-vc-command-buffer))
+ (fn (re-quote-string (file-namestring workfile))))
+ (cond ((re-search-forward
+ (string-append "^\\([CMUP]\\) " fn)
+ (buffer-start buffer))
+ (char=? #\C (extract-right-char (re-match-start 0))))
+ ((re-search-forward
+ (string-append fn
+ " already contains the differences between ")
+ (buffer-start buffer))
+ ;; Special case: file contents in sync with repository
+ ;; anyhow:
+ #f)
+ (else
+ (pop-up-buffer buffer #f)
+ (error "Couldn't analyze cvs update result."))))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id$
+
+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 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: RCS
+
+(declare (usual-integrations))
+\f
+(define vc-type:rcs
+ ;; Splitting up string constant prevents RCS from expanding this
+ ;; keyword.
+ (make-vc-type 'RCS "RCS" "\$Id\$"))
+
+(define (rcs-master? master)
+ (eq? vc-type:rcs (vc-master-type master)))
+
+(define (rcs-directory workfile)
+ (subdirectory-pathname workfile "RCS"))
+
+(define (get-rcs-admin master)
+ (let ((pathname (vc-master-pathname master)))
+ (read-cached-value-1 master 'RCS-ADMIN pathname
+ (lambda (time) time (parse-rcs-admin pathname)))))
+
+(define (check-rcs-headers buffer)
+ (re-search-forward (string-append "\\$[A-Za-z\300-\326\330-\366\370-\377]+"
+ "\\(: [\t -#%-\176\240-\377]*\\)?\\$")
+ (buffer-start buffer)
+ (buffer-end buffer)))
+
+(define (rcs-rev-switch switch revision)
+ (if revision
+ (string-append switch revision)
+ switch))
+
+(define (rcs-mtime-switch master)
+ (and (ref-variable vc-rcs-preserve-mod-times
+ (pathname->buffer (->workfile master)))
+ "-M"))
+
+(define-vc-type-operation 'RELEASE vc-type:rcs
+ (lambda ()
+ (and (= 0 (vc-run-command #f '() "rcs" "-V"))
+ (re-search-forward "^RCS version \\([0-9.]+ *.*\\)"
+ (buffer-start (get-vc-command-buffer)))
+ (extract-string (re-match-start 1) (re-match-end 1)))))
+
+(define-vc-type-operation 'FIND-MASTER vc-type:rcs
+ (lambda (workfile control-dir)
+ (let ((try
+ (lambda (transform)
+ (let ((master-file (transform workfile)))
+ (and (file-exists? master-file)
+ (make-vc-master vc-type:rcs master-file workfile)))))
+ (in-control-dir
+ (lambda (pathname)
+ (merge-pathnames (file-pathname pathname) control-dir)))
+ (rcs-file
+ (lambda (pathname)
+ (merge-pathnames (string-append (file-namestring pathname) ",v")
+ (directory-pathname pathname)))))
+ (or (try (lambda (workfile) (rcs-file (in-control-dir workfile))))
+ (try in-control-dir)
+ (try rcs-file)))))
+
+(define-vc-type-operation 'VALID? vc-type:rcs
+ (lambda (master)
+ (file-exists? (vc-master-pathname master))))
+\f
+(define-vc-type-operation 'DEFAULT-REVISION vc-type:rcs
+ (lambda (master)
+ (let ((delta (rcs-find-delta (get-rcs-admin master) #f #f)))
+ (and delta
+ (rcs-delta/number delta)))))
+
+(define-vc-type-operation 'WORKFILE-REVISION vc-type:rcs
+ (lambda (master)
+ (let ((workfile (vc-master-workfile master)))
+ (read-cached-value-1 master 'RCS-WORKFILE-REVISION workfile
+ (lambda (time)
+ time
+ (let ((parse-buffer
+ (lambda (buffer)
+ (let ((start (buffer-start buffer))
+ (end (buffer-end buffer)))
+ (let ((find-keyword
+ (lambda (keyword)
+ (let ((mark
+ (search-forward
+ (string-append "$" keyword ":")
+ start end #f)))
+ (and mark
+ (skip-chars-forward " " mark end #f)))))
+ (get-revision
+ (lambda (start)
+ (let ((end
+ (skip-chars-forward "0-9." start end)))
+ (and (mark< start end)
+ (let ((revision
+ (extract-string start end)))
+ (let ((length
+ (rcs-number-length revision)))
+ (and (> length 2)
+ (even? length)
+ (rcs-number-head revision
+ (- length 1)
+ #f)))))))))
+ (cond ((or (find-keyword "Id") (find-keyword "Header"))
+ => (lambda (mark)
+ (get-revision
+ (skip-chars-forward
+ " "
+ (skip-chars-forward "^ " mark end)
+ end))))
+ ((find-keyword "Revision") => get-revision)
+ (else #f)))))))
+ (let ((buffer (pathname->buffer workfile)))
+ (if buffer
+ (parse-buffer buffer)
+ (call-with-temporary-buffer " *VC-temp*"
+ (lambda (buffer)
+ (catch-file-errors (lambda (condition) condition #f)
+ (lambda ()
+ (read-buffer buffer workfile #f)
+ (parse-buffer buffer)))))))))))))
+
+(define-vc-type-operation 'WORKFILE-MODIFIED? vc-type:rcs
+ (lambda (master)
+ (read-cached-value-2 master 'MODIFIED?
+ (vc-master-pathname master)
+ (vc-master-workfile master)
+ (lambda (tm tw)
+ tm tw
+ (vc-backend-diff master #f #f #t)))))
+
+(define-vc-type-operation 'NEXT-ACTION vc-type:rcs
+ (lambda (master)
+ (let ((owner (vc-backend-locking-user master #f)))
+ (cond ((not owner) 'CHECKOUT)
+ ((string=? owner (current-user-name)) 'CHECKIN)
+ (else 'STEAL-LOCK)))))
+\f
+(define-vc-type-operation 'KEEP-WORKFILES? vc-type:rcs
+ (lambda (master)
+ (ref-variable vc-keep-workfiles (vc-workfile-buffer master #f))))
+
+(define-vc-type-operation 'WORKFILE-STATUS-STRING vc-type:rcs
+ (lambda (master)
+ (vc-backend-locking-user master #f)))
+
+(define-vc-type-operation 'LOCKING-USER vc-type:rcs
+ (lambda (master revision)
+ (let ((admin (get-rcs-admin master)))
+ (let ((delta
+ (rcs-find-delta admin
+ (or revision
+ (vc-backend-workfile-revision master))
+ #f)))
+ (and delta
+ (let loop ((locks (rcs-admin/locks admin)))
+ (and (not (null? locks))
+ (if (eq? delta (cdar locks))
+ (caar locks)
+ (loop (cdr locks))))))))))
+
+(define-vc-type-operation 'CONTROL-DIRECTORY vc-type:rcs
+ (lambda (directory)
+ (let ((cd (rcs-directory directory)))
+ (and (file-directory? cd)
+ cd))))
+
+(define-vc-type-operation 'REGISTER vc-type:rcs
+ (lambda (workfile revision comment keep?)
+ (with-vc-command-message workfile "Registering"
+ (lambda ()
+ (vc-run-command workfile '() "ci"
+ (and (vc-release? vc-type:rcs "5.6.4") "-i")
+ (rcs-rev-switch (cond ((not keep?) "-r")
+ ((eq? 'LOCK keep?) "-l")
+ (else "-u"))
+ revision)
+ (rcs-mtime-switch workfile)
+ (string-append "-t-" comment)
+ workfile)))))
+
+(define-vc-type-operation 'CHECKOUT vc-type:rcs
+ (lambda (master revision lock? workfile)
+ (let ((revision (or revision (vc-backend-workfile-revision master))))
+ (with-vc-command-message master "Checking out"
+ (lambda ()
+ (if workfile
+ ;; RCS makes it difficult to check a file out into anything
+ ;; but the working file.
+ (begin
+ (delete-file-no-errors workfile)
+ (vc-run-shell-command master '() "co"
+ (rcs-rev-switch "-p" revision)
+ (vc-master-workfile master)
+ ">"
+ workfile)
+ (set-file-modes! workfile (if lock? #o644 #o444)))
+ (vc-run-command master '() "co"
+ (rcs-rev-switch (if lock? "-l" "-r") revision)
+ (rcs-mtime-switch master)
+ (vc-master-workfile master))))))))
+
+(define-vc-type-operation 'CHECKIN vc-type:rcs
+ (lambda (master revision comment keep?)
+ (with-vc-command-message master "Checking in"
+ (lambda ()
+ (vc-run-command master '() "ci"
+ ;; If available, use the secure check-in option.
+ (and (vc-release? vc-type:rcs "5.6.4") "-j")
+ (rcs-rev-switch (if keep? "-u" "-r") revision)
+ (rcs-mtime-switch master)
+ (string-append "-m" comment)
+ (vc-master-workfile master))))))
+\f
+(define-vc-type-operation 'REVERT vc-type:rcs
+ (lambda (master)
+ (with-vc-command-message master "Reverting"
+ (lambda ()
+ (vc-run-command master '() "co"
+ "-f" "-u"
+ (rcs-mtime-switch master)
+ (vc-master-workfile master))))))
+
+(define-vc-type-operation 'STEAL vc-type:rcs
+ (lambda (master revision)
+ (if (not (vc-release? vc-type:rcs "5.6.2"))
+ (error "Unable to steal locks with this version of RCS."))
+ (let ((revision (or revision (vc-backend-workfile-revision master))))
+ (with-vc-command-message master "Stealing lock on"
+ (lambda ()
+ (vc-run-command master '() "rcs"
+ "-M"
+ (rcs-rev-switch "-u" revision)
+ (rcs-rev-switch "-l" revision)
+ (vc-master-workfile master)))))))
+
+(define-vc-type-operation 'DIFF vc-type:rcs
+ (lambda (master rev1 rev2 simple?)
+ (= 1
+ (vc-run-command master
+ (get-vc-diff-options simple?)
+ "rcsdiff"
+ "-q"
+ (if (and rev1 rev2)
+ (list (string-append "-r" rev1)
+ (string-append "-r" rev2))
+ (let ((rev
+ (or rev1 rev2
+ (vc-backend-workfile-revision master))))
+ (and rev
+ (string-append "-r" rev))))
+ (if simple?
+ (and (diff-brief-available?) "--brief")
+ (gc-vc-diff-switches master))
+ (vc-master-workfile master)))))
+
+(define-vc-type-operation 'PRINT-LOG vc-type:rcs
+ (lambda (master)
+ (vc-run-command master '() "rlog" (vc-master-workfile master))))
+
+(define-vc-type-operation 'CHECK-LOG-ENTRY vc-type:rcs
+ (lambda (master log-buffer)
+ master log-buffer
+ unspecific))
+
+(define-vc-type-operation 'CHECK-HEADERS vc-type:rcs
+ (lambda (master buffer)
+ master
+ (check-rcs-headers buffer)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id$
+
+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 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
+
+(declare (usual-integrations))
+\f
+(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)))
+\f
+(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)))))))
+\f
+(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)))
+\f
+(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))
+\f
+(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))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: vc.scm,v 1.113 2008/08/28 19:39:19 riastradh Exp $
+$Id$
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
maybe))))
(values good maybe))))
\f
-;;;; RCS Commands
-
-(define vc-type:rcs
- ;; Splitting up string constant prevents RCS from expanding this
- ;; keyword.
- (make-vc-type 'RCS "RCS" "\$Id\$"))
-
-(define (rcs-master? master)
- (eq? vc-type:rcs (vc-master-type master)))
-
-(define (rcs-directory workfile)
- (subdirectory-pathname workfile "RCS"))
-
-(define (get-rcs-admin master)
- (let ((pathname (vc-master-pathname master)))
- (read-cached-value-1 master 'RCS-ADMIN pathname
- (lambda (time) time (parse-rcs-admin pathname)))))
-
-(define (check-rcs-headers buffer)
- (re-search-forward (string-append "\\$[A-Za-z\300-\326\330-\366\370-\377]+"
- "\\(: [\t -#%-\176\240-\377]*\\)?\\$")
- (buffer-start buffer)
- (buffer-end buffer)))
-
-(define (rcs-rev-switch switch revision)
- (if revision
- (string-append switch revision)
- switch))
-
-(define (rcs-mtime-switch master)
- (and (ref-variable vc-rcs-preserve-mod-times
- (pathname->buffer (->workfile master)))
- "-M"))
-
-(define-vc-type-operation 'RELEASE vc-type:rcs
- (lambda ()
- (and (= 0 (vc-run-command #f '() "rcs" "-V"))
- (re-search-forward "^RCS version \\([0-9.]+ *.*\\)"
- (buffer-start (get-vc-command-buffer)))
- (extract-string (re-match-start 1) (re-match-end 1)))))
-
-(define-vc-type-operation 'FIND-MASTER vc-type:rcs
- (lambda (workfile control-dir)
- (let ((try
- (lambda (transform)
- (let ((master-file (transform workfile)))
- (and (file-exists? master-file)
- (make-vc-master vc-type:rcs master-file workfile)))))
- (in-control-dir
- (lambda (pathname)
- (merge-pathnames (file-pathname pathname) control-dir)))
- (rcs-file
- (lambda (pathname)
- (merge-pathnames (string-append (file-namestring pathname) ",v")
- (directory-pathname pathname)))))
- (or (try (lambda (workfile) (rcs-file (in-control-dir workfile))))
- (try in-control-dir)
- (try rcs-file)))))
-
-(define-vc-type-operation 'VALID? vc-type:rcs
- (lambda (master)
- (file-exists? (vc-master-pathname master))))
-\f
-(define-vc-type-operation 'DEFAULT-REVISION vc-type:rcs
- (lambda (master)
- (let ((delta (rcs-find-delta (get-rcs-admin master) #f #f)))
- (and delta
- (rcs-delta/number delta)))))
-
-(define-vc-type-operation 'WORKFILE-REVISION vc-type:rcs
- (lambda (master)
- (let ((workfile (vc-master-workfile master)))
- (read-cached-value-1 master 'RCS-WORKFILE-REVISION workfile
- (lambda (time)
- time
- (let ((parse-buffer
- (lambda (buffer)
- (let ((start (buffer-start buffer))
- (end (buffer-end buffer)))
- (let ((find-keyword
- (lambda (keyword)
- (let ((mark
- (search-forward
- (string-append "$" keyword ":")
- start end #f)))
- (and mark
- (skip-chars-forward " " mark end #f)))))
- (get-revision
- (lambda (start)
- (let ((end
- (skip-chars-forward "0-9." start end)))
- (and (mark< start end)
- (let ((revision
- (extract-string start end)))
- (let ((length
- (rcs-number-length revision)))
- (and (> length 2)
- (even? length)
- (rcs-number-head revision
- (- length 1)
- #f)))))))))
- (cond ((or (find-keyword "Id") (find-keyword "Header"))
- => (lambda (mark)
- (get-revision
- (skip-chars-forward
- " "
- (skip-chars-forward "^ " mark end)
- end))))
- ((find-keyword "Revision") => get-revision)
- (else #f)))))))
- (let ((buffer (pathname->buffer workfile)))
- (if buffer
- (parse-buffer buffer)
- (call-with-temporary-buffer " *VC-temp*"
- (lambda (buffer)
- (catch-file-errors (lambda (condition) condition #f)
- (lambda ()
- (read-buffer buffer workfile #f)
- (parse-buffer buffer)))))))))))))
-
-(define-vc-type-operation 'WORKFILE-MODIFIED? vc-type:rcs
- (lambda (master)
- (read-cached-value-2 master 'MODIFIED?
- (vc-master-pathname master)
- (vc-master-workfile master)
- (lambda (tm tw)
- tm tw
- (vc-backend-diff master #f #f #t)))))
-
-(define-vc-type-operation 'NEXT-ACTION vc-type:rcs
- (lambda (master)
- (let ((owner (vc-backend-locking-user master #f)))
- (cond ((not owner) 'CHECKOUT)
- ((string=? owner (current-user-name)) 'CHECKIN)
- (else 'STEAL-LOCK)))))
-\f
-(define-vc-type-operation 'KEEP-WORKFILES? vc-type:rcs
- (lambda (master)
- (ref-variable vc-keep-workfiles (vc-workfile-buffer master #f))))
-
-(define-vc-type-operation 'WORKFILE-STATUS-STRING vc-type:rcs
- (lambda (master)
- (vc-backend-locking-user master #f)))
-
-(define-vc-type-operation 'LOCKING-USER vc-type:rcs
- (lambda (master revision)
- (let ((admin (get-rcs-admin master)))
- (let ((delta
- (rcs-find-delta admin
- (or revision
- (vc-backend-workfile-revision master))
- #f)))
- (and delta
- (let loop ((locks (rcs-admin/locks admin)))
- (and (not (null? locks))
- (if (eq? delta (cdar locks))
- (caar locks)
- (loop (cdr locks))))))))))
-
-(define-vc-type-operation 'CONTROL-DIRECTORY vc-type:rcs
- (lambda (directory)
- (let ((cd (rcs-directory directory)))
- (and (file-directory? cd)
- cd))))
-
-(define-vc-type-operation 'REGISTER vc-type:rcs
- (lambda (workfile revision comment keep?)
- (with-vc-command-message workfile "Registering"
- (lambda ()
- (vc-run-command workfile '() "ci"
- (and (vc-release? vc-type:rcs "5.6.4") "-i")
- (rcs-rev-switch (cond ((not keep?) "-r")
- ((eq? 'LOCK keep?) "-l")
- (else "-u"))
- revision)
- (rcs-mtime-switch workfile)
- (string-append "-t-" comment)
- workfile)))))
-
-(define-vc-type-operation 'CHECKOUT vc-type:rcs
- (lambda (master revision lock? workfile)
- (let ((revision (or revision (vc-backend-workfile-revision master))))
- (with-vc-command-message master "Checking out"
- (lambda ()
- (if workfile
- ;; RCS makes it difficult to check a file out into anything
- ;; but the working file.
- (begin
- (delete-file-no-errors workfile)
- (vc-run-shell-command master '() "co"
- (rcs-rev-switch "-p" revision)
- (vc-master-workfile master)
- ">"
- workfile)
- (set-file-modes! workfile (if lock? #o644 #o444)))
- (vc-run-command master '() "co"
- (rcs-rev-switch (if lock? "-l" "-r") revision)
- (rcs-mtime-switch master)
- (vc-master-workfile master))))))))
-
-(define-vc-type-operation 'CHECKIN vc-type:rcs
- (lambda (master revision comment keep?)
- (with-vc-command-message master "Checking in"
- (lambda ()
- (vc-run-command master '() "ci"
- ;; If available, use the secure check-in option.
- (and (vc-release? vc-type:rcs "5.6.4") "-j")
- (rcs-rev-switch (if keep? "-u" "-r") revision)
- (rcs-mtime-switch master)
- (string-append "-m" comment)
- (vc-master-workfile master))))))
-\f
-(define-vc-type-operation 'REVERT vc-type:rcs
- (lambda (master)
- (with-vc-command-message master "Reverting"
- (lambda ()
- (vc-run-command master '() "co"
- "-f" "-u"
- (rcs-mtime-switch master)
- (vc-master-workfile master))))))
-
-(define-vc-type-operation 'STEAL vc-type:rcs
- (lambda (master revision)
- (if (not (vc-release? vc-type:rcs "5.6.2"))
- (error "Unable to steal locks with this version of RCS."))
- (let ((revision (or revision (vc-backend-workfile-revision master))))
- (with-vc-command-message master "Stealing lock on"
- (lambda ()
- (vc-run-command master '() "rcs"
- "-M"
- (rcs-rev-switch "-u" revision)
- (rcs-rev-switch "-l" revision)
- (vc-master-workfile master)))))))
-
-(define-vc-type-operation 'DIFF vc-type:rcs
- (lambda (master rev1 rev2 simple?)
- (= 1
- (vc-run-command master
- (get-vc-diff-options simple?)
- "rcsdiff"
- "-q"
- (if (and rev1 rev2)
- (list (string-append "-r" rev1)
- (string-append "-r" rev2))
- (let ((rev
- (or rev1 rev2
- (vc-backend-workfile-revision master))))
- (and rev
- (string-append "-r" rev))))
- (if simple?
- (and (diff-brief-available?) "--brief")
- (gc-vc-diff-switches master))
- (vc-master-workfile master)))))
-
-(define-vc-type-operation 'PRINT-LOG vc-type:rcs
- (lambda (master)
- (vc-run-command master '() "rlog" (vc-master-workfile master))))
-
-(define-vc-type-operation 'CHECK-LOG-ENTRY vc-type:rcs
- (lambda (master log-buffer)
- master log-buffer
- unspecific))
-
-(define-vc-type-operation 'CHECK-HEADERS vc-type:rcs
- (lambda (master buffer)
- master
- (check-rcs-headers buffer)))
-\f
-;;;; CVS Commands
-
-(define vc-type:cvs
- (make-vc-type 'CVS "CVS" "\$Id\$"))
-
-(define (cvs-master? master)
- (eq? vc-type:cvs (vc-master-type master)))
-
-(define (cvs-directory workfile)
- (subdirectory-pathname workfile "CVS"))
-
-(define (get-cvs-workfile-revision master error?)
- (let ((tokens (find-cvs-entry master)))
- (if tokens
- (cadr tokens)
- (and error?
- (error "Workfile has no version:" (vc-master-workfile master))))))
-
-(define (find-cvs-entry master)
- (let ((pathname (vc-master-pathname master)))
- (read-cached-value-1 master 'CVS-ENTRY pathname
- (lambda (time)
- time
- (%find-cvs-entry pathname (vc-master-workfile master))))))
-
-(define (%find-cvs-entry pathname workfile)
- (let ((line
- (find-cvs-line pathname
- (string-append "/" (file-namestring workfile) "/"))))
- (and line
- (let ((tokens (cdr (burst-string line #\/ #f))))
- (and (fix:= 5 (length tokens))
- tokens)))))
-
-(define (cvs-workfile-protected? workfile)
- (string-prefix? "-r-"
- (file-attributes/mode-string (file-attributes workfile))))
-
-(define (cvs-file-edited? master)
- (let ((pathname
- (merge-pathnames "Baserev"
- (directory-pathname (vc-master-pathname master)))))
- (read-cached-value-1 master 'CVS-FILE-EDITED? pathname
- (lambda (time)
- time
- (find-cvs-line pathname
- (string-append
- "B"
- (file-namestring (vc-master-workfile master))
- "/"))))))
-
-(define (find-cvs-line pathname prefix)
- (and (file-readable? pathname)
- (call-with-input-file pathname
- (lambda (port)
- (let loop ()
- (let ((line (read-line port)))
- (and (not (eof-object? line))
- (if (string-prefix? prefix line)
- line
- (loop)))))))))
-\f
-(define (cvs-status master)
- (if (vc-cvs-stay-local? master)
- (if (vc-backend-workfile-modified? master)
- 'LOCALLY-MODIFIED
- 'UP-TO-DATE)
- (get-cvs-status master
- (lambda (m)
- (if (re-search-forward "^File: [^ \t]+[ \t]+Status: \\(.*\\)" m)
- (convert-cvs-status
- (extract-string (re-match-start 1) (re-match-end 1)))
- 'UNKNOWN)))))
-
-(define (cvs-default-revision master)
- (get-cvs-status master
- (lambda (m)
- (and (re-search-forward cvs-status-regexp m)
- (extract-string (re-match-start 2) (re-match-end 2))))))
-
-(define cvs-status-regexp
- "\\(RCS Version\\|RCS Revision\\|Repository revision\\):[ \t]+\\([0-9.]+\\)")
-
-(define (get-cvs-status master parse-output)
- (vc-run-command master
- `((BUFFER " *vc-status*"))
- "cvs" "status"
- (file-pathname (vc-master-workfile master)))
- (parse-output (buffer-start (find-or-create-buffer " *vc-status*"))))
-
-(define (convert-cvs-status status)
- (cond ((string-ci=? status "Up-to-date")
- 'UP-TO-DATE)
- ((string-ci=? status "Locally Modified")
- 'LOCALLY-MODIFIED)
- ((or (string-ci=? status "Locally Added")
- (string-ci=? status "New file!"))
- 'LOCALLY-ADDED)
- ((string-ci=? status "Locally Removed")
- 'LOCALLY-REMOVED)
- ((or (string-ci=? status "Needs Checkout")
- (string-ci=? status "Needs Patch"))
- 'NEEDS-CHECKOUT)
- ((string-ci=? status "Needs Merge")
- 'NEEDS-MERGE)
- ((or (string-ci=? status "File had conflicts on merge")
- (string-ci=? status "Unresolved Conflict"))
- 'UNRESOLVED-CONFLICT)
- (else
- 'UNKNOWN)))
-
-(define (cvs-rev-switch revision)
- (and revision
- (list "-r" revision)))
-
-(define (vc-cvs-stay-local? master)
- (ref-variable vc-cvs-stay-local (vc-workfile-buffer master #f)))
-
-(define (vc-cvs-workfile-mtime-string master)
- (read-cached-value-2 master 'CVS-MTIME-STRING
- (vc-master-pathname master)
- (vc-master-workfile master)
- (lambda (tm tw)
- (and tm tw
- (let ((entry (find-cvs-entry master)))
- (and entry
- (caddr entry)))))))
-
-(define (set-vc-cvs-workfile-mtime-string! master tm tw modified?)
- (if (and tm tw (not modified?))
- (begin
- ;; This breaks the READ-CACHED-VALUE-2 abstraction:
- (vc-master-put! master 'CVS-MTIME-STRING
- (vector (file-time->global-ctime-string tw) tm tw))
- (let ((buffer (pathname->buffer (vc-master-workfile master))))
- (if buffer
- (vc-mode-line master buffer))))))
-\f
-(define-vc-type-operation 'RELEASE vc-type:cvs
- (lambda ()
- (and (= 0 (vc-run-command #f '() "cvs" "-v"))
- (re-search-forward "^Concurrent Versions System (CVS) \\([0-9.]+\\)"
- (buffer-start (get-vc-command-buffer)))
- (extract-string (re-match-start 1) (re-match-end 1)))))
-
-(define-vc-type-operation 'FIND-MASTER vc-type:cvs
- (lambda (workfile control-dir)
- (let ((entries-file (merge-pathnames "Entries" control-dir)))
- (and (%find-cvs-entry entries-file workfile)
- (make-vc-master vc-type:cvs entries-file workfile)))))
-
-(define-vc-type-operation 'VALID? vc-type:cvs
- (lambda (master)
- (get-cvs-workfile-revision master #f)))
-
-(define-vc-type-operation 'DEFAULT-REVISION vc-type:cvs
- (lambda (master)
- (cvs-default-revision master)))
-
-(define-vc-type-operation 'WORKFILE-REVISION vc-type:cvs
- (lambda (master)
- (get-cvs-workfile-revision master #t)))
-
-(define-vc-type-operation 'LOCKING-USER vc-type:cvs
- (lambda (master revision)
- ;; The workfile is "locked" if it is modified.
- ;; We consider the workfile's owner to be the locker.
- (and (or (not revision)
- (equal? revision (vc-backend-workfile-revision master)))
- (or (not
- (let ((t1 (file-modification-time (vc-master-workfile master)))
- (t2 (vc-cvs-workfile-mtime-string master)))
- (and t1 t2
- (string=? (file-time->global-ctime-string t1) t2))))
- (cvs-file-edited? master))
- (let ((attributes (file-attributes (vc-master-workfile master))))
- (and attributes
- (unix/uid->string (file-attributes/uid attributes)))))))
-
-(define-vc-type-operation 'WORKFILE-MODIFIED? vc-type:cvs
- (lambda (master)
- (read-cached-value-2 master 'MODIFIED?
- (vc-master-pathname master)
- (vc-master-workfile master)
- (lambda (tm tw)
- (if (and tm tw
- (let ((ts (vc-cvs-workfile-mtime-string master)))
- (and ts
- (string=? ts (file-time->global-ctime-string tw)))))
- #f
- (or (vc-cvs-stay-local? master)
- (let ((modified? (vc-backend-diff master #f #f #t)))
- (set-vc-cvs-workfile-mtime-string! master tm tw modified?)
- modified?)))))))
-\f
-(define-vc-type-operation 'NEXT-ACTION vc-type:cvs
- (lambda (master)
- (case (cvs-status master)
- ((UP-TO-DATE)
- (if (or (vc-workfile-buffer-modified? master)
- (cvs-file-edited? master))
- 'CHECKIN
- 'UNMODIFIED))
- ((NEEDS-CHECKOUT NEEDS-MERGE) 'MERGE)
- ((LOCALLY-MODIFIED LOCALLY-ADDED LOCALLY-REMOVED) 'CHECKIN)
- ((UNRESOLVED-CONFLICT) 'RESOLVE-CONFLICT)
- (else
- (error "Unable to determine CVS status of file:"
- (vc-master-workfile master))))))
-
-(define-vc-type-operation 'KEEP-WORKFILES? vc-type:cvs
- (lambda (master)
- master
- #t))
-
-(define-vc-type-operation 'WORKFILE-STATUS-STRING vc-type:cvs
- (lambda (master)
- (case (cvs-status master)
- ((LOCALLY-MODIFIED) "modified")
- ((LOCALLY-ADDED) "added")
- ((NEEDS-CHECKOUT) "patch")
- ((NEEDS-MERGE) "merge")
- ((UNRESOLVED-CONFLICT) "conflict")
- (else #f))))
-
-(define-vc-type-operation 'CONTROL-DIRECTORY vc-type:cvs
- (lambda (directory)
- (let ((cd (cvs-directory directory)))
- (and (file-directory? cd)
- cd))))
-
-(define-vc-type-operation 'STEAL vc-type:cvs
- (lambda (master revision)
- master revision
- (error "You cannot steal a CVS lock; there are no CVS locks to steal.")))
-
-(define-vc-type-operation 'REGISTER vc-type:cvs
- (lambda (workfile revision comment keep?)
- revision keep? ;always keep file.
- (with-vc-command-message workfile "Registering"
- (lambda ()
- (vc-run-command workfile '() "cvs" "add"
- "-m" comment
- (file-pathname workfile))))))
-\f
-(define-vc-type-operation 'CHECKOUT vc-type:cvs
- (lambda (master revision lock? workfile)
- (let ((workfile* (file-pathname (vc-master-workfile master))))
- (with-vc-command-message master "Checking out"
- (lambda ()
- (cond (workfile
- ;; CVS makes it difficult to check a file out into
- ;; anything but the working file.
- (delete-file-no-errors workfile)
- (vc-run-shell-command master '() "cvs" "update" "-p"
- (cvs-rev-switch revision)
- workfile*
- ">"
- workfile))
- (revision
- (vc-run-command master '() "cvs" (and lock? "-w") "update"
- (cvs-rev-switch revision)
- workfile*))
- (else
- (vc-run-command master '() "cvs" "edit" workfile*))))))))
-
-(define-vc-type-operation 'CHECKIN vc-type:cvs
- (lambda (master revision comment keep?)
- keep?
- (with-vc-command-message master "Checking in"
- (lambda ()
- (bind-condition-handler (list condition-type:editor-error)
- (lambda (condition)
- condition
- (if (eq? 'NEEDS-MERGE (cvs-status master))
- ;; The CVS output will be on top of this message.
- (error "Type C-x 0 C-x C-q to merge in changes.")))
- (lambda ()
- ;; Explicit check-in to the trunk requires a double check-in
- ;; (first unexplicit) (CVS-1.3). [This is copied from Emacs
- ;; 20.6, but I don't understand it. -- CPH]
- (if (and revision
- (not (equal? revision
- (vc-backend-workfile-revision master)))
- (trunk-revision? revision))
- (vc-run-command master '() "cvs" "commit"
- "-m" "#intermediate"
- (file-pathname (vc-master-workfile master))))
- (vc-run-command master '() "cvs" "commit"
- (cvs-rev-switch revision)
- "-m" comment
- (file-pathname (vc-master-workfile master)))))
- ;; If this was an explicit check-in, remove the sticky tag.
- (if revision
- (vc-run-command master '() "cvs" "update" "-A"
- (file-pathname (vc-master-workfile master))))))))
-
-(define-vc-type-operation 'REVERT vc-type:cvs
- (lambda (master)
- (with-vc-command-message master "Reverting"
- (lambda ()
- (let ((workfile (vc-master-workfile master)))
- (if (cvs-file-edited? master)
- (vc-run-command master '() "cvs" "unedit"
- (file-pathname workfile))
- (begin
- (delete-file-no-errors workfile)
- (vc-run-command master '() "cvs" "update"
- (file-pathname workfile)))))))))
-\f
-(define-vc-type-operation 'DIFF vc-type:cvs
- (lambda (master rev1 rev2 simple?)
- (= 1
- (vc-run-command master
- (get-vc-diff-options simple?)
- "cvs"
- "diff"
- (if simple?
- (and (diff-brief-available?) "--brief")
- (gc-vc-diff-switches master))
- (and rev1 (string-append "-r" rev1))
- (and rev2 (string-append "-r" rev2))
- (file-pathname (vc-master-workfile master))))))
-
-(define-vc-type-operation 'PRINT-LOG vc-type:cvs
- (lambda (master)
- (vc-run-command master '() "cvs" "log"
- (file-pathname (vc-master-workfile master)))))
-
-(define-vc-type-operation 'CHECK-LOG-ENTRY vc-type:cvs
- (lambda (master log-buffer)
- master log-buffer
- unspecific))
-
-(define-vc-type-operation 'CHECK-HEADERS vc-type:cvs
- (lambda (master buffer)
- master
- (check-rcs-headers buffer)))
-
-(define (cvs-backend-merge-news master)
- (with-vc-command-message master "Merging changes into"
- (lambda ()
- (let ((workfile (vc-master-workfile master)))
- (vc-run-command master '() "cvs" "update" (file-pathname workfile))
- (let ((buffer (get-vc-command-buffer))
- (fn (re-quote-string (file-namestring workfile))))
- (cond ((re-search-forward
- (string-append "^\\([CMUP]\\) " fn)
- (buffer-start buffer))
- (char=? #\C (extract-right-char (re-match-start 0))))
- ((re-search-forward
- (string-append fn
- " already contains the differences between ")
- (buffer-start buffer))
- ;; Special case: file contents in sync with repository
- ;; anyhow:
- #f)
- (else
- (pop-up-buffer buffer #f)
- (error "Couldn't analyze cvs update result."))))))))
-\f
-;;;; Subversion Commands
-
-(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)))
-\f
-(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)))))))
-\f
-(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)))
-\f
-(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))
-\f
-(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))
-\f
-;;;; Bazaar Commands
-
-(define vc-type:bzr
- (make-vc-type 'BZR "bzr" "\$Id\$"))
-
-(define-vc-type-operation 'RELEASE vc-type:bzr
- (lambda ()
- (and (= 0 (vc-run-command #f '() "bzr" "--version"))
- (let ((m (buffer-start (get-vc-command-buffer))))
- (re-match-forward "Bazaar (bzr) \\(.+\\)$"
- m
- (line-end m 0)))
- (extract-string (re-match-start 1) (re-match-end 1)))))
-
-(define-vc-type-operation 'CONTROL-DIRECTORY vc-type:bzr
- (lambda (directory)
- (let ((cd (subdirectory-pathname directory ".bzr")))
- (if (file-directory? cd)
- cd
- 'SEARCH-PARENT))))
-
-(define-vc-type-operation 'FIND-MASTER vc-type:bzr
- (lambda (workfile control-dir)
- (let ((master
- (make-vc-master vc-type:bzr
- (merge-pathnames "README" control-dir)
- workfile)))
- (and (%bzr-master-valid? master)
- master))))
-
-(define-vc-type-operation 'VALID? vc-type:bzr
- (lambda (master)
- (%bzr-master-valid? master)))
-
-(define (%bzr-master-valid? master)
- (%bzr-workfile-cache master 'WORKFILE-VERSIONED? %bzr-workfile-versioned?))
-
-(define-vc-type-operation 'DEFAULT-REVISION vc-type:bzr
- (lambda (master)
- master
- #f))
-
-(define-vc-type-operation 'WORKFILE-REVISION vc-type:bzr
- (lambda (master)
- (bzr-workfile-revision master)))
-
-(define-vc-type-operation 'LOCKING-USER vc-type:bzr
- (lambda (master revision)
- revision ;ignore
- ;; The workfile is "locked" if it is modified.
- ;; We consider the workfile's owner to be the locker.
- (let ((status (get-bzr-status master)))
- (and status
- (bzr-status-modified? status)
- (unix/uid->string
- (file-attributes/uid
- (file-attributes (vc-master-workfile master))))))))
-
-(define (bzr-workfile-revision master)
- (let ((result
- (%bzr-cached-command master 'WORKFILE-REVISION
- "log" "--limit=1" "--line"
- (file-namestring (vc-master-workfile master)))))
- (and result
- (let ((regs (re-string-match "\\([0-9]+\\): \\([^ ]+\\) " result)))
- (and regs
- (re-match-extract result regs 1))))))
-
-(define-vc-type-operation 'WORKFILE-MODIFIED? vc-type:bzr
- (lambda (master)
- (let ((status (get-bzr-status master)))
- (and status
- (bzr-status-modified? status)))))
-\f
-(define-vc-type-operation 'NEXT-ACTION vc-type:bzr
- (lambda (master)
- (let ((status (get-bzr-status master #t)))
- (let ((type (bzr-status-mod-type status)))
- (case type
- ((UNMODIFIED)
- (let ((type (bzr-status-type status)))
- (case type
- ((VERSIONED)
- (if (vc-workfile-buffer-modified? master)
- 'CHECKIN
- 'UNMODIFIED))
- ((UNVERSIONED UNKNOWN) #f)
- ((RENAMED) 'CHECKIN)
- ((CONFLICTED) 'RESOLVE-CONFLICT)
- ((PENDING-MERGE) 'PENDING-MERGE)
- (else (error "Unknown Bazaar status type:" type)))))
- ((CREATED DELETED KIND-CHANGED MODIFIED) 'CHECKIN)
- (else (error "Unknown Bazaar status type:" type)))))))
-
-(define-vc-type-operation 'KEEP-WORKFILES? vc-type:bzr
- (lambda (master)
- master
- #t))
-
-(define-vc-type-operation 'WORKFILE-STATUS-STRING vc-type:bzr
- (lambda (master)
- (let ((status (get-bzr-status master)))
- (and status
- (let ((type (bzr-status-type status)))
- (case type
- ((VERSIONED)
- (case (bzr-status-mod-type status)
- ((CREATED) "created")
- ((DELETED) "deleted")
- ((KIND-CHANGED) "kind-changed")
- ((MODIFIED) "modified")
- (else #f)))
- ((UNVERSIONED) "unversioned")
- ((RENAMED) "renamed")
- ((UNKNOWN) "unknown")
- ((CONFLICTED) "conflicted")
- ((PENDING-MERGE) "pending-merge")
- (else #f)))))))
-
-(define-vc-type-operation 'REGISTER vc-type:bzr
- (lambda (workfile revision comment keep?)
- revision comment keep?
- (with-vc-command-message workfile "Registering"
- (lambda ()
- (vc-run-command workfile '() "bzr" "add" (file-pathname workfile))))))
-
-(define-vc-type-operation 'CHECKOUT vc-type:bzr
- (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 '() "bzr" "cat"
- (bzr-rev-switch revision)
- workfile*
- ">"
- workfile))
- (else
- (vc-run-command master '() "bzr" "update"
- (bzr-rev-switch revision)
- workfile*))))))))
-
-(define-vc-type-operation 'CHECKIN vc-type:bzr
- (lambda (master revision comment keep?)
- keep?
- (with-vc-command-message master "Checking in"
- (lambda ()
- (vc-run-command master '() "bzr" "commit"
- (bzr-rev-switch revision)
- "--message" comment
- (file-pathname (vc-master-workfile master)))))))
-\f
-(define-vc-type-operation 'REVERT vc-type:bzr
- (lambda (master)
- (with-vc-command-message master "Reverting"
- (lambda ()
- (vc-run-command master '() "bzr" "revert"
- (file-pathname (vc-master-workfile master)))))))
-
-(define-vc-type-operation 'STEAL vc-type:bzr
- (lambda (master revision)
- master revision
- (error "There are no Bazaar locks to steal.")))
-
-(define-vc-type-operation 'DIFF vc-type:bzr
- (lambda (master rev1 rev2 simple?)
- (vc-run-command master
- (get-vc-diff-options simple?)
- "bzr"
- "diff"
- (and (not simple?)
- (decorated-string-append "--diff-options="
- " "
- ""
- (gc-vc-diff-switches master)))
- (and (or rev1 rev2)
- (if (and rev1 rev2)
- (string-append "-r" rev1 ".." rev2)
- (string-append "-r" (or rev1 rev2) "..")))
- (file-pathname (vc-master-workfile master)))
- (> (buffer-length (get-vc-diff-buffer simple?)) 0)))
-
-(define-vc-type-operation 'PRINT-LOG vc-type:bzr
- (lambda (master)
- (vc-run-command master '() "bzr" "log"
- (file-pathname (vc-master-workfile master)))))
-
-(define-vc-type-operation 'CHECK-LOG-ENTRY vc-type:bzr
- (lambda (master log-buffer)
- master log-buffer
- unspecific))
-
-(define-vc-type-operation 'CHECK-HEADERS vc-type:bzr
- (lambda (master buffer)
- master buffer
- #f))
-
-(define-vc-type-operation 'MODE-LINE-STATUS vc-type:bzr
- (lambda (master buffer)
- buffer
- (if (vc-backend-workfile-modified? master)
- " bzr **"
- " bzr --")))
-\f
-(define (bzr-rev-switch revision)
- (and revision
- (list "-r" revision)))
-
-(define (bzr-directory workfile)
- (let ((dir (merge-pathnames (directory-pathname workfile)))
- (bzr (pathname-as-directory ".bzr")))
- (let loop ((path (pathname-directory dir)))
- (let ((dir* (merge-pathnames bzr (pathname-new-directory dir path))))
- (cond ((file-directory? dir*) dir*)
- ((pair? (cdr path)) (loop (except-last-pair path)))
- (else #f))))))
-
-(define (%bzr-workfile-versioned? workfile)
- (%bzr-ls-test workfile "--versioned"))
-
-(define (%bzr-workfile-ignored? workfile)
- (%bzr-ls-test workfile "--ignored"))
-
-(define (%bzr-ls-test workfile option)
- (let ((result (%bzr-run-command workfile "ls" "--non-recursive" option)))
- (and result
- (re-string-search-forward (string-append "^"
- (re-quote-string
- (file-namestring workfile))
- "$")
- result))))
-
-(define (%bzr-cached-command master key command . args)
- (%bzr-workfile-cache master key
- (lambda (workfile)
- (apply %bzr-run-command workfile command args))))
-
-(define (%bzr-run-command workfile command . args)
- (let ((directory (directory-pathname workfile)))
- (let ((program (os/find-program "bzr" directory #!default #f)))
- (and program
- (let ((port (open-output-string)))
- (let ((status
- (run-synchronous-subprocess
- program
- (cons command args)
- 'output port
- 'working-directory directory)))
- (and (eqv? status 0)
- (get-output-string port))))))))
-
-(define (%bzr-workfile-cache master key procedure)
- (let ((workfile (vc-master-workfile master)))
- (read-cached-value-1 master key workfile
- (lambda (time)
- time
- (procedure workfile)))))
-\f
-(define (get-bzr-status master #!optional required?)
- (%bzr-workfile-cache master 'GET-STATUS
- (lambda (workfile)
- (or (parse-bzr-status
- (%bzr-run-command workfile "status" "--short"
- (file-namestring workfile)))
- (cond ((%bzr-master-valid? master)
- (make-bzr-status 'VERSIONED 'UNMODIFIED #f))
- (else
- (if (if (default-object? required?) #f required?)
- (error "Unable to determine Bazaar status of file:"
- workfile))
- #f))))))
-
-(define (parse-bzr-status status)
- (and status
- (not (string-null? status))
- (let ((regs (re-string-match "[ +---R?CP][ NDKM][ *] " status #f)))
- (and regs
- (make-bzr-status
- (decode-bzr-status-0 (string-ref status 0))
- (decode-bzr-status-1 (string-ref status 1))
- (decode-bzr-status-2 (string-ref status 2)))))))
-
-(define-record-type <bzr-status>
- (make-bzr-status type mod-type execute-changed?)
- bzr-status?
- (type bzr-status-type)
- (mod-type bzr-status-mod-type)
- (execute-changed? bzr-status-execute-changed?))
-
-(define (bzr-status-modified? status)
- (not (eq? (bzr-status-mod-type status) 'UNMODIFIED)))
-
-(define (decode-bzr-status-0 char)
- (case char
- ((#\space #\+) 'VERSIONED)
- ((#\-) 'UNVERSIONED)
- ((#\R) 'RENAMED)
- ((#\?) 'UNKNOWN)
- ((#\C) 'CONFLICTED)
- ((#\P) 'PENDING-MERGE)
- (else (error "Unknown status char 0:" char))))
-
-(define (decode-bzr-status-1 char)
- (case char
- ((#\space) 'UNMODIFIED)
- ((#\N) 'CREATED)
- ((#\D) 'DELETED)
- ((#\K) 'KIND-CHANGED)
- ((#\M) 'MODIFIED)
- (else (error "Unknown status char 1:" char))))
-
-(define (decode-bzr-status-2 char)
- (case char
- ((#\space) #f)
- ((#\*) #t)
- (else (error "Unknown status char 2:" char))))
-\f
;;;; Command Execution
(define (vc-run-command master options command . arguments)
projects / mit-scheme.git / commitdiff