all messages for Guix-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
blob 9d5b1ae321c8127d9518a3ec4fdccf3d0a7582a1 3601 bytes (raw)
name: guix/tests/git.scm 	 # note: path name is non-authoritative(*)

  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
 
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix tests git)
  #:use-module (git)
  #:use-module ((guix git) #:select (with-repository))
  #:use-module (guix utils)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:use-module (ice-9 control)
  #:export (git-command
            with-temporary-git-repository
            find-commit))

(define git-command
  (make-parameter "git"))

(define (populate-git-repository directory directives)
  "Initialize a new Git checkout and repository in DIRECTORY and apply
DIRECTIVES.  Each element of DIRECTIVES is an sexp like:

  (add \"foo.txt\" \"hi!\")

Return DIRECTORY on success."

  ;; Note: As of version 0.2.0, Guile-Git lacks the necessary bindings to do
  ;; all this, so resort to the "git" command.
  (define (git command . args)
    (apply invoke (git-command) "-C" directory
           command args))

  (mkdir-p directory)
  (git "init")

  (let loop ((directives directives))
    (match directives
      (()
       directory)
      ((('add file contents) rest ...)
       (let ((file (string-append directory "/" file)))
         (mkdir-p (dirname file))
         (call-with-output-file file
           (lambda (port)
             (display (if (string? contents)
                          contents
                          (with-repository directory repository
                            (contents repository)))
                      port)))
         (git "add" file)
         (loop rest)))
      ((('commit text) rest ...)
       (git "commit" "-m" text)
       (loop rest))
      ((('branch name) rest ...)
       (git "branch" name)
       (loop rest))
      ((('checkout branch) rest ...)
       (git "checkout" branch)
       (loop rest))
      ((('merge branch message) rest ...)
       (git "merge" branch "-m" message)
       (loop rest)))))

(define (call-with-temporary-git-repository directives proc)
  (call-with-temporary-directory
   (lambda (directory)
     (populate-git-repository directory directives)
     (proc directory))))

(define-syntax-rule (with-temporary-git-repository directory
                                                   directives exp ...)
  "Evaluate EXP in a context where DIRECTORY contains a checkout populated as
per DIRECTIVES."
  (call-with-temporary-git-repository directives
                                      (lambda (directory)
                                        exp ...)))

(define (find-commit repository message)
  "Return the commit in REPOSITORY whose message includes MESSAGE, a string."
  (let/ec return
    (fold-commits (lambda (commit _)
                    (and (string-contains (commit-message commit)
                                          message)
                         (return commit)))
                  #f
                  repository)
    (error "commit not found" message)))

debug log:

solving 9d5b1ae321 ...
found 9d5b1ae321 in https://git.savannah.gnu.org/cgit/guix.git

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/guix.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.