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

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

;;; Features
21
22
(with-upgradability ()
  (defun featurep (x &optional (*features* *features*))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
23
24
25
26
27
    "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."
28
    (cond
29
30
31
32
33
      ((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))))
34

35
  (defun os-unix-p ()
36
    "Is the underlying operating system some Unix variant?"
37
38
    (or #+abcl (featurep :unix)
        #+(and (not abcl) (or unix cygwin darwin)) t))
39

40
  (defun os-macosx-p ()
41
42
43
    "Is the underlying operating system MacOS X?"
    ;; OS-MACOSX is not mutually exclusive with OS-UNIX,
    ;; in fact the former implies the latter.
44
45
46
47
48
    (or
     #+allegro (featurep :macosx)
     #+clisp (featurep :macos)
     (featurep :darwin)))

49
  (defun os-windows-p ()
50
    "Is the underlying operating system Microsoft Windows?"
51
    (or #+abcl (featurep :windows)
52
        #+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
53

54
  (defun os-genera-p ()
55
    "Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?"
56
    (or #+genera t))
57

58
  (defun os-oldmac-p ()
59
    "Is the underlying operating system an (emulated?) MacOS 9 or earlier?"
60
61
    (or #+mcl t))

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
66
    (loop* :with o
           :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-windows . os-windows-p)
67
                                         (:os-macosx . os-macosx-p)
68
69
70
71
72
73
                                         (:genera . os-genera-p) (:os-oldmac . os-oldmac-p))
           :when (and (not o) (funcall detect)) :do (setf o feature) (pushnew o *features*)
           :else :do (setf *features* (remove feature *features*))
           :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.")))))
74
75

  (detect-os))
76
77
78

;;;; Environment variables: getting them, and parsing them.

79
80
(with-upgradability ()
  (defun getenv (x)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
81
82
83
    "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."
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
    (declare (ignorable x))
    #+(or abcl clisp ecl xcl) (ext:getenv x)
    #+allegro (sys:getenv x)
    #+clozure (ccl:getenv x)
    #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
    #+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)
    #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
    (error "~S is not supported on your implementation" 'getenv))

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

116

117
118
119
120
121
122
;;;; 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.

123
124
(with-upgradability ()
  (defun first-feature (feature-sets)
125
    "A helper for various feature detection functions"
126
127
128
129
130
131
132
133
134
    (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 ()
135
    "The type of Lisp implementation used, as a short UIOP-standardized keyword"
136
137
138
139
140
141
    (first-feature
     '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
       (:cmu :cmucl :cmu) :ecl :gcl
       (:lwpe :lispworks-personal-edition) (:lw :lispworks)
       :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))

142
143
  (defvar *implementation-type* (implementation-type)
    "The type of Lisp implementation used, as a short UIOP-standardized keyword")
144
145

  (defun operating-system ()
146
    "The operating system of the current host"
147
148
149
150
151
152
153
154
    (first-feature
     '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
       (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
       (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
       (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
       :genera)))

  (defun architecture ()
155
    "The CPU architecture of the current host"
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
    (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 ()
176
    "return a string that identifies the current Lisp implementation version"
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
    (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))
        #+cmu (substitute #\- #\/ s)
        #+scl (format nil "~A~A" s
                      ;; ANSI upper case vs lower case.
                      (ecase ext:*case-mode* (:upper "") (:lower "l")))
        #+ecl (format nil "~A~@[-~A~]" s
                      (let ((vcs-id (ext:lisp-implementation-vcs-id)))
                        (subseq vcs-id 0 (min (length vcs-id) 8))))
        #+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
212
213
    "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."
214
215
216
217
218
219
220
    (substitute-if
     #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
     (format nil "~(~a~@{~@[-~a~]~}~)"
             (or (implementation-type) (lisp-implementation-type))
             (or (lisp-version-string) (lisp-implementation-version))
             (or (operating-system) (software-type))
             (or (architecture) (machine-type))))))
221
222
223
224


;;;; Other system information

225
226
(with-upgradability ()
  (defun hostname ()
227
    "return the hostname of the current host"
228
    ;; Note: untested on RMCL
229
    #+(or abcl clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
230
231
232
233
    #+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)))
234

235
236

;;; Current directory
237
238
239
240
(with-upgradability ()

  #+cmu
  (defun parse-unix-namestring* (unix-namestring)
241
    "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object"
242
243
244
245
246
247
248
    (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"
249
250
251
    (or #+abcl (symbol-call :asdf/filesystem :parse-native-namestring
                            (java:jstatic "getProperty" "java.lang.System" "user.dir")
                                                     :ensure-directory t)
252
253
254
255
256
257
258
        #+allegro (excl::current-directory)
        #+clisp (ext:default-directory)
        #+clozure (ccl:current-directory)
        #+(or cmu scl) (#+cmu parse-unix-namestring* #+scl lisp::parse-unix-namestring
                        (strcat (nth-value 1 (unix:unix-current-directory)) "/"))
        #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
        #+ecl (ext:getcwd)
259
        #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p""))
260
261
262
263
264
265
266
267
268
269
        #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
        #+lispworks (system:current-directory)
        #+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))
270
      (or #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (namestring x))
271
272
273
274
275
276
277
278
279
280
281
282
          #+allegro (excl:chdir x)
          #+clisp (ext:cd x)
          #+clozure (setf (ccl:current-directory) x)
          #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x))
          #+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
                         (error "Could not set current directory to ~A" x))
          #+ecl (ext:chdir x)
          #+genera (setf *default-pathname-defaults* x)
          #+lispworks (hcl:change-directory x)
          #+mkcl (mk-ext:chdir x)
          #+sbcl (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))
          (error "chdir not supported on your implementation")))))
283

284
285
286
287
288
289
290

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

291
#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it
292
(with-upgradability ()
293
294
295
296
  (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)
297
298
    "Read a null-terminated string from an octet stream S"
    ;; note: doesn't play well with UNICODE
299
300
301
302
303
304
    (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))
305
306
    "Read a number in little-endian format from an byte (octet) stream S,
the number having BYTES octets (defaulting to 4)."
307
308
309
310
    (loop :for i :from 0 :below bytes
          :sum (ash (read-byte s) (* 8 i))))

  (defun parse-file-location-info (s)
311
    "helper to parse-windows-shortcut"
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
    (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)
335
336
    "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.
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
    (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)))))
366

367