Update of /project/stamp/cvsroot/stamp In directory clnet:/tmp/cvs-serv5849
Modified Files: stamp.asd stamp.lisp Added Files: mel-extra.lisp Log Message: Modified mel-base slightly so that we can get hold of the unique filename that is generated when a message is copied into a maildir folder.
Made com-get-mail add a line to the tags files whenever a message is copied.
--- /project/stamp/cvsroot/stamp/stamp.asd 2007/01/04 03:41:04 1.2 +++ /project/stamp/cvsroot/stamp/stamp.asd 2007/01/04 06:13:08 1.3 @@ -27,4 +27,5 @@ (defsystem :stamp :depends-on (:mcclim :mel-base :climacs :split-sequence) :components ((:file "packages") + (:file "mel-extra") (:file "stamp" :depends-on ("packages")))) --- /project/stamp/cvsroot/stamp/stamp.lisp 2007/01/04 03:55:16 1.5 +++ /project/stamp/cvsroot/stamp/stamp.lisp 2007/01/04 06:13:08 1.6 @@ -307,6 +307,34 @@ (when message (send-message message headers body))))))
+(defun address-string-or-nil (address) + (if (null address) + nil + (mel:address-spec address))) + +(defun standard-tags (message) + "Return a list of standard tags for the message" + (list :subject (mel:subject message) + :date (mel:date message) + :from (address-string-or-nil (mel:from message)) + :to (mapcar #'address-string-or-nil (mel:to message)) + :sender (address-string-or-nil (mel:sender message)))) + +(defun copy-message-and-process-standard-tags (message folder) + (let ((folder-name (mel:name folder)) + (message-name (mel:copy-message message folder)) + (tags (standard-tags message))) + (with-open-file (stream (concatenate 'string folder-name "tags1") + :direction :output + :if-does-not-exist :create + :if-exists :append) + (print (cons message-name tags) stream)) + (with-open-file (stream (concatenate 'string folder-name "tags2") + :direction :output + :if-does-not-exist :create + :if-exists :append) + (print (cons message-name tags) stream)))) + (define-stamp-command (com-get-mail :name t) () (loop for mailbox in *mailboxes* do (loop for message in (mel:messages mailbox) @@ -314,7 +342,7 @@ (mel:messages *inbox-folder*) :key #'mel:message-id :test #'string=) - do (mel:copy-message message *inbox-folder*))) + do (copy-message-and-process-standard-tags message *inbox-folder*))) (redisplay-pane 'headers-pane))
(define-stamp-command (com-show-all-headers :name t) ()
--- /project/stamp/cvsroot/stamp/mel-extra.lisp 2007/01/04 06:13:08 NONE +++ /project/stamp/cvsroot/stamp/mel-extra.lisp 2007/01/04 06:13:08 1.1 (in-package :mel.internal)
;;; modify this method so that it returns the unique filename of the sink #+(or sbcl cmu) (defmethod copy-message-using-folders ((message message) message-folder (sink-folder folder)) "Copy a message (contained in some folder) into another folder" (declare (ignore message-folder)) (with-open-stream (source (open-message-input-stream message)) (with-open-stream (sink (open-message-storing-stream sink-folder message)) (loop for c = (read-char source nil nil) while c do (write-char c sink) finally (return (mel.folders.maildir::unique-message-name sink))))))