[stamp-cvs] CVS stamp
fwillemain
fwillemain at common-lisp.net
Fri Apr 6 08:58:52 UTC 2007
Update of /project/stamp/cvsroot/stamp
In directory clnet:/tmp/cvs-serv22536
Modified Files:
clim-utilities.lisp files-utilities.lisp filters.lisp
mel-extra.lisp misc-utilities.lisp packages.lisp stamp.asd
stamp.lisp
Added Files:
README.txt clim-commands.lisp clim-interface.lisp config.lisp
mel-utilities.lisp message-composing.lisp skeleton
Removed Files:
message.lisp
Log Message:
the application runs with the filter system
--- /project/stamp/cvsroot/stamp/clim-utilities.lisp 2007/03/21 18:21:37 1.1
+++ /project/stamp/cvsroot/stamp/clim-utilities.lisp 2007/04/06 08:58:48 1.2
@@ -27,10 +27,6 @@
(setf (clim:stream-cursor-position pane)
(values (+ cursor-x width) cursor-y)))))
-
-
-
-
(defun maybe-cut-string-at-width (pane string max-width)
(loop for index downfrom (length string)
as string2 = (if (= index (length string))
@@ -40,8 +36,6 @@
until (<= string2-width max-width)
finally (return string2)))
-
-
(defun print-properties-as-table (pane properties)
(clim:formatting-table (pane :x-spacing 10)
(loop for property in properties
@@ -52,8 +46,6 @@
(clim:formatting-cell (pane)
(write-string (cdr property) pane))))))
-
-
(defun hilight-line (pane y)
(multiple-value-bind (pane-x1 pane-y1 pane-x2 pane-y2)
(clim:bounding-rectangle* pane)
@@ -66,3 +58,7 @@
+
+
+
+
--- /project/stamp/cvsroot/stamp/files-utilities.lisp 2007/03/21 18:21:37 1.1
+++ /project/stamp/cvsroot/stamp/files-utilities.lisp 2007/04/06 08:58:48 1.2
@@ -1,6 +1,11 @@
+;;; files-utilities
+
+;;; Management of the various files of the system.
+
(in-package :stamp-core)
-;;fait une copie bit a bit du fichier from dans le fichier to
+;;; Makes a copy bit to bit of the file "from"
+;;; into the file "to".
(defun copy-file (from to)
(with-open-file (in from
:direction :input
@@ -12,32 +17,25 @@
:element-type 'unsigned-byte
:if-does-not-exist :create
:if-exists :overwrite)
-
(do ((i (read-byte in nil -1)
(read-byte in nil -1)))
((minusp i))
(declare (fixnum i))
(write-byte i out)))))
-;; lit le fichier file et le renvoie sous forme de liste
-(defun read-file-to-list(file)
- (with-open-file(stream file
- :direction :input
- :if-does-not-exist :error)
+;;; Reads the file take off and send back it in the form of list.
+(defun read-file-to-list (file)
+ (with-open-file (stream file
+ :direction :input
+ :if-does-not-exist :error)
(loop for l = (read stream nil nil)
- until(null l)
- collect l)))
-
+ until (null l)
+ collect l)))
-;;permet de comparer les fichiers tags file1 et file2
-;;renvoie T si il sont identique et nil sinon
-(defun compare-tags-files(file1 file2)
+;;; Allows to verify if files tags1 and tags2 are identical.
+(defun compare-tags-files (file1 file2)
(let ((l1 (read-file-to-list file1))
(l2 (read-file-to-list file2)))
- (if (equal l1 l2) T )))
+ (equal l1 l2)))
-
-
-
-
--- /project/stamp/cvsroot/stamp/filters.lisp 2007/03/22 17:13:37 1.2
+++ /project/stamp/cvsroot/stamp/filters.lisp 2007/04/06 08:58:48 1.3
@@ -1,42 +1,50 @@
;;; filters
-(defparameter *tags*
- (load-info-list
- (concatenate 'string
- (namestring (user-homedir-pathname))
- "Mail/inbox/tags")))
-
-(defun load-info-list (file)
- (with-open-file (stream file)
- (loop for l = (read stream nil nil)
- until (null l)
- collect l)))
+;;; Functions which allow to generate functions of filter and
+;;; to apply them to all the present messages in our directory
+;;; of e-mails.
+(in-package :stamp-core)
+
+;;; List of the present messages in the file tags1.
+(defparameter *tags* '())
+
+(defun load-tags ()
+ (setf *tags* (read-file-to-list
+ (concatenate 'string
+ *mail-folder*
+ "tags1"))))
+
+;;; List of the functions of filters.
+(defparameter *filter-names* '())
+
+;;; Macro for the definition of filters.
(defmacro define-filter (name args &body body)
`(defun ,name (&rest tags &key , at args &allow-other-keys)
, at body))
+;;; To get back the filtered messages.
(defun filter-messages (filter)
(loop for tag in *tags*
- when (funcall filter :field tag)
+ when (apply filter (cdr tag))
collect tag))
-(filter-messages #'unread)
-
-(define-filter unread (field)
- (declare (ignore tags))
- (getf (cdr field) :unread))
-
-;(unread)
-
-;(define-filter recent-unread ()
-; (and (apply #'recent tags)
-; (apply #'unread tags)))
-
-
-;(defun filter-messages (filter-name)
-; (do ((tmp *tags* (cdr tmp))
-; (res '() (if (funcall filter-name :field (car tmp))
-; (cons (car tmp) res)
-; res)))
-; ((endp tmp) (nreverse res))))
\ No newline at end of file
+;;; To get back the id (as "1167748389.13017_80.localhost")
+;;; of filtered messages.
+(defun filter-messages-for-id (filter)
+ (loop for tag in *tags*
+ as message-id = (car tag)
+ when (apply filter (cdr tag))
+ collect message-id))
+
+;;; To get back the list of the names of filters.
+(defun load-names ()
+ (setf *filter-names*
+ (read-file-to-list
+ (concatenate 'string
+ *config-folder*
+ "default-filters.lisp")))
+ (loop for filter in *filter-names*
+ as filter-name = (cadr filter)
+ when (not (eq filter-name ':stamp-core))
+ collect (string filter-name)))
--- /project/stamp/cvsroot/stamp/mel-extra.lisp 2007/02/15 14:27:18 1.2
+++ /project/stamp/cvsroot/stamp/mel-extra.lisp 2007/04/06 08:58:48 1.3
@@ -1,6 +1,8 @@
+;;; mel-extra
+
(in-package :mel.internal)
-;;; modify this method so that it returns the unique filename of the sink
+;;; 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"
@@ -8,8 +10,8 @@
(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))))))
+ while c do (write-char c sink)
+ finally (return (mel.folders.maildir::unique-message-name sink))))))
(in-package :mel.folders.maildir)
@@ -17,8 +19,8 @@
(defun uidify (file)
(let ((uid-end (position #\: file :from-end t)))
(if uid-end
- (subseq file 0 uid-end)
- file)))
+ (subseq file 0 uid-end)
+ file)))
(defun find-message-file (folder uid)
(let ((uid (uidify uid)))
@@ -28,13 +30,14 @@
(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)))
+ (progn (map nil fn (selected-messages folder))
+ (selected-messages folder)))
(setf (selected-messages folder)
(let ((messages nil))
(flet ((push-message (file)
@@ -58,3 +61,6 @@
(namestring (truename (current-mail folder))))))
(nreverse messages)))))
+
+
+
--- /project/stamp/cvsroot/stamp/misc-utilities.lisp 2007/03/21 18:21:37 1.1
+++ /project/stamp/cvsroot/stamp/misc-utilities.lisp 2007/04/06 08:58:50 1.2
@@ -1,10 +1,7 @@
;;; misc-utilities
-
(in-package :stamp-core)
-
-
(defun format-datetime (time)
(multiple-value-bind (second minute hour date month year day daylight-p zone)
(decode-universal-time time)
@@ -15,29 +12,34 @@
(defun capitalize-words (string)
(with-output-to-string (stream)
(loop with previous-char-alphanumeric = nil
- for c across string
- do (write-char (if (alphanumericp c)
- (if previous-char-alphanumeric
- (char-downcase c)
- (char-upcase c))
- c)
- stream)
- (setf previous-char-alphanumeric (alphanumericp c)))))
+ for c across string
+ do (write-char (if (alphanumericp c)
+ (if previous-char-alphanumeric
+ (char-downcase c)
+ (char-upcase c))
+ c)
+ stream)
+ (setf previous-char-alphanumeric (alphanumericp c)))))
(defun read-stream-as-string (stream)
(with-output-to-string (string-stream)
(loop for c = (read-char stream nil nil)
- until (null c)
- unless (char= c #\return)
- do (write-char c string-stream))))
+ until (null c)
+ unless (char= c #\return)
+ do (write-char c string-stream))))
-(defun next-object-in-sequence (object sequence &key (test #'eq))
+(defun next-object-in-sequence (object sequence &key (test #'equal))
(let ((length (length sequence))
(position (position object sequence :test test)))
(nth (if (= position (1- length)) position (1+ position))
sequence)))
-(defun previous-object-in-sequence (object sequence &key (test #'eq))
+(defun previous-object-in-sequence (object sequence &key (test #'equal))
(let ((position (position object sequence :test test)))
- (nth (if (zerop position) position (1- position))
- sequence)))
+ (nth (if (zerop position)
+ position
+ (1- position))
+ sequence)))
+
+
+
--- /project/stamp/cvsroot/stamp/packages.lisp 2007/03/21 18:21:37 1.3
+++ /project/stamp/cvsroot/stamp/packages.lisp 2007/04/06 08:58:50 1.4
@@ -24,41 +24,106 @@
-(defpackage :stamp-gui
- (:use :cl)
- (:export #:redisplay-pane
- #:print-fixed-width-string
- #:print-properties-as-table
- #:hilight-line ))
-
-
(defpackage :stamp-core
- (:use :cl :stamp-gui)
+ (:use :cl)
(:export #:stamp
+ ;;; Stamp.
#:set-user-address
#:set-smtp-parameters
#:add-pop3-mailbox
- #:print-fixed-width-string
- #:print-properties-as-table
- #:hilight-line
+ #:set-mail-folder
+ #:current-mail
+ #:new-mail
+ #:tmp-mail
+
+ #:load-filters
+ #:get-body-string
+ #:get-attached-file-name
+ #:copy-message-and-process-standard-tags
+
+ #:*mail-folder*
+ #:*inbox-folder*
+ #:*config-folder*
+ #:*current-filters-mails*
+ #:*messages*
+
+ ;;; Files Utilities
+ #:copy-file
+ #:read-file-to-list
+ #:compare-tags-files
+
+ ;;; Filter
+ #:filter-messages
+ #:filter-messages-for-id
+ #:load-names
+ #:load-tags
+ #:*tags*
+ #:*default-filter*
+
+ ;;; Mel Utilities
+ #:get-messages-with-tags
+ #:next-message
+ #:previous-message
+ #:get-all-messages-from-folder
+ ;;; Misc Utilities
#:format-datetime
#:capitalize-words
#:read-stream-as-string
#:next-object-in-sequence
#:previous-object-in-sequence
+ ;;; ???
+ #:set-default-filter
+ #:*default-filter*))
+
+
+(defpackage :stamp-gui
+ (:use :cl :stamp-core)
+ (:export #:redisplay-pane
+ #:print-fixed-width-string
+ #:print-properties-as-table
+ #:hilight-line
+
+ #:*climacs-frame*
+ #:*climacs-startup-hook*
+
+ ;;; Message Composing
#:compose-message
- #:quote-message-text
#:send-message
-
- ;;;Variables
- #:*address*
+ #:*outbox*
#:*mailboxes*
- #:*outbox*))
-
-
+ #:*address*
+ ;;; Config
+ #:*taille-height-m*
+ #:*taille-height-m-max*
+ #:*taille-height-m-min*
+ #:*width-mbp*
+ #:*width-mbp-max*
+ #:*width-mbp-min*
+ #:*height-mbp*
+ #:*height-mbp-max*
+ #:*height-mbp-min*
+ #:*height-ip*
+ #:*height-ip-max*
+ #:*height-ip-min*
+ #:*width-fp*
+ #:*width-fp-max*
+ #:*width-fp-min*
+ #:*width-sp*
+ #:*width-sp-max*
+ #:*width-sp-min*
+ #:*width-hp*
+ #:*height-hp*
+ #:*height-mp*
+ #:set-size-mbp
+ #:set-size-height-ip
+ #:set-size-width-fp
+ #:set-size-width-sp
+ #:set-size-hp
+ #:set-size-height-mp))
+
--- /project/stamp/cvsroot/stamp/stamp.asd 2007/03/21 18:21:37 1.5
+++ /project/stamp/cvsroot/stamp/stamp.asd 2007/04/06 08:58:50 1.6
@@ -27,13 +27,18 @@
(in-package :stamp-core.system)
(defsystem :stamp-core
- :depends-on (:mcclim :mel-base :climacs :split-sequence )
+ :depends-on (:mcclim :mel-base :climacs :split-sequence)
:components ((:file "packages")
- (:file "files-utilities" :depends-on("packages"))
+ (:file "config" :depends-on ("packages"))
+ (:file "files-utilities")
+ (:file "filters")
(:file "misc-utilities")
+ (:file "message-composing")
(:file "mel-extra")
+ (:file "mel-utilities" :depends-on("packages"))
(:file "clim-utilities")
- (:file "message")
+ (:file "clim-interface" :depends-on ("packages"))
+ (:file "clim-commands" :depends-on ("packages"))
(:file "stamp" :depends-on ("packages"))))
--- /project/stamp/cvsroot/stamp/stamp.lisp 2007/03/21 18:21:37 1.12
+++ /project/stamp/cvsroot/stamp/stamp.lisp 2007/04/06 08:58:50 1.13
@@ -25,9 +25,6 @@
(in-package :stamp-core)
-(defparameter *toto* nil)
-(defparameter *show-all-headers* nil)
-
(defun set-user-address (address)
(setf *address* address))
@@ -45,240 +42,52 @@
:password password)
*mailboxes*))
-(defparameter *inbox-folder*
- (mel:make-maildir-folder
- (concatenate 'string
- (namestring (user-homedir-pathname))
- "Mail/inbox/")
- :if-does-not-exist :create))
+(defparameter *inbox-folder*
+ (make-maildir-with-tags *mail-folder*))
(defparameter *config-folder*
(concatenate 'string
(namestring (user-homedir-pathname)) ".clim/stamp/"))
-(defparameter *mail-folder*
- (concatenate 'string
- (namestring (user-homedir-pathname)) "Mail/inbox/"))
-
-
-;;;(defparameter *folder-image*
-;;; (image:read-image-file "folder.ppm"))
-
-(defclass folders-pane (esa:esa-pane-mixin clim:application-pane) ())
-(defclass headers-pane (esa:esa-pane-mixin clim:application-pane) ())
-(defclass message-pane (esa:esa-pane-mixin clim:application-pane) ())
-
-(defclass stamp-minibuffer-pane (esa:minibuffer-pane)
- ()
- (:default-initargs
- :height 20 :max-height 20 :min-height 20))
-
-
-(defclass stamp-info-pane (esa:info-pane)
- ()
- (:default-initargs
- :height 20 :max-height 20 :min-height 20
- :display-function 'display-info
- :incremental-redisplay t))
-
-
-;;sequence de demarrage de stamp , créé les fichiers $HOME/.clim/stamp/filters.lisp
-;;et $HOME/.clim/stamp/start.lisp si ils n'existent pas
-;;filters.lisp est initialisé avec le fichier skeleton qui contient des filtres par défaut
+(defparameter *current-filters-mails* '())
+(defparameter *messages* nil)
+;;; Loading or creating of system's files.
(defun load-sequence ()
- (let (( start (concatenate 'string *config-folder* "start.lisp"))
- ( filter (concatenate 'string *config-folder* "filters.lisp")))
- (with-open-file( f (ensure-directories-exist *config-folder*))
+ (let ((start (concatenate 'string *config-folder* "start.lisp"))
+ (filter (concatenate 'string *config-folder* "default-filters.lisp"))
+ (tags1 (concatenate 'string *mail-folder* "tags1"))
+ (tags2 (concatenate 'string *mail-folder* "tags2")))
+ (with-open-file(f (ensure-directories-exist *config-folder*))
:direction :output
:if-does-not-exist :create)
- (if (probe-file start)
- nil ;; charger le fichier start.lisp
- (with-open-file (f1 start :direction :output :if-does-not-exist :create)))
(if (not (probe-file filter))
(copy-file "skeleton" filter))
- (compare-tags-files
- (concatenate 'string *mail-folder* "tags1")
- (concatenate 'string *mail-folder* "tags2"))))
+ (if (probe-file start)
+ (load start)
+ (with-open-file (f1 start :direction :output :if-does-not-exist :create)
+ (princ "(in-package :stamp-gui)" f1)))
+
+ (if (not (and (probe-file tags2) (probe-file tags1)))
+ (progn
+ (with-open-file (f1 tags2 :direction :output :if-does-not-exist :create))
+ (with-open-file (f2 tags1 :direction :output :if-does-not-exist :create))))
+
+ (compare-tags-files tags1 tags2)))
-
-
-
-
-
-(defun display-info (frame pane)
- (format pane "Folder: ~a" (car (current-folder frame))))
-
-(clim:define-application-frame stamp (esa:esa-frame-mixin
- clim:standard-application-frame)
- ((folders :initform (list (cons "Inbox" *inbox-folder*))
- :accessor folders)
- (current-folder :initform nil :accessor current-folder)
- (current-message :initform nil :accessor current-message))
- (:panes (folders-pane (clim:make-pane 'folders-pane
- :display-function '(display-folders)
- :display-time nil
- :width 150 :min-width 150 :max-width 150))
- (headers-pane (let ((pane (clim:make-pane 'headers-pane
- :display-function '(display-headers)
- :display-time nil
- :command-table 'stamp
- :width 800 :height 150)))
- (setf (esa:windows clim:*application-frame*)
- (list pane))
- pane))
- (message-pane (clim:make-pane 'message-pane
- :display-function '(display-message)
- :display-time nil
- :height 450))
- (adjuster1 (clim:make-pane 'clim-extensions:box-adjuster-gadget))
- (adjuster2 (clim:make-pane 'clim-extensions:box-adjuster-gadget))
- (info (clim:make-pane 'stamp-info-pane))
- (minibuffer (clim:make-pane 'stamp-minibuffer-pane :width 900)))
- (:layouts (default-layout
- (clim:vertically ()
- (clim:horizontally ()
- (clim:scrolling (:width 150 :min-width 150 :max-width 150)
- folders-pane)
- adjuster1
- (clim:vertically ()
- (clim:scrolling (:width 800 :height 150) headers-pane)
- adjuster2
- (clim:scrolling (:height 450) message-pane)))
- info
- minibuffer)))
- (:top-level (esa:esa-top-level)))
-
-(defmethod clim:adopt-frame :after (frame-manager (frame stamp))
- (setf (current-folder frame) (first (folders frame))))
-
-(defmethod clim:handle-event :after ((pane clim-internals::composite-pane)
- (event clim:window-configuration-event))
- (when (eq (clim:frame-name (clim:pane-frame pane)) 'stamp)
- (redisplay-pane 'headers-pane)
- (redisplay-pane 'message-pane)))
-
-(clim:define-presentation-type folder ())
-
-(clim:define-presentation-type message ())
-
-(clim:define-presentation-type attached-file ())
-
-(defun display-folders (frame pane)
- (clim:with-text-family (pane :sans-serif)
- (clim:with-text-face (pane :bold)
- (write-string "Folders" pane))
- (terpri pane)
- (loop with current-folder = (current-folder frame)
- for folder in (folders frame)
- do (when (eq folder current-folder)
- (multiple-value-bind (cursor-x cursor-y)
- (clim:stream-cursor-position pane)
- (declare (ignore cursor-x))
- (hilight-line pane cursor-y)))
- (write-string " " pane)
- ;;(clim-clx::draw-image pane *folder-image* 0 0)
- (clim:with-output-as-presentation (pane (cdr folder) 'folder)
- (write-string (car folder) pane))
- (terpri pane))))
-
-
-
-(defun display-headers (frame pane)
- (clim:with-text-family (pane :sans-serif)
- (let* ((messages (sort (copy-list (mel:messages
- (cdr (current-folder frame))))
- #'< :key #'mel:date))
- (current-message (current-message frame))
- (pane-region (clim:pane-viewport-region pane))
- (pane-width (- (clim:bounding-rectangle-width pane-region) 20))
- (index-width (clim:stream-string-width
- pane
- (princ-to-string (length messages))))
- (date-width (min (clim:stream-string-width pane
- "0000-00-00 00:00:00")
- (floor (* pane-width 0.25))))
- (subject-width (floor (* pane-width 0.5)))
- (from-width (- pane-width index-width subject-width date-width 10)))
- (clim:with-text-face (pane :bold)
- (print-fixed-width-string pane "" (+ index-width 10))
- (print-fixed-width-string pane "Subject" subject-width)
- (print-fixed-width-string pane "From" from-width)
- (print-fixed-width-string pane "Date" date-width)
- (terpri pane))
- (loop for message in messages
- for index from 1
- do (when (eq message current-message)
- (multiple-value-bind (cursor-x cursor-y)
- (clim:stream-cursor-position pane)
- (declare (ignore cursor-x))
- (hilight-line pane cursor-y)))
- (print-fixed-width-string pane
- (princ-to-string index)
- index-width
- :align :right)
- (print-fixed-width-string pane "" 10)
- (clim:with-output-as-presentation (pane message 'message)
- (print-fixed-width-string pane
- (remove #\newline
- (mel:subject message))
- subject-width))
- (print-fixed-width-string pane
- (mel:address-spec (mel:from message))
- from-width)
- (print-fixed-width-string pane
- (format-datetime (mel:date message))
- date-width)
- (terpri pane)))))
-
-(defun display-message (frame pane)
- (let ((message (current-message frame)))
- (when message
- (clim:with-text-family (pane :sans-serif)
- (print-properties-as-table
- pane
- (if *show-all-headers*
- (mapcar (lambda (header)
- (let ((name (symbol-name (car header))))
- (cons (capitalize-words name)
- (string-trim " " (cdr header)))))
- (mel:header-fields message))
- (list (cons "From:" (mel:address-spec (mel:from message)))
- (cons "Date:" (format-datetime (mel:date message)))
- (cons "Subject:" (mel:subject message))))))
- (terpri pane)
- (if (eq (mel:content-type message) :multipart)
- (display-multipart-body pane message)
- (write-string (get-body-string message) pane))
- (terpri pane))))
-
-(defun display-multipart-body (pane message)
- (let ((text-parts '())
- (attached-parts '()))
- (loop for part in (mel:parts message)
- do (multiple-value-bind (super-type sub-type)
- (mel:content-type part)
- (declare (ignore sub-type))
- (if (eq super-type :text)
- (let ((length (mel:content-octets part)))
- (push (get-body-string part length) text-parts))
- (let ((name (get-attached-file-name part)))
- (unless (null name)
- (push part attached-parts))))))
- (loop for part in (reverse attached-parts)
- do (clim:with-text-family (pane :sans-serif)
- (clim:with-output-as-presentation (pane part 'attached-file)
- (write-string (get-attached-file-name part) pane)))
- (terpri pane)
- (terpri pane))
- (loop for part in (reverse text-parts)
- do (write-string part pane))
- (terpri pane)))
-
+;;; Filters loading.
+(defun load-filters ()
+ (compile-file (concatenate 'string *config-folder* "default-filters.lisp"))
+ (load (concatenate 'string *config-folder* "default-filters.fasl"))
+ (if (eq *current-filters-mails* nil)
+ (setf *current-filters-mails* (filter-messages-for-id
+ (find-symbol (string-upcase *default-filter*)
+ (find-package "STAMP-CORE"))))))
+
(defun get-body-string (message &optional length)
(with-output-to-string (out)
(with-open-stream (stream (mel:message-body-stream message))
@@ -295,92 +104,7 @@
(declare (ignore super-type sub-type))
(second (member :name properties))))
-(clim:define-command-table stamp
- :inherit-from (esa:global-esa-table esa:keyboard-macro-table))
-
-(define-stamp-command (com-quit :name t) ()
- (clim:frame-exit clim:*application-frame*))
-
-(define-stamp-command (com-select-folder :name t)
- ((folder 'folder :gesture :select))
- (let ((folder-cons (find folder (folders clim:*application-frame*)
- :key #'cdr)))
- (setf (current-folder clim:*application-frame*) folder-cons
- (current-message clim:*application-frame*) nil))
- (redisplay-pane 'headers-pane)
- (redisplay-pane 'message-pane))
-
-(define-stamp-command (com-select-message :name t)
- ((message 'message :gesture :select))
- (setf (current-message clim:*application-frame*) message)
- (redisplay-pane 'headers-pane)
- (redisplay-pane 'message-pane))
-
-(define-stamp-command (com-next-message :name t
- :keystroke (#\n :control)) ()
- (let ((folder-messages
- (mel:messages (cdr (current-folder clim:*application-frame*)))))
- (setf (current-message clim:*application-frame*)
- (next-object-in-sequence (current-message clim:*application-frame*)
- (sort (copy-list folder-messages)
- #'< :key #'mel:date))))
- (redisplay-pane 'headers-pane)
- (redisplay-pane 'message-pane))
-
-(define-stamp-command (com-previous-message :name t
- :keystroke (#\p :control)) ()
- (let ((folder-messages
- (mel:messages (cdr (current-folder clim:*application-frame*)))))
- (setf (current-message clim:*application-frame*)
- (previous-object-in-sequence (current-message clim:*application-frame*)
- (sort (copy-list folder-messages)
- #'< :key #'mel:date))))
- (redisplay-pane 'headers-pane)
- (redisplay-pane 'message-pane))
-
-(define-stamp-command (com-delete-message :name t
- :keystroke (#\d :control)) ()
- (let ((message (current-message clim:*application-frame*)))
- (unless (null message)
- (mel:delete-message message)))
- (setf (current-message clim:*application-frame*) nil)
- (redisplay-pane 'headers-pane)
- (redisplay-pane 'message-pane))
-
-(define-stamp-command (com-compose-message :name t) ()
- (multiple-value-bind (message headers body)
- (compose-message)
- (when message
- (send-message message headers body))))
-
-(define-stamp-command (com-reply :name t) ()
- (let ((original-message (current-message clim:*application-frame*)))
- (when original-message
- (multiple-value-bind (message headers body)
- (let ((sender (mel:address-spec (mel:from original-message))))
- (compose-message :to sender
- :subject (format nil "Re: ~A"
- (mel:subject original-message))
- :body (quote-message-text (get-body-string
- original-message)
- sender)))
- (when message
- (send-message message headers body))))))
-
-(define-stamp-command (com-forward :name t) ()
- (let ((original-message (current-message clim:*application-frame*)))
- (when original-message
- (multiple-value-bind (message headers body)
- (let ((sender (mel:address-spec (mel:from original-message))))
- (compose-message :subject (format nil "Fwd: ~A"
- (mel:subject original-message))
- :body (quote-message-text (get-body-string
- original-message)
- sender)))
- (when message
- (send-message message headers body))))))
-
-(defun address-string-or-nil (address)
+ (defun address-string-or-nil (address)
(if (null address)
nil
(mel:address-spec address)))
@@ -391,11 +115,12 @@
: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))))
+ :sender (address-string-or-nil (mel:sender message))
+ :unread t))
(defun copy-message-and-process-standard-tags (message folder)
- (let ((folder-name (mel:name folder))
- (message-name (mel:copy-message message folder))
+ (let ((folder-name (name folder))
+ (message-name (move-message message (current-mail folder)))
(tags (standard-tags message)))
(with-open-file (stream (concatenate 'string folder-name "tags1")
:direction :output
@@ -408,34 +133,29 @@
: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)
[50 lines skipped]
--- /project/stamp/cvsroot/stamp/README.txt 2007/04/06 08:58:51 NONE
+++ /project/stamp/cvsroot/stamp/README.txt 2007/04/06 08:58:51 1.1
[145 lines skipped]
--- /project/stamp/cvsroot/stamp/clim-commands.lisp 2007/04/06 08:58:51 NONE
+++ /project/stamp/cvsroot/stamp/clim-commands.lisp 2007/04/06 08:58:51 1.1
[297 lines skipped]
--- /project/stamp/cvsroot/stamp/clim-interface.lisp 2007/04/06 08:58:51 NONE
+++ /project/stamp/cvsroot/stamp/clim-interface.lisp 2007/04/06 08:58:51 1.1
[498 lines skipped]
--- /project/stamp/cvsroot/stamp/config.lisp 2007/04/06 08:58:51 NONE
+++ /project/stamp/cvsroot/stamp/config.lisp 2007/04/06 08:58:51 1.1
[643 lines skipped]
--- /project/stamp/cvsroot/stamp/mel-utilities.lisp 2007/04/06 08:58:52 NONE
+++ /project/stamp/cvsroot/stamp/mel-utilities.lisp 2007/04/06 08:58:52 1.1
[756 lines skipped]
--- /project/stamp/cvsroot/stamp/message-composing.lisp 2007/04/06 08:58:52 NONE
+++ /project/stamp/cvsroot/stamp/message-composing.lisp 2007/04/06 08:58:52 1.1
[875 lines skipped]
--- /project/stamp/cvsroot/stamp/skeleton 2007/04/06 08:58:52 NONE
+++ /project/stamp/cvsroot/stamp/skeleton 2007/04/06 08:58:52 1.1
[901 lines skipped]
More information about the Stamp-cvs
mailing list