os.lisp - clic - Clic is an command line interactive client for gopher written … | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
os.lisp (18098B) | |
--- | |
1 ;;;; -------------------------------------------------------------------… | |
2 ;;;; Access to the Operating System | |
3 | |
4 (uiop/package:define-package :uiop/os | |
5 (:use :uiop/common-lisp :uiop/package :uiop/utility) | |
6 (:export | |
7 #:featurep #:os-unix-p #:os-macosx-p #:os-windows-p #:os-genera-p #:d… | |
8 #:os-cond | |
9 #:getenv #:getenvp ;; environment variables | |
10 #:implementation-identifier ;; implementation identifier | |
11 #:implementation-type #:*implementation-type* | |
12 #:operating-system #:architecture #:lisp-version-string | |
13 #:hostname #:getcwd #:chdir | |
14 ;; Windows shortcut support | |
15 #:read-null-terminated-string #:read-little-endian | |
16 #:parse-file-location-info #:parse-windows-shortcut)) | |
17 (in-package :uiop/os) | |
18 | |
19 ;;; Features | |
20 (with-upgradability () | |
21 (defun featurep (x &optional (*features* *features*)) | |
22 "Checks whether a feature expression X is true with respect to the *… | |
23 as per the CLHS standard for #+ and #-. Beware that just like the CLHS, | |
24 we assume symbols from the KEYWORD package are used, but that unless you… | |
25 your reader will not have magically used the KEYWORD package, so you nee… | |
26 keywords explicitly." | |
27 (cond | |
28 ((atom x) (and (member x *features*) t)) | |
29 ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x… | |
30 ((eq :or (car x)) (some #'featurep (cdr x))) | |
31 ((eq :and (car x)) (every #'featurep (cdr x))) | |
32 (t (parameter-error "~S: malformed feature specification ~S" 'feat… | |
33 | |
34 ;; Starting with UIOP 3.1.5, these are runtime tests. | |
35 ;; You may bind *features* with a copy of what your target system offe… | |
36 (defun os-macosx-p () | |
37 "Is the underlying operating system MacOS X?" | |
38 ;; OS-MACOSX is not mutually exclusive with OS-UNIX, | |
39 ;; in fact the former implies the latter. | |
40 (featurep '(:or :darwin (:and :allegro :macosx) (:and :clisp :macos)… | |
41 | |
42 (defun os-unix-p () | |
43 "Is the underlying operating system some Unix variant?" | |
44 (or (featurep '(:or :unix :cygwin)) (os-macosx-p))) | |
45 | |
46 (defun os-windows-p () | |
47 "Is the underlying operating system Microsoft Windows?" | |
48 (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :m… | |
49 | |
50 (defun os-genera-p () | |
51 "Is the underlying operating system Genera (running on a Symbolics L… | |
52 (featurep :genera)) | |
53 | |
54 (defun os-oldmac-p () | |
55 "Is the underlying operating system an (emulated?) MacOS 9 or earlie… | |
56 (featurep :mcl)) | |
57 | |
58 (defun os-haiku-p () | |
59 "Is the underlying operating system Haiku?" | |
60 (featurep :haiku)) | |
61 | |
62 (defun os-mezzano-p () | |
63 "Is the underlying operating system Mezzano?" | |
64 (featurep :mezzano)) | |
65 | |
66 (defun detect-os () | |
67 "Detects the current operating system. Only needs be run at compile-… | |
68 except on ABCL where it might change between FASL compilation and runtim… | |
69 (loop* :with o | |
70 :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-mac… | |
71 (:os-windows . os-windows-p) | |
72 (:genera . os-genera-p) (:os-ol… | |
73 (:haiku . os-haiku-p) | |
74 (:mezzano . os-mezzano-p)) | |
75 :when (and (or (not o) (eq feature :os-macosx)) (funcall dete… | |
76 :do (setf o feature) (pushnew feature *features*) | |
77 :else :do (setf *features* (remove feature *features*)) | |
78 :finally | |
79 (return (or o (error "Congratulations for trying ASDF on an o… | |
80 that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now … | |
81 | |
82 (defmacro os-cond (&rest clauses) | |
83 #+abcl `(cond ,@clauses) | |
84 #-abcl (loop* :for (test . body) :in clauses :when (eval test) :retu… | |
85 | |
86 (detect-os)) | |
87 | |
88 ;;;; Environment variables: getting them, and parsing them. | |
89 (with-upgradability () | |
90 (defun getenv (x) | |
91 "Query the environment, as in C getenv. | |
92 Beware: may return empty string if a variable is present but empty; | |
93 use getenvp to return NIL in such a case." | |
94 (declare (ignorable x)) | |
95 #+(or abcl clasp clisp ecl xcl) (ext:getenv x) | |
96 #+allegro (sys:getenv x) | |
97 #+clozure (ccl:getenv x) | |
98 #+cmucl (unix:unix-getenv x) | |
99 #+scl (cdr (assoc x ext:*environment-list* :test #'string=)) | |
100 #+cormanlisp | |
101 (let* ((buffer (ct:malloc 1)) | |
102 (cname (ct:lisp-string-to-c-string x)) | |
103 (needed-size (win:getenvironmentvariable cname buffer 0)) | |
104 (buffer1 (ct:malloc (1+ needed-size)))) | |
105 (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed… | |
106 nil | |
107 (ct:c-string-to-lisp-string buffer1)) | |
108 (ct:free buffer) | |
109 (ct:free buffer1))) | |
110 #+gcl (system:getenv x) | |
111 #+(or genera mezzano) nil | |
112 #+lispworks (lispworks:environment-variable x) | |
113 #+mcl (ccl:with-cstrs ((name x)) | |
114 (let ((value (_getenv name))) | |
115 (unless (ccl:%null-ptr-p value) | |
116 (ccl:%get-cstring value)))) | |
117 #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :… | |
118 #+sbcl (sb-ext:posix-getenv x) | |
119 #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl gene… | |
120 (not-implemented-error 'getenv)) | |
121 | |
122 (defsetf getenv (x) (val) | |
123 "Set an environment variable." | |
124 (declare (ignorable x val)) | |
125 #+allegro `(setf (sys:getenv ,x) ,val) | |
126 #+clasp `(ext:setenv ,x ,val) | |
127 #+clisp `(system::setenv ,x ,val) | |
128 #+clozure `(ccl:setenv ,x ,val) | |
129 #+cmucl `(unix:unix-setenv ,x ,val 1) | |
130 #+(or ecl clasp) `(ext:setenv ,x ,val) | |
131 #+lispworks `(setf (lispworks:environment-variable ,x) ,val) | |
132 #+mkcl `(mkcl:setenv ,x ,val) | |
133 #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x… | |
134 #-(or allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl) | |
135 '(not-implemented-error '(setf getenv))) | |
136 | |
137 (defun getenvp (x) | |
138 "Predicate that is true if the named variable is present in the libc… | |
139 then returning the non-empty string value of the variable" | |
140 (let ((g (getenv x))) (and (not (emptyp g)) g)))) | |
141 | |
142 | |
143 ;;;; implementation-identifier | |
144 ;; | |
145 ;; produce a string to identify current implementation. | |
146 ;; Initially stolen from SLIME's SWANK, completely rewritten since. | |
147 ;; We're back to runtime checking, for the sake of e.g. ABCL. | |
148 | |
149 (with-upgradability () | |
150 (defun first-feature (feature-sets) | |
151 "A helper for various feature detection functions" | |
152 (dolist (x feature-sets) | |
153 (multiple-value-bind (short long feature-expr) | |
154 (if (consp x) | |
155 (values (first x) (second x) (cons :or (rest x))) | |
156 (values x x x)) | |
157 (when (featurep feature-expr) | |
158 (return (values short long)))))) | |
159 | |
160 (defun implementation-type () | |
161 "The type of Lisp implementation used, as a short UIOP-standardized … | |
162 (first-feature | |
163 '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) | |
164 (:cmu :cmucl :cmu) :clasp :ecl :gcl | |
165 (:lwpe :lispworks-personal-edition) (:lw :lispworks) | |
166 :mcl :mezzano :mkcl :sbcl :scl (:smbx :symbolics) :xcl))) | |
167 | |
168 (defvar *implementation-type* (implementation-type) | |
169 "The type of Lisp implementation used, as a short UIOP-standardized … | |
170 | |
171 (defun operating-system () | |
172 "The operating system of the current host" | |
173 (first-feature | |
174 '(:cygwin | |
175 (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! | |
176 (:linux :linux :linux-target) ;; for GCL at least, must appear be… | |
177 (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd | |
178 (:solaris :solaris :sunos) | |
179 (:bsd :bsd :freebsd :netbsd :openbsd :dragonfly) | |
180 :unix | |
181 :genera | |
182 :mezzano))) | |
183 | |
184 (defun architecture () | |
185 "The CPU architecture of the current host" | |
186 (first-feature | |
187 '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :p… | |
188 (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :ia… | |
189 (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :… | |
190 :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc) | |
191 :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach | |
192 ;; Java comes last: if someone uses C via CFFI or otherwise JNA o… | |
193 ;; we may have to segregate the code still by architecture. | |
194 (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))) | |
195 | |
196 #+clozure | |
197 (defun ccl-fasl-version () | |
198 ;; the fasl version is target-dependent from CCL 1.8 on. | |
199 (or (let ((s 'ccl::target-fasl-version)) | |
200 (and (fboundp s) (funcall s))) | |
201 (and (boundp 'ccl::fasl-version) | |
202 (symbol-value 'ccl::fasl-version)) | |
203 (error "Can't determine fasl version."))) | |
204 | |
205 (defun lisp-version-string () | |
206 "return a string that identifies the current Lisp implementation ver… | |
207 (let ((s (lisp-implementation-version))) | |
208 (car ; as opposed to OR, this idiom prevents some unreachable code… | |
209 (list | |
210 #+allegro | |
211 (format nil "~A~@[~A~]~@[~A~]~@[~A~]" | |
212 excl::*common-lisp-version-number* | |
213 ;; M means "modern", as opposed to ANSI-compatible mode … | |
214 (and (eq excl:*current-case-mode* :case-sensitive-lower)… | |
215 ;; Note if not using International ACL | |
216 ;; see http://www.franz.com/support/documentation/8.1/do… | |
217 (excl:ics-target-case (:-ics "8")) | |
218 (and (member :smp *features*) "S")) | |
219 #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) | |
220 #+clisp | |
221 (subseq s 0 (position #\space s)) ; strip build information (dat… | |
222 #+clozure | |
223 (format nil "~d.~d-f~d" ; shorten for windows | |
224 ccl::*openmcl-major-version* | |
225 ccl::*openmcl-minor-version* | |
226 (logand (ccl-fasl-version) #xFF)) | |
227 #+cmucl (substitute #\- #\/ s) | |
228 #+scl (format nil "~A~A" s | |
229 ;; ANSI upper case vs lower case. | |
230 (ecase ext:*case-mode* (:upper "") (:lower "l"))) | |
231 #+ecl (format nil "~A~@[-~A~]" s | |
232 (let ((vcs-id (ext:lisp-implementation-vcs-id))) | |
233 (unless (equal vcs-id "UNKNOWN") | |
234 (subseq vcs-id 0 (min (length vcs-id) 8))))) | |
235 #+gcl (subseq s (1+ (position #\space s))) | |
236 #+genera | |
237 (multiple-value-bind (major minor) (sct:get-system-version "Syst… | |
238 (format nil "~D.~D" major minor)) | |
239 #+mcl (subseq s 8) ; strip the leading "Version " | |
240 #+mezzano (format nil "~A-~D" | |
241 (subseq s 0 (position #\space s)) ; strip comm… | |
242 sys.int::*llf-version*) | |
243 ;; seems like there should be a shorter way to do this, like ACA… | |
244 #+mkcl (or | |
245 (let ((fname (find-symbol* '#:git-describe-this-mkcl :mk… | |
246 (when (and fname (fboundp fname)) | |
247 (funcall fname))) | |
248 s) | |
249 s)))) | |
250 | |
251 (defun implementation-identifier () | |
252 "Return a string that identifies the ABI of the current implementati… | |
253 suitable for use as a directory name to segregate Lisp FASLs, C dynamic … | |
254 (substitute-if | |
255 #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) | |
256 (format nil "~(~a~@{~@[-~a~]~}~)" | |
257 (or (implementation-type) (lisp-implementation-type)) | |
258 (lisp-version-string) | |
259 (or (operating-system) (software-type)) | |
260 (or (architecture) (machine-type)))))) | |
261 | |
262 | |
263 ;;;; Other system information | |
264 | |
265 (with-upgradability () | |
266 (defun hostname () | |
267 "return the hostname of the current host" | |
268 #+(or abcl clasp clozure cmucl ecl genera lispworks mcl mezzano mkcl… | |
269 #+cormanlisp "localhost" ;; is there a better way? Does it matter? | |
270 #+allegro (symbol-call :excl.osi :gethostname) | |
271 #+clisp (first (split-string (machine-instance) :separator " ")) | |
272 #+gcl (system:gethostname))) | |
273 | |
274 | |
275 ;;; Current directory | |
276 (with-upgradability () | |
277 | |
278 #+cmucl | |
279 (defun parse-unix-namestring* (unix-namestring) | |
280 "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname obje… | |
281 (multiple-value-bind (host device directory name type version) | |
282 (lisp::parse-unix-namestring unix-namestring 0 (length unix-name… | |
283 (make-pathname :host (or host lisp::*unix-host*) :device device | |
284 :directory directory :name name :type type :version… | |
285 | |
286 (defun getcwd () | |
287 "Get the current working directory as per POSIX getcwd(3), as a path… | |
288 (or #+(or abcl genera mezzano xcl) (truename *default-pathname-defau… | |
289 #+allegro (excl::current-directory) | |
290 #+clisp (ext:default-directory) | |
291 #+clozure (ccl:current-directory) | |
292 #+(or cmucl scl) (#+cmucl parse-unix-namestring* #+scl lisp::par… | |
293 (strcat (nth-value 1 (unix:unix-current-director… | |
294 #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what t… | |
295 #+(or clasp ecl) (ext:getcwd) | |
296 #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p"")) | |
297 #+lispworks (hcl:get-working-directory) | |
298 #+mkcl (mk-ext:getcwd) | |
299 #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/)) | |
300 #+xcl (extensions:current-directory) | |
301 (not-implemented-error 'getcwd))) | |
302 | |
303 (defun chdir (x) | |
304 "Change current directory, as per POSIX chdir(2), to a given pathnam… | |
305 (if-let (x (pathname x)) | |
306 #+(or abcl genera mezzano xcl) (setf *default-pathname-defaults* (… | |
307 #+allegro (excl:chdir x) | |
308 #+clisp (ext:cd x) | |
309 #+clozure (setf (ccl:current-directory) x) | |
310 #+(or cmucl scl) (unix:unix-chdir (ext:unix-namestring x)) | |
311 #+cormanlisp (unless (zerop (win32::_chdir (namestring x))) | |
312 (error "Could not set current directory to ~A" x)) | |
313 #+ecl (ext:chdir x) | |
314 #+clasp (ext:chdir x t) | |
315 #+gcl (system:chdir x) | |
316 #+lispworks (hcl:change-directory x) | |
317 #+mkcl (mk-ext:chdir x) | |
318 #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (s… | |
319 #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl ge… | |
320 (not-implemented-error 'chdir)))) | |
321 | |
322 | |
323 ;;;; ----------------------------------------------------------------- | |
324 ;;;; Windows shortcut support. Based on: | |
325 ;;;; | |
326 ;;;; Jesse Hager: The Windows Shortcut File Format. | |
327 ;;;; http://www.wotsit.org/list.asp?fc=13 | |
328 | |
329 #-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys ol… | |
330 (with-upgradability () | |
331 (defparameter *link-initial-dword* 76) | |
332 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) | |
333 | |
334 (defun read-null-terminated-string (s) | |
335 "Read a null-terminated string from an octet stream S" | |
336 ;; note: doesn't play well with UNICODE | |
337 (with-output-to-string (out) | |
338 (loop :for code = (read-byte s) | |
339 :until (zerop code) | |
340 :do (write-char (code-char code) out)))) | |
341 | |
342 (defun read-little-endian (s &optional (bytes 4)) | |
343 "Read a number in little-endian format from an byte (octet) stream S, | |
344 the number having BYTES octets (defaulting to 4)." | |
345 (loop :for i :from 0 :below bytes | |
346 :sum (ash (read-byte s) (* 8 i)))) | |
347 | |
348 (defun parse-file-location-info (s) | |
349 "helper to parse-windows-shortcut" | |
350 (let ((start (file-position s)) | |
351 (total-length (read-little-endian s)) | |
352 (end-of-header (read-little-endian s)) | |
353 (fli-flags (read-little-endian s)) | |
354 (local-volume-offset (read-little-endian s)) | |
355 (local-offset (read-little-endian s)) | |
356 (network-volume-offset (read-little-endian s)) | |
357 (remaining-offset (read-little-endian s))) | |
358 (declare (ignore total-length end-of-header local-volume-offset)) | |
359 (unless (zerop fli-flags) | |
360 (cond | |
361 ((logbitp 0 fli-flags) | |
362 (file-position s (+ start local-offset))) | |
363 ((logbitp 1 fli-flags) | |
364 (file-position s (+ start | |
365 network-volume-offset | |
366 #x14)))) | |
367 (strcat (read-null-terminated-string s) | |
368 (progn | |
369 (file-position s (+ start remaining-offset)) | |
370 (read-null-terminated-string s)))))) | |
371 | |
372 (defun parse-windows-shortcut (pathname) | |
373 "From a .lnk windows shortcut, extract the pathname linked to" | |
374 ;; NB: doesn't do much checking & doesn't look like it will work wel… | |
375 (with-open-file (s pathname :element-type '(unsigned-byte 8)) | |
376 (handler-case | |
377 (when (and (= (read-little-endian s) *link-initial-dword*) | |
378 (let ((header (make-array (length *link-guid*)))) | |
379 (read-sequence header s) | |
380 (equalp header *link-guid*))) | |
381 (let ((flags (read-little-endian s))) | |
382 (file-position s 76) ;skip rest of header | |
383 (when (logbitp 0 flags) | |
384 ;; skip shell item id list | |
385 (let ((length (read-little-endian s 2))) | |
386 (file-position s (+ length (file-position s))))) | |
387 (cond | |
388 ((logbitp 1 flags) | |
389 (parse-file-location-info s)) | |
390 (t | |
391 (when (logbitp 2 flags) | |
392 ;; skip description string | |
393 (let ((length (read-little-endian s 2))) | |
394 (file-position s (+ length (file-position s))))) | |
395 (when (logbitp 3 flags) | |
396 ;; finally, our pathname | |
397 (let* ((length (read-little-endian s 2)) | |
398 (buffer (make-array length))) | |
399 (read-sequence buffer s) | |
400 (map 'string #'code-char buffer))))))) | |
401 (end-of-file (c) | |
402 (declare (ignore c)) | |
403 nil))))) | |
404 | |
405 |