From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 25 Mar 2002 16:35:58 +0000 (+0000)
Subject: Change M-o command to act like o if the output file is in a known
X-Git-Tag: 20090517-FFI~2193
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8221f8001b8c46ae61223c614cde4fb244fa6c1f;p=mit-scheme.git

Change M-o command to act like o if the output file is in a known
format.
---

diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index e83904b12..7f996a643 100644
--- a/v7/src/imail/imail-file.scm
+++ b/v7/src/imail/imail-file.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-file.scm,v 1.80 2001/09/28 00:41:21 cph Exp $
+;;; $Id: imail-file.scm,v 1.81 2002/03/25 16:35:46 cph Exp $
 ;;;
-;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1999-2002 Massachusetts Institute of Technology
 ;;;
 ;;; This program is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU General Public License as
@@ -46,12 +46,15 @@
 	(hash-table/datum-list file-folder-types))))
 
 (define (url-file-folder-type url)
+  (or (file-folder-type (pathname-url-pathname url))
+      (error "Unknown folder type:" url)))
+
+(define (file-folder-type pathname)
   (let loop ((types (hash-table/datum-list file-folder-types)))
-    (if (not (pair? types))
-	(error "Unknown folder type:" url))
-    (if ((file-folder-type-predicate (car types)) url)
-	(car types)
-	(loop (cdr types)))))
+    (and (pair? types)
+	 (if ((file-folder-type-predicate (car types)) pathname)
+	     (car types)
+	     (loop (cdr types))))))
 
 ;;;; URL
 
