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