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