implemented.
;;; -*-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
;;;
(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)))
(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))
\f
+;; 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 string<?))
+ url-string
+ (lambda (string)
+ (have-protocol string ""))
+ (lambda (prefix get-completions)
+ (if-not-unique prefix
+ (lambda ()
+ (append-map (lambda (name) (have-protocol name ""))
+ (get-completions)))))
+ if-not-found))))
+
+;; Return a list of the completions for URL-STRING.
+
+(define (url-string-completions url-string)
+ (let ((colon (string-find-next-char url-string #\:))
+ (have-protocol
+ (lambda (name body)
+ (let ((completer (get-url-protocol-completer name)))
+ (if completer
+ (map (lambda (string) (string-append name ":" string))
+ (completer body))
+ '())))))
+ (if colon
+ (have-protocol (string-head url-string colon)
+ (string-tail url-string (fix:+ colon 1)))
+ (append-map (lambda (name) (have-protocol name ""))
+ (vector->list
+ ((ordered-string-vector-matches
+ (hash-table/ordered-key-vector url-protocols string<?))
+ url-string))))))
+\f
;;;; Server operations
;; -------------------------------------------------------------------
;;; -*-Scheme-*-
;;;
-;;; $Id: imail-file.scm,v 1.28 2000/05/18 03:42:59 cph Exp $
+;;; $Id: imail-file.scm,v 1.29 2000/05/20 03:22:46 cph Exp $
;;;
;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
;;;
(define-method url-presentation-name ((url <file-url>))
(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 <file-url>))
;;; -*-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
;;;
(define-class <rmail-url> (<file-url>))
-(define-url-protocol "rmail" <rmail-url>
- (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" <rmail-url>
+ (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)))
;;; -*-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
;;;
(define-class <umail-url> (<file-url>))
-(define-url-protocol "umail" <umail-url>
- (lambda (string)
- (%make-umail-url (short-name->pathname string))))
+(let ((filter (file-suffix-filter "mail")))
+ (define-url-protocol "umail" <umail-url>
+ (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)))
;;; -*-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
;;;
(decorated-string-append "" ""
(if (default-object? line-ending) "\n" line-ending)
lines))
-\f
+
(define (short-name->pathname name)
(merge-pathnames name (current-home-directory)))
(write-char #\: port)
(write-string value port)
(newline port))
-
+\f
(define (read-lines port)
(source->list (lambda () (read-line port))))
(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?))
+\f
+;;;; 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<? (string-ref x i) (string-ref y i)) 'LESS 'GREATER)
+ 'GREATER)
+ (if (fix:< i ly)
+ 'LESS
+ 'EQUAL)))))
+
+(define (string-order-ci x y)
+ (let ((lx (string-length x))
+ (ly (string-length y)))
+ (let ((i (substring-match-forward-ci x 0 lx y 0 ly)))
+ (if (fix:< i lx)
+ (if (fix:< i ly)
+ (if (char-ci<? (string-ref x i) (string-ref y i)) 'LESS 'GREATER)
+ 'GREATER)
+ (if (fix:< i ly)
+ 'LESS
+ 'EQUAL)))))
+
+(define (string-prefix-matcher prefix)
+ (let ((l (string-length prefix)))
+ (lambda (x y)
+ (let ((i (string-match-forward x y)))
+ (and (fix:>= 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)))))
+\f
+;;;; 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
projects / mit-scheme.git / commitdiff