Update of /project/stamp/cvsroot/stamp In directory clnet:/tmp/cvs-serv22589

Modified Files: packages.lisp stamp.asd stamp.lisp Added Files: climUtilities.lisp message.lisp misc.lisp Log Message: packages

--- /project/stamp/cvsroot/stamp/packages.lisp 2007/01/03 11:27:56 1.1 +++ /project/stamp/cvsroot/stamp/packages.lisp 2007/03/13 18:55:25 1.2 @@ -1,3 +1,4 @@ + ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*-

;;; Copyright (C) 2006 Matthieu Villeneuve (matthieu.villeneuve@free.fr) @@ -21,9 +22,50 @@

(in-package :cl-user)

-(defpackage :stamp +(defpackage :misc + (:use :cl ) + (:export + :format-datetime + :capitalize-words + :read-stream-as-string + :next-object-in-sequence + :previous-object-in-sequence +)) + +(defpackage :clim-utils (:use :cl) + (:export + :redisplay-pane + :print-fixed-width-string + :print-properties-as-table + :hilight-line + + )) + +(defpackage :message + (:use :cl :misc) + (:export + :compose-message + :quote-message-text + :send-message + :*address* + :*mailboxes* + :*outbox* +)) + +(defpackage :stamp + (:use :cl :misc :clim-utils :message) (:export #:stamp #:set-user-address #:set-smtp-parameters - #:add-pop3-mailbox)) + #:add-pop3-mailbox + ;; Variables + #:*address* + #:*outbox* + #:*mailboxes* + )) + + + + + --- /project/stamp/cvsroot/stamp/stamp.asd 2007/01/04 06:13:08 1.3 +++ /project/stamp/cvsroot/stamp/stamp.asd 2007/03/13 18:55:25 1.4 @@ -22,10 +22,21 @@ (defpackage :stamp.system (:use :common-lisp :asdf))

+ + (in-package :stamp.system)

(defsystem :stamp - :depends-on (:mcclim :mel-base :climacs :split-sequence) - :components ((:file "packages") - (:file "mel-extra") - (:file "stamp" :depends-on ("packages")))) + :depends-on (:mcclim :mel-base :climacs :split-sequence ) + :components ((:file "packages") + (:file "misc") + (:file "mel-extra") + (:file "climUtilities") + (:file "message") + (:file "stamp" :depends-on ("packages")))) + + + + + + --- /project/stamp/cvsroot/stamp/stamp.lisp 2007/01/04 13:37:53 1.10 +++ /project/stamp/cvsroot/stamp/stamp.lisp 2007/03/13 18:55:25 1.11 @@ -21,9 +21,10 @@

(in-package :stamp)

-(defparameter *address* nil) -(defparameter *mailboxes* '()) -(defparameter *outbox* nil) + + + +

(defparameter *show-all-headers* nil)

@@ -51,6 +52,13 @@ "Mail/inbox/") :if-does-not-exist :create))

