src/tools.lisp

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