@@ -146,7 +149,7 @@
 
 (define-method folder-url-is-selectable? ((url <file-url>))
   (and (url-exists? url)
-       (url-file-folder-type url)
+       (file-folder-type (pathname-url-pathname url))
        #t))
 
 (define-method url-corresponding-container ((url <file-url>))
diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index 4b98df048..daac00d9a 100644
--- a/v7/src/imail/imail-rmail.scm
+++ b/v7/src/imail/imail-rmail.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-rmail.scm,v 1.69 2001/09/28 00:41:25 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.70 2002/03/25 16:35:49 cph Exp $
 ;;;
-;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1999-2002 Massachusetts Institute of Technology
 ;;;
 ;;; This program is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU General Public License as
@@ -26,8 +26,8 @@
 (define-class <rmail-folder-type> (<file-folder-type>))
 
 (define-file-folder-type <rmail-folder-type> "Rmail"
-  (lambda (url)
-    (check-file-prefix (pathname-url-pathname url) "BABYL OPTIONS:")))
+  (lambda (pathname)
+    (check-file-prefix pathname "BABYL OPTIONS:")))
 
 ;;;; Server
 
diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index a09d048f8..d659bde48 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.282 2002/02/22 16:07:34 cph Exp $
+;;; $Id: imail-top.scm,v 1.283 2002/03/25 16:35:51 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2002 Massachusetts Institute of Technology
 ;;;
@@ -877,21 +877,26 @@ This command writes the message to the output file in human-readable format,
 			   'HISTORY-INDEX 0)
 	  (command-argument)))
   (lambda (pathname argument)
-    (let ((write-separator? (file-exists? pathname)))
-      (call-with-temporary-buffer " *imail-file-message*"
-	(lambda (buffer)
-	  (let ((mark (mark-left-inserting-copy (buffer-start buffer))))
-	    (move-relative-undeleted argument
-	      (lambda (message)
-		(if write-separator?
-		    (begin
-		      (insert-newline mark)
-		      (insert-chars #\= 79 mark)
-		      (insert-newlines 2 mark))
-		    (set! write-separator? #t))
-		(insert-message message #f 0 mark)))
-	    (mark-temporary! mark))
-	  (append-to-file (buffer-region buffer) pathname #t 'DEFAULT))))))
+    (let ((exists? (file-exists? pathname)))
+      (if (and exists? (file-folder-type pathname))
+	  ((ref-command imail-output)
+	   (url->string (make-pathname-url pathname))
+	   argument)
+	  (call-with-temporary-buffer " *imail-file-message*"
+	    (lambda (buffer)
+	      (let ((mark (mark-left-inserting-copy (buffer-start buffer))))
+		(move-relative-undeleted argument
+		  (lambda (message)
+		    (if exists?
+			(begin
+			  (insert-newline mark)
+			  (insert-chars #\= 79 mark)
+			  (insert-newlines 2 mark))
+			(set! exists? #t))
+		    (insert-message message #f 0 mark)))
+		(mark-temporary! mark))
+	      (append-to-file (buffer-region buffer) pathname #t
+			      'DEFAULT)))))))
 
 ;;;; Attachments
 
@@ -1766,7 +1771,7 @@ Negative argument means search in reverse."
 			    port
 			    (ref-variable imail-default-imap-mailbox
 					  #f)))))
-	((string-ci=? protocol "file") (make-file-url "~/RMAIL"))
+	((string-ci=? protocol "file") (make-pathname-url "~/RMAIL"))
 	(else (error:bad-range-argument protocol))))
 
 (define (imail-default-container)
diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
index 3dac0d5ad..90c4cdf97 100644
--- a/v7/src/imail/imail-umail.scm
+++ b/v7/src/imail/imail-umail.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-umail.scm,v 1.50 2001/09/28 00:41:48 cph Exp $
+;;; $Id: imail-umail.scm,v 1.51 2002/03/25 16:35:54 cph Exp $
 ;;;
-;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
+;;; Copyright (c) 1999-2002 Massachusetts Institute of Technology
 ;;;
 ;;; This program is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU General Public License as
@@ -26,8 +26,8 @@
 (define-class <umail-folder-type> (<file-folder-type>))
 
 (define-file-folder-type <umail-folder-type> "unix mail"
-  (lambda (url)
-    (check-file-prefix (pathname-url-pathname url) "From ")))
+  (lambda (pathname)
+    (check-file-prefix pathname "From ")))
 
 ;;;; Server operations
 
diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index 885f9a1d2..205a9cf4a 100644
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail.pkg,v 1.95 2001/12/18 21:35:40 cph Exp $
+;;; $Id: imail.pkg,v 1.96 2002/03/25 16:35:44 cph Exp $
 ;;;
 ;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
 ;;;
@@ -61,13 +61,12 @@
   (files "imail-file")
   (parent (edwin imail))
   (export (edwin imail)
-	  directory-url?
 	  file-folder-pathname
+	  file-folder-type
 	  file-folder?
 	  file-message?
-	  file-url?
-	  make-directory-url
-	  make-file-url))
+	  make-pathname-url
+	  pathname-url?))
 
 (define-package (edwin imail file-folder rmail-folder)
   (files "imail-rmail")
diff --git a/v7/src/imail/load.scm b/v7/src/imail/load.scm
index d2c8ef69b..26bdb9c80 100644
--- a/v7/src/imail/load.scm
+++ b/v7/src/imail/load.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: load.scm,v 1.38 2002/02/03 04:37:21 cph Exp $
+;;; $Id: load.scm,v 1.39 2002/03/25 16:35:56 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2002 Massachusetts Institute of Technology
 ;;;
@@ -28,4 +28,4 @@
   (lambda ()
     (fluid-let ((*allow-package-redefinition?* #t))
       (load-package-set "imail"))))
-(add-subsystem-identification! "IMAIL" '(1 18))
\ No newline at end of file
+(add-subsystem-identification! "IMAIL" '(1 19))
\ No newline at end of file
diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt
index 815b292ff..d5b3f13cd 100644
--- a/v7/src/imail/todo.txt
+++ b/v7/src/imail/todo.txt
@@ -1,13 +1,9 @@
 IMAIL To-Do List
-$Id: todo.txt,v 1.136 2002/01/12 02:57:38 cph Exp $
+$Id: todo.txt,v 1.137 2002/03/25 16:35:58 cph Exp $
 
 Bug fixes
 ---------
 
-* Change M-o command to act like o if the output file is in a known
-  format.  Maybe make the o command act like M-o if it is _not_ in a
-  known format?  In that case there would be only one output command.
-
 * Remove cache for folders that aren't on server any more.
 
 * When browser pops up a window of URLs that it is operating on, the