From: Chris Hanson Date: Sun, 21 Jun 2009 08:33:42 +0000 (-0700) Subject: Split vc type definitions into separate files. X-Git-Tag: 20100708-Gtk~376 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d9c4d20ca14c512bf74cddd2dbf7b240d0a5b7cd;p=mit-scheme.git Split vc type definitions into separate files. --- diff --git a/src/edwin/decls.scm b/src/edwin/decls.scm index 80dbd9870..ffb3803f0 100644 --- a/src/edwin/decls.scm +++ b/src/edwin/decls.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -42,15 +42,14 @@ USA. (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 #| @@ -226,6 +225,10 @@ USA. "undo" "unix" "vc" + "vc-rcs" + "vc-cvs" + "vc-svn" + "vc-bzr" "verilog" "vhdl" "webster" diff --git a/src/edwin/edwin.ldr b/src/edwin/edwin.ldr index c99d792aa..2c6bc9d40 100644 --- a/src/edwin/edwin.ldr +++ b/src/edwin/edwin.ldr @@ -1,6 +1,6 @@ #| -*-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, @@ -254,6 +254,10 @@ USA. (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) diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index 39715ad77..46f6fd092 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-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, @@ -1437,7 +1437,11 @@ USA. 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 diff --git a/src/edwin/vc-bzr.scm b/src/edwin/vc-bzr.scm new file mode 100644 index 000000000..f98c26cc0 --- /dev/null +++ b/src/edwin/vc-bzr.scm @@ -0,0 +1,347 @@ +#| -*-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)) + +(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))))) + +(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))))))) + +(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 --"))) + +(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))))) + +(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 + (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 diff --git a/src/edwin/vc-cvs.scm b/src/edwin/vc-cvs.scm new file mode 100644 index 000000000..a28398ee1 --- /dev/null +++ b/src/edwin/vc-cvs.scm @@ -0,0 +1,389 @@ +#| -*-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)) + +(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))))))))) + +(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)))))) + +(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?))))))) + +(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)))))) + +(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))))))))) + +(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 diff --git a/src/edwin/vc-rcs.scm b/src/edwin/vc-rcs.scm new file mode 100644 index 000000000..0bc8b6f3e --- /dev/null +++ b/src/edwin/vc-rcs.scm @@ -0,0 +1,296 @@ +#| -*-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)) + +(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)))) + +(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))))) + +(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)))))) + +(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 diff --git a/src/edwin/vc-svn.scm b/src/edwin/vc-svn.scm new file mode 100644 index 000000000..17ca5c873 --- /dev/null +++ b/src/edwin/vc-svn.scm @@ -0,0 +1,356 @@ +#| -*-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)) + +(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 + (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)) \ No newline at end of file diff --git a/src/edwin/vc.scm b/src/edwin/vc.scm index 4dd483233..8bb78cb8e 100644 --- a/src/edwin/vc.scm +++ b/src/edwin/vc.scm @@ -1,6 +1,6 @@ #| -*-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, @@ -1383,1282 +1383,6 @@ the value of vc-log-mode-hook." maybe)))) (values good maybe)))) -;;;; 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)))) - -(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))))) - -(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)))))) - -(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))) - -;;;; 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))))))))) - -(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)))))) - -(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?))))))) - -(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)))))) - -(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))))))))) - -(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.")))))))) - -;;;; 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))) - -(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 - (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)) - -;;;; 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))))) - -(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))))))) - -(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 --"))) - -(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))))) - -(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 - (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)))) - ;;;; Command Execution (define (vc-run-command master options command . arguments)