[clfswm-cvs] r50 - in clfswm: . src
pbrochard at common-lisp.net
pbrochard at common-lisp.net
Tue Mar 18 21:53:47 UTC 2008
Author: pbrochard
Date: Tue Mar 18 16:53:45 2008
New Revision: 50
Added:
clfswm/src/version.lisp
Modified:
clfswm/clfswm.asd
clfswm/src/clfswm-info.lisp
clfswm/src/package.lisp
clfswm/src/tools.lisp
Log:
New version package. Move date-string to tools.lisp. Localize date-string
Modified: clfswm/clfswm.asd
==============================================================================
--- clfswm/clfswm.asd (original)
+++ clfswm/clfswm.asd Tue Mar 18 16:53:45 2008
@@ -16,7 +16,7 @@
(:file "my-html"
:depends-on ("tools"))
(:file "package"
- :depends-on ("my-html" "tools"))
+ :depends-on ("my-html" "tools" "version"))
(:file "config"
:depends-on ("package"))
(:file "keysyms"
@@ -32,10 +32,12 @@
(:file "clfswm"
:depends-on ("xlib-util" "netwm-util" "clfswm-keys" "config"
"clfswm-internal" "tools"))
+ (:file "version"
+ :depends-on ("tools"))
(:file "clfswm-second-mode"
:depends-on ("package" "clfswm-internal"))
(:file "clfswm-info"
- :depends-on ("package" "xlib-util" "config" "clfswm-keys" "clfswm" "clfswm-internal"))
+ :depends-on ("package" "version" "xlib-util" "config" "clfswm-keys" "clfswm" "clfswm-internal"))
(:file "clfswm-util"
:depends-on ("clfswm" "keysyms" "clfswm-info" "clfswm-second-mode" "clfswm-query"))
(:file "clfswm-query"
Modified: clfswm/src/clfswm-info.lisp
==============================================================================
--- clfswm/src/clfswm-info.lisp (original)
+++ clfswm/src/clfswm-info.lisp Tue Mar 18 16:53:45 2008
@@ -352,17 +352,6 @@
(show-key-binding *second-keys* *second-mouse*))
-(let ((days '("Lundi" "Mardi" "Mercredi" "Jeudi" "Vendredi" "Samedi" "Dimanche"))
- (months '("Janvier" "Fevrier" "Mars" "Avril" "Mai" "Juin" "Juillet"
- "Aout" "Septembre" "Octobre" "Novembre" "Decembre")))
- (defun date-string ()
- (multiple-value-bind (second minute hour date month year day)
- (get-decoded-time)
- (format nil " ~2,'0D:~2,'0D:~2,'0D ~A ~2,'0D ~A ~A "
- hour minute second
- (nth day days) date (nth (1- month) months) year))))
-
-
(defun show-date ()
"Show the current time and date"
(info-mode (list (date-string))))
@@ -417,6 +406,9 @@
(#\l show-cd-playlist))))
+(defun show-version ()
+ "Show the current CLFSWM version"
+ (info-mode (list *version*)))
(defun help-on-clfswm ()
"Open the help and info window"
@@ -426,6 +418,7 @@
(#\c show-cpu-proc)
(#\m show-mem-proc)
(#\x xmms-info-menu)
+ (#\v show-version)
(#\d info-on-cd-menu))))
@@ -437,6 +430,7 @@
(#\c show-cpu-proc)
(#\m show-mem-proc)
(#\x xmms-info-menu)
+ (#\v show-version)
(#\d info-on-cd-menu))))
Modified: clfswm/src/package.lisp
==============================================================================
--- clfswm/src/package.lisp (original)
+++ clfswm/src/package.lisp Tue Mar 18 16:53:45 2008
@@ -26,7 +26,7 @@
(in-package :cl-user)
(defpackage clfswm
- (:use :common-lisp :my-html :tools)
+ (:use :common-lisp :my-html :tools :version)
;;(:shadow :defun)
(:export :main))
Modified: clfswm/src/tools.lisp
==============================================================================
--- clfswm/src/tools.lisp (original)
+++ clfswm/src/tools.lisp Tue Mar 18 16:53:45 2008
@@ -44,6 +44,7 @@
:escape-string
:first-position
:find-free-number
+ :date-string
:do-execute
:do-shell
:getenv
@@ -569,179 +570,21 @@
(next-in-list item (reverse lst)))
-;;(defun transfert-stream (in out length &key (bufsize 4096))
-;;;; (ignore-errors
-;; (do* ((data (make-array bufsize
-;; :element-type (stream-element-type in)))
-;; (len 0 (read-sequence data in
-;; :start 0
-;; :end (if (> (+ wlen bufsize) length)
-;; (- length wlen)
-;; bufsize)))
-;; (wlen 0 (+ wlen len)))
-;; ((>= wlen length) (write-sequence data out :start 0 :end len))
-;; (write-sequence data out :start 0 :end len)));)
-;;
-;;
-;;
-;;
-;;
-;;(defun my-copy-file (in-name out-name)
-;; (with-open-file
-;; (in in-name :direction :input :element-type '(unsigned-byte 8))
-;; (with-open-file
-;; (out out-name :direction :output
-;; :if-exists :supersede
-;; :element-type '(unsigned-byte 8))
-;; (transfert-stream in out (file-length in)))))
-
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ;;
-;; Find String part. ;;
-;; ;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun find-string (substr str &key (start 0) (end nil)
- (test nil) (ignore-case nil))
- "Find substr in str. Return begin and end of substr in str as two values.
-Start and end set the findinq region. Ignore-case make find-string case
-insensitive.
-Test (if needed) must be a function which take str pos1 pos2 and must return
-new positions of the substr in str as two values"
- (when (and end (>= start end))
- (return-from find-string nil))
- (let ((pos1 (- start 1))
- (pos2 nil)
- (len (length substr)))
- (when ignore-case
- (setq str (string-upcase str)
- substr (string-upcase substr)))
- (do ((done nil))
- (done (if (functionp test)
- (funcall test str pos1 pos2)
- (values pos1 pos2)))
- (setq pos1 (position (aref substr 0) str :start (+ pos1 1) :end end))
- (unless pos1
- (return-from find-string nil))
- (setq pos2 (string>= str substr :start1 pos1 :end1 end))
- (when (and pos2 (= (- pos2 pos1) len))
- (setq done t)))))
-
-
-
-(defun find-all-strings (substr str &key (start 0) (end nil)
- (test nil) (ignore-case nil))
- "Find all substr in str. Parameters are the same as find-string.
-Return a list with all begin and end positions of substr in str
-ie: '((pos1.1 pos1.2) (pos2.1 pos2.2))..."
- (do ((pos (multiple-value-list
- (find-string substr str :start start :end end
- :test test :ignore-case ignore-case))
- (multiple-value-list
- (find-string substr str :start (second pos) :end end
- :test test :ignore-case ignore-case)))
- (accum nil))
- ((equal pos '(nil)) (nreverse accum))
- (push pos accum)))
-
-
-
-(defun subst-strings (new substr str &key (start 0) (end nil)
- (test nil) (ignore-case nil))
- "Substitute all substr strings in str with new.
-New must be a string or a function witch takes str pos1 pos2
-as parameters and return a string to replace substr"
- (let ((outstr (subseq str 0 start))
- (pos1 start)
- (pos2 0)
- (newpos 0))
- (unless end
- (setq end (length str)))
- (do ((done nil))
- (done outstr)
- (multiple-value-setq
- (pos2 newpos)
- (find-string substr str :start pos1 :end end
- :test test :ignore-case ignore-case))
- (if pos2
- (progn
- (setq outstr (concatenate 'string
- outstr
- (subseq str pos1 pos2)
- (if (functionp new)
- (funcall new str pos2 newpos)
- new)))
- (setq pos1 (if (and newpos (<= newpos end))
- newpos
- end)))
- (progn
- (setq outstr (concatenate 'string
- outstr (subseq str pos1)))
- (setq done t))))))
-
-
-
-(defun my-find-string-test (str pos1 pos2)
- (multiple-value-bind
- (npos1 npos2)
- (find-string "=>" str :start pos2)
- (declare (ignore npos1))
- (values pos1 npos2)))
-
-
-(defun test-find-string ()
- (let ((count 0)
- (str "bla bla foo <= plop gloup => foo
-baz bar <=klm poi => boo <=plop=> faz
-lab totrs <= plip =>"))
-
- (format t "Original:~%~A~2%" str)
- (format t "[1] Simple find on '<=': ~A~%"
- (multiple-value-list
- (find-string "<=" str)))
- (format t "[2] Find with start=15/end=50: ~A~%"
- (multiple-value-list
- (find-string "<=" str :start 15 :end 50)))
-
- (format t "[3] Find with test (ie '<=.*=>'): ~A~%"
- (multiple-value-bind
- (pos1 pos2)
- (find-string "<=" str :test #'my-find-string-test)
- (subseq str pos1 pos2)))
-
- (format t "[4] Find all strings: ~A~%"
- (find-all-strings "<=" str))
-
- (format t "[5] Find all strings:~%")
- (dolist (pos (find-all-strings "<=" str))
- (format t "Found: ~A~%"
- (subseq str (car pos) (second pos))))
-
- (format t "[6] Find all strings with test:~%")
- (dolist (pos (find-all-strings "<=" str :test #'my-find-string-test))
- (format t "Found: ~A~%" (subseq str (car pos) (second pos))))
-
- (format t "[7] Modifie '<=.*=>' with TOTO:~%~A"
- (subst-strings "TOTO" "<=" str
- :test #'my-find-string-test))
- (format t "~%")
- (format t "[8] Modifie '<=.*=>' with a complex expression:~%~A~%"
- (subst-strings
- #'(lambda (str pos1 pos2)
- (let ((repl (string-trim " "
- (subseq str (+ pos1 2) (- pos2 2)))))
- (format nil "<=~A:~A (~A)=>"
- (incf count)
- repl
- (reverse repl))))
- "<=" str
- :test #'(lambda (str pos1 pos2)
- (multiple-value-bind
- (npos1 npos2)
- (find-string "=>" str :start pos2)
- (declare (ignore npos1))
- (values pos1 npos2)))))))
+(let ((jours '("Lundi" "Mardi" "Mercredi" "Jeudi" "Vendredi" "Samedi" "Dimanche"))
+ (mois '("Janvier" "Fevrier" "Mars" "Avril" "Mai" "Juin" "Juillet"
+ "Aout" "Septembre" "Octobre" "Novembre" "Decembre"))
+ (days '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
+ (months '("January" "February" "March" "April" "May" "June" "July"
+ "August" "September" "October" "November" "December")))
+ (defun date-string ()
+ (multiple-value-bind (second minute hour date month year day)
+ (get-decoded-time)
+ (if (search "fr" (getenv "LANG") :test #'string-equal)
+ (format nil " ~2,'0D:~2,'0D:~2,'0D ~A ~2,'0D ~A ~A "
+ hour minute second
+ (nth day jours) date (nth (1- month) mois) year)
+ (format nil " ~2,'0D:~2,'0D:~2,'0D ~A ~A ~2,'0D ~A "
+ hour minute second
+ (nth day days) (nth (1- month) months) date year)))))
Added: clfswm/src/version.lisp
==============================================================================
--- (empty file)
+++ clfswm/src/version.lisp Tue Mar 18 16:53:45 2008
@@ -0,0 +1,36 @@
+;; Copyright (C) 2008 Xavier Maillard <xma at gnu.org>
+;; Copyright (C) 2006 Martin Bishop
+;;
+;; Borrowed from Stumpwm
+;; This file is part of clfswm.
+;;
+;; clfswm is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; clfswm is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+;; Boston, MA 02111-1307 USA
+
+;; Commentary:
+;;
+;; This file contains version information.
+;;
+;; Code:
+
+(in-package :common-lisp-user)
+
+(defpackage version
+ (:use :common-lisp :tools)
+ (:export *version*))
+
+(in-package :version)
+
+(defparameter *version* #.(concatenate 'string "0.0.1-git built " (date-string)))
\ No newline at end of file
More information about the clfswm-cvs
mailing list