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            :search-in-hash
  39            :view-hash-table
  40            :copy-hash-table
  41            :nfuncall
  42            :pfuncall
  43            :symbol-search
  44            :create-symbol :create-symbol-in-package
  45            :call-hook
  46            :add-new-hook
  47            :add-hook
  48            :remove-hook
  49            :clear-timers
  50            :add-timer
  51            :at
  52            :with-timer
  53            :process-timers
  54            :erase-timer
  55            :timer-loop
  56            :dbg
  57            :dbgnl
  58            :dbgc
  59            :make-rectangle
  60            :rectangle-x :rectangle-y :rectangle-width :rectangle-height
  61            :in-rectangle
  62            :distance
  63            :collect-all-symbols
  64            :with-all-internal-symbols
  65            :export-all-functions :export-all-variables
  66            :export-all-functions-and-variables
  67            :ensure-function
  68            :empty-string-p
  69            :find-common-string
  70            :command-in-path
  71            :setf/=
  72            :number->char
  73            :number->string
  74            :number->letter
  75            :simple-type-of
  76            :repeat-chars
  77            :nth-insert
  78            :split-string
  79            :substring-equal
  80            :string-match
  81            :extented-alphanumericp
  82            :append-newline-space
  83            :expand-newline
  84            :ensure-list
  85            :ensure-printable
  86            :limit-length
  87            :ensure-n-elems
  88            :begin-with-2-spaces
  89            :string-equal-p
  90            :find-assoc-word
  91            :print-space
  92            :escape-string
  93            :first-position
  94            :find-free-number
  95            :date-string
  96            :write-backtrace
  97            :do-execute
  98            :do-shell :fdo-shell :do-shell-output
  99            :getenv
 100            :uquit
 101            :urun-prog
 102            :ushell
 103            :ush
 104            :ushell-loop
 105            :cldebug
 106            :get-command-line-words
 107            :string-to-list
 108            :near-position
 109            :string-to-list-multichar
 110            :list-to-string
 111            :list-to-string-list
 112            :clean-string
 113            :one-in-list
 114            :exchange-one-in-list
 115            :rotate-list
 116            :anti-rotate-list
 117            :n-rotate-list
 118            :append-formated-list
 119            :shuffle-list
 120            :parse-integer-in-list
 121            :convert-to-number
 122            :next-in-list :prev-in-list
 123            :find-string
 124            :find-all-strings
 125            :subst-strings
 126            :test-find-string
 127            :memory-usage
 128            :cpu-usage
 129            :battery-usage
 130            :battery-alert-string
 131            :start-system-poll
 132            :stop-system-poll
 133            :system-usage-poll))
 134
 135
 136 (in-package :tools)
 137
 138
 139 (defstruct rectangle x y width height)
 140
 141 (setq *random-state* (make-random-state t))
 142
 143
 144
 145
 146 (defmacro awhen (test &body body)
 147   `(let ((it ,test))
 148      (when it
 149        ,@body)))
 150
 151 (defmacro aif (test then &optional else)
 152   `(let ((it ,test)) (if it ,then ,else)))
 153
 154
 155 ;;; Configuration variables
 156 (defstruct configvar value group doc)
 157
 158 (defparameter *config-var-table* (make-hash-table :test #'equal))
 159
 160 (defmacro defconfig (name value group doc)
 161   `(progn
 162      (setf (gethash ',name *config-var-table*)
 163            (make-configvar :value ,value
 164                            :group (or ,group 'Miscellaneous)))
 165      (defparameter ,name ,value ,doc)))
 166
 167 (defun config-default-value (var)
 168   (let ((config (gethash var *config-var-table*)))
 169     (when config
 170       (configvar-value config))))
 171
 172 (defun config-group->string (group)
 173   (format nil "~:(~A group~)" (substitute #\Space #\- (string group))))
 174
 175
 176 ;;; Configuration variables
 177 (defun config-all-groups ()
 178   (let (all-groups)
 179     (maphash (lambda (key val)
 180                (declare (ignore key))
 181                (pushnew (configvar-group val) all-groups :test #'equal))
 182              *config-var-table*)
 183     (sort all-groups (lambda (x y)
 184                        (string< (string x) (string y))))))
 185
 186
 187
 188
 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))))
 194            hashtable))
 195
 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))))
 202              hashtable)))
 203
 204
 205 (defun view-hash-table (title hashtable)
 206   (maphash (lambda (k v)
 207              (format t "[~A] ~A ~A~%" title k v))
 208            hashtable))
 209
 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))
 214              hashtable)
 215     rethash))
 216
 217
 218 (defun nfuncall (function)
 219   (when function
 220     (funcall function)))
 221
 222 (defun pfuncall (function &rest args)
 223   (when (and function
 224              (or (functionp function)
 225                  (and (symbolp function) (fboundp function))))
 226     (apply function args)))
 227
 228
 229
 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))
 233
 234 (eval-when (:compile-toplevel :load-toplevel :execute)
 235   (defun mkstr (&rest args)
 236     (with-output-to-string (s)
 237       (dolist (a args)
 238         (princ a s))))
 239
 240   (defun create-symbol (&rest args)
 241     (values (intern (string-upcase (apply #'mkstr args)))))
 242
 243   (defun create-symbol-in-package (package &rest args)
 244     (values (intern (string-upcase (apply #'mkstr args)) package))))
 245
 246
 247 ;;;,-----
 248 ;;;| Minimal hook
 249 ;;;`-----
 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"
 253   (let ((result nil))
 254     (labels ((rec (hook)
 255                (when hook
 256                  (typecase hook
 257                    (cons (dolist (h hook)
 258                            (rec h)))
 259                    (function (setf result (apply hook args)))
 260                    (symbol (when (fboundp hook)
 261                              (setf result (apply hook args))))))))
 262       (rec hook)
 263       result)))
 264
 265
 266 (defmacro add-new-hook (hook &rest value)
 267   "Add a hook. Duplicate it if needed"
 268   `(setf ,hook (append (typecase ,hook
 269                          (list ,hook)
 270                          (t (list ,hook)))
 271                        (list ,@value))))
 272
 273 (defmacro add-hook (hook &rest value)
 274   "Add a hook only if not duplicated"
 275   (let ((i (gensym)))
 276     `(dolist (,i (list ,@value))
 277        (unless (member ,i (typecase ,hook
 278                             (list ,hook)
 279                             (t (list ,hook))))
 280          (add-new-hook ,hook ,i)))))
 281
 282 (defmacro remove-hook (hook &rest value)
 283   (let ((i (gensym)))
 284     `(dolist (,i (list ,@value) ,hook)
 285       (setf ,hook (remove ,i ,hook)))))
 286
 287
 288 ;;;,-----
 289 ;;;| Timers tools
 290 ;;;`-----
 291 (defparameter *timer-list* nil)
 292
 293 (declaim (inline realtime->s s->realtime))
 294
 295 (defun realtime->s (rtime)
 296   (float (/ rtime internal-time-units-per-second)))
 297
 298 (defun s->realtime (second)
 299   (round (* second internal-time-units-per-second)))
 300
 301
 302 (defun clear-timers ()
 303   (setf *timer-list* nil))
 304
 305 (defun add-timer (delay fun &optional (id (gensym)))
 306   "Start the function fun at delay seconds."
 307   (push (list id
 308               (let ((time (+ (get-internal-real-time) (s->realtime delay))))
 309                 (lambda (current-time)
 310                   (when (>= current-time time)
 311                     (funcall fun)
 312                     t))))
 313         *timer-list*)
 314   id)
 315
 316 (defun at (delay fun &optional (id (gensym)))
 317   "Start the function fun at delay seconds."
 318   (funcall #'add-timer delay fun id))
 319
 320 (defmacro with-timer ((delay &optional (id (gensym))) &body body)
 321   "Same thing as add-timer but with syntaxic sugar"
 322   `(add-timer ,delay
 323               (lambda ()
 324                 ,@body)
 325               ,id))
 326
 327
 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))))))
 334
 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))))))
 339
 340 (defun timer-test-loop ()
 341   (let ((count 0))
 342     (labels ((plop ()
 343                (format t "Plop-~A" count)
 344                (erase-timer :toto))
 345              (toto ()
 346                (format t "Toto-~A" count)
 347                (add-timer 3 #'toto :toto)))
 348       (add-timer 3 #'toto :toto)
 349       (add-timer 13 #'plop)
 350       (loop
 351          (princ ".") (force-output)
 352          (process-timers)
 353          (sleep 0.5)
 354          (incf count)))))
 355
 356
 357
 358 ;;;,-----
 359 ;;;| Debuging tools
 360 ;;;`-----
 361 (defvar *%dbg-name%* "dbg")
 362 (defvar *%dbg-count%* 0)
 363
 364
 365 (defmacro dbg (&rest forms)
 366   `(progn
 367      ,@(mapcar #'(lambda (form)
 368                    (typecase form
 369                      (string `(setf *%dbg-name%* ,form))
 370                      (number `(setf *%dbg-count%* ,form))))
 371                forms)
 372      (format t "~&DEBUG[~A - ~A]  " (incf *%dbg-count%*) *%dbg-name%*)
 373      ,@(mapcar #'(lambda (form)
 374                    (typecase form
 375                      ((or string number) nil)
 376                      (t `(format t "~A=~S   " ',form ,form))))
 377                forms)
 378      (format t "~%")
 379      (force-output)
 380      ,@forms))
 381
 382 (defmacro dbgnl (&rest forms)
 383   `(progn
 384      ,@(mapcar #'(lambda (form)
 385                    (typecase form
 386                      (string `(setf *%dbg-name%* ,form))
 387                      (number `(setf *%dbg-count%* ,form))))
 388                forms)
 389      (format t "~&DEBUG[~A - ~A] --------------------~%" (incf *%dbg-count%*) *%dbg-name%*)
 390      ,@(mapcar #'(lambda (form)
 391                    (typecase form
 392                      ((or string number) nil)
 393                      (t `(format t "  -  ~A=~S~%" ',form ,form))))
 394                forms)
 395      (force-output)
 396      ,@forms))
 397
 398
 399 (defun dbgc (obj &optional newline)
 400   (princ obj)
 401   (when newline
 402     (terpri))
 403   (force-output))
 404
 405
 406 (defun in-rectangle (x y rectangle)
 407   (and rectangle
 408        (<= (rectangle-x rectangle) x (+ (rectangle-x rectangle) (rectangle-width rectangle)))
 409        (<= (rectangle-y rectangle) y (+ (rectangle-y rectangle) (rectangle-height rectangle)))))
 410
 411
 412
 413 (defun distance (x1 y1 x2 y2)
 414   (+ (abs (- x2 x1)) (abs (- y2 y1))))
 415
 416
 417 ;;; Symbols tools
 418 (defun collect-all-symbols (&optional package)
 419   (format t "Collecting all symbols for Lisp REPL completion...")
 420   (let (all-symbols)
 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.~%")
 427     all-symbols))
 428
 429
 430
 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)
 438          ,@body))))
 439
 440
 441 (defun export-all-functions (package &optional (verbose nil))
 442   (with-all-internal-symbols (symbol package)
 443     (when (fboundp symbol)
 444       (when verbose
 445         (format t "Exporting ~S~%" symbol))
 446       (export symbol package))))
 447
 448
 449 (defun export-all-variables (package &optional (verbose nil))
 450   (with-all-internal-symbols (symbol package)
 451     (when (boundp symbol)
 452       (when verbose
 453         (format t "Exporting ~S~%" symbol))
 454       (export symbol package))))
 455
 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))
 459       (when verbose
 460         (format t "Exporting ~S~%" symbol))
 461       (export symbol package))))
 462
 463
 464
 465 (defun ensure-function (object)
 466   (if (functionp object)
 467       object
 468       (symbol-function object)))
 469
 470
 471
 472
 473 (defun empty-string-p (string)
 474   (string= string ""))
 475
 476
 477 (defun find-common-string (string list &optional orig)
 478   "Return the string in common in all string in list"
 479   (if list
 480       (let ((result (remove-if-not (lambda (x)
 481                                      (zerop (or (search string x :test #'string-equal) -1)))
 482                                    list)))
 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)
 486                 string)
 487             orig))
 488       string))
 489
 490
 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))))
 496     (delete-tmp)
 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)
 502            while line
 503            do (pushnew (subseq line (1+ (or (position #\/ line :from-end t) -1))) commands
 504                        :test #'string=)))
 505       (delete-tmp)
 506       (format t "Done. Found ~A commands in shell PATH.~%" (length commands))
 507       commands)))
 508
 509
 510 ;;; Tools
 511 (defmacro setf/= (var val)
 512   "Set var to val only when var not equal to val"
 513   (let ((gval (gensym)))
 514     `(let ((,gval ,val))
 515        (when (/= ,var ,gval)
 516          (setf ,var ,gval)))))
 517
 518
 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))))
 523         (t #\|)))
 524
 525 (defun number->string (number)
 526   (string (number->char number)))
 527
 528 (defun  number->letter (n &optional (base 26))
 529   (nreverse
 530    (with-output-to-string (str)
 531      (labels ((rec (n)
 532                 (princ (code-char (+ (char-code #\a) (mod n base))) str)
 533                 (when (>= n base)
 534                   (rec (- (truncate (/ n base)) 1)))))
 535        (rec n)))))
 536
 537
 538 (defun simple-type-of (object)
 539   (let ((type (type-of object)))
 540     (typecase type
 541       (cons (first type))
 542       (t type))))
 543
 544
 545 (defun repeat-chars (n char)
 546   "Return a string containing N CHARs."
 547   (make-string n :initial-element char))
 548
 549
 550
 551 (defun nth-insert (n elem list)
 552   "Insert elem in (nth n list)"
 553   (nconc (subseq list 0 n)
 554          (list elem)
 555          (subseq list n)))
 556
 557
 558
 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
 565      while j))
 566
 567 (defun substring-equal (substring string)
 568   (string-equal substring (subseq string 0 (min (length substring) (length string)))))
 569
 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)))))
 575                                       list)
 576                        :test #'string-equal)))
 577
 578
 579 (defun extented-alphanumericp (char)
 580   (or (alphanumericp char)
 581       (eq char #\-)
 582       (eq char #\_)
 583       (eq char #\.)
 584       (eq char #\+)
 585       (eq char #\=)
 586       (eq char #\*)
 587       (eq char #\:)
 588       (eq char #\%)))
 589
 590
 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)
 596            (princ " " stream))
 597          (princ c stream))))
 598
 599
 600 (defun expand-newline (list)
 601   "Expand all newline in strings in list"
 602   (let ((acc nil))
 603     (dolist (l list)
 604       (setf acc (append acc (split-string l #\Newline))))
 605     acc))
 606
 607 (defun ensure-list (object)
 608   "Ensure an object is a list"
 609   (if (listp object)
 610       object
 611       (list object)))
 612
 613
 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 "")) ""))
 617
 618 (defun limit-length (string &optional (length 10))
 619   (subseq string 0 (min (length string) length)))
 620
 621
 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)))))
 628
 629 (defun begin-with-2-spaces (string)
 630   (and (> (length string) 1)
 631        (eql (char string 0) #\Space)
 632        (eql (char string 1) #\Space)))
 633
 634 (defun string-equal-p (x y)
 635   (when (stringp y) (string-equal x y)))
 636
 637
 638
 639
 640 (defun find-assoc-word (word line &optional (delim #\"))
 641   "Find a word pair"
 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))))
 647
 648
 649 (defun print-space (n &optional (stream *standard-output*))
 650   "Print n spaces on stream"
 651   (dotimes (i n)
 652     (princ #\Space stream)))
 653
 654
 655 (defun escape-string (string &optional (escaper '(#\/ #\: #\) #\( #\Space #\; #\,)) (char #\_))
 656   "Replace in string all characters found in the escaper list"
 657   (if escaper
 658       (escape-string (substitute char (car escaper) string) (cdr escaper) char)
 659       string))
 660
 661
 662
 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)))
 666
 667
 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)
 672                      for i in nums
 673                      when (/= n i)
 674                      do (return n))))
 675     (if new-num
 676         new-num
 677         ;; there was no space between the numbers, so use the last + 1
 678         (if (car (last nums))
 679             (1+ (car (last nums)))
 680             0))))
 681
 682
 683
 684
 685
 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))
 694     (dolist (a args)
 695       (setf fullstring (concatenate 'string fullstring " " a)))
 696     #+:cmu (let ((proc (ext:run-program program args :input :stream :output :stream :wait wt)))
 697              (unless proc
 698                (error "Cannot create process."))
 699              (make-two-way-stream
 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)))
 704               (unless proc
 705                 (error "Cannot create process."))
 706               (make-two-way-stream
 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)))
 713                  (unless proc
 714                    (error "Cannot create process."))
 715                  proc)
 716     #+:ecl (ext:run-program program args :input :stream :output :stream
 717                             :error :output)
 718     #+:openmcl (let ((proc (ccl:run-program program args :input
 719                                                          :stream :output
 720                                                          :stream :wait wt)))
 721                  (unless proc
 722                    (error "Cannot create process."))
 723                  (make-two-way-stream
 724                   (ccl:external-process-output-stream proc)
 725                   (ccl:external-process-input-stream proc)))))
 726
 727 (defun do-shell (program &optional args (wait nil) (io :stream))
 728   (do-execute "/bin/sh" `("-c" ,program ,@args) wait io))
 729
 730 (defun fdo-shell (formatter &rest args)
 731   (do-shell (apply #'format nil formatter args)))
 732
 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)
 736        while line
 737        collect line)))
 738
 739
 740
 741 (defun getenv (var)
 742   "Return the value of the environment variable."
 743   #+allegro (sys::getenv (string var))
 744   #+clisp (ext:getenv (string var))
 745   #+(or cmu scl)
 746   (cdr (assoc (string var) ext:*environment-list* :test #'equalp
 747               :key #'string))
 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)))
 756
 757
 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))
 762   #+(or cmu scl)
 763   (let ((cell (assoc (string var) ext:*environment-list* :test #'equalp
 764                                                          :key #'string)))
 765     (if cell
 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)))
 777
 778
 779
 780
 781
 782
 783
 784 (defun uquit ()
 785   #+(or clisp cmu) (ext:quit)
 786   #+sbcl (sb-ext:exit)
 787   #+ecl (si:quit)
 788   #+gcl (lisp:quit)
 789   #+lispworks (lw:quit)
 790   #+(or allegro-cl allegro-cl-trial) (excl:exit)
 791   #+ccl (ccl:quit))
 792
 793
 794
 795
 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."
 799   (do (copy rest)
 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))))
 806
 807
 808
 809
 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)
 815                    :wait wait opts)
 816   #+(and clisp      lisp=cl)
 817   (apply #'ext:run-program prog :arguments args :wait wait opts)
 818   #+(and clisp (not lisp=cl))
 819   (if wait
 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))
 827                      opts)
 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)))
 834
 835
 836 ;;(defparameter *shell-cmd* "/usr/bin/env")
 837 ;;(defparameter *shell-cmd-opt* nil)
 838
 839 #+UNIX (defparameter *shell-cmd* "/bin/sh")
 840 #+UNIX (defparameter *shell-cmd-opt* '("-c"))
 841
 842 #+WIN32 (defparameter *shell-cmd* "cmd.exe")
 843 #+WIN32 (defparameter *shell-cmd-opt* '("/C"))
 844
 845
 846 (defun ushell (&rest strings)
 847   (urun-prog *shell-cmd* :args (append *shell-cmd-opt* strings)))
 848
 849 (defun ush (string)
 850   (urun-prog *shell-cmd* :args (append *shell-cmd-opt* (list string))))
 851
 852
 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|)))
 858
 859
 860 (defun ushell-loop (&optional (shell-fun #'ushell))
 861   (loop
 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~^ ;~%~}~%"
 868                         (multiple-value-list
 869                          (ignore-errors (eval (read-from-string line))))))))))
 870
 871
 872
 873
 874
 875
 876 (defun cldebug (&rest rest)
 877   (princ "DEBUG: ")
 878   (dolist (i rest)
 879     (princ i))
 880   (terpri))
 881
 882
 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*)
 891   #+clisp ext:*args*
 892   #-(or sbcl clozure gcl ecl cmu allegro lispworks clisp)
 893   (error "get-command-line-arguments not supported for your implementation"))
 894
 895
 896
 897
 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))
 902         (accum nil))
 903        ((null index)
 904         (unless (string= (subseq str start) "")
 905           (push (subseq str start) accum))
 906         (nreverse accum))
 907     (when (/= start index)
 908       (push (subseq str start index) accum))))
 909
 910
 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))
 915         (ret (when pos pos)
 916              (if pos
 917                  (if ret
 918                      (if (< pos ret)
 919                          pos
 920                          ret)
 921                      pos)
 922                  ret)))
 923        ((null char) ret)))
 924
 925
 926 ;;;(defun near-position2 (chars str &key (start 0))
 927 ;;;  (loop for i in chars
 928 ;;;     minimize (position i str :start start)))
 929
 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)
 936 ;;                                                :preserve nil))
 937
 938
 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))
 943         (accum nil))
 944        ((null index)
 945         (unless (string= (subseq str start) "")
 946           (push (subseq str start) accum))
 947         (nreverse accum))
 948     (let ((retstr (subseq str start (if preserve (1+ index) index))))
 949       (unless (string= retstr "")
 950         (push retstr accum)))))
 951
 952
 953
 954
 955
 956 (defun list-to-string (lst)
 957   (string-trim " () " (format nil "~A" lst)))
 958
 959
 960
 961 (defun clean-string (string)
 962   "Remove Newline and upcase string"
 963   (string-upcase
 964    (string-right-trim '(#\Newline) string)))
 965
 966 (defun one-in-list (lst)
 967   (nth (random (length lst)) lst))
 968
 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)))
 974     (values lst1 lst2)))
 975
 976
 977 (defun rotate-list (list)
 978   (when list
 979     (append (cdr list) (list (car list)))))
 980
 981 (defun anti-rotate-list (list)
 982   (when list
 983     (append (last list) (butlast list))))
 984
 985 (defun n-rotate-list (list steps)
 986   (when list
 987     (let* ((len (length list))
 988            (nsteps (mod steps len)))
 989       (append (nthcdr nsteps list) (butlast list (- len nsteps))))))
 990
 991
 992 (defun append-formated-list (base-str
 993                              lst
 994                              &key (test-not-fun #'(lambda (x) x nil))
 995                              (print-fun #'(lambda (x) x))
 996                              (default-str ""))
 997   (let ((str base-str) (first t))
 998     (dolist (i lst)
 999       (cond ((funcall test-not-fun i) nil)
1000             (t (setq str
1001                      (concatenate 'string str
1002                                   (if first "" ", ")
1003                                   (format nil "~A"
1004                                           (funcall print-fun i))))
1005                (setq first nil))))
1006     (if (string= base-str str)
1007         (concatenate 'string str default-str) str)))
1008
1009
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))
1014     (dotimes (i time)
1015       (setf ind1 (random (length result)))
1016       (setf ind2 (random (length result)))
1017
1018       (setf swap (nth ind1 result))
1019       (setf (nth ind1 result) (nth ind2 result))
1020       (setf (nth ind2 result) swap))
1021     result))
1022
1023
1024
1025 (defun convert-to-number (str)
1026   (cond ((stringp str) (parse-integer str :junk-allowed t))
1027         ((numberp str) str)))
1028
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))
1032
1033
1034
1035 (defun next-in-list (item lst)
1036   (do ((x lst (cdr x)))
1037       ((null x))
1038     (when (equal item (car x))
1039       (return (if (cadr x) (cadr x) (car lst))))))
1040
1041 (defun prev-in-list (item lst)
1042   (next-in-list item (reverse lst)))
1043
1044
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)
1053         (get-decoded-time)
1054       (if (search "fr" (getenv "LANG") :test #'string-equal)
1055           (format nil "   ~2,'0D:~2,'0D:~2,'0D    ~A ~2,'0D ~A ~A "
1056                   hour minute second
1057                   (nth day jours) date (nth (1- month) mois) year)
1058           (format nil "   ~2,'0D:~2,'0D:~2,'0D    ~A ~A ~2,'0D ~A "
1059                   hour minute second
1060                   (nth day days) (nth (1- month) months) date year)))))
1061
1062 ;;;
1063 ;;; Backtrace function
1064 ;;;
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~%")
1081       (when other-info
1082         (format t "~A~%" other-info))
1083       (format t "--- log end ---~%")))
1084   (format t "Backtrace logged in file: ~A~%" filename))
1085
1086
1087
1088 ;;;
1089 ;;; System information functions
1090 ;;;
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")
1095
1096 (defmacro with-search-line ((word line) &body body)
1097   `(let ((pos (search ,word ,line :test #'string-equal)))
1098     (when (>= (or pos -1) 0)
1099       ,@body)))
1100
1101 (defun extract-battery-usage (line)
1102   (with-search-line ("Battery" line)
1103     (let ((pos (position #\% line)))
1104       (when pos
1105         (parse-integer (subseq line (- pos 3) pos) :junk-allowed t)))))
1106
1107 (defun extract-cpu-usage (line)
1108   (with-search-line ("%Cpu(s):" line)
1109     (let ((pos1 (search "id" line)))
1110       (when pos1
1111         (let ((pos2 (position #\, line :from-end t :end pos1)))
1112           (when pos2
1113             (- 100 (parse-integer (subseq line (1+ pos2) pos1) :junk-allowed t))))))))
1114
1115 (defun extract-mem-used (line)
1116   (with-search-line ("cache:" line)
1117     (parse-integer (subseq line (+ pos 6)) :junk-allowed t)))
1118
1119 (defun extract-mem-total (line)
1120   (with-search-line ("mem:" line)
1121     (parse-integer (subseq line (+ pos 4)) :junk-allowed t)))
1122
1123 (let ((total -1))
1124   (defun memory-usage ()
1125     (let ((output (do-shell *mem-cmd*))
1126           (used -1))
1127       (loop for line = (read-line output nil nil)
1128          while line
1129          do (awhen (extract-mem-used line)
1130               (setf used it))
1131            (awhen (and (= total -1) (extract-mem-total line))
1132              (setf total it)))
1133       (values used total))))
1134
1135
1136 (defun cpu-usage ()
1137   (let ((output (do-shell *cpu-cmd-fast*))
1138         (cpu -1))
1139     (loop for line = (read-line output nil nil)
1140        while line
1141        do (awhen (extract-cpu-usage line)
1142             (setf cpu it)))
1143     cpu))
1144
1145 (defun battery-usage ()
1146   (let ((output (do-shell *bat-cmd*))
1147         (bat -1))
1148     (loop for line = (read-line output nil nil)
1149        while line
1150        do (awhen (extract-battery-usage line)
1151             (setf bat it)))
1152     bat))
1153
1154 (defun battery-alert-string (bat)
1155   (if (numberp bat)
1156       (cond ((<= bat 5) "/!\\")
1157             ((<= bat 10) "!!")
1158             ((<= bat 25) "!")
1159             (t ""))
1160       ""))
1161
1162 ;;;
1163 ;;; System usage with a poll system - Memory, CPU and battery all in one
1164 ;;;
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
1171
1172 while true; do
1173  (~A; ~A ; ~A) > ~A.tmp;
1174   mv ~A.tmp ~A;
1175   sleep ~A;
1176 done~%" *bat-cmd* *cpu-cmd* *mem-cmd* poll-log poll-log poll-log delay)))
1177
1178   (defun system-poll-pid ()
1179     (let ((pid nil))
1180       (let ((output (do-shell "ps x")))
1181         (loop for line = (read-line output nil nil)
1182            while line
1183            do (when (search poll-exec line)
1184                 (push (parse-integer line :junk-allowed t) pid))))
1185       pid))
1186
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)))
1196
1197   (defun start-system-poll (delay)
1198     (unless (probe-file poll-lock)
1199       (stop-system-poll)
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~%"))))
1204
1205   (defun system-usage-poll (&optional (delay 10))
1206     (let ((bat -1)
1207           (cpu -1)
1208           (used -1)
1209           (total -1))
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)
1214              while line
1215              do (awhen (extract-battery-usage line)
1216                   (setf bat it))
1217                (awhen (extract-cpu-usage line)
1218                  (setf cpu it))
1219                (awhen (extract-mem-used line)
1220                  (setf used it))
1221                (awhen (and (= total -1) (extract-mem-total line))
1222                  (setf total it)))))
1223       (values cpu used total bat))))
1224
1225
1226
1227
1228
1229