86 lines
2.7 KiB
Scheme
86 lines
2.7 KiB
Scheme
|
;; cached prefix version
|
||
|
|
|
||
|
|
(define *completion-check-executable* #f)
|
||
|
|
|
||
|
|
(define *cache-alist* '())
|
||
|
|
|
||
|
|
(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 prefix)
|
||
|
|
(let ((p (assoc prefix *cache-alist*)))
|
||
|
|
(if p
|
||
|
|
(cdr p)
|
||
|
|
(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 prefix list)
|
||
|
|
(let ((prefixes (strings-with-prefix (map car *cache-alist*) prefix)))
|
||
|
|
(receive (longer-ones others)
|
||
|
|
(partition (lambda (p)
|
||
|
|
(has-prefix prefix (car p)))
|
||
|
|
*cache-alist*)
|
||
|
|
(set! *cache-alist*
|
||
|
|
(cons (cons prefix (append list (append-map cdr longer-ones)))
|
||
|
|
others)))))
|
||
|
|
|
||
|
|
(define (executables-in-path/prefix prefix)
|
||
|
|
(let ((maybe-result (check-cache-for-prefix prefix)))
|
||
|
|
(or maybe-result
|
||
|
|
(let ((result (append-map! (lambda (dir)
|
||
|
|
(dir-executables/prefix dir prefix))
|
||
|
|
(thread-fluid exec-path-list))))
|
||
|
|
(add-to-cache prefix result)
|
||
|
|
result))))
|
||
|
|
|
||
|
|
(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* #f)
|
||
|
|
|
||
|
|
(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)))))
|