257 lines
7.8 KiB
Scheme
257 lines
7.8 KiB
Scheme
#| -*-Scheme-*-
|
||
|
||
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
||
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
||
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
||
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
||
|
||
This file is part of MIT/GNU Scheme.
|
||
|
||
MIT/GNU Scheme is free software; you can redistribute it and/or modify
|
||
it under the terms of the GNU General Public License as published by
|
||
the Free Software Foundation; either version 2 of the License, or (at
|
||
your option) any later version.
|
||
|
||
MIT/GNU Scheme is distributed in the hope that it will be useful, but
|
||
WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
General Public License for more details.
|
||
|
||
You should have received a copy of the GNU General Public License
|
||
along with MIT/GNU Scheme; if not, write to the Free Software
|
||
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
||
USA.
|
||
|
||
|#
|
||
|
||
;;;; Version Control: git
|
||
|
||
|
||
|
||
(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))))))))
|