src/tools.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: General tools
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2012 Philippe Brochard <pbrochard@common-lisp.net>
   9 ;;;
  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.
  14 ;;;
  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.
  19 ;;;
  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.
  23 ;;;
  24 ;;; --------------------------------------------------------------------------
  25
  26
  27 (in-package :common-lisp-user)
  28
  29 (defpackage tools
  30   (:use common-lisp)
  31   (:export :it
  32            :awhen
  33            :aif
  34            :defconfig :*config-var-table* :configvar-value :configvar-group :config-default-value
  35            :config-all-groups
  36            :config-group->string
  37            :find-in-hash
  38            :view-hash-table
  39            :copy-hash-table
  40            :nfuncall
  41            :pfuncall
  42            :symbol-search
  43            :create-symbol :create-symbol-in-package
  44            :call-hook
  45            :add-new-hook
  46            :add-hook
  47            :remove-hook
  48            :clear-timers
  49            :add-timer
  50            :at
  51            :with-timer
  52            :process-timers
  53            :erase-timer
  54            :timer-loop
  55            :dbg
  56            :dbgnl
  57            :dbgc
  58            :make-rectangle
  59            :rectangle-x :rectangle-y :rectangle-width :rectangle-height
  60            :in-rectangle
  61            :distance
  62            :collect-all-symbols
  63            :with-all-internal-symbols
  64            :export-all-functions :export-all-variables
  65            :export-all-functions-and-variables
  66            :ensure-function
  67            :empty-string-p
  68            :find-common-string
  69            :command-in-path
  70            :setf/=
  71            :number->char
  72            :number->string
  73            :number->letter
  74            :simple-type-of
  75            :repeat-chars
  76            :nth-insert
  77            :split-string
  78            :substring-equal
  79            :string-match
  80            :extented-alphanumericp
  81            :append-newline-space
  82            :expand-newline
  83            :ensure-list
  84            :ensure-printable
  85            :limit-length
  86            :ensure-n-elems
  87            :begin-with-2-spaces
  88            :string-equal-p
  89            :find-assoc-word
  90            :print-space
  91            :escape-string
  92            :first-position
  93            :find-free-number
  94            :date-string
  95            :do-execute
  96            :do-shell :fdo-shell
  97            :getenv
  98            :uquit
  99            :urun-prog
 100            :ushell
 101            :ush
 102            :ushell-loop
 103            :cldebug
 104            :get-command-line-words
 105            :string-to-list
 106            :near-position
 107            :string-to-list-multichar
 108            :list-to-string
 109            :list-to-string-list
 110            :clean-string
 111            :one-in-list
 112            :exchange-one-in-list
 113            :rotate-list
 114            :anti-rotate-list
 115            :n-rotate-list
 116            :append-formated-list
 117            :shuffle-list
 118            :parse-integer-in-list
 119            :convert-to-number
 120            :next-in-list :prev-in-list
 121            :find-string
 122            :find-all-strings
 123            :subst-strings
 124            :test-find-string
 125            :memory-usage
 126            :cpu-usage
 127            :battery-usage
 128            :battery-alert-string
 129            :start-system-poll
 130            :stop-system-poll
 131            :system-usage-poll))
 132
 133
 134 (in-package :tools)
 135
 136
 137 (defstruct rectangle x y width height)
 138
 139 (setq *random-state* (make-random-state t))
 140
 141
 142
 143
 144 (defmacro awhen (test &body body)
 145   `(let ((it ,test))
 146      (when it
 147        ,@body)))
 148
 149 (defmacro aif (test then &optional else)
 150   `(let ((it ,test)) (if it ,then ,else)))
 151
 152
 153 ;;; Configuration variables
 154 (defstruct configvar value group doc)
 155
 156 (defparameter *config-var-table* (make-hash-table :test #'equal))
 157
 158 (defmacro defconfig (name value group doc)
 159   `(progn
 160      (setf (gethash ',name *config-var-table*)
 161            (make-configvar :value ,value
 162                            :group (or ,group 'Miscellaneous)))
 163      (defparameter ,name ,value ,doc)))
 164
 165 (defun config-default-value (var)
 166   (let ((config (gethash var *config-var-table*)))
 167     (when config
 168       (configvar-value config))))
 169
 170 (defun config-group->string (group)
 171   (format nil "~:(~A group~)" (substitute #\Space #\- (string group))))
 172
 173
 174 ;;; Configuration variables
 175 (defun config-all-groups ()
 176   (let (all-groups)
 177     (maphash (lambda (key val)
 178                (declare (ignore key))
 179                (pushnew (configvar-group val) all-groups :test #'equal))
 180              *config-var-table*)
 181     (sort all-groups (lambda (x y)
 182                        (string< (string x) (string y))))))
 183
 184
 185
 186
 187 (defun find-in-hash (val hashtable &optional (test #'equal))
 188   "Return the key associated to val in the hashtable"
 189   (maphash #'(lambda (k v)
 190                (when (and (consp v) (funcall test (first v) val))
 191                  (return-from find-in-hash (values k v))))
 192            hashtable))
 193
 194
 195 (defun view-hash-table (title hashtable)
 196   (maphash (lambda (k v)
 197              (format t "[~A] ~A ~A~%" title k v))
 198            hashtable))
 199
 200 (defun copy-hash-table (hashtable)
 201   (let ((rethash (make-hash-table :test (hash-table-test hashtable))))
 202     (maphash (lambda (k v)
 203                (setf (gethash k rethash) v))
 204              hashtable)
 205     rethash))
 206
 207
 208 (defun nfuncall (function)
 209   (when function
 210     (funcall function)))
 211
 212 (defun pfuncall (function &rest args)
 213   (when (and function
 214              (or (functionp function)
 215                  (and (symbolp function) (fboundp function))))
 216     (apply function args)))
 217
 218
 219 (defun symbol-search (search symbol)
 220   "Search the string 'search' in the symbol name of 'symbol'"
 221   (search search (symbol-name symbol) :test #'string-equal))
 222
 223 (eval-when (:compile-toplevel :load-toplevel :execute)
 224   (defun mkstr (&rest args)
 225     (with-output-to-string (s)
 226       (dolist (a args)
 227         (princ a s))))
 228
 229   (defun create-symbol (&rest args)
 230     (values (intern (string-upcase (apply #'mkstr args)))))
 231
 232   (defun create-symbol-in-package (package &rest args)
 233     (values (intern (string-upcase (apply #'mkstr args)) package))))
 234
 235
 236 ;;;,-----
 237 ;;;| Minimal hook
 238 ;;;`-----
 239 (defun call-hook (hook &rest args)
 240   "Call a hook (a function, a symbol or a list of functions)
 241 Return the result of the last hook"
 242   (let ((result nil))
 243     (labels ((rec (hook)
 244                (when hook
 245                  (typecase hook
 246                    (cons (dolist (h hook)
 247                            (rec h)))
 248                    (function (setf result (apply hook args)))
 249                    (symbol (when (fboundp hook)
 250                              (setf result (apply hook args))))))))
 251       (rec hook)
 252       result)))
 253
 254
 255 (defmacro add-new-hook (hook &rest value)
 256   "Add a hook. Duplicate it if needed"
 257   `(setf ,hook (append (typecase ,hook
 258                          (list ,hook)
 259                          (t (list ,hook)))
 260                        (list ,@value))))
 261
 262 (defmacro add-hook (hook &rest value)
 263   "Add a hook only if not duplicated"
 264   (let ((i (gensym)))
 265     `(dolist (,i (list ,@value))
 266        (unless (member ,i (typecase ,hook
 267                             (list ,hook)
 268                             (t (list ,hook))))
 269          (add-new-hook ,hook ,i)))))
 270
 271 (defmacro remove-hook (hook &rest value)
 272   (let ((i (gensym)))
 273     `(dolist (,i (list ,@value) ,hook)
 274       (setf ,hook (remove ,i ,hook)))))
 275
 276
 277 ;;;,-----
 278 ;;;| Timers tools
 279 ;;;`-----
 280 (defparameter *timer-list* nil)
 281
 282 (declaim (inline realtime->s s->realtime))
 283
 284 (defun realtime->s (rtime)
 285   (float (/ rtime internal-time-units-per-second)))
 286
 287 (defun s->realtime (second)
 288   (round (* second internal-time-units-per-second)))
 289
 290
 291 (defun clear-timers ()
 292   (setf *timer-list* nil))
 293
 294 (defun add-timer (delay fun &optional (id (gensym)))
 295   "Start the function fun at delay seconds."
 296   (push (list id
 297               (let ((time (+ (get-internal-real-time) (s->realtime delay))))
 298                 (lambda (current-time)
 299                   (when (>= current-time time)
 300                     (funcall fun)
 301                     t))))
 302         *timer-list*)
 303   id)
 304
 305 (defun at (delay fun &optional (id (gensym)))
 306   "Start the function fun at delay seconds."
 307   (funcall #'add-timer delay fun id))
 308
 309 (defmacro with-timer ((delay &optional (id (gensym))) &body body)
 310   "Same thing as add-timer but with syntaxic sugar"
 311   `(add-timer ,delay
 312               (lambda ()
 313                 ,@body)
 314               ,id))
 315
 316
 317 (defun process-timers ()
 318   "Call each timers in *timer-list* if needed"
 319   (let ((current-time (get-internal-real-time)))
 320     (dolist (timer *timer-list*)
 321       (when (funcall (second timer) current-time)
 322         (setf *timer-list* (remove timer *timer-list* :test #'equal))))))
 323
 324 (defun erase-timer (id)
 325   "Erase the timer identified by its id"
 326   (setf *timer-list* (remove id *timer-list* :test (lambda (x y)
 327                                                      (equal x (first y))))))
 328
 329 (defun timer-test-loop ()
 330   (let ((count 0))
 331     (labels ((plop ()
 332                (format t "Plop-~A" count)
 333                (erase-timer :toto))
 334              (toto ()
 335                (format t "Toto-~A" count)
 336                (add-timer 3 #'toto :toto)))
 337       (add-timer 3 #'toto :toto)
 338       (add-timer 13 #'plop)
 339       (loop
 340          (princ ".") (force-output)
 341          (process-timers)
 342          (sleep 0.5)
 343          (incf count)))))
 344
 345
 346
 347 ;;;,-----
 348 ;;;| Debuging tools
 349 ;;;`-----
 350 (defvar *%dbg-name%* "dbg")
 351 (defvar *%dbg-count%* 0)
 352
 353
 354 (defmacro dbg (&rest forms)
 355   `(progn
 356      ,@(mapcar #'(lambda (form)
 357                    (typecase form
 358                      (string `(setf *%dbg-name%* ,form))
 359                      (number `(setf *%dbg-count%* ,form))))
 360                forms)
 361      (format t "~&DEBUG[~A - ~A]  " (incf *%dbg-count%*) *%dbg-name%*)
 362      ,@(mapcar #'(lambda (form)
 363                    (typecase form
 364                      ((or string number) nil)
 365                      (t `(format t "~A=~S   " ',form ,form))))
 366                forms)
 367      (format t "~%")
 368      (force-output)
 369      ,@forms))
 370
 371 (defmacro dbgnl (&rest forms)
 372   `(progn
 373      ,@(mapcar #'(lambda (form)
 374                    (typecase form
 375                      (string `(setf *%dbg-name%* ,form))
 376                      (number `(setf *%dbg-count%* ,form))))
 377                forms)
 378      (format t "~&DEBUG[~A - ~A] --------------------~%" (incf *%dbg-count%*) *%dbg-name%*)
 379      ,@(mapcar #'(lambda (form)
 380                    (typecase form
 381                      ((or string number) nil)
 382                      (t `(format t "  -  ~A=~S~%" ',form ,form))))
 383                forms)
 384      (force-output)
 385      ,@forms))
 386
 387
 388 (defun dbgc (obj &optional newline)
 389   (princ obj)
 390   (when newline
 391     (terpri))
 392   (force-output))
 393
 394
 395
 396 (defun in-rectangle (x y rectangle)
 397   (and rectangle
 398        (<= (rectangle-x rectangle) x (+ (rectangle-x rectangle) (rectangle-width rectangle)))
 399        (<= (rectangle-y rectangle) y (+ (rectangle-y rectangle) (rectangle-height rectangle)))))
 400
 401
 402
 403 (defun distance (x1 y1 x2 y2)
 404   (+ (abs (- x2 x1)) (abs (- y2 y1))))
 405
 406
 407 ;;; Symbols tools
 408 (defun collect-all-symbols (&optional package)
 409   (format t "Collecting all symbols for Lisp REPL completion...")
 410   (let (all-symbols)
 411     (do-symbols (symbol (or package *package*))
 412       (pushnew (string-downcase (symbol-name symbol)) all-symbols :test #'string=))
 413     (do-symbols (symbol :keyword)
 414       (pushnew (concatenate 'string ":" (string-downcase (symbol-name symbol)))
 415                all-symbols :test #'string=))
 416     (format t " Done.~%")
 417     all-symbols))
 418
 419
 420
 421 (defmacro with-all-internal-symbols ((var package) &body body)
 422   "Bind symbol to all internal symbols in package"
 423   `(do-symbols (,var ,package)
 424      (multiple-value-bind (sym status)
 425          (find-symbol (symbol-name ,var) ,package)
 426        (declare (ignore sym))
 427        (when (eql status :internal)
 428          ,@body))))
 429
 430
 431 (defun export-all-functions (package &optional (verbose nil))
 432   (with-all-internal-symbols (symbol package)
 433     (when (fboundp symbol)
 434       (when verbose
 435         (format t "Exporting ~S~%" symbol))
 436       (export symbol package))))
 437
 438
 439 (defun export-all-variables (package &optional (verbose nil))
 440   (with-all-internal-symbols (symbol package)
 441     (when (boundp symbol)
 442       (when verbose
 443         (format t "Exporting ~S~%" symbol))
 444       (export symbol package))))
 445
 446 (defun export-all-functions-and-variables (package &optional (verbose nil))
 447   (with-all-internal-symbols (symbol package)
 448     (when (or (fboundp symbol) (boundp symbol))
 449       (when verbose
 450         (format t "Exporting ~S~%" symbol))
 451       (export symbol package))))
 452
 453
 454
 455 (defun ensure-function (object)
 456   (if (functionp object)
 457       object
 458       (symbol-function object)))
 459
 460
 461
 462
 463 (defun empty-string-p (string)
 464   (string= string ""))
 465
 466
 467 (defun find-common-string (string list &optional orig)
 468   "Return the string in common in all string in list"
 469   (if list
 470       (let ((result (remove-if-not (lambda (x)
 471                                      (zerop (or (search string x :test #'string-equal) -1)))
 472                                    list)))
 473         (if (= (length result) (length list))
 474             (if (> (length (first list)) (length string))
 475                 (find-common-string (subseq (first list) 0 (1+ (length string))) list string)
 476                 string)
 477             orig))
 478       string))
 479
 480
 481 (defun command-in-path (&optional (tmpfile "/tmp/clfswm-cmd.tmp"))
 482   (format t "Updating command list for Shell completion...~%")
 483   (labels ((delete-tmp ()
 484              (when (probe-file tmpfile)
 485                (delete-file tmpfile))))
 486     (delete-tmp)
 487     (dolist (dir (split-string (getenv "PATH") #\:))
 488       (ushell (format nil "ls ~A/* >> ~A" dir tmpfile)))
 489     (let ((commands nil))
 490       (with-open-file (stream tmpfile :direction :input)
 491         (loop for line = (read-line stream nil nil)
 492            while line
 493            do (pushnew (subseq line (1+ (or (position #\/ line :from-end t) -1))) commands
 494                        :test #'string=)))
 495       (delete-tmp)
 496       (format t "Done. Found ~A commands in shell PATH.~%" (length commands))
 497       commands)))
 498
 499
 500 ;;; Tools
 501 (defmacro setf/= (var val)
 502   "Set var to val only when var not equal to val"
 503   (let ((gval (gensym)))
 504     `(let ((,gval ,val))
 505        (when (/= ,var ,gval)
 506          (setf ,var ,gval)))))
 507
 508
 509 (defun number->char (number)
 510   (cond ((<= number 25) (code-char (+ (char-code #\a) number)))
 511         ((<= 26 number 35) (code-char (+ (char-code #\0) (- number 26))))
 512         ((<= 36 number 61) (code-char (+ (char-code #\A) (- number 36))))
 513         (t #\|)))
 514
 515 (defun number->string (number)
 516   (string (number->char number)))
 517
 518 (defun  number->letter (n &optional (base 26))
 519   (nreverse
 520    (with-output-to-string (str)
 521      (labels ((rec (n)
 522                 (princ (code-char (+ (char-code #\a) (mod n base))) str)
 523                 (when (>= n base)
 524                   (rec (- (truncate (/ n base)) 1)))))
 525        (rec n)))))
 526
 527
 528 (defun simple-type-of (object)
 529   (let ((type (type-of object)))
 530     (typecase type
 531       (cons (first type))
 532       (t type))))
 533
 534
 535 (defun repeat-chars (n char)
 536   "Return a string containing N CHARs."
 537   (make-string n :initial-element char))
 538
 539
 540
 541 (defun nth-insert (n elem list)
 542   "Insert elem in (nth n list)"
 543   (nconc (subseq list 0 n)
 544          (list elem)
 545          (subseq list n)))
 546
 547
 548
 549 (defun split-string (string &optional (separator #\Space))
 550   "Return a list from a string splited at each separators"
 551   (loop for i = 0 then (1+ j)
 552      as j = (position separator string :start i)
 553      as sub = (subseq string i j)
 554      unless (string= sub "") collect sub
 555      while j))
 556
 557 (defun substring-equal (substring string)
 558   (string-equal substring (subseq string 0 (min (length substring) (length string)))))
 559
 560 (defun string-match (match list)
 561   "Return the string in list witch match the match string"
 562   (let ((len (length match)))
 563     (remove-duplicates (remove-if-not (lambda (x)
 564                                         (string-equal match (subseq x 0 (min len (length x)))))
 565                                       list)
 566                        :test #'string-equal)))
 567
 568
 569 (defun extented-alphanumericp (char)
 570   (or (alphanumericp char)
 571       (eq char #\-)
 572       (eq char #\_)
 573       (eq char #\.)
 574       (eq char #\+)
 575       (eq char #\=)
 576       (eq char #\*)
 577       (eq char #\:)
 578       (eq char #\%)))
 579
 580
 581 (defun append-newline-space (string)
 582   "Append spaces before Newline on each line"
 583   (with-output-to-string (stream)
 584     (loop for c across string do
 585          (when (equal c #\Newline)
 586            (princ " " stream))
 587          (princ c stream))))
 588
 589
 590 (defun expand-newline (list)
 591   "Expand all newline in strings in list"
 592   (let ((acc nil))
 593     (dolist (l list)
 594       (setf acc (append acc (split-string l #\Newline))))
 595     acc))
 596
 597 (defun ensure-list (object)
 598   "Ensure an object is a list"
 599   (if (listp object)
 600       object
 601       (list object)))
 602
 603
 604 (defun ensure-printable (string &optional (new #\?))
 605   "Ensure a string is printable in ascii"
 606   (or (substitute-if-not new #'standard-char-p (or string "")) ""))
 607
 608 (defun limit-length (string &optional (length 10))
 609   (subseq string 0 (min (length string) length)))
 610
 611
 612 (defun ensure-n-elems (list n)
 613   "Ensure that list has exactly n elements"
 614   (let ((length (length list)))
 615     (cond ((= length n) list)
 616           ((< length n) (ensure-n-elems (append list '(nil)) n))
 617           ((> length n) (ensure-n-elems (butlast list) n)))))
 618
 619 (defun begin-with-2-spaces (string)
 620   (and (> (length string) 1)
 621        (eql (char string 0) #\Space)
 622        (eql (char string 1) #\Space)))
 623
 624 (defun string-equal-p (x y)
 625   (when (stringp y) (string-equal x y)))
 626
 627
 628
 629
 630 (defun find-assoc-word (word line &optional (delim #\"))
 631   "Find a word pair"
 632   (let* ((pos (search word line))
 633          (pos-1 (position delim line :start (or pos 0)))
 634          (pos-2 (position delim line :start (1+ (or pos-1 0)))))
 635     (when (and pos pos-1 pos-2)
 636       (subseq line (1+ pos-1) pos-2))))
 637
 638
 639 (defun print-space (n &optional (stream *standard-output*))
 640   "Print n spaces on stream"
 641   (dotimes (i n)
 642     (princ #\Space stream)))
 643
 644
 645 (defun escape-string (string &optional (escaper '(#\/ #\: #\) #\( #\Space #\; #\,)) (char #\_))
 646   "Replace in string all characters found in the escaper list"
 647   (if escaper
 648       (escape-string (substitute char (car escaper) string) (cdr escaper) char)
 649       string))
 650
 651
 652
 653 (defun first-position (word string)
 654   "Return true only if word is at position 0 in string"
 655   (zerop (or (search word string) -1)))
 656
 657
 658 (defun find-free-number (l)             ; stolen from stumpwm - thanks
 659   "Return a number that is not in the list l."
 660   (let* ((nums (sort l #'<))
 661          (new-num (loop for n from 0 to (or (car (last nums)) 0)
 662                      for i in nums
 663                      when (/= n i)
 664                      do (return n))))
 665     (if new-num
 666         new-num
 667         ;; there was no space between the numbers, so use the last + 1
 668         (if (car (last nums))
 669             (1+ (car (last nums)))
 670             0))))
 671
 672
 673
 674
 675
 676 ;;; Shell part (taken from ltk)
 677 (defun do-execute (program args &optional (wt nil) (io :stream))
 678   "execute program with args a list containing the arguments passed to
 679 the program   if wt is non-nil, the function will wait for the execution
 680 of the program to return.
 681    returns a two way stream connected to stdin/stdout of the program"
 682   #-CLISP (declare (ignore io))
 683   (let ((fullstring program))
 684     (dolist (a args)
 685       (setf fullstring (concatenate 'string fullstring " " a)))
 686     #+:cmu (let ((proc (ext:run-program program args :input :stream :output :stream :wait wt)))
 687              (unless proc
 688                (error "Cannot create process."))
 689              (make-two-way-stream
 690               (ext:process-output proc)
 691               (ext:process-input proc)))
 692     #+:clisp (ext:run-program program :arguments args :input io :output io :wait wt)
 693     #+:sbcl (let ((proc (sb-ext:run-program program args :input :stream :output :stream :wait wt)))
 694               (unless proc
 695                 (error "Cannot create process."))
 696               (make-two-way-stream
 697                (sb-ext:process-output proc)
 698                (sb-ext:process-input proc)))
 699     #+:lispworks (system:open-pipe fullstring :direction :io)
 700     #+:allegro (let ((proc (excl:run-shell-command
 701                             (apply #'vector program program args)
 702                             :input :stream :output :stream :wait wt)))
 703                  (unless proc
 704                    (error "Cannot create process."))
 705                  proc)
 706     #+:ecl (ext:run-program program args :input :stream :output :stream
 707                             :error :output)
 708     #+:openmcl (let ((proc (ccl:run-program program args :input
 709                                                          :stream :output
 710                                                          :stream :wait wt)))
 711                  (unless proc
 712                    (error "Cannot create process."))
 713                  (make-two-way-stream
 714                   (ccl:external-process-output-stream proc)
 715                   (ccl:external-process-input-stream proc)))))
 716
 717 (defun do-shell (program &optional args (wait nil) (io :stream))
 718   (do-execute "/bin/sh" `("-c" ,program ,@args) wait io))
 719
 720 (defun fdo-shell (formatter &rest args)
 721   (do-shell (apply #'format nil formatter args)))
 722
 723
 724
 725
 726
 727 (defun getenv (var)
 728   "Return the value of the environment variable."
 729   #+allegro (sys::getenv (string var))
 730   #+clisp (ext:getenv (string var))
 731   #+(or cmu scl)
 732   (cdr (assoc (string var) ext:*environment-list* :test #'equalp
 733               :key #'string))
 734   #+gcl (si:getenv (string var))
 735   #+lispworks (lw:environment-variable (string var))
 736   #+lucid (lcl:environment-variable (string var))
 737   #+(or mcl ccl) (ccl::getenv var)
 738   #+sbcl (sb-posix:getenv (string var))
 739   #+ecl (si:getenv (string var))
 740   #-(or allegro clisp cmu gcl lispworks lucid mcl sbcl scl ecl ccl)
 741   (error 'not-implemented :proc (list 'getenv var)))
 742
 743
 744 (defun (setf getenv) (val var)
 745   "Set an environment variable."
 746   #+allegro (setf (sys::getenv (string var)) (string val))
 747   #+clisp (setf (ext:getenv (string var)) (string val))
 748   #+(or cmu scl)
 749   (let ((cell (assoc (string var) ext:*environment-list* :test #'equalp
 750                                                          :key #'string)))
 751     (if cell
 752         (setf (cdr cell) (string val))
 753         (push (cons (intern (string var) "KEYWORD") (string val))
 754               ext:*environment-list*)))
 755   #+gcl (si:setenv (string var) (string val))
 756   #+lispworks (setf (lw:environment-variable (string var)) (string val))
 757   #+lucid (setf (lcl:environment-variable (string var)) (string val))
 758   #+sbcl (sb-posix:putenv (format nil "~A=~A" (string var) (string val)))
 759   #+ecl (si:setenv (string var) (string val))
 760   #+ccl (ccl::setenv (string var) (string val))
 761   #-(or allegro clisp cmu gcl lispworks lucid sbcl scl ecl ccl)
 762   (error 'not-implemented :proc (list '(setf getenv) var)))
 763
 764
 765
 766
 767
 768
 769
 770 (defun uquit ()
 771   #+(or clisp cmu) (ext:quit)
 772   #+sbcl (sb-ext:quit)
 773   #+ecl (si:quit)
 774   #+gcl (lisp:quit)
 775   #+lispworks (lw:quit)
 776   #+(or allegro-cl allegro-cl-trial) (excl:exit)
 777   #+ccl (ccl:quit))
 778
 779
 780
 781
 782 (defun remove-plist (plist &rest keys)
 783   "Remove the keys from the plist.
 784 Useful for re-using the &REST arg after removing some options."
 785   (do (copy rest)
 786       ((null (setq rest (nth-value 2 (get-properties plist keys))))
 787        (nreconc copy plist))
 788     (do () ((eq plist rest))
 789       (push (pop plist) copy)
 790       (push (pop plist) copy))
 791     (setq plist (cddr plist))))
 792
 793
 794
 795
 796 (defun urun-prog (prog &rest opts &key args (wait t) &allow-other-keys)
 797   "Common interface to shell. Does not return anything useful."
 798   #+gcl (declare (ignore wait))
 799   (setq opts (remove-plist opts :args :wait))
 800   #+allegro (apply #'excl:run-shell-command (apply #'vector prog prog args)
 801                    :wait wait opts)
 802   #+(and clisp      lisp=cl)
 803   (apply #'ext:run-program prog :arguments args :wait wait opts)
 804   #+(and clisp (not lisp=cl))
 805   (if wait
 806       (apply #'lisp:run-program prog :arguments args opts)
 807       (lisp:shell (format nil "~a~{ '~a'~} &" prog args)))
 808   #+cmu (apply #'ext:run-program prog args :wait wait :output *standard-output* opts)
 809   #+gcl (apply #'si:run-process prog args)
 810   #+liquid (apply #'lcl:run-program prog args)
 811   #+lispworks (apply #'sys::call-system-showing-output
 812                      (format nil "~a~{ '~a'~}~@[ &~]" prog args (not wait))
 813                      opts)
 814   #+lucid (apply #'lcl:run-program prog :wait wait :arguments args opts)
 815   #+sbcl (apply #'sb-ext:run-program prog args :wait wait :output *standard-output* opts)
 816   #+ecl (apply #'ext:run-program prog args opts)
 817   #+ccl (apply #'ccl:run-program prog args opts :wait wait)
 818   #-(or allegro clisp cmu gcl liquid lispworks lucid sbcl ecl ccl)
 819   (error 'not-implemented :proc (list 'run-prog prog opts)))
 820
 821
 822 ;;(defparameter *shell-cmd* "/usr/bin/env")
 823 ;;(defparameter *shell-cmd-opt* nil)
 824
 825 #+UNIX (defparameter *shell-cmd* "/bin/sh")
 826 #+UNIX (defparameter *shell-cmd-opt* '("-c"))
 827
 828 #+WIN32 (defparameter *shell-cmd* "cmd.exe")
 829 #+WIN32 (defparameter *shell-cmd-opt* '("/C"))
 830
 831
 832 (defun ushell (&rest strings)
 833   (urun-prog *shell-cmd* :args (append *shell-cmd-opt* strings)))
 834
 835 (defun ush (string)
 836   (urun-prog *shell-cmd* :args (append *shell-cmd-opt* (list string))))
 837
 838
 839 (defun set-shell-dispatch (&optional (shell-fun 'ushell))
 840   (labels ((|shell-reader| (stream subchar arg)
 841              (declare (ignore subchar arg))
 842              (list shell-fun (read stream t nil t))))
 843     (set-dispatch-macro-character #\# #\# #'|shell-reader|)))
 844
 845
 846 (defun ushell-loop (&optional (shell-fun #'ushell))
 847   (loop
 848      (format t "UNI-SHELL> ")
 849      (let* ((line (read-line)))
 850        (cond ((zerop (or (search "quit" line) -1)) (return))
 851              ((zerop (or (position #\! line) -1))
 852               (funcall shell-fun (subseq line 1)))
 853              (t (format t "~{~A~^ ;~%~}~%"
 854                         (multiple-value-list
 855                          (ignore-errors (eval (read-from-string line))))))))))
 856
 857
 858
 859
 860
 861
 862 (defun cldebug (&rest rest)
 863   (princ "DEBUG: ")
 864   (dolist (i rest)
 865     (princ i))
 866   (terpri))
 867
 868
 869 (defun get-command-line-words ()
 870   #+sbcl (cdr sb-ext:*posix-argv*)
 871   #+(or clozure ccl) (cddddr (ccl::command-line-arguments))
 872   #+gcl (cdr si:*command-args*)
 873   #+ecl (loop for i from 1 below (si:argc) collect (si:argv i))
 874   #+cmu (cdddr extensions:*command-line-strings*)
 875   #+allegro (cdr (sys:command-line-arguments))
 876   #+lispworks (cdr sys:*line-arguments-list*)
 877   #+clisp ext:*args*
 878   #-(or sbcl clozure gcl ecl cmu allegro lispworks clisp)
 879   (error "get-command-line-arguments not supported for your implementation"))
 880
 881
 882
 883
 884 (defun string-to-list (str &key (split-char #\space))
 885   (do* ((start 0 (1+ index))
 886         (index (position split-char str :start start)
 887                (position split-char str :start start))
 888         (accum nil))
 889        ((null index)
 890         (unless (string= (subseq str start) "")
 891           (push (subseq str start) accum))
 892         (nreverse accum))
 893     (when (/= start index)
 894       (push (subseq str start index) accum))))
 895
 896
 897 (defun near-position (chars str &key (start 0))
 898   (do* ((char chars (cdr char))
 899         (pos (position (car char) str :start start)
 900              (position (car char) str :start start))
 901         (ret (when pos pos)
 902              (if pos
 903                  (if ret
 904                      (if (< pos ret)
 905                          pos
 906                          ret)
 907                      pos)
 908                  ret)))
 909        ((null char) ret)))
 910
 911
 912 ;;;(defun near-position2 (chars str &key (start 0))
 913 ;;;  (loop for i in chars
 914 ;;;     minimize (position i str :start start)))
 915
 916 ;;(format t "~S~%" (near-position '(#\! #\. #\Space #\;) "klmsqk ppii;dsdsqkl.jldfksj lkm" :start 0))
 917 ;;(format t "~S~%" (near-position '(#\Space) "klmsqk ppii;dsdsqkl.jldfksj lkm" :start 0))
 918 ;;(format t "~S~%" (near-position '(#\; #\l #\m) "klmsqk ppii;dsdsqkl.jldfksj lkm" :start 0))
 919 ;;(format t "result=~S~%" (string-to-list-multichar "klmsqk ppii;dsdsqkl.jldfksj lkm" :preserve t))
 920 ;;(format t "result=~S~%" (string-to-list-multichar "klmsqk ppii;dsd!sqkl.jldfksj lkm"
 921 ;;                                                :split-chars '(#\k  #\! #\. #\; #\m)
 922 ;;                                                :preserve nil))
 923
 924
 925 (defun string-to-list-multichar (str &key (split-chars '(#\space)) (preserve nil))
 926   (do* ((start 0 (1+ index))
 927         (index (near-position split-chars str :start start)
 928                (near-position split-chars str :start start))
 929         (accum nil))
 930        ((null index)
 931         (unless (string= (subseq str start) "")
 932           (push (subseq str start) accum))
 933         (nreverse accum))
 934     (let ((retstr (subseq str start (if preserve (1+ index) index))))
 935       (unless (string= retstr "")
 936         (push retstr accum)))))
 937
 938
 939
 940
 941
 942 (defun list-to-string (lst)
 943   (string-trim " () " (format nil "~A" lst)))
 944
 945
 946
 947 (defun clean-string (string)
 948   "Remove Newline and upcase string"
 949   (string-upcase
 950    (string-right-trim '(#\Newline) string)))
 951
 952 (defun one-in-list (lst)
 953   (nth (random (length lst)) lst))
 954
 955 (defun exchange-one-in-list (lst1 lst2)
 956   (let ((elem1 (one-in-list lst1))
 957         (elem2 (one-in-list lst2)))
 958     (setf lst1 (append (remove elem1 lst1) (list elem2)))
 959     (setf lst2 (append (remove elem2 lst2) (list elem1)))
 960     (values lst1 lst2)))
 961
 962
 963 (defun rotate-list (list)
 964   (when list
 965     (append (cdr list) (list (car list)))))
 966
 967 (defun anti-rotate-list (list)
 968   (when list
 969     (append (last list) (butlast list))))
 970
 971 (defun n-rotate-list (list n)
 972   (if (> n 0)
 973       (n-rotate-list (rotate-list list) (1- n))
 974       list))
 975
 976
 977 (defun append-formated-list (base-str
 978                              lst
 979                              &key (test-not-fun #'(lambda (x) x nil))
 980                              (print-fun #'(lambda (x) x))
 981                              (default-str ""))
 982   (let ((str base-str) (first t))
 983     (dolist (i lst)
 984       (cond ((funcall test-not-fun i) nil)
 985             (t (setq str
 986                      (concatenate 'string str
 987                                   (if first "" ", ")
 988                                   (format nil "~A"
 989                                           (funcall print-fun i))))
 990                (setq first nil))))
 991     (if (string= base-str str)
 992         (concatenate 'string str default-str) str)))
 993
 994
 995 (defun shuffle-list (list &key (time 1))
 996   "Shuffle a list by swapping elements time times"
 997   (let ((result (copy-list list))
 998         (ind1 0) (ind2 0) (swap 0))
 999     (dotimes (i time)
1000       (setf ind1 (random (length result)))
1001       (setf ind2 (random (length result)))
1002
1003       (setf swap (nth ind1 result))
1004       (setf (nth ind1 result) (nth ind2 result))
1005       (setf (nth ind2 result) swap))
1006     result))
1007
1008
1009
1010 (defun convert-to-number (str)
1011   (cond ((stringp str) (parse-integer str :junk-allowed t))
1012         ((numberp str) str)))
1013
1014 (defun parse-integer-in-list (lst)
1015   "Convert all integer string in lst to integer"
1016   (mapcar #'(lambda (x) (convert-to-number x)) lst))
1017
1018
1019
1020 (defun next-in-list (item lst)
1021   (do ((x lst (cdr x)))
1022       ((null x))
1023     (when (equal item (car x))
1024       (return (if (cadr x) (cadr x) (car lst))))))
1025
1026 (defun prev-in-list (item lst)
1027   (next-in-list item (reverse lst)))
1028
1029
1030 (let ((jours '("Lundi" "Mardi" "Mercredi" "Jeudi" "Vendredi" "Samedi" "Dimanche"))
1031       (mois '("Janvier" "Fevrier" "Mars" "Avril" "Mai" "Juin" "Juillet"
1032               "Aout" "Septembre" "Octobre" "Novembre" "Decembre"))
1033       (days '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))
1034       (months '("January" "February" "March" "April" "May" "June" "July"
1035                  "August" "September" "October" "November" "December")))
1036   (defun date-string ()
1037     (multiple-value-bind (second minute hour date month year day)
1038         (get-decoded-time)
1039       (if (search "fr" (getenv "LANG") :test #'string-equal)
1040           (format nil "   ~2,'0D:~2,'0D:~2,'0D    ~A ~2,'0D ~A ~A "
1041                   hour minute second
1042                   (nth day jours) date (nth (1- month) mois) year)
1043           (format nil "   ~2,'0D:~2,'0D:~2,'0D    ~A ~A ~2,'0D ~A "
1044                   hour minute second
1045                   (nth day days) (nth (1- month) months) date year)))))
1046
1047
1048 ;;;
1049 ;;; System information functions
1050 ;;;
1051 (defparameter *bat-cmd* "acpi -b")
1052 (defparameter *cpu-cmd* "top -b -n 2 -d 1 -p 0")
1053 (defparameter *cpu-cmd-fast* "top -b -n 2 -d 0.1 -p 0")
1054 (defparameter *mem-cmd* "free")
1055
1056 (defmacro with-search-line ((word line) &body body)
1057   `(let ((pos (search ,word ,line :test #'string-equal)))
1058     (when (>= (or pos -1) 0)
1059       ,@body)))
1060
1061 (defun extract-battery-usage (line)
1062   (with-search-line ("Battery" line)
1063     (let ((pos (position #\% line)))
1064       (when pos
1065         (parse-integer (subseq line (- pos 3) pos) :junk-allowed t)))))
1066
1067 (defun extract-cpu-usage (line)
1068   (with-search-line ("%Cpu(s):" line)
1069     (let ((pos1 (search "id" line)))
1070       (when pos1
1071         (let ((pos2 (position #\, line :from-end t :end pos1)))
1072           (when pos2
1073             (- 100 (parse-integer (subseq line (1+ pos2) pos1) :junk-allowed t))))))))
1074
1075 (defun extract-mem-used (line)
1076   (with-search-line ("cache:" line)
1077     (parse-integer (subseq line (+ pos 6)) :junk-allowed t)))
1078
1079 (defun extract-mem-total (line)
1080   (with-search-line ("mem:" line)
1081     (parse-integer (subseq line (+ pos 4)) :junk-allowed t)))
1082
1083 (let ((total -1))
1084   (defun memory-usage ()
1085     (let ((output (do-shell *mem-cmd*))
1086           (used -1))
1087       (loop for line = (read-line output nil nil)
1088          while line
1089          do (awhen (extract-mem-used line)
1090               (setf used it))
1091            (awhen (and (= total -1) (extract-mem-total line))
1092              (setf total it)))
1093       (values used total))))
1094
1095
1096 (defun cpu-usage ()
1097   (let ((output (do-shell *cpu-cmd-fast*))
1098         (cpu -1))
1099     (loop for line = (read-line output nil nil)
1100        while line
1101        do (awhen (extract-cpu-usage line)
1102             (setf cpu it)))
1103     cpu))
1104
1105 (defun battery-usage ()
1106   (let ((output (do-shell *bat-cmd*))
1107         (bat -1))
1108     (loop for line = (read-line output nil nil)
1109        while line
1110        do (awhen (extract-battery-usage line)
1111             (setf bat it)))
1112     bat))
1113
1114 (defun battery-alert-string (bat)
1115   (if (numberp bat)
1116       (cond ((<= bat 5) "/!\\")
1117             ((<= bat 10) "!!")
1118             ((<= bat 25) "!")
1119             (t ""))
1120       ""))
1121
1122 ;;;
1123 ;;; System usage with a poll system - Memory, CPU and battery all in one
1124 ;;;
1125 (let ((poll-log "/tmp/.clfswm-system.log")
1126       (poll-exec "/tmp/.clfswm-system.sh")
1127       (running nil))
1128   (defun create-system-poll (delay)
1129     (with-open-file (stream poll-exec :direction :output :if-exists :supersede)
1130       (format stream "#! /bin/sh
1131
1132 while true; do
1133  (~A; ~A ; ~A) > ~A.tmp;
1134   mv ~A.tmp ~A;
1135   sleep ~A;
1136 done~%" *bat-cmd* *cpu-cmd* *mem-cmd* poll-log poll-log poll-log delay)))
1137
1138   (defun system-poll-pid ()
1139     (let ((pid nil))
1140       (let ((output (do-shell "ps x")))
1141         (loop for line = (read-line output nil nil)
1142            while line
1143            do (when (search poll-exec line)
1144                 (push (parse-integer line :junk-allowed t) pid))))
1145       pid))
1146
1147   (defun stop-system-poll ()
1148     (dolist (pid (system-poll-pid))
1149       (fdo-shell "kill ~A" pid))
1150     (when (probe-file poll-log)
1151       (delete-file poll-log))
1152     (when (probe-file poll-exec)
1153       (delete-file poll-exec))
1154     (setf running nil))
1155
1156   (defun start-system-poll (delay)
1157     (unless running
1158       (stop-system-poll)
1159       (create-system-poll delay)
1160       (fdo-shell "exec sh ~A" poll-exec)
1161       (setf running t)))
1162
1163   (defun system-usage-poll (&optional (delay 10))
1164     (let ((bat -1)
1165           (cpu -1)
1166           (used -1)
1167           (total -1))
1168       (start-system-poll delay)
1169       (when (probe-file poll-log)
1170         (with-open-file (stream poll-log :direction :input)
1171           (loop for line = (read-line stream nil nil)
1172              while line
1173              do (awhen (extract-battery-usage line)
1174                   (setf bat it))
1175                (awhen (extract-cpu-usage line)
1176                  (setf cpu it))
1177                (awhen (extract-mem-used line)
1178                  (setf used it))
1179                (awhen (and (= total -1) (extract-mem-total line))
1180                  (setf total it)))))
1181       (values cpu used total bat))))
1182
1183
1184
1185
1186
1187