[stamp-cvs] CVS stamp
fwillemain
fwillemain at common-lisp.net
Wed Mar 21 18:21:37 UTC 2007
Update of /project/stamp/cvsroot/stamp
In directory clnet:/tmp/cvs-serv7714
Modified Files:
message.lisp packages.lisp stamp.asd stamp.lisp
Added Files:
clim-utilities.lisp files-utilities.lisp filters.lisp
misc-utilities.lisp
Log Message:
modifications des packages et ajout de fonctionnalités
--- /project/stamp/cvsroot/stamp/message.lisp 2007/03/13 18:55:25 1.1
+++ /project/stamp/cvsroot/stamp/message.lisp 2007/03/21 18:21:37 1.2
@@ -1,7 +1,7 @@
-(in-package :message)
+;;; Message composing
+(in-package :stamp-core)
-;;; Message composing
(defparameter *address* nil)
(defparameter *mailboxes* '())
@@ -64,7 +64,7 @@
(defun parse-message-file (filename)
(let* ((string (with-open-file (stream filename)
- (misc:read-stream-as-string stream)))
+ (read-stream-as-string stream)))
(boundary-position (search +boundary+ string)))
(when boundary-position
(let* ((headers (parse-headers string 0 boundary-position))
--- /project/stamp/cvsroot/stamp/packages.lisp 2007/03/13 18:55:25 1.2
+++ /project/stamp/cvsroot/stamp/packages.lisp 2007/03/21 18:21:37 1.3
@@ -22,48 +22,41 @@
(in-package :cl-user)
-(defpackage :misc
- (:use :cl )
- (:export
- :format-datetime
- :capitalize-words
- :read-stream-as-string
- :next-object-in-sequence
- :previous-object-in-sequence
-))
-(defpackage :clim-utils
+
+(defpackage :stamp-gui
(: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*
-))
+ (:export #:redisplay-pane
+ #:print-fixed-width-string
+ #:print-properties-as-table
+ #:hilight-line ))
+
-(defpackage :stamp
- (:use :cl :misc :clim-utils :message)
+(defpackage :stamp-core
+ (:use :cl :stamp-gui)
(:export #:stamp
#:set-user-address
#:set-smtp-parameters
#:add-pop3-mailbox
- ;; Variables
+
+ #:print-fixed-width-string
+ #:print-properties-as-table
+ #:hilight-line
+
+ #:format-datetime
+ #:capitalize-words
+ #:read-stream-as-string
+ #:next-object-in-sequence
+ #:previous-object-in-sequence
+
+ #:compose-message
+ #:quote-message-text
+ #:send-message
+
+ ;;;Variables
#:*address*
- #:*outbox*
#:*mailboxes*
- ))
+ #:*outbox*))
--- /project/stamp/cvsroot/stamp/stamp.asd 2007/03/13 18:55:25 1.4
+++ /project/stamp/cvsroot/stamp/stamp.asd 2007/03/21 18:21:37 1.5
@@ -19,19 +19,20 @@
;;; Stamp system definition
-(defpackage :stamp.system
+(defpackage :stamp-core.system
(:use :common-lisp :asdf))
-(in-package :stamp.system)
+(in-package :stamp-core.system)
-(defsystem :stamp
+(defsystem :stamp-core
:depends-on (:mcclim :mel-base :climacs :split-sequence )
:components ((:file "packages")
- (:file "misc")
+ (:file "files-utilities" :depends-on("packages"))
+ (:file "misc-utilities")
(:file "mel-extra")
- (:file "climUtilities")
+ (:file "clim-utilities")
(:file "message")
(:file "stamp" :depends-on ("packages"))))
--- /project/stamp/cvsroot/stamp/stamp.lisp 2007/03/13 18:55:25 1.11
+++ /project/stamp/cvsroot/stamp/stamp.lisp 2007/03/21 18:21:37 1.12
@@ -2,6 +2,10 @@
;;; Copyright (C) 2005-2006 Matthieu Villeneuve (matthieu.villeneuve at free.fr)
;;; Copyright (C) 2006 Robert Strandh (strandh at labri.fr)
+;;; Copyright (C) 2007 Raquel Andia
+;;; Copyright (C) 2007 Alexandre Gomez
+;;; Copyright (C) 2007 Sebastien Serani
+;;; Copyright (C) 2007 Florian Willemain
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
@@ -19,13 +23,9 @@
;;; Stamp main code
-(in-package :stamp)
-
-
-
-
-
+(in-package :stamp-core)
+(defparameter *toto* nil)
(defparameter *show-all-headers* nil)
(defun set-user-address (address)
@@ -53,11 +53,13 @@
: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))
+ (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"))
@@ -79,6 +81,35 @@
: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
+
+
+(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*))
+ :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"))))
+
+
+
+
+
+
+
(defun display-info (frame pane)
(format pane "Folder: ~a" (car (current-folder frame))))
@@ -155,12 +186,14 @@
(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))
+ (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
@@ -401,4 +434,8 @@
;;; Startup
(defun stamp ()
- (clim:run-frame-top-level (clim:make-application-frame 'stamp)))
+ (if (load-sequence)
+ (clim:run-frame-top-level (clim:make-application-frame 'stamp))
+ (print "Critical error on tags please contact fwillemain")))
+
+
--- /project/stamp/cvsroot/stamp/clim-utilities.lisp 2007/03/21 18:21:37 NONE
+++ /project/stamp/cvsroot/stamp/clim-utilities.lisp 2007/03/21 18:21:37 1.1
;;; clim-utilities
(in-package :stamp-gui)
(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/files-utilities.lisp 2007/03/21 18:21:37 NONE
+++ /project/stamp/cvsroot/stamp/files-utilities.lisp 2007/03/21 18:21:37 1.1
(in-package :stamp-core)
;;fait une copie bit a bit du fichier from dans le fichier to
(defun copy-file (from to)
(with-open-file (in from
:direction :input
:element-type 'unsigned-byte
:if-does-not-exist :error
:if-exists :overwrite)
(with-open-file (out to
:direction :output
: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)
(loop for l = (read stream nil nil)
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)
(let ((l1 (read-file-to-list file1))
(l2 (read-file-to-list file2)))
(if (equal l1 l2) T )))
--- /project/stamp/cvsroot/stamp/filters.lisp 2007/03/21 18:21:37 NONE
+++ /project/stamp/cvsroot/stamp/filters.lisp 2007/03/21 18:21:37 1.1
;;; filters
(defparameter *tags*
(load-info-list
(concatenate 'string
(namestring (user-homedir-pathname))
"Mail/inbox/tags")))
(defmacro define-filter (name args &body body)
`(defun ,name (&rest tags &key , at args &allow-other-keys)
, at body))
;(defun apply-filter (name)
; (let (tmp *tags*))
; (loop for l = (car tmp)
; until (null l)
; (if (#'name l)
; (collect l))
; (setq tmp (cdr tmp))
; (print l)))
(defun apply-filter (name)
(do ((tmp (car *tags*) (cdr tmp))
(res '() (when (funcall name (car tmp)
(cons (car tmp) res)))))
((endp tmp) (nreverse res))))
(list (apply-filter #'unread))
(car *tags*)
;(defun load-info-list (file)
; (with-open-file (stream file)
; (loop for l = (read stream nil nil)
; until (null l)
; do (print l))))
(defun load-info-list (file)
(with-open-file (stream file)
(loop for l = (read stream nil nil)
until (null l)
collect l)))
(getf (cdr *tags*) :unread)
(print (list *tags*))
(define-filter unread (field)
(getf (cdr field) :unread))
(define-filter recent-unread ()
(and (apply #'recent tags)
(apply #'unread tags)))
--- /project/stamp/cvsroot/stamp/misc-utilities.lisp 2007/03/21 18:21:37 NONE
+++ /project/stamp/cvsroot/stamp/misc-utilities.lisp 2007/03/21 18:21:37 1.1
;;; 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)
(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)))
More information about the Stamp-cvs
mailing list