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