From fwillemain at common-lisp.net Tue Mar 13 18:55:25 2007 From: fwillemain at common-lisp.net (fwillemain) Date: Tue, 13 Mar 2007 13:55:25 -0500 (EST) Subject: [stamp-cvs] CVS stamp Message-ID: <20070313185525.EEE9432021@common-lisp.net> 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] From fwillemain at common-lisp.net Wed Mar 21 18:21:37 2007 From: fwillemain at common-lisp.net (fwillemain) Date: Wed, 21 Mar 2007 13:21:37 -0500 (EST) Subject: [stamp-cvs] CVS stamp Message-ID: <20070321182137.C8D9C3A03E@common-lisp.net> 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))) From fwillemain at common-lisp.net Wed Mar 21 18:24:36 2007 From: fwillemain at common-lisp.net (fwillemain) Date: Wed, 21 Mar 2007 13:24:36 -0500 (EST) Subject: [stamp-cvs] CVS stamp Message-ID: <20070321182436.40D5B3A03E@common-lisp.net> Update of /project/stamp/cvsroot/stamp In directory clnet:/tmp/cvs-serv8233 Removed Files: misc.lisp Log Message: suppression des fichiers misc.lisp et climUtilities.lisp From fwillemain at common-lisp.net Wed Mar 21 18:25:42 2007 From: fwillemain at common-lisp.net (fwillemain) Date: Wed, 21 Mar 2007 13:25:42 -0500 (EST) Subject: [stamp-cvs] CVS stamp Message-ID: <20070321182542.5E2CE4509E@common-lisp.net> Update of /project/stamp/cvsroot/stamp In directory clnet:/tmp/cvs-serv8575 Removed Files: climUtilities.lisp Log Message: suppression des fichiers misc.lisp et climUtilities.lisp From fwillemain at common-lisp.net Thu Mar 22 17:13:37 2007 From: fwillemain at common-lisp.net (fwillemain) Date: Thu, 22 Mar 2007 12:13:37 -0500 (EST) Subject: [stamp-cvs] CVS stamp Message-ID: <20070322171337.6D53B36083@common-lisp.net> Update of /project/stamp/cvsroot/stamp In directory clnet:/tmp/cvs-serv3756 Modified Files: filters.lisp Log Message: filter-messages --- /project/stamp/cvsroot/stamp/filters.lisp 2007/03/21 18:21:37 1.1 +++ /project/stamp/cvsroot/stamp/filters.lisp 2007/03/22 17:13:37 1.2 @@ -6,49 +6,37 @@ (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) +(defmacro define-filter (name args &body body) + `(defun ,name (&rest tags &key , at args &allow-other-keys) + , at body)) + +(defun filter-messages (filter) + (loop for tag in *tags* + when (funcall filter :field tag) + collect tag)) -(print (list *tags*)) +(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))) + -(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