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