From: Chris Hanson Date: Mon, 22 May 2000 03:32:17 +0000 (+0000) Subject: Provide inserted default strings to all URL prompts. X-Git-Tag: 20090517-FFI~3763 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=00d4be9197cc85237e835ac9d474bcd377415a7d;p=mit-scheme.git Provide inserted default strings to all URL prompts. --- diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm index 10db2a748..ef2bd89bd 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.80 2000/05/22 03:01:13 cph Exp $ +;;; $Id: imail-core.scm,v 1.81 2000/05/22 03:32:04 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -69,6 +69,15 @@ ;; presentation layer. (define-generic url-presentation-name (url)) +;; Return a string that represents the object containing URL's folder. +;; E.g. the container of "imap://localhost/inbox" is +;; "imap://localhost/". +(define (url-container-string url) + (make-url-string (url-protocol url) + (url-body-container-string url))) + +(define-generic url-body-container-string (url)) + ;; Convert STRING to a URL. GET-DEFAULT-URL is a procedure of one ;; argument that returns a URL that is used to fill in defaults if ;; STRING is a specification for a partial URL. GET-DEFAULT-URL is diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm index cc71678ed..601797f63 100644 --- a/v7/src/imail/imail-file.scm +++ b/v7/src/imail/imail-file.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-file.scm,v 1.31 2000/05/22 02:17:39 cph Exp $ +;;; $Id: imail-file.scm,v 1.32 2000/05/22 03:32:09 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -33,6 +33,9 @@ (define-method url-presentation-name ((url )) (file-namestring (file-url-pathname url))) +(define-method url-body-container-string ((url )) + (directory-namestring (file-url-pathname url))) + (define (define-file-url-completers class filter) (define-method %url-complete-string ((string ) (default-url class) diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index f97bc8b60..3ef94f710 100644 --- a/v7/src/imail/imail-imap.scm +++ b/v7/src/imail/imail-imap.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-imap.scm,v 1.64 2000/05/22 03:01:18 cph Exp $ +;;; $Id: imail-imap.scm,v 1.65 2000/05/22 03:32:12 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -61,13 +61,19 @@ (define-method url-presentation-name ((url )) (imap-url-mailbox url)) +(define-method url-body-container-string ((url )) + (make-imap-url-string (imap-url-user-id url) + (imap-url-host url) + (imap-url-port url) + "")) + (define (compatible-imap-urls? url1 url2) ;; Can URL1 and URL2 both be accessed from the same IMAP session? ;; E.g. can the IMAP COPY command work between them? (and (string=? (imap-url-user-id url1) (imap-url-user-id url2)) (string-ci=? (imap-url-host url1) (imap-url-host url2)) (= (imap-url-port url1) (imap-url-port url2)))) - + (define-method parse-url-body (string default-url) (call-with-values (lambda () (parse-imap-url-body string default-url)) (lambda (user-id host port mailbox) diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm index 1467aac8c..675ad2253 100644 --- a/v7/src/imail/imail-top.scm +++ b/v7/src/imail/imail-top.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: imail-top.scm,v 1.78 2000/05/22 02:17:50 cph Exp $ +;;; $Id: imail-top.scm,v 1.79 2000/05/22 03:32:17 cph Exp $ ;;; ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology ;;; @@ -104,10 +104,10 @@ May be called with an IMAIL folder URL as argument; but does not copy any new mail into the folder." (lambda () (list (and (command-argument) - (prompt-for-imail-url-string "Run IMAIL on folder" #f - 'DEFAULT-TYPE 'VISIBLE-DEFAULT - 'HISTORY 'IMAIL - 'HISTORY-INDEX 0)))) + (prompt-for-imail-url-string "Run IMAIL on folder" + (imail-default-url) + 'DEFAULT-TYPE 'INSERTED-DEFAULT + 'HISTORY 'IMAIL)))) (lambda (url-string) (let ((folder (open-folder @@ -138,20 +138,24 @@ May be called with an IMAIL folder URL as argument; (define (prompt-for-imail-url-string prompt default . options) (apply prompt-for-completed-string prompt - default + (and default (url-container-string default)) (lambda (string if-unique if-not-unique if-not-found) (url-complete-string string imail-get-default-url if-unique if-not-unique if-not-found)) (lambda (string) (url-string-completions string imail-get-default-url)) - (lambda (string) string #t) + (lambda (string) + (url? + (ignore-errors + (lambda () + (parse-url-string string imail-get-default-url))))) options)) (define (imail-default-url) (let ((primary-folder (ref-variable imail-primary-folder))) (if primary-folder (imail-parse-partial-url primary-folder) - (imail-get-default-url "imap")))) + (imail-get-default-url #f)))) (define (imail-parse-partial-url string) (parse-url-string string imail-get-default-url)) @@ -848,7 +852,7 @@ With prefix argument N, removes FLAG from next N messages, (define-command imail-input "Append messages to this folder from a specified folder." (lambda () - (list (prompt-for-imail-url-string "Input from folder" #f + (list (prompt-for-imail-url-string "Input from folder" (imail-default-url) 'DEFAULT-TYPE 'INSERTED-DEFAULT 'HISTORY 'IMAIL-INPUT 'HISTORY-INDEX 0))) @@ -868,7 +872,7 @@ With prefix argument N, removes FLAG from next N messages, (define-command imail-output "Append this message to a specified folder." (lambda () - (list (prompt-for-imail-url-string "Output to folder" #f + (list (prompt-for-imail-url-string "Output to folder" (imail-default-url) 'DEFAULT-TYPE 'INSERTED-DEFAULT 'HISTORY 'IMAIL-OUTPUT 'HISTORY-INDEX 0) @@ -890,20 +894,18 @@ With prefix argument N, removes FLAG from next N messages, "Create a new folder with the specified name. An error if signalled if the folder already exists." (lambda () - (list (prompt-for-imail-url-string "Create folder" #f + (list (prompt-for-imail-url-string "Create folder" (imail-default-url) 'DEFAULT-TYPE 'INSERTED-DEFAULT - 'HISTORY 'IMAIL-CREATE-FOLDER - 'HISTORY-INDEX 0))) + 'HISTORY 'IMAIL-CREATE-FOLDER))) (lambda (url-string) (create-folder (imail-parse-partial-url url-string)))) (define-command imail-delete-folder "Delete a specified folder." (lambda () - (list (prompt-for-imail-url-string "Delete folder" #f + (list (prompt-for-imail-url-string "Delete folder" (imail-default-url) 'DEFAULT-TYPE 'INSERTED-DEFAULT - 'HISTORY 'IMAIL-DELETE-FOLDER - 'HISTORY-INDEX 0))) + 'HISTORY 'IMAIL-DELETE-FOLDER))) (lambda (url-string) (delete-folder (imail-parse-partial-url url-string))))