Newer
Older
;;; --------------------------------------------------------------------------
;;; CLFSWM - FullScreen Window Manager
;;;
;;; --------------------------------------------------------------------------
;;; Documentation: General tools
;;; --------------------------------------------------------------------------
;;;
;;; (C) 2012 Philippe Brochard <pbrochard@common-lisp.net>
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;;
;;; --------------------------------------------------------------------------
(in-package :common-lisp-user)
(defpackage tools
(:use common-lisp)
(:export :it
:awhen
:aif
Philippe Brochard
committed
:defconfig :*config-var-table* :configvar-value :configvar-group :config-default-value
Philippe Brochard
committed
:config-all-groups
:config-group->string
Philippe Brochard
committed
:find-in-hash
Philippe Brochard
committed
:search-in-hash
Philippe Brochard
committed
:view-hash-table
:copy-hash-table
Philippe Brochard
committed
:symbol-search
Philippe Brochard
committed
:create-symbol :create-symbol-in-package
Philippe Brochard
committed
:add-new-hook
Philippe Brochard
committed
:add-hook
:remove-hook
Philippe Brochard
committed
:clear-timers
:add-timer
Philippe Brochard
committed
:at
Philippe Brochard
committed
:with-timer
:process-timers
Philippe Brochard
committed
:erase-timer
Philippe Brochard
committed
:timer-loop
Philippe Brochard
committed
:dbgc
:make-rectangle
:rectangle-x :rectangle-y :rectangle-width :rectangle-height
:in-rectangle
Philippe Brochard
committed
:collect-all-symbols
Philippe Brochard
committed
:with-all-internal-symbols
:export-all-functions :export-all-variables
:export-all-functions-and-variables
Philippe Brochard
committed
:ensure-function
Philippe Brochard
committed
:empty-string-p
Philippe Brochard
committed
:find-common-string
:command-in-path
Philippe Brochard
committed
:number->char
Philippe Brochard
committed
:number->string
Philippe Brochard
committed
:number->letter
Philippe Brochard
committed
:simple-type-of
Desmond O. Chang
committed
:repeat-chars
:nth-insert
Philippe Brochard
committed
:substring-equal
:string-match
:extented-alphanumericp
Philippe Brochard
committed
:append-newline-space
Philippe Brochard
committed
:begin-with-2-spaces
Philippe Brochard
committed
:string-equal-p
:find-assoc-word
:print-space
:escape-string
:first-position
:find-free-number
:date-string
Philippe Brochard
committed
:write-backtrace
:do-shell :fdo-shell :do-shell-output
:getenv
:uquit
:urun-prog
:ushell
:ush
:ushell-loop
:cldebug
:get-command-line-words
:string-to-list
:near-position
:string-to-list-multichar
:list-to-string
:list-to-string-list
:clean-string
:one-in-list
:exchange-one-in-list
:rotate-list
:anti-rotate-list
:append-formated-list
:shuffle-list
:parse-integer-in-list
:convert-to-number
:next-in-list :prev-in-list
:find-string
:find-all-strings
:subst-strings
:test-find-string
:memory-usage
:cpu-usage
:battery-usage
Philippe Brochard
committed
:battery-alert-string
:start-system-poll
:stop-system-poll
:system-usage-poll))
(defstruct rectangle x y width height)
Philippe Brochard
committed
Philippe Brochard
committed
(defmacro awhen (test &body body)
`(let ((it ,test))
(when it
,@body)))
(defmacro aif (test then &optional else)
`(let ((it ,test)) (if it ,then ,else)))
Philippe Brochard
committed
Philippe Brochard
committed
;;; Configuration variables
(defstruct configvar value group doc)
(defparameter *config-var-table* (make-hash-table :test #'equal))
(defmacro defconfig (name value group doc)
`(progn
(setf (gethash ',name *config-var-table*)
(make-configvar :value ,value
:group (or ,group 'Miscellaneous)))
(defparameter ,name ,value ,doc)))
(defun config-default-value (var)
(let ((config (gethash var *config-var-table*)))
(when config
(configvar-value config))))
(defun config-group->string (group)
(format nil "~:(~A group~)" (substitute #\Space #\- (string group))))
Philippe Brochard
committed
Philippe Brochard
committed
;;; Configuration variables
(defun config-all-groups ()
(let (all-groups)
(maphash (lambda (key val)
(declare (ignore key))
(pushnew (configvar-group val) all-groups :test #'equal))
*config-var-table*)
Philippe Brochard
committed
(sort all-groups (lambda (x y)
(string< (string x) (string y))))))
Philippe Brochard
committed
Philippe Brochard
committed
Philippe Brochard
committed
(defun find-in-hash (val hashtable &optional (test #'equal))
"Return the key associated to val in the hashtable"
(maphash #'(lambda (k v)
(when (and (consp v) (funcall test (first v) val))
(return-from find-in-hash (values k v))))
hashtable))
Philippe Brochard
committed
(defun search-in-hash (val hashtable)
"Return the key who match the val in the hashtable"
(let ((val (symbol-name val)))
(maphash #'(lambda (k v)
(when (and (consp v) (substring-equal (symbol-name (first v)) val))
(return-from search-in-hash (values k v))))
hashtable)))
Philippe Brochard
committed
Philippe Brochard
committed
(defun view-hash-table (title hashtable)
(maphash (lambda (k v)
(format t "[~A] ~A ~A~%" title k v))
hashtable))
(defun copy-hash-table (hashtable)
(let ((rethash (make-hash-table :test (hash-table-test hashtable))))
(maphash (lambda (k v)
(setf (gethash k rethash) v))
hashtable)
rethash))
(defun nfuncall (function)
(when function
(funcall function)))
Philippe Brochard
committed
(when (and function
(or (functionp function)
(and (symbolp function) (fboundp function))))
Philippe Brochard
committed
(defun symbol-search (search symbol)
"Search the string 'search' in the symbol name of 'symbol'"
(search search (symbol-name symbol) :test #'string-equal))
Philippe Brochard
committed
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun mkstr (&rest args)
(with-output-to-string (s)
(dolist (a args)
(princ a s))))
Philippe Brochard
committed
(defun create-symbol (&rest args)
(values (intern (string-upcase (apply #'mkstr args)))))
Philippe Brochard
committed
Philippe Brochard
committed
(defun create-symbol-in-package (package &rest args)
(values (intern (string-upcase (apply #'mkstr args)) package))))
Philippe Brochard
committed
Philippe Brochard
committed
(defun call-hook (hook &rest args)
"Call a hook (a function, a symbol or a list of functions)
Return the result of the last hook"
(let ((result nil))
(labels ((rec (hook)
(when hook
(typecase hook
(cons (dolist (h hook)
(rec h)))
Philippe Brochard
committed
(function (setf result (apply hook args)))
(symbol (when (fboundp hook)
(setf result (apply hook args))))))))
Philippe Brochard
committed
(defmacro add-new-hook (hook &rest value)
"Add a hook. Duplicate it if needed"
`(setf ,hook (append (typecase ,hook
Philippe Brochard
committed
(list ,hook)
(t (list ,hook)))
(list ,@value))))
Philippe Brochard
committed
Philippe Brochard
committed
(defmacro add-hook (hook &rest value)
"Add a hook only if not duplicated"
(let ((i (gensym)))
Philippe Brochard
committed
`(dolist (,i (list ,@value))
Philippe Brochard
committed
(unless (member ,i (typecase ,hook
(list ,hook)
(t (list ,hook))))
(add-new-hook ,hook ,i)))))
(defmacro remove-hook (hook &rest value)
(let ((i (gensym)))
Philippe Brochard
committed
`(dolist (,i (list ,@value) ,hook)
(setf ,hook (remove ,i ,hook)))))
Philippe Brochard
committed
Philippe Brochard
committed
;;;,-----
;;;| Timers tools
;;;`-----
(defparameter *timer-list* nil)
(declaim (inline realtime->s s->realtime))
(defun realtime->s (rtime)
(float (/ rtime internal-time-units-per-second)))
(defun s->realtime (second)
(round (* second internal-time-units-per-second)))
(defun clear-timers ()
(setf *timer-list* nil))
(defun add-timer (delay fun &optional (id (gensym)))
Philippe Brochard
committed
"Start the function fun at delay seconds."
(push (list id
(let ((time (+ (get-internal-real-time) (s->realtime delay))))
Philippe Brochard
committed
(lambda (current-time)
(when (>= current-time time)
Philippe Brochard
committed
(funcall fun)
t))))
*timer-list*)
id)
Philippe Brochard
committed
Philippe Brochard
committed
(defun at (delay fun &optional (id (gensym)))
"Start the function fun at delay seconds."
(funcall #'add-timer delay fun id))
(defmacro with-timer ((delay &optional (id (gensym))) &body body)
Philippe Brochard
committed
"Same thing as add-timer but with syntaxic sugar"
Philippe Brochard
committed
`(add-timer ,delay
(lambda ()
,@body)
,id))
Philippe Brochard
committed
(defun process-timers ()
Philippe Brochard
committed
"Call each timers in *timer-list* if needed"
Philippe Brochard
committed
(let ((current-time (get-internal-real-time)))
(dolist (timer *timer-list*)
(when (funcall (second timer) current-time)
(setf *timer-list* (remove timer *timer-list* :test #'equal))))))
Philippe Brochard
committed
(defun erase-timer (id)
Philippe Brochard
committed
"Erase the timer identified by its id"
Philippe Brochard
committed
(setf *timer-list* (remove id *timer-list* :test (lambda (x y)
(equal x (first y))))))
Philippe Brochard
committed
(defun timer-test-loop ()
Philippe Brochard
committed
(let ((count 0))
(labels ((plop ()
(format t "Plop-~A" count)
(erase-timer :toto))
(toto ()
(format t "Toto-~A" count)
(add-timer 3 #'toto :toto)))
(add-timer 3 #'toto :toto)
(add-timer 13 #'plop)
(loop
(princ ".") (force-output)
(process-timers)
(sleep 0.5)
(incf count)))))
Philippe Brochard
committed
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
;;;,-----
;;;| Debuging tools
;;;`-----
(defvar *%dbg-name%* "dbg")
(defvar *%dbg-count%* 0)
(defmacro dbg (&rest forms)
`(progn
,@(mapcar #'(lambda (form)
(typecase form
(string `(setf *%dbg-name%* ,form))
(number `(setf *%dbg-count%* ,form))))
forms)
(format t "~&DEBUG[~A - ~A] " (incf *%dbg-count%*) *%dbg-name%*)
,@(mapcar #'(lambda (form)
(typecase form
((or string number) nil)
(t `(format t "~A=~S " ',form ,form))))
forms)
(format t "~%")
(force-output)
,@forms))
(defmacro dbgnl (&rest forms)
`(progn
,@(mapcar #'(lambda (form)
(typecase form
(string `(setf *%dbg-name%* ,form))
(number `(setf *%dbg-count%* ,form))))
forms)
(format t "~&DEBUG[~A - ~A] --------------------~%" (incf *%dbg-count%*) *%dbg-name%*)
,@(mapcar #'(lambda (form)
(typecase form
((or string number) nil)
(t `(format t " - ~A=~S~%" ',form ,form))))
forms)
(force-output)
,@forms))
Philippe Brochard
committed
(defun dbgc (obj &optional newline)
(princ obj)
(when newline
(terpri))
(force-output))
(defun in-rectangle (x y rectangle)
(and rectangle
(<= (rectangle-x rectangle) x (+ (rectangle-x rectangle) (rectangle-width rectangle)))
(<= (rectangle-y rectangle) y (+ (rectangle-y rectangle) (rectangle-height rectangle)))))
(defun distance (x1 y1 x2 y2)
(+ (abs (- x2 x1)) (abs (- y2 y1))))
Philippe Brochard
committed
;;; Symbols tools
Philippe Brochard
committed
(defun collect-all-symbols (&optional package)
Philippe Brochard
committed
(format t "Collecting all symbols for Lisp REPL completion...")
Philippe Brochard
committed
(let (all-symbols)
(do-symbols (symbol (or package *package*))
(pushnew (string-downcase (symbol-name symbol)) all-symbols :test #'string=))
(do-symbols (symbol :keyword)
(pushnew (concatenate 'string ":" (string-downcase (symbol-name symbol)))
all-symbols :test #'string=))
(format t " Done.~%")
all-symbols))
Philippe Brochard
committed
(defmacro with-all-internal-symbols ((var package) &body body)
"Bind symbol to all internal symbols in package"
`(do-symbols (,var ,package)
(multiple-value-bind (sym status)
(find-symbol (symbol-name ,var) ,package)
(declare (ignore sym))
(when (eql status :internal)
,@body))))
(defun export-all-functions (package &optional (verbose nil))
(with-all-internal-symbols (symbol package)
(when (fboundp symbol)
(when verbose
(format t "Exporting ~S~%" symbol))
(export symbol package))))
Philippe Brochard
committed
(defun export-all-variables (package &optional (verbose nil))
(with-all-internal-symbols (symbol package)
(when (boundp symbol)
(when verbose
(format t "Exporting ~S~%" symbol))
(export symbol package))))
(defun export-all-functions-and-variables (package &optional (verbose nil))
(with-all-internal-symbols (symbol package)
(when (or (fboundp symbol) (boundp symbol))
(when verbose
(format t "Exporting ~S~%" symbol))
(export symbol package))))
Philippe Brochard
committed
(defun ensure-function (object)
(if (functionp object)
object
(symbol-function object)))
Philippe Brochard
committed
(defun empty-string-p (string)
(string= string ""))
Philippe Brochard
committed
(defun find-common-string (string list &optional orig)
"Return the string in common in all string in list"
(if list
(let ((result (remove-if-not (lambda (x)
(zerop (or (search string x :test #'string-equal) -1)))
list)))
(if (= (length result) (length list))
(if (> (length (first list)) (length string))
(find-common-string (subseq (first list) 0 (1+ (length string))) list string)
string)
orig))
string))
(defun command-in-path (&optional (tmpfile "/tmp/clfswm-cmd.tmp"))
Philippe Brochard
committed
(format t "Updating command list for Shell completion...~%")
(labels ((delete-tmp ()
(when (probe-file tmpfile)
(delete-file tmpfile))))
(delete-tmp)
(dolist (dir (split-string (getenv "PATH") #\:))
(ushell (format nil "ls ~A/* >> ~A" dir tmpfile)))
(let ((commands nil))
(with-open-file (stream tmpfile :direction :input)
(loop for line = (read-line stream nil nil)
while line
do (pushnew (subseq line (1+ (or (position #\/ line :from-end t) -1))) commands
:test #'string=)))
(delete-tmp)
(format t "Done. Found ~A commands in shell PATH.~%" (length commands))
commands)))
Philippe Brochard
committed
;;; Tools
(defmacro setf/= (var val)
"Set var to val only when var not equal to val"
(let ((gval (gensym)))
`(let ((,gval ,val))
(when (/= ,var ,gval)
(setf ,var ,gval)))))
Philippe Brochard
committed
(defun number->char (number)
Philippe Brochard
committed
(cond ((<= number 25) (code-char (+ (char-code #\a) number)))
((<= 26 number 35) (code-char (+ (char-code #\0) (- number 26))))
((<= 36 number 61) (code-char (+ (char-code #\A) (- number 36))))
(t #\|)))
(defun number->string (number)
(string (number->char number)))
Philippe Brochard
committed
(defun number->letter (n &optional (base 26))
(nreverse
(with-output-to-string (str)
(labels ((rec (n)
(princ (code-char (+ (char-code #\a) (mod n base))) str)
(when (>= n base)
(rec (- (truncate (/ n base)) 1)))))
(rec n)))))
Philippe Brochard
committed
Philippe Brochard
committed
Philippe Brochard
committed
(defun simple-type-of (object)
(let ((type (type-of object)))
(typecase type
(cons (first type))
(t type))))
Desmond O. Chang
committed
(defun repeat-chars (n char)
"Return a string containing N CHARs."
(make-string n :initial-element char))
(defun nth-insert (n elem list)
"Insert elem in (nth n list)"
(nconc (subseq list 0 n)
(list elem)
(subseq list n)))
(defun split-string (string &optional (separator #\Space))
"Return a list from a string splited at each separators"
(loop for i = 0 then (1+ j)
as j = (position separator string :start i)
as sub = (subseq string i j)
unless (string= sub "") collect sub
while j))
Philippe Brochard
committed
(defun substring-equal (substring string)
(string-equal substring (subseq string 0 (min (length substring) (length string)))))
(defun string-match (match list)
"Return the string in list witch match the match string"
(let ((len (length match)))
(remove-duplicates (remove-if-not (lambda (x)
(string-equal match (subseq x 0 (min len (length x)))))
list)
:test #'string-equal)))
(defun extented-alphanumericp (char)
(or (alphanumericp char)
(eq char #\-)
(eq char #\_)
(eq char #\.)
Philippe Brochard
committed
(eq char #\+)
(eq char #\=)
(eq char #\*)
(eq char #\:)
(eq char #\%)))
Philippe Brochard
committed
(defun append-newline-space (string)
"Append spaces before Newline on each line"
(with-output-to-string (stream)
(loop for c across string do
(when (equal c #\Newline)
(princ " " stream))
(princ c stream))))
(defun expand-newline (list)
"Expand all newline in strings in list"
(let ((acc nil))
(dolist (l list)
(setf acc (append acc (split-string l #\Newline))))
acc))
(defun ensure-list (object)
"Ensure an object is a list"
(if (listp object)
object
(list object)))
(defun ensure-printable (string &optional (new #\?))
"Ensure a string is printable in ascii"
(or (substitute-if-not new #'standard-char-p (or string "")) ""))
(defun limit-length (string &optional (length 10))
(subseq string 0 (min (length string) length)))
(defun ensure-n-elems (list n)
"Ensure that list has exactly n elements"
(let ((length (length list)))
(cond ((= length n) list)
((< length n) (ensure-n-elems (append list '(nil)) n))
((> length n) (ensure-n-elems (butlast list) n)))))
Philippe Brochard
committed
Philippe Brochard
committed
(defun begin-with-2-spaces (string)
(and (> (length string) 1)
(eql (char string 0) #\Space)
(eql (char string 1) #\Space)))
Philippe Brochard
committed
(defun string-equal-p (x y)
(when (stringp y) (string-equal x y)))
(defun find-assoc-word (word line &optional (delim #\"))
"Find a word pair"
(let* ((pos (search word line))
(pos-1 (position delim line :start (or pos 0)))
(pos-2 (position delim line :start (1+ (or pos-1 0)))))
(when (and pos pos-1 pos-2)
(subseq line (1+ pos-1) pos-2))))
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
(defun print-space (n &optional (stream *standard-output*))
"Print n spaces on stream"
(dotimes (i n)
(princ #\Space stream)))
(defun escape-string (string &optional (escaper '(#\/ #\: #\) #\( #\Space #\; #\,)) (char #\_))
"Replace in string all characters found in the escaper list"
(if escaper
(escape-string (substitute char (car escaper) string) (cdr escaper) char)
string))
(defun first-position (word string)
"Return true only if word is at position 0 in string"
(zerop (or (search word string) -1)))
(defun find-free-number (l) ; stolen from stumpwm - thanks
"Return a number that is not in the list l."
(let* ((nums (sort l #'<))
(new-num (loop for n from 0 to (or (car (last nums)) 0)
for i in nums
when (/= n i)
do (return n))))
(if new-num
new-num
;; there was no space between the numbers, so use the last + 1
(if (car (last nums))
(1+ (car (last nums)))
0))))
;;; Shell part (taken from ltk)
(defun do-execute (program args &optional (wt nil) (io :stream))
"execute program with args a list containing the arguments passed to
the program if wt is non-nil, the function will wait for the execution
of the program to return.
returns a two way stream connected to stdin/stdout of the program"
#-CLISP (declare (ignore io))
(let ((fullstring program))
(dolist (a args)
(setf fullstring (concatenate 'string fullstring " " a)))
#+:cmu (let ((proc (ext:run-program program args :input :stream :output :stream :wait wt)))
(unless proc
(error "Cannot create process."))
(make-two-way-stream
(ext:process-output proc)
(ext:process-input proc)))
#+:clisp (ext:run-program program :arguments args :input io :output io :wait wt)
#+:sbcl (let ((proc (sb-ext:run-program program args :input :stream :output :stream :wait wt)))
(make-two-way-stream
(sb-ext:process-output proc)
(sb-ext:process-input proc)))
#+:lispworks (system:open-pipe fullstring :direction :io)
#+:allegro (let ((proc (excl:run-shell-command
(apply #'vector program program args)
:input :stream :output :stream :wait wt)))
(unless proc
(error "Cannot create process."))
Philippe Brochard
committed
#+:ecl (ext:run-program program args :input :stream :output :stream
:error :output)
#+:openmcl (let ((proc (ccl:run-program program args :input
:stream :output
:stream :wait wt)))
(unless proc
(error "Cannot create process."))
(make-two-way-stream
(ccl:external-process-output-stream proc)
(ccl:external-process-input-stream proc)))))
(defun do-shell (program &optional args (wait nil) (io :stream))
(do-execute "/bin/sh" `("-c" ,program ,@args) wait io))
Philippe Brochard
committed
(defun fdo-shell (formatter &rest args)
(do-shell (apply #'format nil formatter args)))
(defun do-shell-output (formatter &rest args)
(let ((output (do-shell (apply #'format nil formatter args) nil t)))
(loop for line = (read-line output nil nil)
while line
collect line)))
(defun getenv (var)
"Return the value of the environment variable."
#+allegro (sys::getenv (string var))
#+clisp (ext:getenv (string var))
#+(or cmu scl)
(cdr (assoc (string var) ext:*environment-list* :test #'equalp
:key #'string))
#+gcl (si:getenv (string var))
#+lispworks (lw:environment-variable (string var))
#+lucid (lcl:environment-variable (string var))
#+(or mcl ccl) (ccl::getenv var)
#-(or allegro clisp cmu gcl lispworks lucid mcl sbcl scl ecl ccl)
(error 'not-implemented :proc (list 'getenv var)))
(defun (setf getenv) (val var)
"Set an environment variable."
#+allegro (setf (sys::getenv (string var)) (string val))
#+clisp (setf (ext:getenv (string var)) (string val))
#+(or cmu scl)
(let ((cell (assoc (string var) ext:*environment-list* :test #'equalp
:key #'string)))
(if cell
(setf (cdr cell) (string val))
(push (cons (intern (string var) "KEYWORD") (string val))
ext:*environment-list*)))
#+gcl (si:setenv (string var) (string val))
#+lispworks (setf (lw:environment-variable (string var)) (string val))
#+lucid (setf (lcl:environment-variable (string var)) (string val))
#+sbcl (sb-posix:putenv (format nil "~A=~A" (string var) (string val)))
#+ccl (ccl::setenv (string var) (string val))
#-(or allegro clisp cmu gcl lispworks lucid sbcl scl ecl ccl)
(error 'not-implemented :proc (list '(setf getenv) var)))
(defun uquit ()
#+(or clisp cmu) (ext:quit)
#+ecl (si:quit)
#+gcl (lisp:quit)
#+lispworks (lw:quit)
#+(or allegro-cl allegro-cl-trial) (excl:exit)
#+ccl (ccl:quit))
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
(defun remove-plist (plist &rest keys)
"Remove the keys from the plist.
Useful for re-using the &REST arg after removing some options."
(do (copy rest)
((null (setq rest (nth-value 2 (get-properties plist keys))))
(nreconc copy plist))
(do () ((eq plist rest))
(push (pop plist) copy)
(push (pop plist) copy))
(setq plist (cddr plist))))
(defun urun-prog (prog &rest opts &key args (wait t) &allow-other-keys)
"Common interface to shell. Does not return anything useful."
#+gcl (declare (ignore wait))
(setq opts (remove-plist opts :args :wait))
#+allegro (apply #'excl:run-shell-command (apply #'vector prog prog args)
:wait wait opts)
#+(and clisp lisp=cl)
(apply #'ext:run-program prog :arguments args :wait wait opts)
#+(and clisp (not lisp=cl))
(if wait
(apply #'lisp:run-program prog :arguments args opts)
(lisp:shell (format nil "~a~{ '~a'~} &" prog args)))
#+cmu (apply #'ext:run-program prog args :wait wait :output *standard-output* opts)
#+gcl (apply #'si:run-process prog args)
#+liquid (apply #'lcl:run-program prog args)
#+lispworks (apply #'sys::call-system-showing-output
(format nil "~a~{ '~a'~}~@[ &~]" prog args (not wait))
opts)
#+lucid (apply #'lcl:run-program prog :wait wait :arguments args opts)
#+sbcl (apply #'sb-ext:run-program prog args :wait wait :output *standard-output* opts)
Philippe Brochard
committed
#+ccl (ccl:run-program prog args :wait wait)
#-(or allegro clisp cmu gcl liquid lispworks lucid sbcl ecl ccl)
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
(error 'not-implemented :proc (list 'run-prog prog opts)))
;;(defparameter *shell-cmd* "/usr/bin/env")
;;(defparameter *shell-cmd-opt* nil)
#+UNIX (defparameter *shell-cmd* "/bin/sh")
#+UNIX (defparameter *shell-cmd-opt* '("-c"))
#+WIN32 (defparameter *shell-cmd* "cmd.exe")
#+WIN32 (defparameter *shell-cmd-opt* '("/C"))
(defun ushell (&rest strings)
(urun-prog *shell-cmd* :args (append *shell-cmd-opt* strings)))
(defun ush (string)
(urun-prog *shell-cmd* :args (append *shell-cmd-opt* (list string))))
(defun set-shell-dispatch (&optional (shell-fun 'ushell))
(labels ((|shell-reader| (stream subchar arg)
(declare (ignore subchar arg))
(list shell-fun (read stream t nil t))))
(set-dispatch-macro-character #\# #\# #'|shell-reader|)))
(defun ushell-loop (&optional (shell-fun #'ushell))
(loop
(format t "UNI-SHELL> ")
(let* ((line (read-line)))
(cond ((zerop (or (search "quit" line) -1)) (return))
((zerop (or (position #\! line) -1))
(funcall shell-fun (subseq line 1)))
(t (format t "~{~A~^ ;~%~}~%"
(ignore-errors (eval (read-from-string line))))))))))
(defun cldebug (&rest rest)
(princ "DEBUG: ")
(dolist (i rest)
(princ i))
(terpri))
(defun get-command-line-words ()
Philippe Brochard
committed
#+sbcl (cdr sb-ext:*posix-argv*)
#+(or clozure ccl) (cddddr (ccl::command-line-arguments))
#+gcl (cdr si:*command-args*)
#+ecl (loop for i from 1 below (si:argc) collect (si:argv i))
#+cmu (cdddr extensions:*command-line-strings*)
#+allegro (cdr (sys:command-line-arguments))
#+lispworks (cdr sys:*line-arguments-list*)
#+clisp ext:*args*
#-(or sbcl clozure gcl ecl cmu allegro lispworks clisp)
(error "get-command-line-arguments not supported for your implementation"))
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
(defun string-to-list (str &key (split-char #\space))
(do* ((start 0 (1+ index))
(index (position split-char str :start start)
(position split-char str :start start))
(accum nil))
((null index)
(unless (string= (subseq str start) "")
(push (subseq str start) accum))
(nreverse accum))
(when (/= start index)
(push (subseq str start index) accum))))
(defun near-position (chars str &key (start 0))
(do* ((char chars (cdr char))
(pos (position (car char) str :start start)
(position (car char) str :start start))
(ret (when pos pos)
(if pos
(if ret
(if (< pos ret)
pos
ret)
pos)
ret)))
((null char) ret)))
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
;;;(defun near-position2 (chars str &key (start 0))
;;; (loop for i in chars
;;; minimize (position i str :start start)))
;;(format t "~S~%" (near-position '(#\! #\. #\Space #\;) "klmsqk ppii;dsdsqkl.jldfksj lkm" :start 0))
;;(format t "~S~%" (near-position '(#\Space) "klmsqk ppii;dsdsqkl.jldfksj lkm" :start 0))
;;(format t "~S~%" (near-position '(#\; #\l #\m) "klmsqk ppii;dsdsqkl.jldfksj lkm" :start 0))
;;(format t "result=~S~%" (string-to-list-multichar "klmsqk ppii;dsdsqkl.jldfksj lkm" :preserve t))
;;(format t "result=~S~%" (string-to-list-multichar "klmsqk ppii;dsd!sqkl.jldfksj lkm"
;; :split-chars '(#\k #\! #\. #\; #\m)
;; :preserve nil))
(defun string-to-list-multichar (str &key (split-chars '(#\space)) (preserve nil))
(do* ((start 0 (1+ index))
(index (near-position split-chars str :start start)
(near-position split-chars str :start start))
(accum nil))
((null index)
(unless (string= (subseq str start) "")
(push (subseq str start) accum))
(nreverse accum))
(let ((retstr (subseq str start (if preserve (1+ index) index))))
(unless (string= retstr "")
(push retstr accum)))))
(defun list-to-string (lst)
(string-trim " () " (format nil "~A" lst)))
(defun clean-string (string)
"Remove Newline and upcase string"
(string-upcase
(string-right-trim '(#\Newline) string)))
(defun one-in-list (lst)
(nth (random (length lst)) lst))
(defun exchange-one-in-list (lst1 lst2)
(let ((elem1 (one-in-list lst1))
(elem2 (one-in-list lst2)))
(setf lst1 (append (remove elem1 lst1) (list elem2)))
(setf lst2 (append (remove elem2 lst2) (list elem1)))
(values lst1 lst2)))
(defun rotate-list (list)
(when list
(append (cdr list) (list (car list)))))
(defun anti-rotate-list (list)
(when list
(append (last list) (butlast list))))
Michael Raitza
committed
(defun n-rotate-list (list steps)
(when list
(let* ((len (length list))
(nsteps (mod steps len)))
(append (nthcdr nsteps list) (butlast list (- len nsteps))))))
&key (test-not-fun #'(lambda (x) x nil))
(print-fun #'(lambda (x) x))
(default-str ""))
(let ((str base-str) (first t))
(dolist (i lst)
(cond ((funcall test-not-fun i) nil)