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@free.fr) ;;; Copyright (C) 2006 Robert Strandh (strandh@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 ,@args &allow-other-keys) ,@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)))