57 lines
1.9 KiB
Scheme
57 lines
1.9 KiB
Scheme
|
;; functions that interact with the git executable
|
||
|
|
|
||
|
|
(module utils-git *
|
||
|
|
(import
|
||
|
|
(chicken base)
|
||
|
|
(chicken format) ;; format
|
||
|
|
(chicken io) ;; read-line
|
||
|
|
(chicken process) ;; call-with-input-pipe
|
||
|
|
(chicken string) ;; string-intersperse
|
||
|
|
(clojurian syntax)
|
||
|
|
scheme
|
||
|
|
)
|
||
|
|
|
||
|
|
(define lines-from-git-command (cute call-with-input-pipe <> read-lines))
|
||
|
|
|
||
|
|
(define (in-git-directory?)
|
||
|
|
(not (eof-object? (call-with-input-pipe "git rev-parse --git-dir" read-line))))
|
||
|
|
|
||
|
|
;; a weird hack to detect whether git considers a blob to be a binary or a text
|
||
|
|
;; file. works by requesting the numstat diff between it and the empty tree.
|
||
|
|
;; binary files give not a line count but '-' placeholders.
|
||
|
|
(define (git-file-is-text? source-file)
|
||
|
|
(not (equal?
|
||
|
|
"-\t-\t"
|
||
|
|
(call-with-input-pipe
|
||
|
|
(string-append "git diff 4b825dc642cb6eb9a060e54bf8d69288fbee4904 --numstat HEAD -- " (qs source-file))
|
||
|
|
(cute read-line <> 4)))))
|
||
|
|
|
||
|
|
(define (git-repository->paths-list)
|
||
|
|
(lines-from-git-command "git ls-tree -r --name-only HEAD"))
|
||
|
|
|
||
|
|
(define (git-file->lines source-file)
|
||
|
|
(->
|
||
|
|
source-file
|
||
|
|
(qs)
|
||
|
|
((flip format) "git show HEAD:~a")
|
||
|
|
(lines-from-git-command)))
|
||
|
|
|
||
|
|
;; the result of asking git for some configuration; #f if no result.
|
||
|
|
(define (git-config->string key)
|
||
|
|
(let [(result (call-with-input-pipe (string-append "git config " key) read-line))]
|
||
|
|
(if (eof-object? result) #f result)))
|
||
|
|
|
||
|
|
(define (git-commits)
|
||
|
|
;; date ref title author, tab-separated.
|
||
|
|
(map (cute string-split <> "\t")
|
||
|
|
(lines-from-git-command "git log --format=format:%as%x09%h%x09%s%x09%aN HEAD")))
|
||
|
|
|
||
|
|
(define (git-contributors)
|
||
|
|
(lines-from-git-command "git shortlog -ns HEAD"))
|
||
|
|
|
||
|
|
;; copy a file verbatim from the repo @HEAD to some path
|
||
|
|
(define (git-copy src dst)
|
||
|
|
(system (format "git show HEAD:~a > ~a" (qs src) (qs dst))))
|
||
|
|
|
||
|
|
)
|