From 7337f9b4515d2bb132dadecb28e37c5b57fc31b0 Mon Sep 17 00:00:00 2001
From: eknauel <eknauel>
Date: Sat, 28 May 2005 12:03:11 +0000
Subject: [PATCH] Import orion's `file-name-completion.scm' as `complete.scm'

---
 scheme/complete.scm | 85 +++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 85 insertions(+)
 create mode 100644 scheme/complete.scm

diff --git a/scheme/complete.scm b/scheme/complete.scm
new file mode 100644
index 0000000..1d974a6
--- /dev/null
+++ b/scheme/complete.scm
@@ -0,0 +1,85 @@
+;; 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)))))