os.lisp 17.6 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
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)
Daniel Kochmański's avatar
Daniel Kochmański committed
72
                                         (:genera . os-genera-p) (:os-oldmac . os-oldmac-p)
73
74
                                         (:haiku . os-haiku-p)
                                         (:mezzano . os-mezzano-p))
75
76
           :when (and (or (not o) (eq feature :os-macosx)) (funcall detect))
           :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
124
125
    "Set an environment variable."
      (declare (ignorable x val))
    #+allegro `(setf (sys:getenv ,x) ,val)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
126
    #+clisp `(system::setenv ,x ,val)
Robert P. Goldman's avatar
Robert P. Goldman committed
127
    #+clozure `(ccl:setenv ,x ,val)
128
    #+cmucl `(unix:unix-setenv ,x ,val 1)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
129
    #+ecl `(ext:setenv ,x ,val)
Robert P. Goldman's avatar
Robert P. Goldman committed
130
131
132
    #+lispworks `(hcl:setenv ,x ,val)
    #+mkcl `(mkcl:setenv ,x ,val)
    #+sbcl `(progn (require :sb-posix) (symbol-call :sb-posix :setenv ,x ,val 1))
133
    #-(or allegro clisp clozure cmucl ecl lispworks mkcl sbcl)
134
    '(not-implemented-error '(setf getenv)))
Robert P. Goldman's avatar
Robert P. Goldman committed
135

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

141

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

148
149
(with-upgradability ()
  (defun first-feature (feature-sets)
150
    "A helper for various feature detection functions"
151
152
153
154
155
156
157
158
159
    (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 ()
160
    "The type of Lisp implementation used, as a short UIOP-standardized keyword"
161
162
    (first-feature
     '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
163
       (:cmu :cmucl :cmu) :clasp :ecl :gcl
164
       (:lwpe :lispworks-personal-edition) (:lw :lispworks)
165
       :mcl :mezzano :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
166

167
168
  (defvar *implementation-type* (implementation-type)
    "The type of Lisp implementation used, as a short UIOP-standardized keyword")
169
170

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

  (defun architecture ()
184
    "The CPU architecture of the current host"
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
    (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 ()
205
    "return a string that identifies the current Lisp implementation version"
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
    (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))
226
        #+cmucl (substitute #\- #\/ s)
227
228
229
        #+scl (format nil "~A~A" s
                      ;; ANSI upper case vs lower case.
                      (ecase ext:*case-mode* (:upper "") (:lower "l")))
230
231
        #+ecl (format nil "~A~@[-~A~]" s
                      (let ((vcs-id (ext:lisp-implementation-vcs-id)))
232
233
                        (unless (equal vcs-id "UNKNOWN")
                          (subseq vcs-id 0 (min (length vcs-id) 8)))))
234
235
236
237
238
        #+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 "
239
240
241
        #+mezzano (format nil "~A-~D"
                          (subseq s 0 (position #\space s)) ; strip commit hash
                          sys.int::*llf-version*)
242
243
244
245
246
247
        ;; 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)
248
249
250
        s))))

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


;;;; Other system information

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

273
274

;;; Current directory
275
276
(with-upgradability ()

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

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

320
321
322
323
324
325
326

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

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

  (defun parse-file-location-info (s)
347
    "helper to parse-windows-shortcut"
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
    (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)
371
372
    "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.
373
374
375
376
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
    (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)))))
402

403