From: Chris Hanson Date: Sat, 20 May 2000 03:22:52 +0000 (+0000) Subject: First draft of URL completion mechanism. IMAP method not yet X-Git-Tag: 20090517-FFI~3776 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f4bc520ae3fee38d74db5b5e52eb8c8be646ab60;p=mit-scheme.git First draft of URL completion mechanism. IMAP method not yet implemented. --- diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index f71854a52..4ace5a7a6 100644 --- a/v7/src/imail/imail-core.scm +++ b/v7/src/imail/imail-core.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-core.scm,v 1.76 2000/05/19 21:02:00 cph Exp $ +;;; $Id: imail-core.scm,v 1.77 2000/05/20 03:22:41 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -72,7 +72,8 @@ (let ((colon (string-find-next-char string #\:))) (if (not colon) (error:bad-range-argument string 'STRING->URL)) - ((get-url-protocol-parser (string-head string colon)) + ((or (get-url-protocol-parser (string-head string colon)) + (error:bad-range-argument string 'STRING->URL)) (string-tail string (fix:+ colon 1)))))) (hash-table/put! saved-urls string url) url))) @@ -90,21 +91,90 @@ (define (url->string url) (string-append (url-protocol url) ":" (url-body url))) -(define (define-url-protocol name class parser) +(define (define-url-protocol name class parser completer completions) (define-method url-protocol ((url class)) url name) - (hash-table/put! url-protocol-parsers (string-downcase name) parser)) + (hash-table/put! url-protocols + (string-downcase name) + (vector parser completer completions))) -(define (get-url-protocol-parser name) - (or (hash-table/get url-protocol-parsers (string-downcase name) #f) - (error:bad-range-argument name 'GET-URL-PROTOCOL-PARSER))) +(define (get-url-protocol-parser name) (get-url-protocol-item name 0)) +(define (get-url-protocol-completer name) (get-url-protocol-item name 1)) +(define (get-url-protocol-completions name) (get-url-protocol-item name 2)) -(define url-protocol-parsers +(define (get-url-protocol-item name index) + (let ((v (hash-table/get url-protocols (string-downcase name) #f))) + (and v + (vector-ref v index)))) + +(define url-protocols (make-string-hash-table)) ;; Return a string that concisely identifies URL, for use in the ;; presentation layer. (define-generic url-presentation-name (url)) +;; Do completion on URL-STRING, which is a partially-specified URL. +;; Tail-recursively calls one of the three procedure arguments, as +;; follows. If URL-STRING has a unique completion, IF-UNIQUE is +;; called with that completion. If URL-STRING has more than one +;; completion, IF-NOT-UNIQUE is called with two arguments: the first +;; argument is a prefix string that all of the completions share, and +;; the second argument is a thunk that returns a list of the +;; completions. If URL-STRING has no completions, IF-NOT-FOUND is +;; called with no arguments. + +(define (url-complete-string url-string if-unique if-not-unique if-not-found) + (let ((colon (string-find-next-char url-string #\:)) + (have-protocol + (lambda (name body) + (let ((prepend (lambda (string) (string-append name ":" string)))) + (let ((completer (get-url-protocol-completer name))) + (if completer + (completer + body + (lambda (string) + (if-unique (prepend string))) + (lambda (prefix get-completions) + (if-not-unique + (prepend prefix) + (lambda () (map prepend (get-completions))))) + if-not-found) + (if-not-found))))))) + (if colon + (have-protocol (string-head url-string colon) + (string-tail url-string (fix:+ colon 1))) + ((ordered-string-vector-completer + (hash-table/ordered-key-vector url-protocols stringlist + ((ordered-string-vector-matches + (hash-table/ordered-key-vector url-protocols string)) (file-namestring (file-url-pathname url))) +(define ((file-url-completer filter) + string if-unique if-not-unique if-not-found) + (pathname-complete-string (short-name->pathname string) filter + (lambda (string) + (if-unique (pathname->short-name string))) + (lambda (prefix get-completions) + (if-not-unique (pathname->short-name prefix) + (lambda () (map pathname->short-name (get-completions))))) + if-not-found)) + +(define ((file-url-completions filter) string) + (map pathname->short-name + (pathname-completions-list (short-name->pathname string) filter))) + +(define (file-suffix-filter suffix) + (let ((suffix (string-append "." suffix))) + (let ((l (string-length suffix))) + (lambda (string) + (let ((i (string-search-forward suffix string))) + (and i + (fix:> i 0) + (let ((i (fix:+ i l))) + (or (fix:= i (string-length string)) + (char=? #\. (string-ref string i)))))))))) + ;;;; Server operations (define-method %delete-folder ((url )) diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm index 75260c24d..8bdcb5fdb 100644 --- a/v7/src/imail/imail-rmail.scm +++ b/v7/src/imail/imail-rmail.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-rmail.scm,v 1.31 2000/05/17 17:54:34 cph Exp $ +;;; $Id: imail-rmail.scm,v 1.32 2000/05/20 03:22:48 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -26,9 +26,16 @@ (define-class ()) -(define-url-protocol "rmail" - (lambda (string) - (%make-rmail-url (short-name->pathname string)))) +(let ((filter + (let ((suffix-filter (file-suffix-filter "rmail"))) + (lambda (string) + (or (string-ci=? string "rmail") + (suffix-filter string)))))) + (define-url-protocol "rmail" + (lambda (string) + (%make-rmail-url (short-name->pathname string))) + (file-url-completer filter) + (file-url-completions filter))) (define (make-rmail-url pathname) (save-url (%make-rmail-url pathname))) diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm index 413e8cc6b..2e712742b 100644 --- a/v7/src/imail/imail-umail.scm +++ b/v7/src/imail/imail-umail.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-umail.scm,v 1.26 2000/05/17 17:54:47 cph Exp $ +;;; $Id: imail-umail.scm,v 1.27 2000/05/20 03:22:50 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -26,9 +26,12 @@ (define-class ()) -(define-url-protocol "umail" - (lambda (string) - (%make-umail-url (short-name->pathname string)))) +(let ((filter (file-suffix-filter "mail"))) + (define-url-protocol "umail" + (lambda (string) + (%make-umail-url (short-name->pathname string))) + (file-url-completer filter) + (file-url-completions filter))) (define (make-umail-url pathname) (save-url (%make-umail-url pathname))) diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm index b0afd551a..3c94b41e7 100644 --- a/v7/src/imail/imail-util.scm +++ b/v7/src/imail/imail-util.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-util.scm,v 1.17 2000/05/19 17:52:40 cph Exp $ +;;; $Id: imail-util.scm,v 1.18 2000/05/20 03:22:52 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -169,7 +169,7 @@ (decorated-string-append "" "" (if (default-object? line-ending) "\n" line-ending) lines)) - + (define (short-name->pathname name) (merge-pathnames name (current-home-directory))) @@ -191,7 +191,7 @@ (write-char #\: port) (write-string value port) (newline port)) - + (define (read-lines port) (source->list (lambda () (read-line port)))) @@ -240,4 +240,151 @@ (define (burst-comma-list-string string) (list-transform-negative (map string-trim (burst-string string #\, #f)) - string-null?)) \ No newline at end of file + string-null?)) + +;;;; Ordered-string-vector completion + +(define (hash-table/ordered-key-vector table <) + (let ((v (list->vector (hash-table/key-list url-protocols)))) + (sort! v <) + v)) + +(define (ordered-string-vector-completer strings) + (lambda (string if-unique if-not-unique if-not-found) + (ordered-vector-minimum-match strings string identity-procedure + string-order (string-prefix-matcher string) + if-unique if-not-unique if-not-found))) + +(define (ordered-string-vector-completer-ci strings) + (lambda (string if-unique if-not-unique if-not-found) + (ordered-vector-minimum-match strings string identity-procedure + string-order-ci + (string-prefix-matcher-ci string) + if-unique if-not-unique if-not-found))) + +(define (ordered-string-vector-matches strings) + (lambda (string) + (ordered-vector-matches strings string identity-procedure + string-order (string-prefix-matcher string)))) + +(define (ordered-string-vector-matches-ci strings) + (lambda (string) + (ordered-vector-matches strings string identity-procedure + string-order-ci + (string-prefix-matcher-ci string)))) + +(define (string-order x y) + (let ((lx (string-length x)) + (ly (string-length y))) + (let ((i (substring-match-forward x 0 lx y 0 ly))) + (if (fix:< i lx) + (if (fix:< i ly) + (if (char= i l) + i))))) + +(define (string-prefix-matcher-ci prefix) + (let ((l (string-length prefix))) + (lambda (x y) + (let ((i (string-match-forward-ci x y))) + (and (fix:>= i l) + i))))) + +;;;; Filename Completion + +(define (pathname-complete-string pathname filter + if-unique if-not-unique if-not-found) + (let loop + ((pathnames (filtered-completions (merge-pathnames pathname) filter))) + (if (pair? pathnames) + (if (pair? (cdr pathnames)) + (if-not-unique + (string-greatest-common-prefix + (map ->namestring pathnames)) + (lambda () + (map canonicalize-pathname pathnames))) + (let ((pathname (car pathnames))) + (let ((pathnames + (filtered-list (pathname-as-directory pathname) filter))) + (if (pair? pathnames) + (loop pathnames) + (if-unique pathname))))) + (if-not-found)))) + +(define (pathname-completions-list pathname filter) + (map canonicalize-pathname + (filtered-completions (merge-pathnames pathname) filter))) + +(define (filtered-completions pathname filter) + (let ((directory (directory-namestring pathname))) + (if (safe-file-directory? directory) + (let ((prefix (file-namestring pathname)) + (channel (directory-channel-open directory))) + (let loop ((result '())) + (let ((name (directory-channel-read-matching channel prefix))) + (if name + (loop + (if (filter name) + (cons (parse-namestring (string-append directory name) + #f #f) + result) + result)) + (begin + (directory-channel-close channel) + result))))) + '()))) + +(define (filtered-list pathname filter) + (let ((directory (directory-namestring pathname))) + (if (safe-file-directory? directory) + (let ((channel (directory-channel-open directory))) + (let loop ((result '())) + (let ((name (directory-channel-read channel))) + (if name + (loop + (if (filter name) + (cons (parse-namestring (string-append directory name) + #f #f) + result) + result)) + (begin + (directory-channel-close channel) + result))))) + '()))) + +(define (safe-file-directory? pathname) + (call-with-current-continuation + (lambda (k) + (bind-condition-handler (list condition-type:file-error + condition-type:port-error) + (lambda (condition) + condition + (k #f)) + (lambda () + (file-directory? pathname)))))) + +(define (canonicalize-pathname pathname) + (if (safe-file-directory? pathname) + (pathname-as-directory pathname) + pathname)) \ No newline at end of file