From c6d3aeb9784aaffcc1ccc86f2306fb6f6c10e576 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 22 May 2000 03:01:30 +0000 Subject: [PATCH] Restructure the URL completion code to clean it up a bit. Change the completer so that it doesn't do completion on URL protocols. Instead, if there isn't a protocol prefix on the string, it assumes the protocol of the default URL, and completes the string relative to that URL. --- v7/src/imail/imail-core.scm | 86 +++++++++++++++++------------------- v7/src/imail/imail-imap.scm | 72 ++++++++++++++++-------------- v7/src/imail/imail-rmail.scm | 4 +- v7/src/imail/imail-umail.scm | 4 +- v7/src/imail/imail-util.scm | 71 +---------------------------- 5 files changed, 83 insertions(+), 154 deletions(-) diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index 49fd53254..10db2a748 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.79 2000/05/22 02:17:35 cph Exp $ +;;; $Id: imail-core.scm,v 1.80 2000/05/22 03:01:13 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -53,8 +53,11 @@ ;; Return the body of URL as a string. (define-generic url-body (url)) +(define (make-url-string protocol body) + (string-append protocol ":" body)) + (define (url->string url) - (string-append (url-protocol url) ":" (url-body url))) + (make-url-string (url-protocol url) (url-body url))) (define-method write-instance ((url ) port) (write-instance-helper 'URL url port @@ -76,15 +79,15 @@ (define (parse-url-string string get-default-url) (let ((colon (string-find-next-char string #\:))) (if colon - (%parse-url-string (string-tail string (fix:+ colon 1)) + (parse-url-body (string-tail string (fix:+ colon 1)) (get-default-url (string-head string colon))) - (%parse-url-string string (get-default-url #f))))) + (parse-url-body string (get-default-url #f))))) ;; Protocol-specific parsing. Dispatch on the class of DEFAULT-URL. ;; Each method is responsible for calling INTERN-URL on the result of ;; the parse, and returning the interned URL. Illegal syntax in ;; STRING must cause an error to be signalled. -(define-generic %parse-url-string (string default-url)) +(define-generic parse-url-body (string default-url)) (define (intern-url url) (let ((string (url->string url))) @@ -120,33 +123,17 @@ (define (url-complete-string string get-default-url if-unique if-not-unique if-not-found) - (let ((colon (string-find-next-char string #\:))) - (if colon - (let ((name (string-head string colon))) - (if (url-protocol-name? name) - (let ((prepend - (lambda (string) (string-append name ":" string)))) - (%url-complete-string (string-tail string (fix:+ colon 1)) - (get-default-url name) - (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))) - (let ((colonify (lambda (name) (string-append name ":")))) - ((ordered-string-vector-completer - (hash-table/ordered-key-vector url-protocols stringlist - ((ordered-string-vector-matches - (hash-table/ordered-key-vector url-protocols string string->number) - ((parser-token pv 'HOST) 143) - (else (imap-url-port default-url))) - (or (parser-token pv 'MAILBOX) - (imap-url-mailbox default-url)))))))) + (if pv + (values (or (parser-token pv 'USER-ID) + (imap-url-user-id default-url)) + (or (parser-token pv 'HOST) + (imap-url-host default-url)) + (cond ((parser-token pv 'PORT) => string->number) + ((parser-token pv 'HOST) 143) + (else (imap-url-port default-url))) + (or (parser-token pv 'MAILBOX) + (imap-url-mailbox default-url))) + (values #f #f #f #f)))))) (define-method %url-complete-string ((string ) (default-url ) if-unique if-not-unique if-not-found) - (call-with-values - (lambda () (parse-imap-completion-url-string string default-url)) + (call-with-values (lambda () (imap-completion-args string default-url)) (lambda (mailbox url) (if mailbox (let ((convert (lambda (mailbox) - (url-body (parse-imap-url-string mailbox url))))) + (make-imap-url-string (imap-url-user-id url) + (imap-url-host url) + (imap-url-port url) + mailbox)))) (complete-imap-mailbox mailbox url (lambda (mailbox) (if-unique (convert mailbox))) (lambda (prefix get-mailboxes) - (if-not-unique (if (string-null? prefix) - (make-imap-url-string (imap-url-user-id url) - (imap-url-host url) - (imap-url-port url) - "") - (convert prefix)) + (if-not-unique (convert prefix) (lambda () (map convert (get-mailboxes))))) if-not-found)) (if-not-found))))) (define-method %url-string-completions ((string ) (default-url )) - (call-with-values - (lambda () (parse-imap-completion-url-string string default-url)) + (call-with-values (lambda () (imap-completion-args string default-url)) (lambda (mailbox url) (if mailbox (map (lambda (mailbox) - (url-body (parse-imap-url-string mailbox url))) + (make-imap-url-string (imap-url-user-id url) + (imap-url-host url) + (imap-url-port url) + mailbox)) (imap-mailbox-completions mailbox url)) '())))) -(define (parse-imap-completion-url-string string default-url) - (cond ((string-null? string) - (values string default-url)) - ((parse-imap-url-string string default-url) - => (lambda (url) (values (imap-url-mailbox url) url))) - (else - (values #f #f)))) +(define (imap-completion-args string default-url) + (if (string-null? string) + (values string default-url) + (call-with-values (lambda () (parse-imap-url-body string default-url)) + (lambda (user-id host port mailbox) + (if user-id + (values mailbox (make-imap-url user-id host port "inbox")) + (values #f #f)))))) (define (complete-imap-mailbox mailbox url if-unique if-not-unique if-not-found) diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm index 9fad354d4..9c6014912 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.34 2000/05/22 02:17:47 cph Exp $ +;;; $Id: imail-rmail.scm,v 1.35 2000/05/22 03:01:24 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -32,7 +32,7 @@ (lambda (pathname) (intern-url (constructor (merge-pathnames pathname)))))) -(define-method %parse-url-string ((string ) (default-url )) +(define-method parse-url-body ((string ) (default-url )) (make-rmail-url (merge-pathnames string (file-url-pathname default-url)))) (define-file-url-completers diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm index bdba2b2c9..fd0d5cb92 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.28 2000/05/22 02:17:55 cph Exp $ +;;; $Id: imail-umail.scm,v 1.29 2000/05/22 03:01:28 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -32,7 +32,7 @@ (lambda (pathname) (intern-url (constructor (merge-pathnames pathname)))))) -(define-method %parse-url-string ((string ) (default-url )) +(define-method parse-url-body ((string ) (default-url )) (make-umail-url (merge-pathnames string (file-url-pathname default-url)))) (define-file-url-completers diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm index d6aabe5e5..98196dd43 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.23 2000/05/21 00:03:32 cph Exp $ +;;; $Id: imail-util.scm,v 1.24 2000/05/22 03:01:30 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -297,75 +297,6 @@ (define derived-port-condition (condition-accessor condition-type:derived-port-error 'CONDITION)) -;;;; Ordered-string-vector completion - -(define (hash-table/ordered-key-vector table <) - (let ((v (list->vector (hash-table/key-list table)))) - (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 -- 2.25.1