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)))))
