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