119 lines
3.6 KiB
Scheme
119 lines
3.6 KiB
Scheme
(define-record-type completion-set :completion-set
|
|
(really-make-completion-set strings cache)
|
|
completion-set?
|
|
(strings completion-set-strings set-completion-set-strings!)
|
|
(cache completion-set-cache set-completion-set-cache!))
|
|
|
|
(define (make-empty-completion-set)
|
|
(really-make-completion-set '() '()))
|
|
|
|
(define (make-completion-set strings)
|
|
(really-make-completion-set
|
|
(lset-intersection strings strings) '()))
|
|
|
|
(define (make-completion-set-for-executables path-list)
|
|
(really-make-completion-set
|
|
(executables-in-path-list path-list) '()))
|
|
|
|
(define (adjoin-completion-set cs string)
|
|
(really-make-completion-set
|
|
(cons string (completion-set-strings cs)) '()))
|
|
|
|
(define (completions-for cs prefix)
|
|
(let ((maybe-result (check-cache-for-prefix cs prefix)))
|
|
(or maybe-result
|
|
(let ((result (strings-with-prefix
|
|
(completion-set-strings cs) prefix)))
|
|
(add-to-cache cs prefix result)
|
|
result))))
|
|
|
|
;; cached prefix version
|
|
|
|
(define *completion-check-executable* #f)
|
|
|
|
(define (strings-with-prefix strings prefix)
|
|
(let ((plen (string-length prefix)))
|
|
(filter (lambda (s)
|
|
(and (>= (string-length s) plen)
|
|
(string=? (substring s 0 plen) prefix)))
|
|
strings)))
|
|
|
|
(define (check-cache-for-prefix cs prefix)
|
|
(let* ((cache-alist (completion-set-cache cs))
|
|
(p (assoc prefix cache-alist)))
|
|
(cond
|
|
(p => cdr)
|
|
(else
|
|
(let loop ((nprefix prefix))
|
|
(if (string=? nprefix "")
|
|
#f
|
|
(let* ((nprefix (substring prefix 0 (- (string-length nprefix) 1)))
|
|
(p (assoc nprefix cache-alist)))
|
|
(if p
|
|
(strings-with-prefix (cdr p) prefix)
|
|
(loop nprefix)))))))))
|
|
|
|
(define (has-prefix prefix s)
|
|
(let ((pl (string-length prefix)))
|
|
(and (>= (string-length s) (string-length prefix))
|
|
(string=? (substring s 0 pl) prefix))))
|
|
|
|
(define (add-to-cache cs prefix list)
|
|
(let* ((cache-alist (completion-set-cache cs))
|
|
(prefixes (strings-with-prefix (map car cache-alist) prefix)))
|
|
(receive (longer-ones others)
|
|
(partition (lambda (p)
|
|
(has-prefix prefix (car p)))
|
|
cache-alist)
|
|
(set-completion-set-cache!
|
|
cs
|
|
(cons (cons prefix (append list (append-map cdr longer-ones)))
|
|
others)))))
|
|
|
|
(define (executables-in-path/prefix cs prefix)
|
|
(let ((maybe-result (check-cache-for-prefix cs prefix)))
|
|
(or maybe-result
|
|
(let ((result (append-map! (lambda (dir)
|
|
(dir-executables/prefix dir prefix))
|
|
(thread-fluid exec-path-list))))
|
|
(add-to-cache cs prefix result)
|
|
result))))
|
|
|
|
(define completions-for-executables executables-in-path/prefix)
|
|
|
|
(define (dir-executables/prefix dir prefix)
|
|
(if (file-readable? dir)
|
|
(map file-name-nondirectory
|
|
(let ((files (glob (string-append dir "/" prefix "*"))))
|
|
(if *completion-check-executable*
|
|
(filter executable? files)
|
|
files)))
|
|
'()))
|
|
|
|
;; caching version
|
|
|
|
(define *cache* #t)
|
|
|
|
(define (executables-in-path)
|
|
(or *cache*
|
|
(begin
|
|
(set! *cache* (executables-in-path-list (thread-fluid exec-path-list)))
|
|
*cache*)))
|
|
|
|
(define (executables-in-path-list path-list)
|
|
(append-map! dir-executables path-list))
|
|
|
|
(define (dir-executables dir)
|
|
(if (file-readable? dir)
|
|
(map file-name-nondirectory
|
|
(filter executable? (glob (string-append dir "/*"))))
|
|
'()))
|
|
|
|
(define (executable? name) ;; TODO maybe check if executable by this user
|
|
(with-errno-handler
|
|
((errno packet)
|
|
(else #f))
|
|
(let ((info (file-info name)))
|
|
(and (file-info-executable? info)
|
|
(file-info-regular? info)))))
|