cl-git/branch.lisp at main · fiddlerwoaroof/cl-git · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
(in-package :fwoar.cl-git)

(defun get-local-unpacked-branches (repository)
  (mapcar (data-lens:juxt #'pathname-name
                          (alexandria:compose #'serapeum:trim-whitespace
                                              #'alexandria:read-file-into-string))
          (uiop:directory*
           (merge-pathnames "refs/heads/*"
                            (root repository)))))

(defun get-local-packed-branches (repository)
  (let* ((packed-ref-file-name (merge-pathnames "packed-refs"
                                                (root repository))))
    (when (probe-file packed-ref-file-name)
      (with-open-file (s packed-ref-file-name)
        (loop for line = (read-line s nil)
              for parts = (partition #\space line)
              for branch-name = (second parts)
              while line
              unless (alexandria:starts-with-subseq "#" line)
                when (alexandria:starts-with-subseq "refs/heads" branch-name)
                  collect (list (subseq branch-name
                                        (1+ (position #\/ branch-name
                                                      :from-end t)))
                                (first parts)))))))

(defun get-local-branches (repository)
  (append (get-local-unpacked-branches repository)
          (get-local-packed-branches repository)))

(defgeneric branches (repository)
  (:method ((repository git-repository))
    (get-local-branches repository)))

(defgeneric branch (repository name)
  (:method ((repository git-repository) name)
    (second
     (find name (get-local-branches repository)
           :test 'equal
           :key 'car))))