os.lisp 17.2 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
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
    (not-implemented-error 'getenv))
116

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)
129
    '(not-implemented-error '(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
        #+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 "
232
233
234
235
236
237
        ;; 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)
238
239
240
        s))))

  (defun implementation-identifier ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
241
242
    "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."
243
244
245
246
    (substitute-if
     #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
     (format nil "~(~a~@{~@[-~a~]~}~)"
             (or (implementation-type) (lisp-implementation-type))
247
             (lisp-version-string)
248
249
             (or (operating-system) (software-type))
             (or (architecture) (machine-type))))))
250
251
252
253


;;;; Other system information

254
255
(with-upgradability ()
  (defun hostname ()
256
    "return the hostname of the current host"
257
    ;; Note: untested on RMCL
258
    #+(or abcl clasp clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
259
260
261
262
    #+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)))
263

264
265

;;; Current directory
266
267
(with-upgradability ()

268
  #+cmucl
269
  (defun parse-unix-namestring* (unix-namestring)
270
    "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object"
271
272
273
274
275
276
277
    (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"
278
    (or #+(or abcl genera xcl) (truename *default-pathname-defaults*) ;; d-p-d is canonical!
279
280
281
        #+allegro (excl::current-directory)
        #+clisp (ext:default-directory)
        #+clozure (ccl:current-directory)
282
        #+(or cmucl scl) (#+cmucl parse-unix-namestring* #+scl lisp::parse-unix-namestring
283
284
                        (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
285
        #+(or clasp ecl) (ext:getcwd)
286
        #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p""))
287
        #+lispworks (hcl:get-working-directory)
288
289
290
        #+mkcl (mk-ext:getcwd)
        #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
        #+xcl (extensions:current-directory)
291
        (not-implemented-error 'getcwd)))
292
293
294
295

  (defun chdir (x)
    "Change current directory, as per POSIX chdir(2), to a given pathname object"
    (if-let (x (pathname x))
296
      #+(or abcl genera xcl) (setf *default-pathname-defaults* (truename x)) ;; d-p-d is canonical!
297
298
299
      #+allegro (excl:chdir x)
      #+clisp (ext:cd x)
      #+clozure (setf (ccl:current-directory) x)
300
      #+(or cmucl scl) (unix:unix-chdir (ext:unix-namestring x))
301
302
      #+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
303
      #+(or clasp ecl) (ext:chdir x)
304
305
306
307
      #+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)))
308
      #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl)
309
      (not-implemented-error 'chdir))))
310

311
312
313
314
315
316
317

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

318
#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it
319
(with-upgradability ()
320
321
322
323
  (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)
324
325
    "Read a null-terminated string from an octet stream S"
    ;; note: doesn't play well with UNICODE
326
327
328
329
330
331
    (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))
332
333
    "Read a number in little-endian format from an byte (octet) stream S,
the number having BYTES octets (defaulting to 4)."
334
335
336
337
    (loop :for i :from 0 :below bytes
          :sum (ash (read-byte s) (* 8 i))))

  (defun parse-file-location-info (s)
338
    "helper to parse-windows-shortcut"
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
    (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)
362
363
    "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.
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
    (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)))))
393

394