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