gitile/gitile/git.scm

git.scm

1
;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>
2
;;;;
3
;;;; This library is free software; you can redistribute it and/or
4
;;;; modify it under the terms of the GNU Lesser General Public
5
;;;; License as published by the Free Software Foundation; either
6
;;;; version 3 of the License, or (at your option) any later version.
7
;;;;
8
;;;; This library is distributed in the hope that it will be useful,
9
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11
;;;; Lesser General Public License for more details.
12
;;;;
13
;;;; You should have received a copy of the GNU Lesser General Public
14
;;;; License along with this library; if not, write to the Free Software
15
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
16
;;;;
17
18
(define-module (gitile git)
19
  #:use-module (bytestructures guile)
20
  #:use-module (git)
21
  #:use-module (git types)
22
  #:use-module (srfi srfi-9)
23
  #:use-module ((system foreign) #:select (make-pointer
24
                                           pointer->string
25
                                           procedure->pointer
26
                                           set-pointer-finalizer!
27
                                           %null-pointer))
28
  #:use-module ((system foreign) #:prefix foreign:)
29
  #:export (config-entry-name config-entry-value config-entry-include-depth
30
            config-entry-level
31
            config-foreach))
32
33
(define pointer->bytestructure (@@ (git structs) pointer->bytestructure))
34
(define bytestructure->pointer (@@ (git structs) bytestructure->pointer))
35
36
(define tree-entry-type
37
  (let ((proc (libgit2->procedure int "git_tree_entry_type" '(*))))
38
    (lambda (entry)
39
      (proc (tree-entry->pointer entry)))))
40
41
(define %config-entry (bs:struct `((name ,(bs:pointer uint8)) ; char *
42
                                   (value ,(bs:pointer uint8)) ; char *
43
                                   (include-depth ,uint64)
44
                                   (level ,int) ; git_config_level_t
45
                                   (free ,(bs:pointer int))
46
                                   (payload ,(bs:pointer int)))))
47
(define-record-type <config-entry>
48
  (%make-config-entry bytestructure)
49
  config-entry?
50
  (bytestructure config-entry-bytestructure))
51
52
(define (pointer->config-entry pointer)
53
  (%make-config-entry (pointer->bytestructure pointer %config-entry)))
54
55
(define (config-entry->pointer entry)
56
  (bytestructure->pointer (config-entry-bytestructure entry)))
57
58
(define (config-entry-name entry)
59
  (pointer->string (make-pointer (bytestructure-ref (config-entry-bytestructure entry) 'name))))
60
61
(define (config-entry-value entry)
62
  (pointer->string (make-pointer (bytestructure-ref (config-entry-bytestructure entry) 'value))))
63
64
(define (config-entry-include-depth entry)
65
  (bytestructure-ref (config-entry-bytestructure entry) 'include-depth))
66
67
(define (config-entry-level entry)
68
  (bytestructure-ref (config-entry-bytestructure entry) 'level))
69
70
(define %config-entry-free (libgit2->pointer "git_config_entry_free"))
71
72
(define (pointer->config-entry! pointer)
73
    (set-pointer-finalizer! pointer %config-entry-free)
74
      (pointer->config-entry pointer))
75
76
(define config-foreach
77
  (let ((proc (libgit2->procedure* "git_config_foreach" '(* * *))))
78
    (lambda (config callback)
79
      (let ((callback* (procedure->pointer foreign:int
80
                                           (lambda (entry _)
81
                                             (callback (pointer->config-entry entry)))
82
                                           (list '* '*))))
83
        (proc (config->pointer config) callback* %null-pointer)))))
84