diff options
Diffstat (limited to 'tissue')
| -rw-r--r-- | tissue/git.scm | 144 |
1 files changed, 11 insertions, 133 deletions
diff --git a/tissue/git.scm b/tissue/git.scm index 67e1695..c7b1fcc 100644 --- a/tissue/git.scm +++ b/tissue/git.scm @@ -27,19 +27,7 @@ #:use-module (ice-9 match) #: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 - 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 ((system foreign) #:select (%null-pointer)) #:use-module (tissue utils) #:export (git-top-level current-git-repository @@ -50,121 +38,6 @@ ;; 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 diff-find-similar! (let ((proc (libgit2->procedure* "git_diff_find_similar" '(* *)))) (lambda (diff) @@ -187,6 +60,12 @@ repository." "Return the current git repository." (repository-open (git-top-level))) +(define (head-tree repository) + "Return tree of HEAD in REPOSITORY." + (commit-tree + (commit-lookup repository + (reference-name->oid repository "HEAD")))) + (define (commit-date commit) (time-monotonic->date (make-time time-monotonic @@ -195,11 +74,10 @@ repository." (* 60 (commit-time-offset commit)))) (define* (git-tracked-files #:optional (repository (current-git-repository))) - "Return a list of all files tracked in REPOSITORY. The returned -filenames are relative to the top-level directory of REPOSITORY and do -not have a leading slash." - (map index-entry-path - (index-entries (repository-index repository)))) + "Return a list of all files and directories tracked in REPOSITORY. The +returned paths are relative to the top-level directory of REPOSITORY +and do not have a leading slash." + (tree-list (head-tree repository))) (define (commit-deltas repository commit) "Return the list of <diff-delta> objects created by COMMIT with |