April 2007 - stamp-cvs@common-lisp.net - mailman3.common-lisp.net

[stamp-cvs] CVS stamp
by fwillemain 06 Apr '07

06 Apr '07

Update of /project/stamp/cvsroot/stamp In directory clnet:/tmp/cvs-serv28026 Modified Files: stamp.lisp Log Message: error on load-sequence --- /project/stamp/cvsroot/stamp/stamp.lisp 2007/04/06 08:58:50 1.13 +++ /project/stamp/cvsroot/stamp/stamp.lisp 2007/04/06 09:24:14 1.14 @@ -71,10 +71,10 @@ (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))) + (if (or (not (probe-file tags2)) (not (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)))) + (with-open-file (f1 tags2 :direction :output :if-does-not-exist :create :if-exists nil)) + (with-open-file (f2 tags1 :direction :output :if-does-not-exist :create :if-exists nil)))) (compare-tags-files tags1 tags2)))

1 0

[stamp-cvs] CVS stamp
by fwillemain 06 Apr '07

06 Apr '07

Update of /project/stamp/cvsroot/stamp In directory clnet:/tmp/cvs-serv22967 Added Files: start.lisp Log Message: start.lisp for launch the application --- /project/stamp/cvsroot/stamp/start.lisp 2007/04/06 09:00:26 NONE +++ /project/stamp/cvsroot/stamp/start.lisp 2007/04/06 09:00:26 1.1 (require 'asdf-install) (load "stamp.asd") (asdf:operate 'asdf:load-op :stamp-core) (stamp-core:stamp)

1 0

[stamp-cvs] CVS stamp
by fwillemain 06 Apr '07

06 Apr '07

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 ,@args &allow-other-keys) ,@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]

1 0