+(defparameter *config-folder* + (with-open-file (f (ensure-directories-exist + (concatenate 'string + (namestring (user-homedir-pathname)) + ".clim/stamp/"))) + :direction :output)) + ;;;(defparameter *folder-image* ;;; (image:read-image-file "folder.ppm"))

@@ -390,208 +398,6 @@ (declare (ignore filename)) ))

-;;; Message composing - -(defparameter *climacs-frame* nil) - -(defparameter *climacs-startup-hook* nil) - -(defmethod clim:adopt-frame :after (frame-manager (frame climacs-gui:climacs)) - (when *climacs-startup-hook* - (funcall *climacs-startup-hook*))) - -(defun compose-message (&key (to "") (subject "") body) - (let ((content-filename (make-temporary-filename))) - (with-open-file (out content-filename :direction :output) - (princ (make-message-file-contents :to to - :subject subject - :body body) - out)) - (let ((filename (make-temporary-filename))) - (let ((*climacs-startup-hook* - (lambda () - (clim:layout-frame *climacs-frame* 800 600) - (clim:execute-frame-command - *climacs-frame* - `(climacs-core::find-file ,filename)) - (clim:execute-frame-command - *climacs-frame* - `(climacs-commands::com-insert-file ,content-filename)) - (delete-file content-filename))) - (*climacs-frame* - (clim:make-application-frame 'climacs-gui:climacs))) - (clim:run-frame-top-level *climacs-frame*)) - (let ((parsed-data (ignore-errors (parse-message-file filename)))) - (when (probe-file filename) - (delete-file filename)) - (values (first parsed-data) - (second parsed-data) - (third parsed-data)))))) - -;;; this should be a defconstant, but it is not very -;;; practical during development, because of the number -;;; of times the file gets reloaded. -- RS 2007-01-04 -(defparameter +boundary+ "---- text follows this line ----") - -(defun make-temporary-filename () - (let ((base (format nil "/tmp/stamp-~A" (get-universal-time)))) - (loop for i from 0 - as path = (format nil "~A-~A" base i) - while (probe-file path) - finally (return path)))) - -(defun make-message-file-contents (&key (to "") (subject "") body) - (with-output-to-string (out) - (format out "To: ~A~%" to) - (format out "Subject: ~A~%" subject) - (format out "~A~%" +boundary+) - (when body - (princ body out)))) - -(defun parse-message-file (filename) - (let* ((string (with-open-file (stream filename) - (read-stream-as-string stream))) - (boundary-position (search +boundary+ string))) - (when boundary-position - (let* ((headers (parse-headers string 0 boundary-position)) - (to (cdr (assoc :to headers))) - (body (string-trim '(#\space #\return #\linefeed) - (subseq string (+ boundary-position - (length +boundary+)))))) - (when to - (let ((message - (mel:make-message :subject (cdr (assoc :subject headers)) - :from *address* - :to (cdr (assoc :to headers)) - :body body))) - (setf (mel:header-fields message) headers) - (list message headers body))))))) - -(defun parse-headers (string start end) - (let ((lines (mapcar (lambda (line) - (string-trim '(#\space #\return) line)) - (split-sequence:split-sequence #\newline string - :start start - :end end)))) - (loop for line in lines - as index = (position #: line) - unless (null index) - collect (cons (intern (string-upcase (subseq line 0 index)) :keyword) - (string-trim '(#\space) (subseq line (1+ index))))))) - -(defun print-headers (headers stream) - (loop for header in headers - as name = (symbol-name (car header)) - do (format stream "~A: ~A~%" (capitalize-words name) (cdr header)))) - -(defun quote-message-text (text author) - (let ((lines (mapcar (lambda (line) - (string-trim '(#\space #\return) line)) - (split-sequence:split-sequence #\newline text)))) - (with-output-to-string (out) - (when author - (format out "~A wrote:~%" author)) - (loop for line in lines - do (format out "> ~A~%" line))))) - -(defun send-message (message headers body) - (let ((stream (mel:open-message-storing-stream *outbox* message))) - (unwind-protect - (progn - (print-headers headers stream) - (format stream body)) - (close stream)))) - -;;; CLIM utilities - -(defun redisplay-pane (name) - (let ((pane (clim:get-frame-pane clim:*application-frame* name))) - (clim:redisplay-frame-pane clim:*application-frame* pane :force-p t))) - -(defun print-fixed-width-string (pane string width &key (align :left)) - (let* ((string2 (maybe-cut-string-at-width pane string width)) - (string2-width (clim:stream-string-width pane string2))) - (multiple-value-bind (cursor-x cursor-y) - (clim:stream-cursor-position pane) - (setf (clim:stream-cursor-position pane) - (values (case align - (:left cursor-x) - (:center (+ cursor-x (floor (- width string2-width) 2))) - (:right (+ cursor-x (- width string2-width)))) - cursor-y)) - (write-string string2 pane) - (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)) - string - (concatenate 'string (subseq string 0 index) "...")) - as string2-width = (clim:stream-string-width pane string2) - 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 - do (clim:formatting-row (pane) - (clim:with-text-face (pane :bold) - (clim:formatting-cell (pane :align-x :right) - (write-string (car property) pane))) - (clim:formatting-cell (pane) - (write-string (cdr property) pane)))))) - -(defparameter *hilight-color* (clim:make-rgb-color 0.8 0.8 1.0)) - -(defun hilight-line (pane y) - (multiple-value-bind (pane-x1 pane-y1 pane-x2 pane-y2) - (clim:bounding-rectangle* pane) - (declare (ignore pane-y1 pane-y2)) - (let ((height (clim:text-style-height clim:*default-text-style* pane))) - (clim:draw-rectangle* pane - pane-x1 y pane-x2 (+ y height 1) - :filled t :ink *hilight-color*)))) - -;;; Misc utilities - -(defun format-datetime (time) - (multiple-value-bind (second minute hour date month year day daylight-p zone) - (decode-universal-time time) - (declare (ignore day daylight-p zone)) - (format nil "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D" - year month date hour minute second))) - -(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))))) - -(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)))) - -(defun next-object-in-sequence (object sequence &key (test #'eq)) - (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)) - (let ((position (position object sequence :test test))) - (nth (if (zerop position) position (1- position)) - sequence))) - ;;; Startup

(defun stamp ()

--- /project/stamp/cvsroot/stamp/climUtilities.lisp 2007/03/13 18:55:25 NONE +++ /project/stamp/cvsroot/stamp/climUtilities.lisp 2007/03/13 18:55:25 1.1 ;;; CLIM utilities (in-package :clim-utils)

(defparameter *hilight-color* (clim:make-rgb-color 0.8 0.8 1.0))

(defun redisplay-pane (name) (let ((pane (clim:get-frame-pane clim:*application-frame* name))) (clim:redisplay-frame-pane clim:*application-frame* pane :force-p t)))

(defun print-fixed-width-string (pane string width &key (align :left)) (let* ((string2 (maybe-cut-string-at-width pane string width)) (string2-width (clim:stream-string-width pane string2))) (multiple-value-bind (cursor-x cursor-y) (clim:stream-cursor-position pane) (setf (clim:stream-cursor-position pane)

(values (case align (:left cursor-x) (:center (+ cursor-x (floor (- width string2-width) 2))) (:right (+ cursor-x (- width string2-width)))) cursor-y)) (write-string string2 pane) (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)) string (concatenate 'string (subseq string 0 index) "...")) as string2-width = (clim:stream-string-width pane string2) 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 do (clim:formatting-row (pane) (clim:with-text-face (pane :bold) (clim:formatting-cell (pane :align-x :right) (write-string (car property) pane))) (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) (declare (ignore pane-y1 pane-y2)) (let ((height (clim:text-style-height clim:*default-text-style* pane))) (clim:draw-rectangle* pane pane-x1 y pane-x2 (+ y height 1) :filled t :ink *hilight-color*))))

--- /project/stamp/cvsroot/stamp/message.lisp 2007/03/13 18:55:25 NONE +++ /project/stamp/cvsroot/stamp/message.lisp 2007/03/13 18:55:25 1.1 (in-package :message)

;;; Message composing

(defparameter *address* nil) (defparameter *mailboxes* '()) (defparameter *outbox* nil)

(defparameter *climacs-frame* nil) (defparameter *climacs-startup-hook* nil)

(defmethod clim:adopt-frame :after (frame-manager (frame climacs-gui:climacs)) (when *climacs-startup-hook* (funcall *climacs-startup-hook*)))

(defun compose-message (&key (to "") (subject "") body) (let ((content-filename (make-temporary-filename))) (with-open-file (out content-filename :direction :output) (princ (make-message-file-contents :to to :subject subject :body body) out)) (let ((filename (make-temporary-filename))) (let ((*climacs-startup-hook* (lambda () (clim:layout-frame *climacs-frame* 800 600) (clim:execute-frame-command *climacs-frame* `(climacs-core::find-file ,filename)) (clim:execute-frame-command *climacs-frame* `(climacs-commands::com-insert-file ,content-filename)) (delete-file content-filename))) (*climacs-frame* (clim:make-application-frame 'climacs-gui:climacs))) (clim:run-frame-top-level *climacs-frame*)) (let ((parsed-data (ignore-errors (parse-message-file filename)))) (when (probe-file filename) (delete-file filename)) (values (first parsed-data) (second parsed-data) (third parsed-data))))))

;;; this should be a defconstant, but it is not very ;;; practical during development, because of the number ;;; of times the file gets reloaded. -- RS 2007-01-04 (defparameter +boundary+ "---- text follows this line ----")

(defun make-temporary-filename () (let ((base (format nil "/tmp/stamp-~A" (get-universal-time)))) (loop for i from 0 as path = (format nil "~A-~A" base i) while (probe-file path) finally (return path))))

(defun make-message-file-contents (&key (to "") (subject "") body) (with-output-to-string (out) (format out "To: ~A~%" to) (format out "Subject: ~A~%" subject) (format out "~A~%" +boundary+) (when body (princ body out))))

(defun parse-message-file (filename) (let* ((string (with-open-file (stream filename) (misc:read-stream-as-string stream))) (boundary-position (search +boundary+ string))) (when boundary-position (let* ((headers (parse-headers string 0 boundary-position)) (to (cdr (assoc :to headers))) (body (string-trim '(#\space #\return #\linefeed) (subseq string (+ boundary-position (length +boundary+)))))) (when to (let ((message (mel:make-message :subject (cdr (assoc :subject headers)) :from *address* :to (cdr (assoc :to headers)) :body body))) (setf (mel:header-fields message) headers) (list message headers body)))))))

(defun parse-headers (string start end) (let ((lines (mapcar (lambda (line) (string-trim '(#\space #\return) line)) (split-sequence:split-sequence #\newline string :start start :end end)))) (loop for line in lines as index = (position #: line) unless (null index) collect (cons (intern (string-upcase (subseq line 0 index)) :keyword) (string-trim '(#\space) (subseq line (1+ index)))))))

[24 lines skipped] --- /project/stamp/cvsroot/stamp/misc.lisp 2007/03/13 18:55:25 NONE +++ /project/stamp/cvsroot/stamp/misc.lisp 2007/03/13 18:55:25 1.1

[67 lines skipped]