[stamp-cvs] CVS stamp

[rstrandh]

Update of /project/stamp/cvsroot/stamp
In directory clnet:/tmp/cvs-serv28250

Modified Files:
	mel-extra.lisp 
Log Message:
Mel-base uses declarations of `simple-base-string' that it probably
shouldn't.  Recent versions of SBCL don't seem to return simple base
string in some contexts where mel-base wants them.

Fix this temporarily by redefining the offending mel-base functions.  



--- /project/stamp/cvsroot/stamp/mel-extra.lisp	2007/01/04 06:13:08	1.1
+++ /project/stamp/cvsroot/stamp/mel-extra.lisp	2007/02/15 14:27:18	1.2
@@ -11,3 +11,50 @@
             while c do (write-char c sink)
 	    finally (return (mel.folders.maildir::unique-message-name sink))))))
 
+(in-package :mel.folders.maildir)
+
+(declaim (inline uidify))
+(defun uidify (file)
+  (let ((uid-end (position #\: file :from-end t)))
+    (if uid-end
+      (subseq file 0 uid-end)
+      file)))
+        
+(defun find-message-file (folder uid)
+  (let ((uid (uidify uid)))
+    (declare (type string uid))
+    (let ((cell (gethash uid (uid-cache folder))))
+      (when cell
+        (case (car cell)
+	  (:new (mel.filesystem:append-name (new-mail folder) (cdr cell)))
+	  (:cur (mel.filesystem:append-name (current-mail folder) (cdr cell))))))))
+
+(defmethod map-messages (fn (folder maildir-folder))
+  (declare (optimize (speed 0) (safety 3)))
+  (or (and (folder-recent-p folder)
+	   (slot-boundp folder 'selected-messages)
+	   (selected-messages folder)
+	   (progn (map nil fn (selected-messages folder)) (selected-messages folder)))
+      (setf (selected-messages folder)
+	    (let ((messages nil))
+	      (flet ((push-message (file)
+		       (let ((message (find-message folder file :if-does-not-exist :create)))
+			 (push message messages)
+			 message)))
+		(declare #-(or sbcl cmu)(dynamic-extent #'push-message))
+		(let ((uid-cache (uid-cache folder)))
+		  
+		  (mel.filesystem:map-directory 
+		   (lambda (file)
+		     (setf (gethash file uid-cache) (cons :new file))
+		     (funcall fn (push-message file)))
+		   (namestring (truename (new-mail folder))))
+		  
+		  (mel.filesystem:map-directory 
+		   (lambda (file)
+		     (let ((uid (uidify file)))
+		       (setf (gethash uid uid-cache) (cons :cur file))
+		       (funcall fn (push-message file))))
+		   (namestring (truename (current-mail folder))))))
+	      
+	      (nreverse messages)))))