diff options
| -rw-r--r-- | tissue/git.scm | 144 |
1 files changed, 140 insertions, 4 deletions
diff --git a/tissue/git.scm b/tissue/git.scm index 8be3970..5cc8a52 100644 --- a/tissue/git.scm +++ b/tissue/git.scm @@ -17,13 +17,147 @@ ;;; along with tissue. If not, see <https://www.gnu.org/licenses/>. (define-module (tissue git) + #:use-module (rnrs arithmetic bitwise) #:use-module (rnrs io ports) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (srfi srfi-171) + #:use-module (git) + #:use-module (git types) + ;; There are many name conflicts between (system foreign). So, we + ;; carefully select a few and prefix the rest. + #:use-module ((system foreign) #:select (null-pointer? + pointer->string + make-pointer + dereference-pointer)) + #:use-module ((system foreign) #:prefix foreign:) + #:use-module ((bytestructures guile) #:select (bs:pointer + bs:struct + bs:vector + bytestructure-ref)) + #:use-module ((bytestructures guile) #:prefix bs:) #:use-module (tissue utils) #:export (git-top-level git-tracked-files)) +;; We bind additional functions from libgit2 that are not already +;; bound in guile-git. TODO: Contribute them to guile-git. + +(define pointer->bytestructure + (@@ (git structs) pointer->bytestructure)) + +(define bytestructure->pointer + (@@ (git structs) bytestructure->pointer)) + +(define %oid + (bs:vector 20 bs:uint8)) + +(define %index-time + (bs:struct `((seconds ,bs:int32) + (nanoseconds ,bs:uint32)))) + +(define %index-entry + (bs:struct `((ctime ,%index-time) + (mtime ,%index-time) + (dev ,bs:uint32) + (ino ,bs:uint32) + (mode ,bs:uint32) + (uid ,bs:uint32) + (gid ,bs:uint32) + (file-size ,bs:uint32) + (id ,%oid) + (flags ,bs:uint16) + (flags-extended ,bs:uint16) + (path ,(bs:pointer bs:uint8))))) + +(define-record-type <index-time> + (%make-index-time seconds nanoseconds) + index-time? + (seconds index-time-seconds) + (nanoseconds index-time-nanoseconds)) + +(define (pointer->index-time pointer) + (if (null-pointer? pointer) + #f + (let ((bs (pointer->bytestructure pointer %index-time))) + (%make-index-time + (bytestructure-ref bs 'seconds) + (bytestructure-ref bs 'nanoseconds))))) + +(define-record-type <index-entry> + (%make-index-entry ctime mtime dev ino mode uid gid file-size id flags path) + index-entry? + (ctime index-entry-ctime) + (mtime index-entry-mtime) + (dev index-entry-dev) + (ino index-entry-ino) + (mode index-entry-mode) + (uid index-entry-uid) + (gid index-entry-gid) + (file-size index-entry-file-size) + (id index-entry-id) + (flags index-entry-flags) + (path index-entry-path)) + +(define (pointer->index-entry pointer) + (if (null-pointer? pointer) + #f + (let* ((bs (pointer->bytestructure pointer %index-entry)) + (flags (bytestructure-ref bs 'flags))) + (%make-index-entry + (pointer->index-time + (bytestructure->pointer (bytestructure-ref bs 'ctime))) + (pointer->index-time + (bytestructure->pointer (bytestructure-ref bs 'mtime))) + (bytestructure-ref bs 'dev) + (bytestructure-ref bs 'ino) + (bytestructure-ref bs 'mode) + (bytestructure-ref bs 'uid) + (bytestructure-ref bs 'gid) + (bytestructure-ref bs 'file-size) + (pointer->oid + (bytestructure->pointer (bytestructure-ref bs 'id))) + (if (zero? (logand flags + (bitwise-arithmetic-shift 1 15))) + (list) + (list 'assume-valid)) + (pointer->string + (make-pointer (bytestructure-ref bs 'path)) + (bitwise-and flags (bitwise-not (bitwise-arithmetic-shift 1 13)))))))) + +;; The repository-index function in guile-git has a bug. See +;; https://gitlab.com/guile-git/guile-git/-/merge_requests/34 . To +;; work around this, we redefine it here. +(define repository-index + (let ((proc (libgit2->procedure* "git_repository_index" (list '* '*)))) + (lambda (repository) + (let ((out (make-double-pointer))) + (proc out (repository->pointer repository)) + (pointer->index (dereference-pointer out)))))) + +(define index-version + (let ((proc (libgit2->procedure foreign:unsigned-int "git_index_version" (list '*)))) + (lambda (index) + (proc (index->pointer index))))) + +(define index-entry-count + (compose (libgit2->procedure foreign:size_t "git_index_entrycount" (list '*)) + index->pointer)) + +(define index-entry + (let ((proc (libgit2->procedure '* "git_index_get_byindex" (list '* foreign:size_t)))) + (lambda (index n) + (unless (= (index-version index) 2) + (error "Unsupported git index version:" (index-version index))) + (pointer->index-entry (proc (index->pointer index) n))))) + +(define (index-entries index) + "Return the list of all entries in INDEX, a <git-index> object. The +return value is a list of <index-entry> objects." + (map (lambda (i) + (index-entry index i)) + (iota (index-entry-count index)))) + (define (git-top-level) "Return the top-level directory of the current git repository." @@ -37,7 +171,9 @@ repository." (loop (dirname curdir)))))) (define (git-tracked-files) - "Return a list of all files tracked in the current git repository." - (call-with-input-pipe - (cut port-transduce (tmap identity) rcons get-line <>) - "git" "ls-files")) + "Return a list of all files tracked in the current git repository. The +returned filenames are relative to the top-level directory of the +current git repository and do not have a leading slash." + (map index-entry-path + (index-entries (repository-index + (repository-open (git-top-level)))))) |