src/tools.lisp

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