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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
|
;;; Guile-Git --- GNU Guile bindings of libgit2
;;; Copyright © 2018, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 submodule)
#:use-module (system foreign)
#:use-module (git bindings)
#:use-module (git types)
#:use-module (git errors)
#:use-module (git structs)
#:export (repository-submodules
submodule?
submodule-lookup
submodule-name
submodule-path
submodule-owner
submodule-head-id
submodule-init
submodule-reload
submodule-add-setup
submodule-add-finalize
submodule-add-to-index
submodule-set-url!
submodule-set-branch!
submodule-update))
;; https://libgit2.org/libgit2/#HEAD/group/submodule
(define %submodule-free (libgit2->pointer "git_submodule_free"))
(define %submodule-owners
;; This table maps <submodule> records to their "owner", usually a
;; <repository> record. This is used to ensure that the lifetime of the
;; submodule is shorter than that of its owner so that 'submodule-owner'
;; always returns a valid object.
(make-weak-key-hash-table))
(define* (pointer->submodule! pointer #:optional owner)
(set-pointer-finalizer! pointer %submodule-free)
(let ((submodule (pointer->submodule pointer)))
(when owner
(hashq-set! %submodule-owners submodule owner))
submodule))
(define submodule-map
(let ((proc (libgit2->procedure* "git_submodule_foreach" '(* * *))))
(lambda (repository callback)
(let* ((result '())
(trampoline (lambda (submodule name payload)
;; We can't capture SUBMODULE here because its
;; lifetime is limited to the dynamic extent of
;; the 'git_submodule_foreach' call.
(set! result
(cons (callback (pointer->string name))
result))
0)))
(proc (repository->pointer repository)
(procedure->pointer int trampoline '(* * *))
%null-pointer)
(reverse result)))))
(define (repository-submodules repository)
"Return the list of submodule names of REPOSITORY."
(submodule-map repository identity))
(define submodule-name
(let ((proc (libgit2->procedure '* "git_submodule_name" '(*))))
(lambda (submodule)
"Get the file name of SUBMODULE."
(pointer->string (proc (submodule->pointer submodule))))))
(define submodule-path
(let ((proc (libgit2->procedure '* "git_submodule_path" '(*))))
(lambda (submodule)
"Get the file name of SUBMODULE."
(pointer->string (proc (submodule->pointer submodule))))))
(define submodule-owner
(let ((proc (libgit2->procedure '* "git_submodule_owner" '(*))))
(lambda (submodule)
"Return the repository that contains SUBMODULE."
(pointer->repository (proc (submodule->pointer submodule))))))
(define submodule-head-id
(let ((proc (libgit2->procedure '* "git_submodule_head_id" '(*))))
(lambda (submodule)
"Return the OID for SUBMODULE in the current HEAD tree. Return #f if
that information isn't available, for instance if SUBMODULE is not fully set
up."
(let ((ptr (proc (submodule->pointer submodule))))
(if (null-pointer? ptr)
#f
(pointer->oid ptr))))))
(define submodule-lookup
(let ((proc (libgit2->procedure* "git_submodule_lookup" `(* * *))))
(lambda (repository name)
"Look up submodule NAME under REPOSITORY. Return the submodule object
on success and #f if NAME could not be found."
(let ((submodule (make-double-pointer)))
(catch 'git-error
(lambda ()
(proc submodule
(repository->pointer repository)
(string->pointer name))
(pointer->submodule! (dereference-pointer submodule) repository))
(lambda (key error . rest)
;; For convenience return #f in the common case.
(if (= GIT_ENOTFOUND (git-error-code error))
#f
(apply throw key error rest))))))))
(define submodule-init
(let ((proc (libgit2->procedure* "git_submodule_init" `(* ,int))))
(lambda* (submodule #:optional overwrite?)
"Copy submodule info into \".git/config\" file, just like \"git
submodule init\"."
(proc (submodule->pointer submodule)
(if overwrite? 1 0)))))
(define submodule-reload
(let ((proc (libgit2->procedure* "git_submodule_reload" `(* ,int))))
(lambda* (submodule #:optional force?)
"Reload SUBMODULE from '.git/config', etc."
(proc (submodule->pointer submodule)
(if force? 1 0)))))
(define submodule-add-setup
(let ((proc (libgit2->procedure* "git_submodule_add_setup"
`(* * * * ,int))))
(lambda* (repository url path #:key use-gitlink?)
"Set up a new submodule in REPOSITORY for the repository URL at PATH.
This does \"git submodule add\" up to the fetch and checkout of the submodule
contents. It preps a new submodule, creates an entry in .gitmodules and
creates an empty initialized repository either at the given path in the
working directory or in .git/modules with a gitlink from the working
directory to the new repo."
(let ((submodule (make-double-pointer)))
(proc submodule
(repository->pointer repository)
(string->pointer url)
(string->pointer path)
(if use-gitlink? 1 0))
(pointer->submodule! (dereference-pointer submodule) repository)))))
(define submodule-add-finalize
(let ((proc (libgit2->procedure* "git_submodule_add_finalize" '(*))))
(lambda (submodule)
"Resolve the setup of SUBMODULE. This should be called on a submodule
once you have called add setup and done the clone of the submodule. This
adds the '.gitmodules' file and the newly cloned submodule to the index to be
ready to be committed (but doesn't actually do the commit)."
(proc (submodule->pointer submodule)))))
(define submodule-add-to-index
(let ((proc (libgit2->procedure* "git_submodule_add_to_index" `(* ,int))))
(lambda* (submodule #:optional (write-index? #t))
"Add current submodule HEAD commit to index of superproject."
(proc (submodule->pointer submodule)
(if write-index? 1 0)))))
(define submodule-set-url!
(let ((proc (libgit2->procedure* "git_submodule_set_url" '(* * *))))
(lambda (repository name url)
"Change to URL the url of submodule NAME in REPOSITORY."
(proc (repository->pointer repository)
(string->pointer name)
(string->pointer url)))))
(define submodule-set-branch!
(let ((proc (libgit2->procedure* "git_submodule_set_branch" '(* * *))))
(lambda (repository name branch)
"Change to BRANCH the branch of submodule NAME in REPOSITORY."
(proc (repository->pointer repository)
(string->pointer name)
(string->pointer branch)))))
(define GIT-SUBMODULE-UPDATE-OPTIONS-VERSION 1)
(define make-submodule-update-options
(let ((proc (libgit2->procedure* "git_submodule_update_options_init"
`(* ,unsigned-int))))
(lambda ()
(let ((options (make-submodule-update-options-bytestructure)))
(proc (submodule-update-options->pointer options)
GIT-SUBMODULE-UPDATE-OPTIONS-VERSION)
options))))
(define submodule-update
(let ((proc (libgit2->procedure* "git_submodule_update" `(* ,int *))))
(lambda* (submodule #:key (initialize? #t)
(allow-fetch? #t)
(fetch-options #f))
"Update SUBMODULE. This will clone it and check out the subrepository
to the commit specified in the index of the containing repository. If
SUBMODULE doesn't contain the target commit, then the submodule is fetched
using the fetch options supplied in FETCH-OPTIONS. When ALLOW-FETCH? is
true, allow fetching from the submodule's default remote if the target commit
isn't found."
(let ((options (make-submodule-update-options)))
(set-submodule-update-options-allow-fetch?! options allow-fetch?)
(when fetch-options
(set-submodule-update-options-fetch-options! options fetch-options))
(proc (submodule->pointer submodule)
(if initialize? 1 0)
(submodule-update-options->pointer options))))))
|
