Coverage report: /home/ellis/comp/core/lib/vc/git.lisp

Kind	Covered	All	%
expression	29	235	12.3
branch	4	8	50.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; git.lisp --- Git VC

2

3

;;

4

5

;;; Code:

6

(in-package :vc/git)

7

8

(deferror git-error (vc-error) () (:auto t))

9

10

(defvar *git-program* (cli:find-exe "git"))

11

12

(defun run-git-command (cmd &optional args (output t) (wait t))

13

(unless (listp args) (setf args (list args)))

14

(setf args (mapcar #'vc/proto::namestring-or args)) ;; TODO 2024-05-10: slow

15

(sb-ext:run-program *git-program* (push cmd args) :output output :wait wait))

16

17

(defun git-url-p (url)

18

"Return nil if URL does not look like a URL to a git valid remote."

19

(let ((url-str (if (typep url 'pathname)

20

(namestring url)

21

url)))

22

(ppcre:scan '(:alternation

23

(:regex "\\.git$")

24

(:regex "^git://")

25

(:regex "^https://git\\.")

26

(:regex "^git@"))

27

url-str)))

28

29

(defun gitignore (&optional (path ".gitignore"))

30

(vc/proto::make-vc-ignore :path path :patterns (vc/proto::map-lines #'vc/proto::glob-path-match path)))

31

32

;; https://git-scm.com/docs/git-config

33

(defclass git-config (vc-config) ())

34

35

;; TODO 2024-08-22: read ini files

36

(defmethod find-config ((obj (eql :git)) &rest args &key (directory (user-homedir-pathname)))

37

(declare (ignore args))

38

(let ((*default-pathname-defaults* directory))

39

(when-let ((config (directory ".gitconfig")))

40

(car config))))

41

42

(defclass git-repo (vc-repo)

43

((index))) ;; working-directory

44

45

(defun make-git-repo (path &key init)

46

(let ((repo (make-instance 'git-repo :path path)))

47

(when init (vc-init repo))

48

repo))

49

50

(defmethod vc-type ((self git-repo)) :git)

51

52

(defmethod print-object ((self git-repo) stream)

53

(print-unreadable-object (self stream)

54

(format stream "~S" (vc-type self))

55

(when-let ((remotes (vc-remotes self)))

56

(format stream " ~A" remotes))))

57

58

(defmethod vc-init ((self (eql :git)))

59

(make-instance 'git-repo :path (pathname *default-pathname-defaults*)))

60

61

(defmethod vc-init ((self git-repo))

62

(let ((path (path self)))

63

(if (zerop (sb-ext:process-exit-code (run-git-command "init" path)))

64

(not (probe-file path))

65

(git-error "git init failed:" path))))

66

67

(defmethod vc-run ((self git-repo) (cmd string) &rest args)

68

(with-directory (path self)

69

(run-git-command cmd args)))

70

71

(defmethod vc-clone ((self git-repo) remote &key &allow-other-keys)

72

(with-slots (path) self

73

(sb-ext:process-exit-code (run-git-command "clone" (list remote path)))))

74

75

(defmethod vc-pull ((self git-repo) &optional remote)

76

(with-slots (path) self

77

(with-directory path

78

(sb-ext:process-exit-code (run-git-command "pull" `(,@(when remote (list remote))))))))

79

80

(defmethod vc-push ((self git-repo) &key remote branch set-upstream force all)

81

(with-slots (path) self

82

(with-directory path

83

(sb-ext:process-exit-code

84

(run-git-command "push" `(,@(when force '("--force"))

85

,@(when all '("--all"))

86

,@(when set-upstream '("-u"))

87

,@(when remote `(,remote))

88

,@(when branch `(,branch))))))))

89

90

(defmethod vc-commit ((self git-repo) msg &key &allow-other-keys)

91

(with-slots (path) self

92

(with-directory path

93

(sb-ext:process-exit-code (run-git-command "commit" `("-m" ,msg))))))

94

95

(defmethod vc-add ((self git-repo) &rest files)

96

(with-slots (path) self

97

(with-directory path

98

(sb-ext:process-exit-code (run-git-command "add" files)))))

99

100

(defmethod vc-remove ((self git-repo) &rest files)

101

(with-slots (path) self

102

(with-directory path

103

(sb-ext:process-exit-code (run-git-command "remove" files)))))

104

105

(defmethod vc-remote ((self git-repo) (cmd (eql :add)) &key (name "origin") url)

106

(run-git-command "remote" (list "add" name url)))

107

108

(defmethod vc-submodule ((self git-repo) (cmd (eql :add)) &key url)

109

(run-git-command "submodule" (list "add" url)))

110

111

(defmethod vc-submodule ((self git-repo) (cmd (eql :init)) &key)

112

(run-git-command "submodule" (list "init")))

113

114

(defmethod vc-submodule ((self git-repo) (cmd (eql :update)) &key init)

115

(run-git-command "submodule" `("update" ,@(when init '("--init")))))

116

117

(defmethod vc-remote ((self git-repo) (cmd null) &key name verbose)

118

(if name

119

(run-git-command "remote" `("show" ,name ,@(when verbose '("-v"))))

120

(run-git-command "remote")))

121

122

(defmethod vc-update ((self git-repo) &optional branch)

123

(run-git-command "checkout" (when branch (list branch))))

124

125

;; TODO

126

(defmethod vc-addremove ((self git-repo) &rest files)

127

(with-slots (path) self

128

(with-directory path

129

(sb-ext:process-exit-code (run-git-command "addremove" files)))))

130

131

(defmethod vc-status ((self git-repo) &key &allow-other-keys) (vc-run self "status"))

132

133

(defmethod vc-branch ((self git-repo)) (vc-run self "branch"))

134

135

(defmethod vc-diff ((a git-repo) (b git-repo) &key &allow-other-keys)

136

(vc-run a "diff" (vc-head a) (vc-head b)))

137

138

(defmethod id ((self git-repo))

139

(with-slots (path) self

140

(with-directory path

141

(with-open-stream (s (sb-ext:process-output (run-git-command "id")))

142

(with-output-to-string (str)

143

(loop for c = (read-char s nil nil)

144

while c

145

do (write-char c str))

146

str)))))

147

148

;; TODO 2023-12-29: does git have a cmdserver?

149

;; (declaim (inline make-git-client))

150

;; (defstruct git-client

151

;; (pid 0 :type fixnum :read-only t)

152

;; (pgid 0 :type fixnum)

153

;; (cwd (sb-posix:getcwd) :type string))