1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: General tools
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2012 Philippe Brochard <pbrochard@common-lisp.net>
10 ;;; This program is free software; you can redistribute it and/or modify
11 ;;; it under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 3 of the License, or
13 ;;; (at your option) any later version.
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with this program; if not, write to the Free Software
22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
24 ;;; --------------------------------------------------------------------------
27 (in-package :common-lisp-user
)
34 :defconfig
:*config-var-table
* :configvar-value
:configvar-group
:config-default-value
44 :create-symbol
:create-symbol-in-package
60 :rectangle-x
:rectangle-y
:rectangle-width
:rectangle-height
64 :with-all-internal-symbols
65 :export-all-functions
:export-all-variables
66 :export-all-functions-and-variables
81 :extented-alphanumericp
98 :do-shell
:fdo-shell
:do-shell-output
106 :get-command-line-words
109 :string-to-list-multichar
114 :exchange-one-in-list
118 :append-formated-list
120 :parse-integer-in-list
122 :next-in-list
:prev-in-list
130 :battery-alert-string
139 (defstruct rectangle x y width height
)
141 (setq *random-state
* (make-random-state t
))
146 (defmacro awhen
(test &body body
)
151 (defmacro aif
(test then
&optional else
)
152 `(let ((it ,test
)) (if it
,then
,else
)))
155 ;;; Configuration variables
156 (defstruct configvar value group doc
)
158 (defparameter *config-var-table
* (make-hash-table :test
#'equal
))
160 (defmacro defconfig
(name value group doc
)
162 (setf (gethash ',name
*config-var-table
*)
163 (make-configvar :value
,value
164 :group
(or ,group
'Miscellaneous
)))
165 (defparameter ,name
,value
,doc
)))
167 (defun config-default-value (var)
168 (let ((config (gethash var
*config-var-table
*)))
170 (configvar-value config
))))
172 (defun config-group->string
(group)
173 (format nil
"~:(~A group~)" (substitute #\Space
#\-
(string group
))))
176 ;;; Configuration variables
177 (defun config-all-groups ()
179 (maphash (lambda (key val
)
180 (declare (ignore key
))
181 (pushnew (configvar-group val
) all-groups
:test
#'equal
))
183 (sort all-groups
(lambda (x y
)
184 (string< (string x
) (string y
))))))
189 (defun find-in-hash (val hashtable
&optional
(test #'equal
))
190 "Return the key associated to val in the hashtable"
191 (maphash #'(lambda (k v
)
192 (when (and (consp v
) (funcall test
(first v
) val
))
193 (return-from find-in-hash
(values k v
))))
196 (defun search-in-hash (val hashtable
)
197 "Return the key who match the val in the hashtable"
198 (let ((val (symbol-name val
)))
199 (maphash #'(lambda (k v
)
200 (when (and (consp v
) (substring-equal (symbol-name (first v
)) val
))
201 (return-from search-in-hash
(values k v
))))
205 (defun view-hash-table (title hashtable
)
206 (maphash (lambda (k v
)
207 (format t
"[~A] ~A ~A~%" title k v
))
210 (defun copy-hash-table (hashtable)
211 (let ((rethash (make-hash-table :test
(hash-table-test hashtable
))))
212 (maphash (lambda (k v
)
213 (setf (gethash k rethash
) v
))
218 (defun nfuncall (function)
222 (defun pfuncall (function &rest args
)
224 (or (functionp function
)
225 (and (symbolp function
) (fboundp function
))))
226 (apply function args
)))
230 (defun symbol-search (search symbol
)
231 "Search the string 'search' in the symbol name of 'symbol'"
232 (search search
(symbol-name symbol
) :test
#'string-equal
))
234 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
235 (defun mkstr (&rest args
)
236 (with-output-to-string (s)
240 (defun create-symbol (&rest args
)
241 (values (intern (string-upcase (apply #'mkstr args
)))))
243 (defun create-symbol-in-package (package &rest args
)
244 (values (intern (string-upcase (apply #'mkstr args
)) package
))))
250 (defun call-hook (hook &rest args
)
251 "Call a hook (a function, a symbol or a list of functions)
252 Return the result of the last hook"
257 (cons (dolist (h hook
)
259 (function (setf result
(apply hook args
)))
260 (symbol (when (fboundp hook
)
261 (setf result
(apply hook args
))))))))
266 (defmacro add-new-hook
(hook &rest value
)
267 "Add a hook. Duplicate it if needed"
268 `(setf ,hook
(append (typecase ,hook
273 (defmacro add-hook
(hook &rest value
)
274 "Add a hook only if not duplicated"
276 `(dolist (,i
(list ,@value
))
277 (unless (member ,i
(typecase ,hook
280 (add-new-hook ,hook
,i
)))))
282 (defmacro remove-hook
(hook &rest value
)
284 `(dolist (,i
(list ,@value
) ,hook
)
285 (setf ,hook
(remove ,i
,hook
)))))
291 (defparameter *timer-list
* nil
)
293 (declaim (inline realtime-
>s s-
>realtime
))
295 (defun realtime->s
(rtime)
296 (float (/ rtime internal-time-units-per-second
)))
298 (defun s->realtime
(second)
299 (round (* second internal-time-units-per-second
)))
302 (defun clear-timers ()
303 (setf *timer-list
* nil
))
305 (defun add-timer (delay fun
&optional
(id (gensym)))
306 "Start the function fun at delay seconds."
308 (let ((time (+ (get-internal-real-time) (s->realtime delay
))))
309 (lambda (current-time)
310 (when (>= current-time time
)
316 (defun at (delay fun
&optional
(id (gensym)))
317 "Start the function fun at delay seconds."
318 (funcall #'add-timer delay fun id
))
320 (defmacro with-timer
((delay &optional
(id (gensym))) &body body
)
321 "Same thing as add-timer but with syntaxic sugar"
328 (defun process-timers ()
329 "Call each timers in *timer-list* if needed"
330 (let ((current-time (get-internal-real-time)))
331 (dolist (timer *timer-list
*)
332 (when (funcall (second timer
) current-time
)
333 (setf *timer-list
* (remove timer
*timer-list
* :test
#'equal
))))))
335 (defun erase-timer (id)
336 "Erase the timer identified by its id"
337 (setf *timer-list
* (remove id
*timer-list
* :test
(lambda (x y
)
338 (equal x
(first y
))))))
340 (defun timer-test-loop ()
343 (format t
"Plop-~A" count
)
346 (format t
"Toto-~A" count
)
347 (add-timer 3 #'toto
:toto
)))
348 (add-timer 3 #'toto
:toto
)
349 (add-timer 13 #'plop
)
351 (princ ".") (force-output)
361 (defvar *%dbg-name%
* "dbg")
362 (defvar *%dbg-count%
* 0)
365 (defmacro dbg
(&rest forms
)
367 ,@(mapcar #'(lambda (form)
369 (string `(setf *%dbg-name%
* ,form
))
370 (number `(setf *%dbg-count%
* ,form
))))
372 (format t
"~&DEBUG[~A - ~A] " (incf *%dbg-count%
*) *%dbg-name%
*)
373 ,@(mapcar #'(lambda (form)
375 ((or string number
) nil
)
376 (t `(format t
"~A=~S " ',form
,form
))))
382 (defmacro dbgnl
(&rest forms
)
384 ,@(mapcar #'(lambda (form)
386 (string `(setf *%dbg-name%
* ,form
))
387 (number `(setf *%dbg-count%
* ,form
))))
389 (format t
"~&DEBUG[~A - ~A] --------------------~%" (incf *%dbg-count%
*) *%dbg-name%
*)
390 ,@(mapcar #'(lambda (form)
392 ((or string number
) nil
)
393 (t `(format t
" - ~A=~S~%" ',form
,form
))))
399 (defun dbgc (obj &optional newline
)
406 (defun in-rectangle (x y rectangle
)
408 (<= (rectangle-x rectangle
) x
(+ (rectangle-x rectangle
) (rectangle-width rectangle
)))
409 (<= (rectangle-y rectangle
) y
(+ (rectangle-y rectangle
) (rectangle-height rectangle
)))))
413 (defun distance (x1 y1 x2 y2
)
414 (+ (abs (- x2 x1
)) (abs (- y2 y1
))))
418 (defun collect-all-symbols (&optional package
)
419 (format t
"Collecting all symbols for Lisp REPL completion...")
421 (do-symbols (symbol (or package
*package
*))
422 (pushnew (string-downcase (symbol-name symbol
)) all-symbols
:test
#'string
=))
423 (do-symbols (symbol :keyword
)
424 (pushnew (concatenate 'string
":" (string-downcase (symbol-name symbol
)))
425 all-symbols
:test
#'string
=))
426 (format t
" Done.~%")
431 (defmacro with-all-internal-symbols
((var package
) &body body
)
432 "Bind symbol to all internal symbols in package"
433 `(do-symbols (,var
,package
)
434 (multiple-value-bind (sym status
)
435 (find-symbol (symbol-name ,var
) ,package
)
436 (declare (ignore sym
))
437 (when (eql status
:internal
)
441 (defun export-all-functions (package &optional
(verbose nil
))
442 (with-all-internal-symbols (symbol package
)
443 (when (fboundp symbol
)
445 (format t
"Exporting ~S~%" symbol
))
446 (export symbol package
))))
449 (defun export-all-variables (package &optional
(verbose nil
))
450 (with-all-internal-symbols (symbol package
)
451 (when (boundp symbol
)
453 (format t
"Exporting ~S~%" symbol
))
454 (export symbol package
))))
456 (defun export-all-functions-and-variables (package &optional
(verbose nil
))
457 (with-all-internal-symbols (symbol package
)
458 (when (or (fboundp symbol
) (boundp symbol
))
460 (format t
"Exporting ~S~%" symbol
))
461 (export symbol package
))))
465 (defun ensure-function (object)
466 (if (functionp object
)
468 (symbol-function object
)))
473 (defun empty-string-p (string)
477 (defun find-common-string (string list
&optional orig
)
478 "Return the string in common in all string in list"
480 (let ((result (remove-if-not (lambda (x)
481 (zerop (or (search string x
:test
#'string-equal
) -
1)))
483 (if (= (length result
) (length list
))
484 (if (> (length (first list
)) (length string
))
485 (find-common-string (subseq (first list
) 0 (1+ (length string
))) list string
)
491 (defun command-in-path (&optional
(tmpfile "/tmp/clfswm-cmd.tmp"))
492 (format t
"Updating command list for Shell completion...~%")
493 (labels ((delete-tmp ()
494 (when (probe-file tmpfile
)
495 (delete-file tmpfile
))))
497 (dolist (dir (split-string (getenv "PATH") #\
:))
498 (ushell (format nil
"ls ~A/* >> ~A" dir tmpfile
)))
499 (let ((commands nil
))
500 (with-open-file (stream tmpfile
:direction
:input
)
501 (loop for line
= (read-line stream nil nil
)
503 do
(pushnew (subseq line
(1+ (or (position #\
/ line
:from-end t
) -
1))) commands
506 (format t
"Done. Found ~A commands in shell PATH.~%" (length commands
))
511 (defmacro setf
/= (var val
)
512 "Set var to val only when var not equal to val"
513 (let ((gval (gensym)))
515 (when (/= ,var
,gval
)
516 (setf ,var
,gval
)))))
519 (defun number->char
(number)
520 (cond ((<= number
25) (code-char (+ (char-code #\a) number
)))
521 ((<= 26 number
35) (code-char (+ (char-code #\
0) (- number
26))))
522 ((<= 36 number
61) (code-char (+ (char-code #\A
) (- number
36))))
525 (defun number->string
(number)
526 (string (number->char number
)))
528 (defun number->letter
(n &optional
(base 26))
530 (with-output-to-string (str)
532 (princ (code-char (+ (char-code #\a) (mod n base
))) str
)
534 (rec (- (truncate (/ n base
)) 1)))))
538 (defun simple-type-of (object)
539 (let ((type (type-of object
)))
545 (defun repeat-chars (n char
)
546 "Return a string containing N CHARs."
547 (make-string n
:initial-element char
))
551 (defun nth-insert (n elem list
)
552 "Insert elem in (nth n list)"
553 (nconc (subseq list
0 n
)
559 (defun split-string (string &optional
(separator #\Space
))
560 "Return a list from a string splited at each separators"
561 (loop for i
= 0 then
(1+ j
)
562 as j
= (position separator string
:start i
)
563 as sub
= (subseq string i j
)
564 unless
(string= sub
"") collect sub
567 (defun substring-equal (substring string
)
568 (string-equal substring
(subseq string
0 (min (length substring
) (length string
)))))
570 (defun string-match (match list
)
571 "Return the string in list witch match the match string"
572 (let ((len (length match
)))
573 (remove-duplicates (remove-if-not (lambda (x)
574 (string-equal match
(subseq x
0 (min len
(length x
)))))
576 :test
#'string-equal
)))
579 (defun extented-alphanumericp (char)
580 (or (alphanumericp char
)
591 (defun append-newline-space (string)
592 "Append spaces before Newline on each line"
593 (with-output-to-string (stream)
594 (loop for c across string do
595 (when (equal c
#\Newline
)
600 (defun expand-newline (list)
601 "Expand all newline in strings in list"
604 (setf acc
(append acc
(split-string l
#\Newline
))))
607 (defun ensure-list (object)
608 "Ensure an object is a list"
614 (defun ensure-printable (string &optional
(new #\?))
615 "Ensure a string is printable in ascii"
616 (or (substitute-if-not new
#'standard-char-p
(or string
"")) ""))
618 (defun limit-length (string &optional
(length 10))
619 (subseq string
0 (min (length string
) length
)))
622 (defun ensure-n-elems (list n
)
623 "Ensure that list has exactly n elements"
624 (let ((length (length list
)))
625 (cond ((= length n
) list
)
626 ((< length n
) (ensure-n-elems (append list
'(nil)) n
))
627 ((> length n
) (ensure-n-elems (butlast list
) n
)))))
629 (defun begin-with-2-spaces (string)
630 (and (> (length string
) 1)
631 (eql (char string
0) #\Space
)
632 (eql (char string
1) #\Space
)))
634 (defun string-equal-p (x y
)
635 (when (stringp y
) (string-equal x y
)))
640 (defun find-assoc-word (word line
&optional
(delim #\"))
642 (let* ((pos (search word line
))
643 (pos-1 (position delim line
:start
(or pos
0)))
644 (pos-2 (position delim line
:start
(1+ (or pos-1
0)))))
645 (when (and pos pos-1 pos-2
)
646 (subseq line
(1+ pos-1
) pos-2
))))
649 (defun print-space (n &optional
(stream *standard-output
*))
650 "Print n spaces on stream"
652 (princ #\Space stream
)))
655 (defun escape-string (string &optional
(escaper '(#\
/ #\
: #\
) #\
( #\Space
#\
; #\,)) (char #\_))
656 "Replace in string all characters found in the escaper list"
658 (escape-string (substitute char
(car escaper
) string
) (cdr escaper
) char
)
663 (defun first-position (word string
)
664 "Return true only if word is at position 0 in string"
665 (zerop (or (search word string
) -
1)))
668 (defun find-free-number (l) ; stolen from stumpwm - thanks
669 "Return a number that is not in the list l."
670 (let* ((nums (sort l
#'<))
671 (new-num (loop for n from
0 to
(or (car (last nums
)) 0)
677 ;; there was no space between the numbers, so use the last + 1
678 (if (car (last nums
))
679 (1+ (car (last nums
)))
686 ;;; Shell part (taken from ltk)
687 (defun do-execute (program args
&optional
(wt nil
) (io :stream
))
688 "execute program with args a list containing the arguments passed to
689 the program if wt is non-nil, the function will wait for the execution
690 of the program to return.
691 returns a two way stream connected to stdin/stdout of the program"
692 #-CLISP
(declare (ignore io
))
693 (let ((fullstring program
))
695 (setf fullstring
(concatenate 'string fullstring
" " a
)))
696 #+:cmu
(let ((proc (ext:run-program program args
:input
:stream
:output
:stream
:wait wt
)))
698 (error "Cannot create process."))
700 (ext:process-output proc
)
701 (ext:process-input proc
)))
702 #+:clisp
(ext:run-program program
:arguments args
:input io
:output io
:wait wt
)
703 #+:sbcl
(let ((proc (sb-ext:run-program program args
:input
:stream
:output
:stream
:wait wt
)))
705 (error "Cannot create process."))
707 (sb-ext:process-output proc
)
708 (sb-ext:process-input proc
)))
709 #+:lispworks
(system:open-pipe fullstring
:direction
:io
)
710 #+:allegro
(let ((proc (excl:run-shell-command
711 (apply #'vector program program args
)
712 :input
:stream
:output
:stream
:wait wt
)))
714 (error "Cannot create process."))
716 #+:ecl
(ext:run-program program args
:input
:stream
:output
:stream
718 #+:openmcl
(let ((proc (ccl:run-program program args
:input
722 (error "Cannot create process."))
724 (ccl:external-process-output-stream proc
)
725 (ccl:external-process-input-stream proc
)))))
727 (defun do-shell (program &optional args
(wait nil
) (io :stream
))
728 (do-execute "/bin/sh" `("-c" ,program
,@args
) wait io
))
730 (defun fdo-shell (formatter &rest args
)
731 (do-shell (apply #'format nil formatter args
)))
733 (defun do-shell-output (formatter &rest args
)
734 (let ((output (do-shell (apply #'format nil formatter args
) nil t
)))
735 (loop for line
= (read-line output nil nil
)
742 "Return the value of the environment variable."
743 #+allegro
(sys::getenv
(string var
))
744 #+clisp
(ext:getenv
(string var
))
746 (cdr (assoc (string var
) ext
:*environment-list
* :test
#'equalp
748 #+gcl
(si:getenv
(string var
))
749 #+lispworks
(lw:environment-variable
(string var
))
750 #+lucid
(lcl:environment-variable
(string var
))
751 #+(or mcl ccl
) (ccl::getenv var
)
752 #+sbcl
(sb-posix:getenv
(string var
))
753 #+ecl
(si:getenv
(string var
))
754 #-
(or allegro clisp cmu gcl lispworks lucid mcl sbcl scl ecl ccl
)
755 (error 'not-implemented
:proc
(list 'getenv var
)))
758 (defun (setf getenv
) (val var
)
759 "Set an environment variable."
760 #+allegro
(setf (sys::getenv
(string var
)) (string val
))
761 #+clisp
(setf (ext:getenv
(string var
)) (string val
))
763 (let ((cell (assoc (string var
) ext
:*environment-list
* :test
#'equalp
766 (setf (cdr cell
) (string val
))
767 (push (cons (intern (string var
) "KEYWORD") (string val
))
768 ext
:*environment-list
*)))
769 #+gcl
(si:setenv
(string var
) (string val
))
770 #+lispworks
(setf (lw:environment-variable
(string var
)) (string val
))
771 #+lucid
(setf (lcl:environment-variable
(string var
)) (string val
))
772 #+sbcl
(sb-posix:putenv
(format nil
"~A=~A" (string var
) (string val
)))
773 #+ecl
(si:setenv
(string var
) (string val
))
774 #+ccl
(ccl::setenv
(string var
) (string val
))
775 #-
(or allegro clisp cmu gcl lispworks lucid sbcl scl ecl ccl
)
776 (error 'not-implemented
:proc
(list '(setf getenv
) var
)))
785 #+(or clisp cmu
) (ext:quit
)
789 #+lispworks
(lw:quit
)
790 #+(or allegro-cl allegro-cl-trial
) (excl:exit
)
796 (defun remove-plist (plist &rest keys
)
797 "Remove the keys from the plist.
798 Useful for re-using the &REST arg after removing some options."
800 ((null (setq rest
(nth-value 2 (get-properties plist keys
))))
801 (nreconc copy plist
))
802 (do () ((eq plist rest
))
803 (push (pop plist
) copy
)
804 (push (pop plist
) copy
))
805 (setq plist
(cddr plist
))))
810 (defun urun-prog (prog &rest opts
&key args
(wait t
) &allow-other-keys
)
811 "Common interface to shell. Does not return anything useful."
812 #+gcl
(declare (ignore wait
))
813 (setq opts
(remove-plist opts
:args
:wait
))
814 #+allegro
(apply #'excl
:run-shell-command
(apply #'vector prog prog args
)
816 #+(and clisp lisp
=cl
)
817 (apply #'ext
:run-program prog
:arguments args
:wait wait opts
)
818 #+(and clisp
(not lisp
=cl
))
820 (apply #'lisp
:run-program prog
:arguments args opts
)
821 (lisp:shell
(format nil
"~a~{ '~a'~} &" prog args
)))
822 #+cmu
(apply #'ext
:run-program prog args
:wait wait
:output
*standard-output
* opts
)
823 #+gcl
(apply #'si
:run-process prog args
)
824 #+liquid
(apply #'lcl
:run-program prog args
)
825 #+lispworks
(apply #'sys
::call-system-showing-output
826 (format nil
"~a~{ '~a'~}~@[ &~]" prog args
(not wait
))
828 #+lucid
(apply #'lcl
:run-program prog
:wait wait
:arguments args opts
)
829 #+sbcl
(apply #'sb-ext
:run-program prog args
:wait wait
:output
*standard-output
* opts
)
830 #+ecl
(apply #'ext
:run-program prog args opts
)
831 #+ccl
(ccl:run-program prog args
:wait wait
)
832 #-
(or allegro clisp cmu gcl liquid lispworks lucid sbcl ecl ccl
)
833 (error 'not-implemented
:proc
(list 'run-prog prog opts
)))
836 ;;(defparameter *shell-cmd* "/usr/bin/env")
837 ;;(defparameter *shell-cmd-opt* nil)
839 #+UNIX
(defparameter *shell-cmd
* "/bin/sh")
840 #+UNIX
(defparameter *shell-cmd-opt
* '("-c"))
842 #+WIN32
(defparameter *shell-cmd
* "cmd.exe")
843 #+WIN32
(defparameter *shell-cmd-opt
* '("/C"))
846 (defun ushell (&rest strings
)
847 (urun-prog *shell-cmd
* :args
(append *shell-cmd-opt
* strings
)))
850 (urun-prog *shell-cmd
* :args
(append *shell-cmd-opt
* (list string
))))
853 (defun set-shell-dispatch (&optional
(shell-fun 'ushell
))
854 (labels ((|shell-reader|
(stream subchar arg
)
855 (declare (ignore subchar arg
))
856 (list shell-fun
(read stream t nil t
))))
857 (set-dispatch-macro-character #\
# #\
# #'|shell-reader|
)))
860 (defun ushell-loop (&optional
(shell-fun #'ushell
))
862 (format t
"UNI-SHELL> ")
863 (let* ((line (read-line)))
864 (cond ((zerop (or (search "quit" line
) -
1)) (return))
865 ((zerop (or (position #\
! line
) -
1))
866 (funcall shell-fun
(subseq line
1)))
867 (t (format t
"~{~A~^ ;~%~}~%"
869 (ignore-errors (eval (read-from-string line
))))))))))
876 (defun cldebug (&rest rest
)
883 (defun get-command-line-words ()
884 #+sbcl
(cdr sb-ext
:*posix-argv
*)
885 #+(or clozure ccl
) (cddddr (ccl::command-line-arguments
))
886 #+gcl
(cdr si
:*command-args
*)
887 #+ecl
(loop for i from
1 below
(si:argc
) collect
(si:argv i
))
888 #+cmu
(cdddr extensions
:*command-line-strings
*)
889 #+allegro
(cdr (sys:command-line-arguments
))
890 #+lispworks
(cdr sys
:*line-arguments-list
*)
892 #-
(or sbcl clozure gcl ecl cmu allegro lispworks clisp
)
893 (error "get-command-line-arguments not supported for your implementation"))
898 (defun string-to-list (str &key
(split-char #\space
))
899 (do* ((start 0 (1+ index
))
900 (index (position split-char str
:start start
)
901 (position split-char str
:start start
))
904 (unless (string= (subseq str start
) "")
905 (push (subseq str start
) accum
))
907 (when (/= start index
)
908 (push (subseq str start index
) accum
))))
911 (defun near-position (chars str
&key
(start 0))
912 (do* ((char chars
(cdr char
))
913 (pos (position (car char
) str
:start start
)
914 (position (car char
) str
:start start
))
926 ;;;(defun near-position2 (chars str &key (start 0))
927 ;;; (loop for i in chars
928 ;;; minimize (position i str :start start)))
930 ;;(format t "~S~%" (near-position '(#\! #\. #\Space #\;) "klmsqk ppii;dsdsqkl.jldfksj lkm" :start 0))
931 ;;(format t "~S~%" (near-position '(#\Space) "klmsqk ppii;dsdsqkl.jldfksj lkm" :start 0))
932 ;;(format t "~S~%" (near-position '(#\; #\l #\m) "klmsqk ppii;dsdsqkl.jldfksj lkm" :start 0))
933 ;;(format t "result=~S~%" (string-to-list-multichar "klmsqk ppii;dsdsqkl.jldfksj lkm" :preserve t))
934 ;;(format t "result=~S~%" (string-to-list-multichar "klmsqk ppii;dsd!sqkl.jldfksj lkm"
935 ;; :split-chars '(#\k #\! #\. #\; #\m)
939 (defun string-to-list-multichar (str &key
(split-chars '(#\space
)) (preserve nil
))
940 (do* ((start 0 (1+ index
))
941 (index (near-position split-chars str
:start start
)
942 (near-position split-chars str
:start start
))
945 (unless (string= (subseq str start
) "")
946 (push (subseq str start
) accum
))
948 (let ((retstr (subseq str start
(if preserve
(1+ index
) index
))))
949 (unless (string= retstr
"")
950 (push retstr accum
)))))
956 (defun list-to-string (lst)
957 (string-trim " () " (format nil
"~A" lst
)))
961 (defun clean-string (string)
962 "Remove Newline and upcase string"
964 (string-right-trim '(#\Newline
) string
)))
966 (defun one-in-list (lst)
967 (nth (random (length lst
)) lst
))
969 (defun exchange-one-in-list (lst1 lst2
)
970 (let ((elem1 (one-in-list lst1
))
971 (elem2 (one-in-list lst2
)))
972 (setf lst1
(append (remove elem1 lst1
) (list elem2
)))
973 (setf lst2
(append (remove elem2 lst2
) (list elem1
)))
977 (defun rotate-list (list)
979 (append (cdr list
) (list (car list
)))))
981 (defun anti-rotate-list (list)
983 (append (last list
) (butlast list
))))
985 (defun n-rotate-list (list steps
)
987 (let* ((len (length list
))
988 (nsteps (mod steps len
)))
989 (append (nthcdr nsteps list
) (butlast list
(- len nsteps
))))))
992 (defun append-formated-list (base-str
994 &key
(test-not-fun #'(lambda (x) x nil
))
995 (print-fun #'(lambda (x) x
))
997 (let ((str base-str
) (first t
))
999 (cond ((funcall test-not-fun i
) nil
)
1001 (concatenate 'string str
1004 (funcall print-fun i
))))
1006 (if (string= base-str str
)
1007 (concatenate 'string str default-str
) str
)))
1010 (defun shuffle-list (list &key
(time 1))
1011 "Shuffle a list by swapping elements time times"
1012 (let ((result (copy-list list
))
1013 (ind1 0) (ind2 0) (swap 0))
1015 (setf ind1
(random (length result
)))
1016 (setf ind2
(random (length result
)))
1018 (setf swap
(nth ind1 result
))
1019 (setf (nth ind1 result
) (nth ind2 result
))
1020 (setf (nth ind2 result
) swap
))
1025 (defun convert-to-number (str)
1026 (cond ((stringp str
) (parse-integer str
:junk-allowed t
))
1027 ((numberp str
) str
)))
1029 (defun parse-integer-in-list (lst)
1030 "Convert all integer string in lst to integer"
1031 (mapcar #'(lambda (x) (convert-to-number x
)) lst
))
1035 (defun next-in-list (item lst
)
1036 (do ((x lst
(cdr x
)))
1038 (when (equal item
(car x
))
1039 (return (if (cadr x
) (cadr x
) (car lst
))))))
1041 (defun prev-in-list (item lst
)
1042 (next-in-list item
(reverse lst
)))
1045 (let ((jours '("Lundi" "Mardi" "Mercredi" "Jeudi" "Vendredi" "Samedi" "Dimanche"))
1046 (mois '("Janvier" "Fevrier" "Mars" "Avril" "Mai" "Juin" "Juillet"
1047 "Aout" "Septembre" "Octobre" "Novembre" "Decembre"))
1048 (days '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
1049 (months '("January" "February" "March" "April" "May" "June" "July"
1050 "August" "September" "October" "November" "December")))
1051 (defun date-string ()
1052 (multiple-value-bind (second minute hour date month year day
)
1054 (if (search "fr" (getenv "LANG") :test
#'string-equal
)
1055 (format nil
" ~2,'0D:~2,'0D:~2,'0D ~A ~2,'0D ~A ~A "
1057 (nth day jours
) date
(nth (1- month
) mois
) year
)
1058 (format nil
" ~2,'0D:~2,'0D:~2,'0D ~A ~A ~2,'0D ~A "
1060 (nth day days
) (nth (1- month
) months
) date year
)))))
1063 ;;; Backtrace function
1065 (defun write-backtrace (filename &optional other-info clear
)
1066 (when (and clear
(probe-file filename
))
1067 (delete-file filename
))
1068 (with-open-file (stream filename
:direction
:output
:if-exists
:append
1069 :if-does-not-exist
:create
)
1070 (let ((*standard-output
* stream
)
1071 (*debug-io
* stream
))
1072 (format t
"================== New backtrace ==================~%")
1073 (format t
"--- ~A ---~%" (date-string))
1074 (format t
"Lisp: ~A ; Version: ~A~2%" (lisp-implementation-type)
1075 (lisp-implementation-version))
1076 #+clisp
(system::print-backtrace
)
1077 #+(or cmucl scl
) (debug:backtrace
)
1078 #+sbcl
(sb-debug:backtrace
)
1079 #+(or mcl ccl
) (ccl:print-call-history
:detailed-p nil
)
1080 #-
(or clisp cmucl scl sbcl mcl ccl
) (format t
"Backtrace not defined~%")
1082 (format t
"~A~%" other-info
))
1083 (format t
"--- log end ---~%")))
1084 (format t
"Backtrace logged in file: ~A~%" filename
))
1089 ;;; System information functions
1091 (defparameter *bat-cmd
* "acpi -b")
1092 (defparameter *cpu-cmd
* "top -b -n 2 -d 1 -p 0")
1093 (defparameter *cpu-cmd-fast
* "top -b -n 2 -d 0.1 -p 0")
1094 (defparameter *mem-cmd
* "free")
1096 (defmacro with-search-line
((word line
) &body body
)
1097 `(let ((pos (search ,word
,line
:test
#'string-equal
)))
1098 (when (>= (or pos -
1) 0)
1101 (defun extract-battery-usage (line)
1102 (with-search-line ("Battery" line
)
1103 (let ((pos (position #\% line
)))
1105 (parse-integer (subseq line
(- pos
3) pos
) :junk-allowed t
)))))
1107 (defun extract-cpu-usage (line)
1108 (with-search-line ("%Cpu(s):" line
)
1109 (let ((pos1 (search "id" line
)))
1111 (let ((pos2 (position #\
, line
:from-end t
:end pos1
)))
1113 (- 100 (parse-integer (subseq line
(1+ pos2
) pos1
) :junk-allowed t
))))))))
1115 (defun extract-mem-used (line)
1116 (with-search-line ("cache:" line
)
1117 (parse-integer (subseq line
(+ pos
6)) :junk-allowed t
)))
1119 (defun extract-mem-total (line)
1120 (with-search-line ("mem:" line
)
1121 (parse-integer (subseq line
(+ pos
4)) :junk-allowed t
)))
1124 (defun memory-usage ()
1125 (let ((output (do-shell *mem-cmd
*))
1127 (loop for line
= (read-line output nil nil
)
1129 do
(awhen (extract-mem-used line
)
1131 (awhen (and (= total -
1) (extract-mem-total line
))
1133 (values used total
))))
1137 (let ((output (do-shell *cpu-cmd-fast
*))
1139 (loop for line
= (read-line output nil nil
)
1141 do
(awhen (extract-cpu-usage line
)
1145 (defun battery-usage ()
1146 (let ((output (do-shell *bat-cmd
*))
1148 (loop for line
= (read-line output nil nil
)
1150 do
(awhen (extract-battery-usage line
)
1154 (defun battery-alert-string (bat)
1156 (cond ((<= bat
5) "/!\\")
1163 ;;; System usage with a poll system - Memory, CPU and battery all in one
1165 (let ((poll-log "/tmp/.clfswm-system.log")
1166 (poll-exec "/tmp/.clfswm-system.sh")
1167 (poll-lock "/tmp/.clfswm-system.lock"))
1168 (defun create-system-poll (delay)
1169 (with-open-file (stream poll-exec
:direction
:output
:if-exists
:supersede
)
1170 (format stream
"#! /bin/sh
1173 (~A; ~A ; ~A) > ~A.tmp;
1176 done~%" *bat-cmd
* *cpu-cmd
* *mem-cmd
* poll-log poll-log poll-log delay
)))
1178 (defun system-poll-pid ()
1180 (let ((output (do-shell "ps x")))
1181 (loop for line
= (read-line output nil nil
)
1183 do
(when (search poll-exec line
)
1184 (push (parse-integer line
:junk-allowed t
) pid
))))
1187 (defun stop-system-poll ()
1188 (dolist (pid (system-poll-pid))
1189 (fdo-shell "kill ~A" pid
))
1190 (when (probe-file poll-log
)
1191 (delete-file poll-log
))
1192 (when (probe-file poll-exec
)
1193 (delete-file poll-exec
))
1194 (when (probe-file poll-lock
)
1195 (delete-file poll-lock
)))
1197 (defun start-system-poll (delay)
1198 (unless (probe-file poll-lock
)
1200 (create-system-poll delay
)
1201 (fdo-shell "exec sh ~A" poll-exec
)
1202 (with-open-file (stream poll-lock
:direction
:output
:if-exists
:supersede
)
1203 (format stream
"CLFSWM system poll started~%"))))
1205 (defun system-usage-poll (&optional
(delay 10))
1210 (start-system-poll delay
)
1211 (when (probe-file poll-log
)
1212 (with-open-file (stream poll-log
:direction
:input
)
1213 (loop for line
= (read-line stream nil nil
)
1215 do
(awhen (extract-battery-usage line
)
1217 (awhen (extract-cpu-usage line
)
1219 (awhen (extract-mem-used line
)
1221 (awhen (and (= total -
1) (extract-mem-total line
))
1223 (values cpu used total bat
))))