163 lines
5.2 KiB
Racket
163 lines
5.2 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/path
|
|
racket/string
|
|
racket/contract
|
|
racket/system
|
|
"config.rkt"
|
|
)
|
|
|
|
(provide git-exe
|
|
set-git-exe!
|
|
run-git
|
|
git-out
|
|
git-error
|
|
git-displ
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Supporting functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define cached-git-exe #f)
|
|
|
|
(define (ask-for-git-executable)
|
|
(displayln "Git was not found on PATH.")
|
|
(displayln "Enter the full path to git/git.exe, or press Enter to abort:")
|
|
(let loop ()
|
|
(display "> ")
|
|
(flush-output)
|
|
(let ((answer (read-line)))
|
|
(when (or (eof-object? answer)
|
|
(string=? (string-trim answer) ""))
|
|
(error 'git "Git executable not found; configuration aborted"))
|
|
(let ((candidate (find-executable-path answer)))
|
|
(if (eq? candidate #f)
|
|
(begin
|
|
(displayln
|
|
(format "'~a' is not found, please try again or press Enter to abort." answer))
|
|
(loop))
|
|
(begin
|
|
(set-git-exe! candidate)
|
|
#t)))))
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Provided functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define/contract (git-exe)
|
|
(-> (or/c path? #f))
|
|
(if (eq? cached-git-exe #f)
|
|
(let ((the-git-exe (let ((exe (cfg-get 'git 'exe #f)))
|
|
(if (eq? exe #f)
|
|
(let ((path (find-executable-path "git")))
|
|
(if (eq? path #f)
|
|
(if (ask-for-git-executable)
|
|
(git-exe)
|
|
#f)
|
|
path))
|
|
exe
|
|
))))
|
|
(set! cached-git-exe the-git-exe)
|
|
the-git-exe)
|
|
cached-git-exe))
|
|
|
|
(define/contract (set-git-exe! exe-path)
|
|
(-> path? void?)
|
|
(void
|
|
(begin
|
|
(cfg-set! 'git 'exe exe-path)
|
|
(set! cached-git-exe exe-path))))
|
|
|
|
|
|
(define (run-git args)
|
|
(putenv "GIT_TERMINAL_PROMPT" "0")
|
|
(let-values (((process stdout stdin stderr)
|
|
(apply subprocess
|
|
#f
|
|
#f
|
|
#f
|
|
(git-exe)
|
|
(map (λ (arg) (format "~a" arg)) args)
|
|
)))
|
|
(close-output-port stdin)
|
|
(let ((output-channel (make-channel)))
|
|
(define (read-output source port)
|
|
(thread
|
|
(lambda ()
|
|
(let loop ()
|
|
(let ((line (read-line port)))
|
|
(channel-put output-channel (list source line))
|
|
(if (eof-object? line)
|
|
(close-input-port port)
|
|
(loop)))))))
|
|
|
|
(read-output 'stdout stdout)
|
|
(read-output 'stderr stderr)
|
|
|
|
(let loop ((open-ports 2)
|
|
(result '()))
|
|
(if (= open-ports 0)
|
|
(begin
|
|
(subprocess-wait process)
|
|
(values (subprocess-status process)
|
|
(reverse result)))
|
|
(let* ((output (channel-get output-channel))
|
|
(line (cadr output)))
|
|
(if (eof-object? line)
|
|
(loop (- open-ports 1) result)
|
|
(loop open-ports
|
|
(cons output result)))))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Provided utility functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (is-output? e)
|
|
(or (eq? (car e) 'stdout)
|
|
(and (eq? (car e) 'stderr)
|
|
(string-prefix? (string-downcase (cadr e)) "warning:"))))
|
|
|
|
(define (is-error? e)
|
|
(not (is-output? e)))
|
|
|
|
(define (git-out cmd output)
|
|
(let* ((out (map (λ (e) (cadr e)) (filter (λ (e) (is-output? e)) output)))
|
|
(err (map (λ (e) (cadr e)) (filter (λ (e) (is-error? e)) output)))
|
|
(r (null? err))
|
|
)
|
|
(values r (if (eq? r #t) out err))))
|
|
|
|
(define-syntax git-error
|
|
(syntax-rules ()
|
|
((_ cmd msg* outp)
|
|
(let* ((out (map (λ (e) (if (list? e)
|
|
(if (null? e)
|
|
""
|
|
(if (or (eq? (car e) 'stdout)
|
|
(eq? (car e) 'stderr))
|
|
(format "~a" (cadr e))
|
|
(format "~a" e)))
|
|
(format "~a" e)))
|
|
(if (list? outp) outp (list outp))))
|
|
(enter (if (eq? (system-type 'os) 'windows) "\n" "\n"))
|
|
(msg (format "git ~a: ~a: ~a" cmd msg* (string-join out enter)))
|
|
)
|
|
(err-git msg)
|
|
(error 'git msg))
|
|
)
|
|
)
|
|
)
|
|
|
|
(define re-a #px"~+")
|
|
|
|
(define (git-displ out)
|
|
(let ((str (if (string? out) out (string-join out "\n"))))
|
|
(unless (string=? (string-trim str) "")
|
|
(let ((s (regexp-replace* re-a str "~~")))
|
|
(info-git s))
|
|
(when (cfg-get 'git 'display-output #t)
|
|
(displayln str)))))
|