os.lisp 17.8 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
      ((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)))
32
      (t (parameter-error "~S: malformed feature specification ~S" 'featurep 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
    (featurep '(:or :darwin (:and :allegro :macosx) (:and :clisp :macos))))

  (defun os-unix-p ()
    "Is the underlying operating system some Unix variant?"
Robert Goldman's avatar
Robert Goldman committed
44
    (or (featurep '(:or :unix :cygwin :haiku)) (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
63
64
65
  (defun os-mezzano-p ()
    "Is the underlying operating system Mezzano?"
    (featurep :mezzano))

66
  (defun detect-os ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
67
68
    "Detects the current operating system. Only needs be run at compile-time,
except on ABCL where it might change between FASL compilation and runtime."
69
    (loop* :with o
70
71
           :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-macosx . os-macosx-p)
                                         (:os-windows . os-windows-p)
Robert Goldman's avatar
Robert Goldman committed
72
73
74
75
                                         (:os-genera . os-genera-p) (:os-oldmac . os-oldmac-p)
                                         (:os-haiku . os-haiku-p)
                                         (:os-mezzano . os-mezzano-p))
           :when (and (or (not o) (eq feature :os-macosx) (eq feature :os-haiku)) (funcall detect))
76
           :do (setf o feature) (pushnew feature *features*)
77
           :else :do (setf *features* (remove feature *features*))
78
79
80
           :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.")))))
81

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

86
  (detect-os))
87
88

;;;; Environment variables: getting them, and parsing them.
89
90
(with-upgradability ()
  (defun getenv (x)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
91
92
93
    "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."
94
    (declare (ignorable x))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
95
    #+(or abcl clasp clisp ecl xcl) (ext:getenv x)
96
97
    #+allegro (sys:getenv x)
    #+clozure (ccl:getenv x)
98
    #+cmucl (unix:unix-getenv x)
99
    #+scl (cdr (assoc x ext:*environment-list* :test #'string=))
100
101
102
103
104
105
106
107
108
109
110
    #+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)
111
    #+(or genera mezzano) nil
112
113
114
115
116
117
118
    #+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)
119
    #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl)
120
    (not-implemented-error 'getenv))
121

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
122
  (defsetf getenv (x) (val)
Robert P. Goldman's avatar
Robert P. Goldman committed
123
    "Set an environment variable."
124
    (declare (ignorable x val))
Robert P. Goldman's avatar
Robert P. Goldman committed
125
    #+allegro `(setf (sys:getenv ,x) ,val)
126
    #+clasp `(ext:setenv ,x ,val)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
127
    #+clisp `(system::setenv ,x ,val)
Robert P. Goldman's avatar
Robert P. Goldman committed
128
    #+clozure `(ccl:setenv ,x ,val)
129
    #+cmucl `(unix:unix-setenv ,x ,val 1)
130
    #+(or ecl clasp) `(ext:setenv ,x ,val)
Robert Goldman's avatar
Robert Goldman committed
131
    #+lispworks `(setf (lispworks:environment-variable ,x) ,val)
Robert P. Goldman's avatar
Robert P. Goldman committed
132
133
    #+mkcl `(mkcl:setenv ,x ,val)
    #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1))
134
    #-(or allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl)
135
    '(not-implemented-error '(setf getenv)))
Robert P. Goldman's avatar
Robert P. Goldman committed
136

137
138
  (defun getenvp (x)
    "Predicate that is true if the named variable is present in the libc environment,
139
then returning the non-empty string value of the variable"
140
    (let ((g (getenv x))) (and (not (emptyp g)) g))))
141

142

143
144
145
146
147
148
;;;; 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.

149
150
(with-upgradability ()
  (defun first-feature (feature-sets)
151
    "A helper for various feature detection functions"
152
153
154
155
156
157
158
159
160
    (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 ()
161
    "The type of Lisp implementation used, as a short UIOP-standardized keyword"
162
163
    (first-feature
     '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
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
169
  (defvar *implementation-type* (implementation-type)
    "The type of Lisp implementation used, as a short UIOP-standardized keyword")
170
171

  (defun operating-system ()
172
    "The operating system of the current host"
173
    (first-feature
174
175
     '(:cygwin
       (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
176
177
       (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
       (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
178
179
180
       (:solaris :solaris :sunos)
       (:bsd :bsd :freebsd :netbsd :openbsd :dragonfly)
       :unix
181
182
       :genera
       :mezzano)))
183
184

  (defun architecture ()
185
    "The CPU architecture of the current host"
186
187
188
189
190
    (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)
Eric Timmons's avatar
Eric Timmons committed
191
192
193
       :mipsel :mipseb :mips :alpha
       (:arm64 :arm64 :aarch64 :armv8l :armv8b :aarch64_be :|aarch64|)
       (:arm :arm :arm-target) :vlm :imach
194
195
196
197
198
199
200
201
202
203
204
205
206
207
       ;; 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 ()
208
    "return a string that identifies the current Lisp implementation version"
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
    (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))
229
        #+cmucl (substitute #\- #\/ s)
230
231
232
        #+scl (format nil "~A~A" s
                      ;; ANSI upper case vs lower case.
                      (ecase ext:*case-mode* (:upper "") (:lower "l")))
233
234
        #+ecl (format nil "~A~@[-~A~]" s
                      (let ((vcs-id (ext:lisp-implementation-vcs-id)))
235
236
                        (unless (equal vcs-id "UNKNOWN")
                          (subseq vcs-id 0 (min (length vcs-id) 8)))))
237
238
239
240
241
        #+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 "
242
243
244
        #+mezzano (format nil "~A-~D"
                          (subseq s 0 (position #\space s)) ; strip commit hash
                          sys.int::*llf-version*)
245
246
247
248
249
250
        ;; seems like there should be a shorter way to do this, like ACALL.
        #+mkcl (or
                (let ((fname (find-symbol* '#:git-describe-this-mkcl :mkcl nil)))
                  (when (and fname (fboundp fname))
                    (funcall fname)))
                s)
251
252
253
        s))))

  (defun implementation-identifier ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
254
255
    "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."
256
257
258
259
    (substitute-if
     #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
     (format nil "~(~a~@{~@[-~a~]~}~)"
             (or (implementation-type) (lisp-implementation-type))
260
             (lisp-version-string)
261
262
             (or (operating-system) (software-type))
             (or (architecture) (machine-type))))))
263
264
265
266


;;;; Other system information

267
268
(with-upgradability ()
  (defun hostname ()
269
    "return the hostname of the current host"
270
    #+(or abcl clasp clozure cmucl ecl genera lispworks mcl mezzano mkcl sbcl scl xcl) (machine-instance)
271
272
273
274
    #+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)))
275

276
277

;;; Current directory
278
279
(with-upgradability ()

280
  #+cmucl
281
  (defun parse-unix-namestring* (unix-namestring)
282
    "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object"
283
284
285
286
287
288
289
    (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"
290
    (or #+(or abcl genera mezzano xcl) (truename *default-pathname-defaults*) ;; d-p-d is canonical!
291
292
293
        #+allegro (excl::current-directory)
        #+clisp (ext:default-directory)
        #+clozure (ccl:current-directory)
294
        #+(or cmucl scl) (#+cmucl parse-unix-namestring* #+scl lisp::parse-unix-namestring
295
296
                        (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
297
        #+(or clasp ecl) (ext:getcwd)
298
        #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p""))
299
        #+lispworks (hcl:get-working-directory)
300
301
302
        #+mkcl (mk-ext:getcwd)
        #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
        #+xcl (extensions:current-directory)
303
        (not-implemented-error 'getcwd)))
304
305
306
307

  (defun chdir (x)
    "Change current directory, as per POSIX chdir(2), to a given pathname object"
    (if-let (x (pathname x))
308
      #+(or abcl genera mezzano xcl) (setf *default-pathname-defaults* (truename x)) ;; d-p-d is canonical!
309
310
311
      #+allegro (excl:chdir x)
      #+clisp (ext:cd x)
      #+clozure (setf (ccl:current-directory) x)
312
      #+(or cmucl scl) (unix:unix-chdir (ext:unix-namestring x))
313
314
      #+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
                     (error "Could not set current directory to ~A" x))
315
316
      #+ecl (ext:chdir x)
      #+clasp (ext:chdir x t)
317
318
319
320
      #+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)))
321
      #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl)
322
      (not-implemented-error 'chdir))))
323

324
325
326
327
328
329
330

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

331
#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it
332
(with-upgradability ()
333
334
335
336
  (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)
337
338
    "Read a null-terminated string from an octet stream S"
    ;; note: doesn't play well with UNICODE
339
340
341
342
343
344
    (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))
345
346
    "Read a number in little-endian format from an byte (octet) stream S,
the number having BYTES octets (defaulting to 4)."
347
348
349
350
    (loop :for i :from 0 :below bytes
          :sum (ash (read-byte s) (* 8 i))))

  (defun parse-file-location-info (s)
351
    "helper to parse-windows-shortcut"
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
    (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)
375
376
    "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.
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
    (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)))))
406

407