src/tools.lisp

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