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