[stamp-cvs] CVS stamp
fwillemain
fwillemain at common-lisp.net
Tue Mar 13 18:55:25 UTC 2007
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 at 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]
More information about the Stamp-cvs
mailing list