From 39d88d69d3f624593694627b1c4f2a860297af86 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 22 Jun 2009 00:28:39 -0700 Subject: [PATCH] Initial implementation of vc-git. --- src/edwin/decls.scm | 5 +- src/edwin/ed-ffi.scm | 7 +- src/edwin/edwin.ldr | 1 + src/edwin/edwin.pkg | 4 +- src/edwin/vc-git.scm | 257 +++++++++++++++++++++++++++++++++++++++++++ src/edwin/vc-rcs.scm | 3 + 6 files changed, 273 insertions(+), 4 deletions(-) create mode 100644 src/edwin/vc-git.scm diff --git a/src/edwin/decls.scm b/src/edwin/decls.scm index ffb3803f0..cd9a2ba0c 100644 --- a/src/edwin/decls.scm +++ b/src/edwin/decls.scm @@ -225,10 +225,11 @@ USA. "undo" "unix" "vc" - "vc-rcs" + "vc-bzr" "vc-cvs" + "vc-git" + "vc-rcs" "vc-svn" - "vc-bzr" "verilog" "vhdl" "webster" diff --git a/src/edwin/ed-ffi.scm b/src/edwin/ed-ffi.scm index 5b745b2d3..c1a1571a8 100644 --- a/src/edwin/ed-ffi.scm +++ b/src/edwin/ed-ffi.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: ed-ffi.scm,v 1.59 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, @@ -177,6 +177,11 @@ USA. ("utils" (edwin)) ("utlwin" (edwin window)) ("vc" (edwin vc)) + ("vc-bzr" (edwin vc)) + ("vc-cvs" (edwin vc)) + ("vc-git" (edwin vc)) + ("vc-rcs" (edwin vc)) + ("vc-svn" (edwin vc)) ("verilog" (edwin verilog)) ("vhdl" (edwin vhdl)) ("webster" (edwin)) diff --git a/src/edwin/edwin.ldr b/src/edwin/edwin.ldr index 2c6bc9d40..667257595 100644 --- a/src/edwin/edwin.ldr +++ b/src/edwin/edwin.ldr @@ -258,6 +258,7 @@ USA. (load "vc-cvs" (->environment '(EDWIN VC))) (load "vc-svn" (->environment '(EDWIN VC))) (load "vc-bzr" (->environment '(EDWIN VC))) + (load "vc-git" (->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 46f6fd092..3c5d4f888 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -1441,7 +1441,8 @@ USA. "vc-rcs" "vc-cvs" "vc-svn" - "vc-bzr") + "vc-bzr" + "vc-git") (parent (edwin)) (export (edwin) edwin-command$vc-diff @@ -1457,6 +1458,7 @@ USA. edwin-command$vc-version-diff edwin-command$vc-version-other-window edwin-mode$vc-log + edwin-variable$git-diff-switches edwin-variable$vc-checkin-hooks edwin-variable$vc-checkout-carefully edwin-variable$vc-command-messages diff --git a/src/edwin/vc-git.scm b/src/edwin/vc-git.scm new file mode 100644 index 000000000..5156290a5 --- /dev/null +++ b/src/edwin/vc-git.scm @@ -0,0 +1,257 @@ +#| -*-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: git + +(declare (usual-integrations)) + +(define vc-type:git + (make-vc-type 'GIT "git" "\$Id\$")) + +(define-vc-type-operation 'RELEASE vc-type:git + (lambda () + (and (= 0 (vc-run-command #f '() "git" "--version")) + (let ((m (buffer-start (get-vc-command-buffer)))) + (re-match-forward "git version \\(.+\\)$" + m + (line-end m 0))) + (extract-string (re-match-start 1) (re-match-end 1))))) + +(define-vc-type-operation 'CONTROL-DIRECTORY vc-type:git + (lambda (directory) + (let ((cd (subdirectory-pathname directory ".git"))) + (if (file-directory? cd) + cd + 'SEARCH-PARENT)))) + +(define-vc-type-operation 'FIND-MASTER vc-type:git + (lambda (workfile control-dir) + (and (%git-workfile-versioned? workfile) + (make-vc-master vc-type:git + (merge-pathnames "description" control-dir) + workfile)))) + +(define-vc-type-operation 'VALID? vc-type:git + (lambda (master) + (%git-workfile-versioned? (vc-master-workfile master)))) + +(define-vc-type-operation 'DEFAULT-REVISION vc-type:git + (lambda (master) + master + #f)) + +(define-vc-type-operation 'WORKFILE-REVISION vc-type:git + (lambda (master) + (let ((result + (%git-run-command (vc-master-workfile master) + "symbolic-ref" "HEAD"))) + (and result + (let ((regs + (re-string-match "^\\(refs/heads/\\)?\\(.+\\)$" result))) + (if regs + (re-match-extract result regs 2) + result)))))) + +(define-vc-type-operation 'LOCKING-USER vc-type:git + (lambda (master revision) + revision ;ignore + ;; The workfile is "locked" if it is modified. + ;; We consider the workfile's owner to be the locker. + (and (%git-workfile-modified? (vc-master-workfile master)) + (unix/uid->string + (file-attributes/uid + (file-attributes (vc-master-workfile master))))))) + +(define-vc-type-operation 'WORKFILE-MODIFIED? vc-type:git + (lambda (master) + (%git-workfile-modified? (vc-master-workfile master)))) + +(define-vc-type-operation 'NEXT-ACTION vc-type:git + (lambda (master) + (let ((status (%git-workfile-status (vc-master-workfile master)))) + (case status + ((UNVERSIONED UNKNOWN) #f) + ((UNMODIFIED) + (if (vc-workfile-buffer-modified? master) + 'CHECKIN + 'UNMODIFIED)) + ((ADDED COPIED DELETED MODIFIED RENAMED TYPE-CHANGED) 'CHECKIN) + ((UNMERGED) 'PENDING-MERGE) + (else (error "Unknown git status type:" status)))))) + +(define-vc-type-operation 'KEEP-WORKFILES? vc-type:git + (lambda (master) + master + #t)) + +(define-vc-type-operation 'WORKFILE-STATUS-STRING vc-type:git + (lambda (master) + (let ((status (%git-workfile-status (vc-master-workfile master)))) + (if (eq? status 'UNMODIFIED) + #f + (symbol->string status))))) + +(define-vc-type-operation 'REGISTER vc-type:git + (lambda (workfile revision comment keep?) + revision comment keep? + (with-vc-command-message workfile "Registering" + (lambda () + (vc-run-command workfile '() "git" "add" "--" + (file-pathname workfile)))))) + +(define-vc-type-operation 'CHECKOUT vc-type:git + (lambda (master revision lock? output-file) + lock? + (let ((workfile (file-pathname (vc-master-workfile master)))) + (with-vc-command-message master "Checking out" + (lambda () + (cond (output-file + (delete-file-no-errors output-file) + (vc-run-shell-command master '() "git" "show" + (string-append + (or revision "HEAD") + ":" + (enough-namestring + workfile + (directory-pathname + (vc-master-pathname master)))) + ">" + output-file)) + (else + (vc-run-command master '() "git" "checkout" + (or revision "HEAD") + "--" workfile)))))))) + +(define-vc-type-operation 'CHECKIN vc-type:git + (lambda (master revision comment keep?) + revision keep? + (with-vc-command-message master "Checking in" + (lambda () + (vc-run-command master '() "git" "commit" + "--message" comment + (file-pathname (vc-master-workfile master))))))) + +(define-vc-type-operation 'REVERT vc-type:git + (lambda (master) + (with-vc-command-message master "Reverting" + (lambda () + (vc-run-command master '() "git" "checkout" "HEAD" + "--" (file-pathname (vc-master-workfile master))))))) + +(define-vc-type-operation 'STEAL vc-type:git + (lambda (master revision) + master revision + (error "There are no git locks to steal."))) + +(define-vc-type-operation 'DIFF vc-type:git + (lambda (master rev1 rev2 simple?) + (if (and rev1 rev2) + (vc-run-command master (get-vc-diff-options simple?) + "git" "diff-tree" + "--exit-code" "-p" + (and (not simple?) + (ref-variable git-diff-switches + (vc-workfile-buffer master #f))) + rev1 rev2 + "--" (file-pathname (vc-master-workfile master))) + (vc-run-command master (get-vc-diff-options simple?) + "git" "diff-index" + "--exit-code" "-p" + (and (not simple?) + (ref-variable git-diff-switches + (vc-workfile-buffer master #f))) + (or rev1 "HEAD") + "--" (file-pathname (vc-master-workfile master)))) + (> (buffer-length (get-vc-diff-buffer simple?)) 0))) + +(define-variable git-diff-switches + "A list of strings specifying switches to pass to the `git diff' command." + '() + list-of-strings?) + +(define-vc-type-operation 'PRINT-LOG vc-type:git + (lambda (master) + (vc-run-command master '() "git" "log" "--follow" "--name-status" + "--" (file-pathname (vc-master-workfile master))))) + +(define-vc-type-operation 'CHECK-LOG-ENTRY vc-type:git + (lambda (master log-buffer) + master log-buffer + unspecific)) + +(define-vc-type-operation 'CHECK-HEADERS vc-type:git + (lambda (master buffer) + master buffer + #f)) + +(define (%git-workfile-status workfile) + (if (%git-run-command workfile "add" "--refresh" "--" + (file-namestring workfile)) + (let ((result + (%git-run-command workfile "diff-index" "-z" "HEAD" "--" + (file-namestring workfile)))) + (cond ((not result) 'UNKNOWN) + ((string-null? result) 'UNMODIFIED) + (else + (let ((regs + (re-string-match + "^:[0-7]+ [0-7]+ [0-9a-f]+ [0-9a-f]+ \\(.\\)[0-9]*\000" + result))) + (and regs + (let ((status + (string-ref (re-match-extract result regs 1) + 0))) + (case status + ((#\A) 'ADDED) + ((#\C) 'COPIED) + ((#\D) 'DELETED) + ((#\M) 'MODIFIED) + ((#\R) 'RENAMED) + ((#\T) 'TYPE-CHANGED) + ((#\U) 'UNMERGED) + (else (error "Unknown status:" status))))))))) + 'UNVERSIONED)) + +(define (%git-workfile-versioned? workfile) + (not (memq (%git-workfile-status workfile) '(UNKNOWN UNVERSIONED)))) + +(define (%git-workfile-modified? workfile) + (not (eq? (%git-workfile-status workfile) 'UNMODIFIED))) + +(define (%git-run-command workfile command . args) + (let ((directory (directory-pathname workfile))) + (let ((program (os/find-program "git" 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)))))))) \ No newline at end of file diff --git a/src/edwin/vc-rcs.scm b/src/edwin/vc-rcs.scm index 0bc8b6f3e..037e4d1ac 100644 --- a/src/edwin/vc-rcs.scm +++ b/src/edwin/vc-rcs.scm @@ -190,6 +190,9 @@ USA. (lambda (directory) (let ((cd (rcs-directory directory))) (and (file-directory? cd) + (any (lambda (pathname) + (string-suffix? ",v" (file-namestring pathname))) + (directory-read cd)) cd)))) (define-vc-type-operation 'REGISTER vc-type:rcs -- 2.25.1