Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 320 lines (286 sloc) 13.682 kb
92cd9ad move implementation specific code to wrappers.lisp
Shawn authored
1 ;; Copyright (C) 2003-2008 Shawn Betts
2 ;;
3 ;; This file is part of stumpwm.
4 ;;
5 ;; stumpwm is free software; you can redistribute it and/or modify
6 ;; it under the terms of the GNU General Public License as published by
7 ;; the Free Software Foundation; either version 2, or (at your option)
8 ;; any later version.
9
10 ;; stumpwm is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;; GNU General Public License for more details.
14
15 ;; You should have received a copy of the GNU General Public License
16 ;; along with this software; see the file COPYING. If not, write to
17 ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
18 ;; Boston, MA 02111-1307 USA
19
20 ;; Commentary:
21 ;;
22 ;; portability wrappers. Any code that must run different code for
23 ;; different lisps should be wrapped up in a function and put here.
24 ;;
25 ;; Code:
26
27 (in-package #:stumpwm)
28
29 (export '(getenv))
30
2a9c0ab Defined not-implemented condition.
Morgan Veyret authored
31 (define-condition not-implemented (stumpwm-error)
32 () (:documentation "Describes a non implemented functionnality."))
33
92cd9ad move implementation specific code to wrappers.lisp
Shawn authored
34 ;;; XXX: DISPLAY env var isn't set for cmucl
35 (defun run-prog (prog &rest opts &key args (wait t) &allow-other-keys)
36 "Common interface to shell. Does not return anything useful."
37 #+gcl (declare (ignore wait))
38 (setq opts (remove-plist opts :args :wait))
39 #+allegro (apply #'excl:run-shell-command (apply #'vector prog prog args)
40 :wait wait opts)
41 #+(and clisp lisp=cl)
42 (progn
43 ;; Arg. We can't pass in an environment so just set the DISPLAY
44 ;; variable so it's inherited by the child process.
45 (setf (getenv "DISPLAY") (format nil "~a:~d.~d"
46 (screen-host (current-screen))
47 (xlib:display-display *display*)
48 (screen-id (current-screen))))
49 (apply #'ext:run-program prog :arguments args :wait wait opts))
50 #+(and clisp (not lisp=cl))
51 (if wait
52 (apply #'lisp:run-program prog :arguments args opts)
53 (lisp:shell (format nil "~a~{ '~a'~} &" prog args)))
54 #+cmu (apply #'ext:run-program prog args :output t :error t :wait wait opts)
55 #+gcl (apply #'si:run-process prog args)
56 #+liquid (apply #'lcl:run-program prog args)
57 #+lispworks (apply #'sys::call-system
58 (format nil "~a~{ '~a'~}~@[ &~]" prog args (not wait))
59 opts)
60 #+lucid (apply #'lcl:run-program prog :wait wait :arguments args opts)
61 #+sbcl (apply #'sb-ext:run-program prog args :output t :error t :wait wait
62 ;; inject the DISPLAY variable in so programs show up
63 ;; on the right screen.
64 :environment (cons (screen-display-string (current-screen))
65 (remove-if (lambda (str)
66 (string= "DISPLAY=" str :end2 (min 8 (length str))))
67 (sb-ext:posix-environ)))
68 opts)
854b572 fix run-prog, run-prog-collect-output and print-backtrace ccl support
Philip Fominykh authored
69 #+ccl (ccl:run-program prog (mapcar (lambda (s)
70 (if (simple-string-p s) s (coerce s 'simple-string)))
71 args)
72 :wait wait :output t :error t)
73 #-(or allegro clisp cmu gcl liquid lispworks lucid sbcl ccl)
2a9c0ab Defined not-implemented condition.
Morgan Veyret authored
74 (error 'not-implemented))
92cd9ad move implementation specific code to wrappers.lisp
Shawn authored
75
76 ;;; XXX: DISPLAY isn't set for cmucl
77 (defun run-prog-collect-output (prog &rest args)
78 "run a command and read its output."
79 #+allegro (with-output-to-string (s)
80 (excl:run-shell-command (format nil "~a~{ ~a~}" prog args)
81 :output s :wait t))
82 ;; FIXME: this is a dumb hack but I don't care right now.
83 #+clisp (with-output-to-string (s)
84 ;; Arg. We can't pass in an environment so just set the DISPLAY
85 ;; variable so it's inherited by the child process.
86 (setf (getenv "DISPLAY") (format nil "~a:~d.~d"
87 (screen-host (current-screen))
88 (xlib:display-display *display*)
89 (screen-id (current-screen))))
90 (let ((out (ext:run-program prog :arguments args :wait t :output :stream)))
91 (loop for i = (read-char out nil out)
92 until (eq i out)
93 do (write-char i s))))
94 #+cmu (with-output-to-string (s) (ext:run-program prog args :output s :error s :wait t))
95 #+sbcl (with-output-to-string (s)
96 (sb-ext:run-program prog args :output s :error s :wait t
97 ;; inject the DISPLAY variable in so programs show up
98 ;; on the right screen.
99 :environment (cons (screen-display-string (current-screen))
100 (remove-if (lambda (str)
101 (string= "DISPLAY=" str :end2 (min 8 (length str))))
102 (sb-ext:posix-environ)))))
854b572 fix run-prog, run-prog-collect-output and print-backtrace ccl support
Philip Fominykh authored
103 #+ccl (with-output-to-string (s)
104 (ccl:run-program prog (mapcar (lambda (s)
105 (if (simple-string-p s) s (coerce s 'simple-string)))
106 args)
107 :wait t :output s :error t))
108 #-(or allegro clisp cmu sbcl ccl)
2a9c0ab Defined not-implemented condition.
Morgan Veyret authored
109 (error 'not-implemented))
92cd9ad move implementation specific code to wrappers.lisp
Shawn authored
110
111 (defun getenv (var)
112 "Return the value of the environment variable."
113 #+allegro (sys::getenv (string var))
114 #+clisp (ext:getenv (string var))
115 #+(or cmu scl)
116 (cdr (assoc (string var) ext:*environment-list* :test #'equalp
117 :key #'string))
118 #+gcl (si:getenv (string var))
119 #+lispworks (lw:environment-variable (string var))
120 #+lucid (lcl:environment-variable (string var))
121 #+mcl (ccl::getenv var)
122 #+sbcl (sb-posix:getenv (string var))
85ffcd8 @vtl Add support for OpenMCL
vtl authored
123 #+openmcl (ccl:getenv (string var))
124 #-(or allegro clisp cmu gcl lispworks lucid mcl sbcl scl openmcl)
2a9c0ab Defined not-implemented condition.
Morgan Veyret authored
125 (error 'not-implemented))
92cd9ad move implementation specific code to wrappers.lisp
Shawn authored
126
127 (defun (setf getenv) (val var)
128 "Set the value of the environment variable, @var{var} to @var{val}."
129 #+allegro (setf (sys::getenv (string var)) (string val))
130 #+clisp (setf (ext:getenv (string var)) (string val))
131 #+(or cmu scl)
132 (let ((cell (assoc (string var) ext:*environment-list* :test #'equalp
133 :key #'string)))
134 (if cell
135 (setf (cdr cell) (string val))
136 (push (cons (intern (string var) "KEYWORD") (string val))
137 ext:*environment-list*)))
138 #+gcl (si:setenv (string var) (string val))
139 #+lispworks (setf (lw:environment-variable (string var)) (string val))
140 #+lucid (setf (lcl:environment-variable (string var)) (string val))
141 #+sbcl (sb-posix:putenv (format nil "~A=~A" (string var) (string val)))
85ffcd8 @vtl Add support for OpenMCL
vtl authored
142 #+openmcl (ccl:setenv (string var) (string val))
143 #-(or allegro clisp cmu gcl lispworks lucid sbcl scl openmcl)
2a9c0ab Defined not-implemented condition.
Morgan Veyret authored
144 (error 'not-implemented))
92cd9ad move implementation specific code to wrappers.lisp
Shawn authored
145
2eae3e6 fix compilation with new SBCL's
Rupert Swarbrick authored
146 (eval-when (:compile-toplevel :load-toplevel :execute)
147 ;; On 20th May 2009, SBCL lost unix-file-kind and replaced it with the
148 ;; internal native-file-kind. Since there's no overlap, we'd better cope with
149 ;; either possibility.
150 (let (#+sbcl (file-kind-fun
151 (or (find-symbol "NATIVE-FILE-KIND" :sb-impl)
152 (find-symbol "UNIX-FILE-KIND" :sb-unix))))
153 (defun pathname-is-executable-p (pathname)
154 "Return T if the pathname describes an executable file."
155 #+sbcl
156 (let ((filename (coerce (file-namestring pathname) 'base-string)))
157 (and (eq (funcall file-kind-fun filename) :file)
158 (sb-unix:unix-access filename sb-unix:x_ok)))
159 ;; FIXME: this is not exactly perfect
160 #+clisp
161 (logand (posix:convert-mode (posix:file-stat-mode (posix:file-stat pathname)))
162 (posix:convert-mode '(:xusr :xgrp :xoth)))
163 #-(or sbcl clisp) t)))
92cd9ad move implementation specific code to wrappers.lisp
Shawn authored
164
165 (defun probe-path (path)
166 "Return the truename of a supplied path, or nil if it does not exist."
167 (handler-case
168 (truename
169 (let ((pathname (pathname path)))
170 ;; If there is neither a type nor a name, we have a directory
171 ;; pathname already. Otherwise make a valid one.
172 (if (and (not (pathname-name pathname))
173 (not (pathname-type pathname)))
174 pathname
175 (make-pathname
176 :directory (append (or (pathname-directory pathname)
177 (list :relative))
178 (list (file-namestring pathname)))
179 :name nil :type nil :defaults pathname))))
180 (file-error () nil)))
181
182 (defun portable-file-write-date (pathname)
183 ;; clisp errors out if you run file-write-date on a directory.
184 #+clisp (posix:file-stat-mtime (posix:file-stat pathname))
185 #-clisp (file-write-date pathname))
186
187 (defun print-backtrace (&optional (frames 100))
188 "print a backtrace of FRAMES number of frames to standard-output"
189 #+sbcl (sb-debug:backtrace frames *standard-output*)
190 #+clisp (ext:show-stack 1 frames (sys::the-frame))
854b572 fix run-prog, run-prog-collect-output and print-backtrace ccl support
Philip Fominykh authored
191 #+ccl (ccl:print-call-history :count frames :stream *standard-output* :detailed-p nil)
92cd9ad move implementation specific code to wrappers.lisp
Shawn authored
192
854b572 fix run-prog, run-prog-collect-output and print-backtrace ccl support
Philip Fominykh authored
193 #-(or sbcl clisp ccl) (write-line "Sorry, no backtrace for you."))
92cd9ad move implementation specific code to wrappers.lisp
Shawn authored
194
195 (defun bytes-to-string (data)
196 "Convert a list of bytes into a string."
3834c21 @vtl Handle convert errors in bytes-to-string
vtl authored
197 #+sbcl (handler-bind
198 ((sb-impl::octet-decoding-error #'(lambda (c) (invoke-restart 'use-value "?"))))
199 (sb-ext:octets-to-string
200 (make-array (length data) :element-type '(unsigned-byte 8) :initial-contents data)))
92cd9ad move implementation specific code to wrappers.lisp
Shawn authored
201 #+clisp
202 (ext:convert-string-from-bytes
203 (make-array (length data) :element-type '(unsigned-byte 8) :initial-contents data)
204 custom:*terminal-encoding*)
205 #-(or sbcl clisp)
206 (map 'list #'code-char string))
207
208 (defun string-to-bytes (string)
209 "Convert a string to a vector of octets."
210 #+sbcl
211 (sb-ext:string-to-octets string)
212 #+clisp
213 (ext:convert-string-to-bytes string custom:*terminal-encoding*)
214 #-(or sbcl clisp)
215 (map 'list #'char-code string))
216
217 (defun utf8-to-string (octets)
218 "Convert the list of octets to a string."
bb7181f handle bad utf-8 codes when decoding strings in sbcl
Shawn authored
219 #+sbcl (handler-bind
220 ((sb-impl::octet-decoding-error #'(lambda (c) (invoke-restart 'use-value "?"))))
221 (sb-ext:octets-to-string
222 (coerce octets '(vector (unsigned-byte 8)))
223 :external-format :utf-8))
92cd9ad move implementation specific code to wrappers.lisp
Shawn authored
224 #+clisp (ext:convert-string-from-bytes (coerce octets '(vector (unsigned-byte 8)))
225 charset:utf-8)
226 #-(or sbcl clisp)
227 (map 'string #'code-char octets))
228
229 (defun string-to-utf8 (string)
230 "Convert the string to a vector of octets."
231 #+sbcl (sb-ext:string-to-octets
232 string
233 :external-format :utf-8)
234 #+clisp (ext:convert-string-to-bytes string charset:utf-8)
235 #-(or sbcl clisp)
236 (map 'list #'char-code string))
a831cd9 workaround the clx pixmap/window error
Shawn authored
237
238 (defun make-xlib-window (xobject)
239 "For some reason the clx xid cache screws up returns pixmaps when
240 they should be windows. So use this function to make a window out of them."
241 #+clisp (make-instance 'xlib:window :id (slot-value xobject 'xlib::id) :display *display*)
242 #+sbcl (xlib::make-window :id (slot-value xobject 'xlib::id) :display *display*)
243 #-(or sbcl clisp)
2a9c0ab Defined not-implemented condition.
Morgan Veyret authored
244 (error 'not-implemented))
dcc9ad1 add workaround for clx xid cache bug for sbcl
Shawn authored
245
e66214c fix the pixmap/window error for sbcl and clisp
Shawn authored
246 ;; Right now clisp and sbcl both work the same way
247 (defun lookup-error-recoverable-p ()
5a49b9e properly find the :one restart when recovering from a xlib:lookup-error
Shawn authored
248 #+(or clisp sbcl) (find :one (compute-restarts) :key 'restart-name)
e66214c fix the pixmap/window error for sbcl and clisp
Shawn authored
249 #-(or clisp sbcl) nil)
250
251 (defun recover-from-lookup-error ()
252 #+(or clisp sbcl) (invoke-restart :one)
2a9c0ab Defined not-implemented condition.
Morgan Veyret authored
253 #-(or clisp sbcl) (error 'not-implemented))
dcc9ad1 add workaround for clx xid cache bug for sbcl
Shawn authored
254
ecbfd60 @blitz Add FreeBSD to the clisp hack. This should only influence contrib mod…
blitz authored
255 ;;; CLISP does not include features to distinguish different Unix
256 ;;; flavours (at least until version 2.46). Until this is fixed, use a
257 ;;; hack to determine them.
b0710fa @blitz Move hack for missing :linux feature on clisp into wrappers.lisp
blitz authored
258
ecbfd60 @blitz Add FreeBSD to the clisp hack. This should only influence contrib mod…
blitz authored
259 #+ (and clisp (not (or linux freebsd)))
b0710fa @blitz Move hack for missing :linux feature on clisp into wrappers.lisp
blitz authored
260 (eval-when (eval load compile)
7a745e2 @86me in wrappers.lisp use the posix instead of os package
86me authored
261 (let ((osname (posix:uname-sysname (posix:uname))))
ecbfd60 @blitz Add FreeBSD to the clisp hack. This should only influence contrib mod…
blitz authored
262 (cond
263 ((string= osname "Linux") (pushnew :linux *features*))
264 ((string= osname "FreeBSD") (pushnew :freebsd *features*))
265 (t (warn "Your operating system is not recognized.")))))
b0710fa @blitz Move hack for missing :linux feature on clisp into wrappers.lisp
blitz authored
266
80123d1 @blitz Added SBCL sysfs workaround.
blitz authored
267 ;;; On GNU/Linux some contribs use sysfs to figure out useful info for
268 ;;; the user. SBCL upto at least 1.0.16 (but probably much later) has
269 ;;; a problem handling files in sysfs caused by SBCL's slightly
270 ;;; unusual handling of files in general and Linux' sysfs violating
271 ;;; POSIX. When this situation is resolved, this function may be removed.
272 #+ linux
273 (export '(read-line-from-sysfs))
274
275 #+ linux
276 (defun read-line-from-sysfs (stream &optional (blocksize 80))
277 "READ-LINE, but with a workaround for a known SBCL/Linux bug
278 regarding files in sysfs. Data is read in chunks of BLOCKSIZE bytes."
279 #- sbcl
58f84ef @blitz Fixed read-line-from-sysfs for non-SBCL CLs.
blitz authored
280 (declare (ignore blocksize))
281 #- sbcl
282 (read-line stream)
80123d1 @blitz Added SBCL sysfs workaround.
blitz authored
283 #+ sbcl
284 (let ((buf (make-array blocksize
285 :element-type '(unsigned-byte 8)
286 :initial-element 0))
287 (fd (sb-sys:fd-stream-fd stream))
288 (string-filled 0)
289 (string (make-string blocksize))
290 bytes-read
291 pos
292 (stringlen blocksize))
293
294 (loop
295 ; Read in the raw bytes
296 (setf bytes-read
297 (sb-unix:unix-read fd (sb-sys:vector-sap buf) blocksize))
298
299 ; This is # bytes both read and in the correct line.
300 (setf pos (or (position (char-code #\Newline) buf) bytes-read))
301
302 ; Resize the string if necessary.
303 (when (> (+ pos string-filled) stringlen)
304 (setf stringlen (max (+ pos string-filled)
305 (* 2 stringlen)))
306 (let ((new (make-string stringlen)))
307 (replace new string)
308 (setq string new)))
309
310 ; Translate read bytes to string
311 (setf (subseq string string-filled)
312 (sb-ext:octets-to-string (subseq buf 0 pos)))
313
314 (incf string-filled pos)
315
316 (if (< pos blocksize)
317 (return (subseq string 0 string-filled))))))
318
319 ;;; EOF
Something went wrong with that request. Please try again.