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
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
;;; Guile-Git --- GNU Guile bindings of libgit2
;;; Copyright © 2016 Amirouche Boubekki <amirouche@hypermove.net>
;;; Copyright © 2016, 2017 Erik Edrosa <erik.edrosa@gmail.com>
;;;
;;; This file is part of Guile-Git.
;;;
;;; Guile-Git 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 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Guile-Git 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 Guile-Git. If not, see <http://www.gnu.org/licenses/>.
(define-module (git branch)
#:use-module (ice-9 receive)
#:use-module (system foreign)
#:use-module (git bindings)
#:use-module (git reference)
#:use-module (git types)
#:export (BRANCH-LOCAL
BRANCH-REMOTE
BRANCH-ALL
branch-create
branch-create-from-annotated
branch-delete
branch-is-head?
branch-iterator-new
branch-list
branch-fold
branch-lookup
branch-move
branch-name
branch-next
branch-set-upstream
branch-upstream))
;;; branch https://libgit2.github.com/libgit2/#HEAD/group/branch
(define BRANCH-LOCAL 1)
(define BRANCH-REMOTE 2)
(define BRANCH-ALL (logior BRANCH-LOCAL BRANCH-REMOTE))
(define branch-create
(let ((proc (libgit2->procedure* "git_branch_create" `(* * * * ,int))))
(lambda (repository branch-name target force)
(let ((out (make-double-pointer)))
(proc out
(repository->pointer repository)
(string->pointer branch-name)
(commit->pointer target)
(if force 1 0))
(pointer->reference! (dereference-pointer out))))))
(define branch-create-from-annotated
(let ((proc (libgit2->procedure* "git_branch_create_from_annotated" `(* * * * ,int))))
(lambda (repository branch-name commit force)
(let ((out (make-double-pointer)))
(proc out
(repository->pointer repository)
(string->pointer branch-name)
(annotated-commit->pointer commit)
(if force 1 0))
(pointer->reference! (dereference-pointer out))))))
(define branch-delete
(let ((proc (libgit2->procedure* "git_branch_delete" '(*))))
(lambda (branch)
(proc (reference->pointer branch)))))
(define branch-is-head?
(let ((proc (libgit2->procedure int "git_branch_is_head" '(*))))
(lambda (branch)
(case (proc (reference->pointer branch))
((0) #f)
((1) #t)
(else => (lambda (code) (raise-git-error code)))))))
(define %branch-iterator-free (libgit2->pointer "git_branch_iterator_free"))
(define (pointer->branch-iterator! pointer)
(set-pointer-finalizer! pointer %branch-iterator-free)
(pointer->branch-iterator pointer))
(define branch-iterator-new
(let ((proc (libgit2->procedure* "git_branch_iterator_new" `(* * ,int))))
(lambda (repository flags)
(let ((out (make-double-pointer)))
(proc out (repository->pointer repository) flags)
(pointer->branch-iterator (dereference-pointer out))))))
(define branch-lookup
(let ((proc (libgit2->procedure* "git_branch_lookup" `(* * * ,int))))
(lambda* (repository branch-name #:optional (type BRANCH-ALL))
(let ((out (make-double-pointer)))
(proc out
(repository->pointer repository)
(string->pointer branch-name)
type)
(pointer->reference! (dereference-pointer out))))))
(define branch-move
(let ((proc (libgit2->procedure* "git_branch_move" `(* * * ,int))))
(lambda (reference new-branch-name force)
(let ((out (make-double-pointer)))
(proc out
(reference->pointer reference)
(string->pointer new-branch-name)
(if force 1 0))
(pointer->reference! (dereference-pointer out))))))
(define branch-name
(let ((proc (libgit2->procedure* "git_branch_name" '(* *))))
(lambda (reference)
(let ((out (make-double-pointer)))
(proc out (reference->pointer reference))
(pointer->string (dereference-pointer out))))))
(define branch-next
(let ((proc (libgit2->procedure* "git_branch_next" '(* * *))))
(lambda (iterator)
(let ((out (make-double-pointer))
(out-type (make-double-pointer)))
(proc out out-type (branch-iterator->pointer iterator))
(values (pointer->reference (dereference-pointer out))
(pointer-address (dereference-pointer out-type)))))))
(define branch-set-upstream
(let ((proc (libgit2->procedure* "git_branch_set_upstream" '(* *))))
(lambda (branch upstream-name)
(proc (reference->pointer branch) (string->pointer upstream-name)))))
(define branch-upstream
(let ((proc (libgit2->procedure* "git_branch_upstream" '(* *))))
(lambda (branch)
(let ((out (make-double-pointer)))
(proc out (reference->pointer branch))
(pointer->reference (dereference-pointer out))))))
(define* (branch-fold proc init repository #:optional (flag BRANCH-ALL))
(let ((iterator (branch-iterator-new repository flag)))
(let loop ((acc init))
(let ((branch (false-if-exception (branch-next iterator))))
(if branch
(loop (proc branch acc))
acc)))))
(define* (branch-list repository #:optional (flag BRANCH-ALL))
(branch-fold cons '() repository flag))
|
