os.lisp 17 KB
Newer Older
1
;;;; ---------------------------------------------------------------------------
2
3
;;;; Access to the Operating System

4
5
(uiop/package:define-package :uiop/os
  (:use :uiop/common-lisp :uiop/package :uiop/utility)
6
  (:export
7
   #:featurep #:os-unix-p #:os-macosx-p #:os-windows-p #:os-genera-p #:detect-os ;; features
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
8
   #:os-cond
9
   #:getenv #:getenvp ;; environment variables
10
   #:implementation-identifier ;; implementation identifier
11
12
   #:implementation-type #:*implementation-type*
   #:operating-system #:architecture #:lisp-version-string
13
14
15
16
   #:hostname #:getcwd #:chdir
   ;; Windows shortcut support
   #:read-null-terminated-string #:read-little-endian
   #:parse-file-location-info #:parse-windows-shortcut))
17
(in-package :uiop/os)
18
19

;;; Features
20
21
(with-upgradability ()
  (defun featurep (x &optional (*features* *features*))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
22
23
24
25
26
    "Checks whether a feature expression X is true with respect to the *FEATURES* set,
as per the CLHS standard for #+ and #-. Beware that just like the CLHS,
we assume symbols from the KEYWORD package are used, but that unless you're using #+/#-
your reader will not have magically used the KEYWORD package, so you need specify
keywords explicitly."
27
    (cond
28
29
30
31
32
      ((atom x) (and (member x *features*) t))
      ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x))))
      ((eq :or (car x)) (some #'featurep (cdr x)))
      ((eq :and (car x)) (every #'featurep (cdr x)))
      (t (error "Malformed feature specification ~S" x))))
33

34
35
  ;; Starting with UIOP 3.1.5, these are runtime tests.
  ;; You may bind *features* with a copy of what your target system offers to test its properties.
36
  (defun os-macosx-p ()
37
38
39
    "Is the underlying operating system MacOS X?"
    ;; OS-MACOSX is not mutually exclusive with OS-UNIX,
    ;; in fact the former implies the latter.
40
41
42
43
44
    (featurep '(:or :darwin (:and :allegro :macosx) (:and :clisp :macos))))

  (defun os-unix-p ()
    "Is the underlying operating system some Unix variant?"
    (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 :mingw32 :mingw64))))
49

50
  (defun os-genera-p ()
51
    "Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?"
52
    (featurep :genera))
53

54
  (defun os-oldmac-p ()
55
    "Is the underlying operating system an (emulated?) MacOS 9 or earlier?"
56
    (featurep :mcl))
57

Daniel Kochmański's avatar
Daniel Kochmański committed
58
59
60
61
  (defun os-haiku-p ()
    "Is the underlying operating system Haiku?"
    (featurep :haiku))

62
  (defun detect-os ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
63
64
    "Detects the current operating system. Only needs be run at compile-time,
except on ABCL where it might change between FASL compilation and runtime."
65
    (loop* :with o
66
67
           :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-macosx . os-macosx-p)
                                         (:os-windows . os-windows-p)
Daniel Kochmański's avatar
Daniel Kochmański committed
68
69
                                         (:genera . os-genera-p) (:os-oldmac . os-oldmac-p)
                                         (:haiku . os-haiku-p))
70
71
           :when (and (or (not o) (eq feature :os-macosx)) (funcall detect))
           :do (setf o feature) (pushnew feature *features*)
72
           :else :do (setf *features* (remove feature *features*))
73
74
75
           :finally
           (return (or o (error "Congratulations for trying ASDF on an operating system~%~
that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it.")))))
76

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
77
78
79
80
  (defmacro os-cond (&rest clauses)
    #+abcl `(cond ,@clauses)
    #-abcl (loop* :for (test . body) :in clauses :when (eval test) :return `(progn ,@body)))

81
  (detect-os))
82
83

;;;; Environment variables: getting them, and parsing them.
84
85
(with-upgradability ()
  (defun getenv (x)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
86
87
88
    "Query the environment, as in C getenv.
Beware: may return empty string if a variable is present but empty;
use getenvp to return NIL in such a case."
89
    (declare (ignorable x))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
90
    #+(or abcl clasp clisp ecl xcl) (ext:getenv x)
91
92
    #+allegro (sys:getenv x)
    #+clozure (ccl:getenv x)
93
    #+cmucl (unix:unix-getenv x)
94
    #+scl (cdr (assoc x ext:*environment-list* :test #'string=))
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
    #+cormanlisp
    (let* ((buffer (ct:malloc 1))
           (cname (ct:lisp-string-to-c-string x))
           (needed-size (win:getenvironmentvariable cname buffer 0))
           (buffer1 (ct:malloc (1+ needed-size))))
      (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
                 nil
                 (ct:c-string-to-lisp-string buffer1))
        (ct:free buffer)
        (ct:free buffer1)))
    #+gcl (system:getenv x)
    #+genera nil
    #+lispworks (lispworks:environment-variable x)
    #+mcl (ccl:with-cstrs ((name x))
            (let ((value (_getenv name)))
              (unless (ccl:%null-ptr-p value)
                (ccl:%get-cstring value))))
    #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x)
    #+sbcl (sb-ext:posix-getenv x)
114
    #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
115
116
    (error "~S is not supported on your implementation" 'getenv))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
117
  (defsetf getenv (x) (val)
Robert P. Goldman's avatar
Robert P. Goldman committed
118
119
120
    "Set an environment variable."
      (declare (ignorable x val))
    #+allegro `(setf (sys:getenv ,x) ,val)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
121
    #+clisp `(system::setenv ,x ,val)
Robert P. Goldman's avatar
Robert P. Goldman committed
122
    #+clozure `(ccl:setenv ,x ,val)
123
    #+cmucl `(unix:unix-setenv ,x ,val 1)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
124
    #+ecl `(ext:setenv ,x ,val)
Robert P. Goldman's avatar
Robert P. Goldman committed
125
126
127
    #+lispworks `(hcl:setenv ,x ,val)
    #+mkcl `(mkcl:setenv ,x ,val)
    #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1))
128
    #-(or allegro clisp clozure cmucl ecl lispworks mkcl sbcl)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
129
    '(error "~S ~S is not supported on your implementation" 'setf 'getenv))
Robert P. Goldman's avatar
Robert P. Goldman committed
130

131
132
  (defun getenvp (x)
    "Predicate that is true if the named variable is present in the libc environment,
133
then returning the non-empty string value of the variable"
134
    (let ((g (getenv x))) (and (not (emptyp g)) g))))
135

136

137
138
139
140
141
142
;;;; implementation-identifier
;;
;; produce a string to identify current implementation.
;; Initially stolen from SLIME's SWANK, completely rewritten since.
;; We're back to runtime checking, for the sake of e.g. ABCL.

143
144
(with-upgradability ()
  (defun first-feature (feature-sets)
145
    "A helper for various feature detection functions"
146
147
148
149
150
151
152
153
154
    (dolist (x feature-sets)
      (multiple-value-bind (short long feature-expr)
          (if (consp x)
              (values (first x) (second x) (cons :or (rest x)))
              (values x x x))
        (when (featurep feature-expr)
          (return (values short long))))))

  (defun implementation-type ()
155
    "The type of Lisp implementation used, as a short UIOP-standardized keyword"
156
157
    (first-feature
     '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
158
       (:cmu :cmucl :cmu) :clasp :ecl :gcl
159
160
161
       (:lwpe :lispworks-personal-edition) (:lw :lispworks)
       :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))

162
163
  (defvar *implementation-type* (implementation-type)
    "The type of Lisp implementation used, as a short UIOP-standardized keyword")
164
165

  (defun operating-system ()
166
    "The operating system of the current host"
167
    (first-feature
168
169
     '(:cygwin
       (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
170
171
       (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
       (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
172
173
174
       (:solaris :solaris :sunos)
       (:bsd :bsd :freebsd :netbsd :openbsd :dragonfly)
       :unix
175
176
177
       :genera)))

  (defun architecture ()
178
    "The CPU architecture of the current host"
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
    (first-feature
     '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386))
       (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
       (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
       :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
       :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
       ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
       ;; we may have to segregate the code still by architecture.
       (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))

  #+clozure
  (defun ccl-fasl-version ()
    ;; the fasl version is target-dependent from CCL 1.8 on.
    (or (let ((s 'ccl::target-fasl-version))
          (and (fboundp s) (funcall s)))
        (and (boundp 'ccl::fasl-version)
             (symbol-value 'ccl::fasl-version))
        (error "Can't determine fasl version.")))

  (defun lisp-version-string ()
199
    "return a string that identifies the current Lisp implementation version"
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
    (let ((s (lisp-implementation-version)))
      (car ; as opposed to OR, this idiom prevents some unreachable code warning
       (list
        #+allegro
        (format nil "~A~@[~A~]~@[~A~]~@[~A~]"
                excl::*common-lisp-version-number*
                ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default)
                (and (eq excl:*current-case-mode* :case-sensitive-lower) "M")
                ;; Note if not using International ACL
                ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
                (excl:ics-target-case (:-ics "8"))
                (and (member :smp *features*) "S"))
        #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
        #+clisp
        (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
        #+clozure
        (format nil "~d.~d-f~d" ; shorten for windows
                ccl::*openmcl-major-version*
                ccl::*openmcl-minor-version*
                (logand (ccl-fasl-version) #xFF))
220
        #+cmucl (substitute #\- #\/ s)
221
222
223
        #+scl (format nil "~A~A" s
                      ;; ANSI upper case vs lower case.
                      (ecase ext:*case-mode* (:upper "") (:lower "l")))
224
225
226
        #+ecl (format nil "~A~@[-~A~]" s
                      (let ((vcs-id (ext:lisp-implementation-vcs-id)))
                        (subseq vcs-id 0 (min (length vcs-id) 8))))
227
228
229
230
231
232
233
234
        #+gcl (subseq s (1+ (position #\space s)))
        #+genera
        (multiple-value-bind (major minor) (sct:get-system-version "System")
          (format nil "~D.~D" major minor))
        #+mcl (subseq s 8) ; strip the leading "Version "
        s))))

  (defun implementation-identifier ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
235
236
    "Return a string that identifies the ABI of the current implementation,
suitable for use as a directory name to segregate Lisp FASLs, C dynamic libraries, etc."
237
238
239
240
    (substitute-if
     #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
     (format nil "~(~a~@{~@[-~a~]~}~)"
             (or (implementation-type) (lisp-implementation-type))
241
             (lisp-version-string)
242
243
             (or (operating-system) (software-type))
             (or (architecture) (machine-type))))))
244
245
246
247


;;;; Other system information

248
249
(with-upgradability ()
  (defun hostname ()
250
    "return the hostname of the current host"
251
    ;; Note: untested on RMCL
252
    #+(or abcl clasp clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
253
254
255
256
    #+cormanlisp "localhost" ;; is there a better way? Does it matter?
    #+allegro (symbol-call :excl.osi :gethostname)
    #+clisp (first (split-string (machine-instance) :separator " "))
    #+gcl (system:gethostname)))
257

258
259

;;; Current directory
260
261
(with-upgradability ()

262
  #+cmucl
263
  (defun parse-unix-namestring* (unix-namestring)
264
    "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object"
265
266
267
268
269
270
271
    (multiple-value-bind (host device directory name type version)
        (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring))
      (make-pathname :host (or host lisp::*unix-host*) :device device
                     :directory directory :name name :type type :version version)))

  (defun getcwd ()
    "Get the current working directory as per POSIX getcwd(3), as a pathname object"
272
    (or #+(or abcl genera xcl) (truename *default-pathname-defaults*) ;; d-p-d is canonical!
273
274
275
        #+allegro (excl::current-directory)
        #+clisp (ext:default-directory)
        #+clozure (ccl:current-directory)
276
        #+(or cmucl scl) (#+cmucl parse-unix-namestring* #+scl lisp::parse-unix-namestring
277
278
                        (strcat (nth-value 1 (unix:unix-current-directory)) "/"))
        #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
279
        #+(or clasp ecl) (ext:getcwd)
280
        #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p""))
281
        #+lispworks (hcl:get-working-directory)
282
283
284
285
286
287
288
289
        #+mkcl (mk-ext:getcwd)
        #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
        #+xcl (extensions:current-directory)
        (error "getcwd not supported on your implementation")))

  (defun chdir (x)
    "Change current directory, as per POSIX chdir(2), to a given pathname object"
    (if-let (x (pathname x))
290
      #+(or abcl genera xcl) (setf *default-pathname-defaults* (truename x)) ;; d-p-d is canonical!
291
292
293
      #+allegro (excl:chdir x)
      #+clisp (ext:cd x)
      #+clozure (setf (ccl:current-directory) x)
294
      #+(or cmucl scl) (unix:unix-chdir (ext:unix-namestring x))
295
296
      #+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
                     (error "Could not set current directory to ~A" x))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
297
      #+(or clasp ecl) (ext:chdir x)
298
299
300
301
      #+gcl (system:chdir x)
      #+lispworks (hcl:change-directory x)
      #+mkcl (mk-ext:chdir x)
      #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x)))
302
      #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl)
303
      (error "chdir not supported on your implementation"))))
304

305
306
307
308
309
310
311

;;;; -----------------------------------------------------------------
;;;; Windows shortcut support.  Based on:
;;;;
;;;; Jesse Hager: The Windows Shortcut File Format.
;;;; http://www.wotsit.org/list.asp?fc=13

312
#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it
313
(with-upgradability ()
314
315
316
317
  (defparameter *link-initial-dword* 76)
  (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))

  (defun read-null-terminated-string (s)
318
319
    "Read a null-terminated string from an octet stream S"
    ;; note: doesn't play well with UNICODE
320
321
322
323
324
325
    (with-output-to-string (out)
      (loop :for code = (read-byte s)
            :until (zerop code)
            :do (write-char (code-char code) out))))

  (defun read-little-endian (s &optional (bytes 4))
326
327
    "Read a number in little-endian format from an byte (octet) stream S,
the number having BYTES octets (defaulting to 4)."
328
329
330
331
    (loop :for i :from 0 :below bytes
          :sum (ash (read-byte s) (* 8 i))))

  (defun parse-file-location-info (s)
332
    "helper to parse-windows-shortcut"
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
    (let ((start (file-position s))
          (total-length (read-little-endian s))
          (end-of-header (read-little-endian s))
          (fli-flags (read-little-endian s))
          (local-volume-offset (read-little-endian s))
          (local-offset (read-little-endian s))
          (network-volume-offset (read-little-endian s))
          (remaining-offset (read-little-endian s)))
      (declare (ignore total-length end-of-header local-volume-offset))
      (unless (zerop fli-flags)
        (cond
          ((logbitp 0 fli-flags)
           (file-position s (+ start local-offset)))
          ((logbitp 1 fli-flags)
           (file-position s (+ start
                               network-volume-offset
                               #x14))))
        (strcat (read-null-terminated-string s)
                (progn
                  (file-position s (+ start remaining-offset))
                  (read-null-terminated-string s))))))

  (defun parse-windows-shortcut (pathname)
356
357
    "From a .lnk windows shortcut, extract the pathname linked to"
    ;; NB: doesn't do much checking & doesn't look like it will work well with UNICODE.
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
    (with-open-file (s pathname :element-type '(unsigned-byte 8))
      (handler-case
          (when (and (= (read-little-endian s) *link-initial-dword*)
                     (let ((header (make-array (length *link-guid*))))
                       (read-sequence header s)
                       (equalp header *link-guid*)))
            (let ((flags (read-little-endian s)))
              (file-position s 76)        ;skip rest of header
              (when (logbitp 0 flags)
                ;; skip shell item id list
                (let ((length (read-little-endian s 2)))
                  (file-position s (+ length (file-position s)))))
              (cond
                ((logbitp 1 flags)
                 (parse-file-location-info s))
                (t
                 (when (logbitp 2 flags)
                   ;; skip description string
                   (let ((length (read-little-endian s 2)))
                     (file-position s (+ length (file-position s)))))
                 (when (logbitp 3 flags)
                   ;; finally, our pathname
                   (let* ((length (read-little-endian s 2))
                          (buffer (make-array length)))
                     (read-sequence buffer s)
                     (map 'string #'code-char buffer)))))))
        (end-of-file (c)
          (declare (ignore c))
          nil)))))
387

388