[stamp-cvs] CVS stamp

[rstrandh]

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