From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 28 Sep 2001 00:42:21 +0000 (+0000)
Subject: Change handling of file folders so that their type is determined
X-Git-Tag: 20090517-FFI~2544
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1a5295bdb3ca16be9a039db2f14818222ce9eeb2;p=mit-scheme.git

Change handling of file folders so that their type is determined
solely by their contents rather than their names.
---

diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index aebfc2f89..e83904b12 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.79 2001/09/14 02:06:43 cph Exp $
+;;; $Id: imail-file.scm,v 1.80 2001/09/28 00:41:21 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -23,6 +23,36 @@
 
 (declare (usual-integrations))
 
+;;;; File-folder types
+
+(define-class <file-folder-type> ()
+  (name define accessor)
+  (predicate define accessor))
+
+(define (define-file-folder-type class name predicate)
+  (hash-table/put! file-folder-types
+		   class
+		   ((instance-constructor class '(NAME PREDICATE))
+		    name predicate)))
+
+(define file-folder-types
+  (make-eq-hash-table))
+
+(define (prompt-for-file-folder-type url)
+  (imail-ui:prompt-for-alist-value
+   (string-append "File type for " (url->string url))
+   (map (lambda (type)
+	  (cons (file-folder-type-name type) type))
+	(hash-table/datum-list file-folder-types))))
+
+(define (url-file-folder-type url)
+  (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)))))
+
 ;;;; URL
 
 (define-class <pathname-url> (<url>)
@@ -30,24 +60,15 @@
 
 (define-url-protocol "file" <pathname-url>)
 
-(define (pathname-url-constructor class)
-  (let ((procedure
-	 (let ((constructor (instance-constructor class '(PATHNAME))))
-	   (lambda (pathname)
-	     (intern-url (constructor (merge-pathnames pathname))
-			 pathname-container-url)))))
-    (register-pathname-url-constructor class procedure)
-    procedure))
-
-(define (register-pathname-url-constructor class constructor)
-  (hash-table/put! pathname-url-constructors class constructor))
-
-(define (get-pathname-url-constructor class)
-  (or (hash-table/get pathname-url-constructors class #f)
-      (error "Unknown pathname-url class:" class)))
-
-(define pathname-url-constructors
-  (make-eq-hash-table))
+(define (make-pathname-url pathname)
+  (case (file-type-indirect pathname)
+    ((REGULAR) (make-file-url pathname))
+    ((DIRECTORY) (make-directory-url pathname))
+    ((#F)
+     (if (directory-pathname? pathname)
+	 (make-directory-url pathname)
+	 (make-file-url pathname)))
+    (else (error "Pathname refers to illegal file type:" pathname))))
 
 (define (pathname-container-url url)
   (make-directory-url (pathname-container (pathname-url-pathname url))))
@@ -62,67 +83,9 @@
 (define (pathname-container pathname)
   (directory-pathname (directory-pathname-as-file pathname)))
 
-(define (define-pathname-url-predicates class
-	  file-predicate
-	  directory-predicate
-	  pathname-predicate)
-  (let ((constructor (get-pathname-url-constructor class)))
-    (let loop ((entries pathname-url-predicates))
-      (if (pair? entries)
-	  (if (eq? class (vector-ref (car entries) 0))
-	      (begin
-		(vector-set! (car entries) 1 file-predicate)
-		(vector-set! (car entries) 2 directory-predicate)
-		(vector-set! (car entries) 3 pathname-predicate)
-		(vector-set! (car entries) 4 constructor))
-	      (loop (cdr entries)))
-	  (begin
-	    (set! pathname-url-predicates
-		  (cons (vector class
-				file-predicate
-				directory-predicate
-				pathname-predicate
-				constructor)
-			pathname-url-predicates))
-	    unspecific)))))
-
-(define (find-pathname-url-constructor pathname must-exist? if-not-found)
-  (let ((type (file-type-indirect pathname))
-	(search
-	 (lambda (index)
-	   (let loop ((entries pathname-url-predicates))
-	     (and (pair? entries)
-		  (if ((vector-ref (car entries) index) pathname)
-		      (vector-ref (car entries) 4)
-		      (loop (cdr entries))))))))
-    (or (case type
-	  ((REGULAR) (search 1))
-	  ((DIRECTORY) (search 2))
-	  ((#F) (and (not must-exist?) (search 3)))
-	  (else #f))
-	(and if-not-found
-	     (if-not-found pathname type)))))
-
-(define pathname-url-predicates '())
-
 (define-method parse-url-body ((string <string>) (default-url <pathname-url>))
-  (let ((pathname
-	 (parse-pathname-url-body string (pathname-url-pathname default-url))))
-    ((standard-pathname-url-constructor pathname) pathname)))
-
-(define (standard-pathname-url-constructor pathname)
-  (find-pathname-url-constructor pathname #f
-    (lambda (pathname type)
-      (case type
-	((REGULAR) make-file-url)
-	((DIRECTORY) make-directory-url)
-	((#F)
-	 (if (directory-pathname? pathname)
-	     make-directory-url
-	     ;; Default for non-existent files:
-	     make-umail-url))
-	(else
-	 (error "Pathname refers to illegal file type:" pathname))))))
+  (make-pathname-url
+   (parse-pathname-url-body string (pathname-url-pathname default-url))))
 
 (define (parse-pathname-url-body string default-pathname)
   (let ((finish
@@ -171,13 +134,20 @@
 ;;;; File URLs
 
 (define-class <file-url> (<folder-url> <pathname-url>))
-(define make-file-url (pathname-url-constructor <file-url>))
+
+(define make-file-url
+  (let ((constructor (instance-constructor <file-url> '(PATHNAME))))
+    (lambda (pathname)
+      (intern-url (constructor (merge-pathnames pathname))
+		  pathname-container-url))))
 
 (define-method url-exists? ((url <file-url>))
   (file-exists? (pathname-url-pathname url)))
 
 (define-method folder-url-is-selectable? ((url <file-url>))
-  (and (find-pathname-url-constructor (pathname-url-pathname url) #t #f) #t))
+  (and (url-exists? url)
+       (url-file-folder-type url)
+       #t))
 
 (define-method url-corresponding-container ((url <file-url>))
   url
@@ -197,26 +167,20 @@
        (constructor (pathname-as-directory (merge-pathnames pathname)))
        pathname-container-url))))
 
-(register-pathname-url-constructor <directory-url> make-directory-url)
-
 (define-method url-exists? ((url <directory-url>))
   (file-directory? (pathname-url-pathname url)))
 
 (define-method make-content-url ((url <directory-url>) name)
-  (let ((pathname (merge-pathnames name (pathname-url-pathname url))))
-    ((standard-pathname-url-constructor pathname) pathname)))
+  (make-pathname-url (merge-pathnames name (pathname-url-pathname url))))
 
 (define-method container-url-contents ((url <directory-url>))
   (simple-directory-read (pathname-url-pathname url)
     (lambda (name directory result)
       (if (or (string=? name ".") (string=? name ".."))
 	  result
-	  (let* ((pathname
-		  (parse-namestring (string-append directory name) #f #f))
-		 (constructor (pathname-url-filter pathname)))
-	    (if constructor
-		(cons (constructor pathname) result)
-		result))))))
+	  (cons (make-pathname-url
+		 (parse-namestring (string-append directory name) #f #f))
+		result)))))
 
 ;;;; Server operations
 
@@ -227,7 +191,7 @@
    (parse-pathname-url-body
     string
     (directory-pathname (pathname-url-pathname default-url)))
-   pathname-url-filter
+   (lambda (pathname) pathname #t)
    (lambda (string)
      (if-unique (pathname->url-body string)))
    (lambda (prefix get-completions)
@@ -242,17 +206,20 @@
 	(parse-pathname-url-body
 	 string
 	 (directory-pathname (pathname-url-pathname default-url)))
-	pathname-url-filter)))
+	(lambda (pathname) pathname #t))))
 
-(define (pathname-url-filter pathname)
-  (find-pathname-url-constructor pathname #t
-    (lambda (pathname type)
-      pathname
-      (and (eq? type 'DIRECTORY)
-	   make-directory-url))))
+(define-method %create-resource ((url <file-url>))
+  (let ((pathname (pathname-url-pathname url)))
+    (if (file-exists? pathname)
+	(error:bad-range-argument url 'CREATE-RESOURCE))
+    (create-file-folder-file url (prompt-for-file-folder-type url))
+    (open-resource url)))
+
+(define-generic create-file-folder-file (url type))
 
 (define-method %create-resource ((url <directory-url>))
-  (make-directory (pathname-url-pathname url)))
+  (make-directory (pathname-url-pathname url))
+  (maybe-make-resource url make-file-container))
 
 (define-method %delete-resource ((url <file-url>))
   (delete-file (pathname-url-pathname url)))
@@ -289,6 +256,15 @@
 (define (file-folder-pathname folder)
   (pathname-url-pathname (resource-locator folder)))
 
+(define-method open-resource ((url <pathname-url>))
+  (or (and (url-exists? url)
+	   (%open-file-resource url (url-file-folder-type url)))
+      (begin
+	(unmemoize-resource url)
+	(error:bad-range-argument url 'OPEN-RESOURCE))))
+
+(define-generic %open-file-resource (url folder-type))
+
 (define-method close-resource ((folder <file-folder>) no-defer?)
   no-defer?
   (save-resource folder)
@@ -318,27 +294,31 @@
   (vector-ref (file-folder-messages folder) index))
 
 (define-method %append-message ((message <message>) (url <file-url>))
-  (let ((folder (get-memoized-resource url)))
-    (if folder
-	(let ((message (make-message-copy message folder))
-	      (exists?
-	       (or (file-folder-file-modification-time folder)
-		   (file-exists? (file-folder-pathname folder)))))
-	  (without-interrupts
-	   (lambda ()
-	     (set-file-folder-messages!
-	      folder
-	      (let ((messages (file-folder-messages folder)))
-		(let ((n (vector-length messages)))
-		  (let ((messages (vector-grow messages (fix:+ n 1))))
-		    (attach-message! message folder n)
-		    (vector-set! messages n message)
-		    messages))))))
-	  (not exists?))
-	(append-message-to-file message url))))
+  (let ((exists? (url-exists? url)))
+    (let ((folder (get-memoized-resource url)))
+      (if folder
+	  (let ((message (make-message-copy message folder)))
+	    (without-interrupts
+	     (lambda ()
+	       (set-file-folder-messages!
+		folder
+		(let ((messages (file-folder-messages folder)))
+		  (let ((n (vector-length messages)))
+		    (let ((messages (vector-grow messages (fix:+ n 1))))
+		      (attach-message! message folder n)
+		      (vector-set! messages n message)
+		      messages)))))))
+	  (let ((type
+		 (if exists?
+		     (url-file-folder-type url)
+		     (prompt-for-file-folder-type url))))
+	    (if (not exists?)
+		(create-file-folder-file url type))
+	    (append-message-to-file message url type))))
+    (not exists?)))
 
 (define-generic make-message-copy (message folder))
-(define-generic append-message-to-file (message url))
+(define-generic append-message-to-file (message url type))
 
 (define-method expunge-deleted-messages ((folder <file-folder>))
   (without-interrupts
diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index 52099ede8..4b98df048 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.68 2001/06/12 00:47:36 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.69 2001/09/28 00:41:25 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -23,35 +23,20 @@
 
 (declare (usual-integrations))
 
-;;;; URL
-
-(define-class <rmail-url> (<file-url>))
-(define make-rmail-url (pathname-url-constructor <rmail-url>))
-
-(define-pathname-url-predicates <rmail-url>
-  (lambda (pathname) (check-file-prefix pathname "BABYL OPTIONS:"))
-  (lambda (pathname) pathname #f)
-  (lambda (pathname)
-    (or (equal? (pathname-type pathname) "rmail")
-	(and (equal? (pathname-name pathname) "RMAIL")
-	     (not (pathname-type pathname))))))
-
-;;;; Server operations
-
-(define-method %create-resource ((url <rmail-url>))
-  (if (file-exists? (pathname-url-pathname url))
-      (error:bad-range-argument url 'CREATE-RESOURCE))
-  (let ((folder (make-rmail-folder url)))
-    (set-file-folder-messages! folder '#())
-    (set-rmail-folder-header-fields!
-     folder
-     (compute-rmail-folder-header-fields folder))
-    (set-file-folder-file-modification-time! folder (get-universal-time))
-    (set-file-folder-file-modification-count!
-     folder
-     (object-modification-count folder))
-    (save-resource folder)))
-
+(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:")))
+
+;;;; Server
+
+(define-method create-file-folder-file (url (type <rmail-folder-type>))
+  type
+  (call-with-binary-output-file (pathname-url-pathname url)
+    (lambda (port)
+      (write-rmail-file-header (make-rmail-folder-header-fields '()) port))))
+
 ;;;; Folder
 
 (define-class (<rmail-folder> (constructor (locator))) (<file-folder>)
@@ -73,12 +58,9 @@
 	(make-header-field "Note" "If you are seeing it in rmail,")
 	(make-header-field "Note" "it means the file has no messages in it.")))
 
-(define-method open-resource ((url <rmail-url>))
-  (if (file-readable? (pathname-url-pathname url))
-      (maybe-make-resource url make-rmail-folder)
-      (begin
-	(unmemoize-resource url)
-	(error:bad-range-argument url 'OPEN-RESOURCE))))
+(define-method %open-file-resource (url (type <rmail-folder-type>))
+  type
+  (maybe-make-resource url make-rmail-folder))
 
 ;;;; Message
 
@@ -263,19 +245,11 @@
 	(lambda (message)
 	  (write-rmail-message message port))))))
 
-(define-method append-message-to-file ((message <message>) (url <rmail-url>))
-  (let ((pathname (pathname-url-pathname url)))
-    (let ((exists? (file-exists? pathname)))
-      (if exists?
-	  (call-with-binary-append-file pathname
-	    (lambda (port)
-	      (write-rmail-message message port)))
-	  (call-with-binary-output-file pathname
-	    (lambda (port)
-	      (write-rmail-file-header (make-rmail-folder-header-fields '())
-				       port)
-	      (write-rmail-message message port))))
-      (not exists?))))
+(define-method append-message-to-file (message url (type <rmail-folder-type>))
+  type
+  (call-with-binary-append-file (pathname-url-pathname url)
+    (lambda (port)
+      (write-rmail-message message port))))
 
 (define (write-rmail-file-header header-fields port)
   (write-string "BABYL OPTIONS: -*- rmail -*-" port)
diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index a38e08732..e3f69ac67 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.271 2001/09/14 21:19:29 cph Exp $
+;;; $Id: imail-top.scm,v 1.272 2001/09/28 00:41:44 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -1732,7 +1732,7 @@ Negative argument means search in reverse."
 			    port
 			    (ref-variable imail-default-imap-mailbox
 					  #f)))))
-	((string-ci=? protocol "file") (make-rmail-url "~/RMAIL"))
+	((string-ci=? protocol "file") (make-file-url "~/RMAIL"))
 	(else (error:bad-range-argument protocol))))
 
 (define (imail-default-container)
@@ -1846,6 +1846,7 @@ Negative argument means search in reverse."
 (define *imail-message-wrapper-prefix* #f)
 
 (define imail-ui:message message)
+(define imail-ui:prompt-for-alist-value prompt-for-alist-value)
 (define imail-ui:prompt-for-yes-or-no? prompt-for-yes-or-no?)
 
 (define (imail-ui:body-cache-limit message)
diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
index 23f5496d2..3dac0d5ad 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.49 2001/06/12 00:47:39 cph Exp $
+;;; $Id: imail-umail.scm,v 1.50 2001/09/28 00:41:48 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -23,39 +23,28 @@
 
 (declare (usual-integrations))
 
-;;;; URL
+(define-class <umail-folder-type> (<file-folder-type>))
 
-(define-class <umail-url> (<file-url>))
-(define make-umail-url (pathname-url-constructor <umail-url>))
-
-(define-pathname-url-predicates <umail-url>
-  (lambda (pathname) (check-file-prefix pathname "From "))
-  (lambda (pathname) pathname #f)
-  (lambda (pathname) (equal? (pathname-type pathname) "mail")))
+(define-file-folder-type <umail-folder-type> "unix mail"
+  (lambda (url)
+    (check-file-prefix (pathname-url-pathname url) "From ")))
 
 ;;;; Server operations
 
-(define-method %create-resource ((url <umail-url>))
-  (if (file-exists? (pathname-url-pathname url))
-      (error:bad-range-argument url 'CREATE-RESOURCE))
-  (let ((folder (make-umail-folder url)))
-    (set-file-folder-messages! folder '#())
-    (set-file-folder-file-modification-time! folder (get-universal-time))
-    (set-file-folder-file-modification-count!
-     folder
-     (object-modification-count folder))
-    (save-resource folder)))
+(define-method create-file-folder-file (url (type <umail-folder-type>))
+  type
+  (call-with-binary-output-file (pathname-url-pathname url)
+    (lambda (port)
+      port
+      unspecific)))
 
 ;;;; Folder
 
 (define-class (<umail-folder> (constructor (locator))) (<file-folder>))
 
-(define-method open-resource ((url <umail-url>))
-  (if (file-readable? (pathname-url-pathname url))
-      (maybe-make-resource url make-umail-folder)
-      (begin
-	(unmemoize-resource url)
-	(error:bad-range-argument url 'OPEN-RESOURCE))))
+(define-method %open-file-resource (url (type <umail-folder-type>))
+  type
+  (maybe-make-resource url make-umail-folder))
 
 ;;;; Message
 
@@ -160,13 +149,11 @@
 	(lambda (message)
 	  (write-umail-message message #t port))))))
 
-(define-method append-message-to-file ((message <message>) (url <umail-url>))
-  (let ((pathname (pathname-url-pathname url)))
-    (let ((exists? (file-exists? pathname)))
-      (call-with-binary-append-file pathname
-	(lambda (port)
-	  (write-umail-message message #t port)))
-      (not exists?))))
+(define-method append-message-to-file (message url (type <umail-folder-type>))
+  type
+  (call-with-binary-append-file (pathname-url-pathname url)
+    (lambda (port)
+      (write-umail-message message #t port))))
 
 (define (write-umail-message message output-flags? port)
   (write-string (umail-message-from-line message) port)
diff --git a/v7/src/imail/imail.pkg b/v7/src/imail/imail.pkg
index c16412d65..8ce13281f 100644
--- a/v7/src/imail/imail.pkg
+++ b/v7/src/imail/imail.pkg
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail.pkg,v 1.87 2001/06/04 17:42:49 cph Exp $
+;;; $Id: imail.pkg,v 1.88 2001/09/28 00:41:16 cph Exp $
 ;;;
 ;;; Copyright (c) 2000-2001 Massachusetts Institute of Technology
 ;;;
@@ -117,28 +117,27 @@
   (files "imail-file")
   (parent (edwin imail))
   (export (edwin imail)
+	  directory-url?
 	  file-folder-pathname
 	  file-folder?
 	  file-message?
-	  file-url?))
+	  file-url?
+	  make-directory-url
+	  make-file-url))
 
 (define-package (edwin imail file-folder rmail-folder)
   (files "imail-rmail")
   (parent (edwin imail file-folder))
   (export (edwin imail)
-	  make-rmail-url
 	  rmail-folder?
-	  rmail-message?
-	  rmail-url?))
+	  rmail-message?))
 
 (define-package (edwin imail file-folder umail-folder)
   (files "imail-umail")
   (parent (edwin imail file-folder))
   (export (edwin imail)
-	  make-umail-url
 	  umail-folder?
-	  umail-message?
-	  umail-url?)
+	  umail-message?)
   (export (edwin imail file-folder rmail-folder)
 	  read-umail-message
 	  umail-delimiter?))
@@ -327,6 +326,7 @@
 	  imail-ui:message-wrapper
 	  imail-ui:present-user-alert
 	  imail-ui:progress-meter
+	  imail-ui:prompt-for-alist-value
 	  imail-ui:prompt-for-yes-or-no?))
 
 (define-package (edwin imail front-end summary)
diff --git a/v7/src/imail/load.scm b/v7/src/imail/load.scm
index 7d7494463..f5b86e570 100644
--- a/v7/src/imail/load.scm
+++ b/v7/src/imail/load.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: load.scm,v 1.29 2001/09/14 02:07:21 cph Exp $
+;;; $Id: load.scm,v 1.30 2001/09/28 00:42:21 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -28,4 +28,4 @@
   (lambda ()
     (fluid-let ((*allow-package-redefinition?* #t))
       (load-package-set "imail"))))
-(add-subsystem-identification! "IMAIL" '(1 12))
\ No newline at end of file
+(add-subsystem-identification! "IMAIL" '(1 13))
\ No newline at end of file