[slime-cvs] CVS slime/contrib

[mbaringer]

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv30436/contrib

Modified Files:
	ChangeLog 
Added Files:
	swank-motd.lisp slime-motd.el 
Log Message:
Message Of The Day for slime


--- /project/slime/cvsroot/slime/contrib/ChangeLog	2008/01/27 10:17:34	1.82
+++ /project/slime/cvsroot/slime/contrib/ChangeLog	2008/02/03 18:39:23	1.83
@@ -1,3 +1,8 @@
+2008-02-03  Marco Baringer  <mb at bese.it>
+
+	* swank-motd.lisp, slime-motd.el: Message Of The Day printing for
+	slime.
+
 2008-01-27  Helmut Eller  <heller at common-lisp.net>
 
 	Make autodoc use the correct width of the typeout-window.

--- /project/slime/cvsroot/slime/contrib/swank-motd.lisp	2008/02/03 18:39:23	NONE
+++ /project/slime/cvsroot/slime/contrib/swank-motd.lisp	2008/02/03 18:39:23	1.1
(in-package :swank)

(defun parse-changelog (changelog-pathname)
  (with-open-file (stream changelog-pathname :direction :input)
    (labels ((entry-line-p (line)
               (and (<= 10 (length line))
                    (digit-char-p (aref line 0))
                    (digit-char-p (aref line 1))
                    (digit-char-p (aref line 2))
                    (digit-char-p (aref line 3))
                    (char= #\- (aref line 4))
                    (digit-char-p (aref line 5))
                    (digit-char-p (aref line 6))
                    (char= #\- (aref line 7))
                    (digit-char-p (aref line 8))
                    (digit-char-p (aref line 9))))
             (read-next-entry ()
               ;; don't use with-output-to-string to avoid sbcl
               ;; compiler warnings
               (with-output-to-string (entry-text)
                 (loop
                    for changelog-line = (read-line stream nil stream nil)
                    when (eq changelog-line stream)
                      do (return-from read-next-entry
                           (values (get-output-stream-string entry-text) nil))
                    when (entry-line-p changelog-line)
                      do (return-from read-next-entry
                           (values (get-output-stream-string entry-text) changelog-line))
                    do (write-line changelog-line entry-text)))))
      (let ((this-author-line (nth-value 1 (read-next-entry)))
            (entries '()))
        (loop
           (multiple-value-bind (text next-author-line)
               (read-next-entry)
             (with-output-to-string (text+author)
               (write-line this-author-line text+author)
               (write-string text text+author)
               (push (list (encode-universal-time 0 0 0
                                                  (parse-integer this-author-line :start 8 :end 10)
                                                  (parse-integer this-author-line :start 5 :end 7)
                                                  (parse-integer this-author-line :start 0 :end 4))
                           (get-output-stream-string text+author))
                     entries))
             (if (null next-author-line)
                 (return-from parse-changelog entries)
                 (setf this-author-line next-author-line))))))))

(defun read-motd (motd-pathname)
  (handler-case
      (let ((entries (mapcar #'second
                             (remove-if (lambda (date/entry-text)
                                          (< (first date/entry-text) (- (get-universal-time) (* 60 60 24 7))))
                                        (parse-changelog motd-pathname)))))
        
        (when entries
          (with-output-to-string (motd-for-emacs)
            (format motd-for-emacs ";; MOTD read from ~S.~%" motd-pathname)
            (dolist (entry entries)
              (with-input-from-string (stream entry)
                (loop
                  for line = (read-line stream nil stream nil)
                  until (eq line stream)
                  do (write-string ";; " motd-for-emacs)
                  do (write-line line motd-for-emacs)))))))
    (error (c)
      (format nil ";; ERROR ~S OPENING MOTD ~S.~%" c motd-pathname))))
--- /project/slime/cvsroot/slime/contrib/slime-motd.el	2008/02/03 18:39:23	NONE
+++ /project/slime/cvsroot/slime/contrib/slime-motd.el	2008/02/03 18:39:23	1.1
;;; slime-motd.el --- Message Of The Day in a slime repl
;;
;; Authors: Marco Baringer <mb at bese.it>
;;
;; License: GNU GPL (same license as Emacs)
;;
;;; Installation
;;
;; Add slime-motd to your slime-setup call.

(require 'slime-banner)

(defcustom slime-motd-pathname nil
  "The local pathnamethe motd is read from."
  :group 'slime-mode
  :type '(file :must-match t))

(defun slime-insert-motd ()
  (slime-eval-async `(cl:progn
                      (swank:swank-require :swank-motd)
                      (swank::read-motd ,slime-motd-pathname))
                    (lambda (motd)
                      (when motd
                        (slime-repl-insert-result (list :values motd))))))

(defun slime-motd-init ()
  (add-hook 'slime-connected-hook 'slime-insert-motd))

(provide 'slime-motd)