3rdparties/software/uiop-3.3.4/os.lisp (18098 bytes)
1 ;;;; --------------------------------------------------------------------------- 2 ;;;; Access to the Operating System 3 4 (uiop/package:define-package :uiop/os 5 (: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 8 #:os-cond 9 #:getenv #:getenvp ;; environment variables 10 #:implementation-identifier ;; implementation identifier 11 #:implementation-type #:*implementation-type* 12 #:operating-system #:architecture #:lisp-version-string 13 #:hostname #:getcwd #:chdir 14 ;; Windows shortcut support 15 #:read-null-terminated-string #:read-little-endian 16 #:parse-file-location-info #:parse-windows-shortcut)) 17 (in-package :uiop/os) 18 19 ;;; Features 20 (with-upgradability () 21 (defun featurep (x &optional (*features* *features*)) 22 "Checks whether a feature expression X is true with respect to the *FEATURES* set, 23 as per the CLHS standard for #+ and #-. Beware that just like the CLHS, 24 we assume symbols from the KEYWORD package are used, but that unless you're using #+/#- 25 your reader will not have magically used the KEYWORD package, so you need specify 26 keywords explicitly." 27 (cond 28 ((atom x) (and (member x *features*) t)) 29 ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x)))) 30 ((eq :or (car x)) (some #'featurep (cdr x))) 31 ((eq :and (car x)) (every #'featurep (cdr x))) 32 (t (parameter-error "~S: malformed feature specification ~S" 'featurep x)))) 33 34 ;; Starting with UIOP 3.1.5, these are runtime tests. 35 ;; You may bind *features* with a copy of what your target system offers to test its properties. 36 (defun os-macosx-p () 37 "Is the underlying operating system MacOS X?" 38 ;; OS-MACOSX is not mutually exclusive with OS-UNIX, 39 ;; in fact the former implies the latter. 40 (featurep '(:or :darwin (:and :allegro :macosx) (:and :clisp :macos)))) 41 42 (defun os-unix-p () 43 "Is the underlying operating system some Unix variant?" 44 (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 58 (defun os-haiku-p () 59 "Is the underlying operating system Haiku?" 60 (featurep :haiku)) 61 62 (defun os-mezzano-p () 63 "Is the underlying operating system Mezzano?" 64 (featurep :mezzano)) 65 66 (defun detect-os () 67 "Detects the current operating system. Only needs be run at compile-time, 68 except on ABCL where it might change between FASL compilation and runtime." 69 (loop* :with o 70 :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-macosx . os-macosx-p) 71 (:os-windows . os-windows-p) 72 (:genera . os-genera-p) (:os-oldmac . os-oldmac-p) 73 (:haiku . os-haiku-p) 74 (:mezzano . os-mezzano-p)) 75 :when (and (or (not o) (eq feature :os-macosx)) (funcall detect)) 76 :do (setf o feature) (pushnew feature *features*) 77 :else :do (setf *features* (remove feature *features*)) 78 :finally 79 (return (or o (error "Congratulations for trying ASDF on an operating system~%~ 80 that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it."))))) 81 82 (defmacro os-cond (&rest clauses) 83 #+abcl `(cond ,@clauses) 84 #-abcl (loop* :for (test . body) :in clauses :when (eval test) :return `(progn ,@body))) 85 86 (detect-os)) 87 88 ;;;; Environment variables: getting them, and parsing them. 89 (with-upgradability () 90 (defun getenv (x) 91 "Query the environment, as in C getenv. 92 Beware: may return empty string if a variable is present but empty; 93 use getenvp to return NIL in such a case." 94 (declare (ignorable x)) 95 #+(or abcl clasp clisp ecl xcl) (ext:getenv x) 96 #+allegro (sys:getenv x) 97 #+clozure (ccl:getenv x) 98 #+cmucl (unix:unix-getenv x) 99 #+scl (cdr (assoc x ext:*environment-list* :test #'string=)) 100 #+cormanlisp 101 (let* ((buffer (ct:malloc 1)) 102 (cname (ct:lisp-string-to-c-string x)) 103 (needed-size (win:getenvironmentvariable cname buffer 0)) 104 (buffer1 (ct:malloc (1+ needed-size)))) 105 (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size)) 106 nil 107 (ct:c-string-to-lisp-string buffer1)) 108 (ct:free buffer) 109 (ct:free buffer1))) 110 #+gcl (system:getenv x) 111 #+(or genera mezzano) nil 112 #+lispworks (lispworks:environment-variable x) 113 #+mcl (ccl:with-cstrs ((name x)) 114 (let ((value (_getenv name))) 115 (unless (ccl:%null-ptr-p value) 116 (ccl:%get-cstring value)))) 117 #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x) 118 #+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 122 (defsetf getenv (x) (val) 123 "Set an environment variable." 124 (declare (ignorable x val)) 125 #+allegro `(setf (sys:getenv ,x) ,val) 126 #+clasp `(ext:setenv ,x ,val) 127 #+clisp `(system::setenv ,x ,val) 128 #+clozure `(ccl:setenv ,x ,val) 129 #+cmucl `(unix:unix-setenv ,x ,val 1) 130 #+(or ecl clasp) `(ext:setenv ,x ,val) 131 #+lispworks `(setf (lispworks:environment-variable ,x) ,val) 132 #+mkcl `(mkcl:setenv ,x ,val) 133 #+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))) 136 137 (defun getenvp (x) 138 "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 ;;;; implementation-identifier 144 ;; 145 ;; produce a string to identify current implementation. 146 ;; Initially stolen from SLIME's SWANK, completely rewritten since. 147 ;; We're back to runtime checking, for the sake of e.g. ABCL. 148 149 (with-upgradability () 150 (defun first-feature (feature-sets) 151 "A helper for various feature detection functions" 152 (dolist (x feature-sets) 153 (multiple-value-bind (short long feature-expr) 154 (if (consp x) 155 (values (first x) (second x) (cons :or (rest x))) 156 (values x x x)) 157 (when (featurep feature-expr) 158 (return (values short long)))))) 159 160 (defun implementation-type () 161 "The type of Lisp implementation used, as a short UIOP-standardized keyword" 162 (first-feature 163 '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) 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 (defvar *implementation-type* (implementation-type) 169 "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 '(:cygwin 175 (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! 176 (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd 177 (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd 178 (:solaris :solaris :sunos) 179 (:bsd :bsd :freebsd :netbsd :openbsd :dragonfly) 180 :unix 181 :genera 182 :mezzano))) 183 184 (defun architecture () 185 "The CPU architecture of the current host" 186 (first-feature 187 '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386)) 188 (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) 189 (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc) 190 :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc) 191 :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach 192 ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI, 193 ;; we may have to segregate the code still by architecture. 194 (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))) 195 196 #+clozure 197 (defun ccl-fasl-version () 198 ;; the fasl version is target-dependent from CCL 1.8 on. 199 (or (let ((s 'ccl::target-fasl-version)) 200 (and (fboundp s) (funcall s))) 201 (and (boundp 'ccl::fasl-version) 202 (symbol-value 'ccl::fasl-version)) 203 (error "Can't determine fasl version."))) 204 205 (defun lisp-version-string () 206 "return a string that identifies the current Lisp implementation version" 207 (let ((s (lisp-implementation-version))) 208 (car ; as opposed to OR, this idiom prevents some unreachable code warning 209 (list 210 #+allegro 211 (format nil "~A~@[~A~]~@[~A~]~@[~A~]" 212 excl::*common-lisp-version-number* 213 ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default) 214 (and (eq excl:*current-case-mode* :case-sensitive-lower) "M") 215 ;; Note if not using International ACL 216 ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm 217 (excl:ics-target-case (:-ics "8")) 218 (and (member :smp *features*) "S")) 219 #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) 220 #+clisp 221 (subseq s 0 (position #\space s)) ; strip build information (date, etc.) 222 #+clozure 223 (format nil "~d.~d-f~d" ; shorten for windows 224 ccl::*openmcl-major-version* 225 ccl::*openmcl-minor-version* 226 (logand (ccl-fasl-version) #xFF)) 227 #+cmucl (substitute #\- #\/ s) 228 #+scl (format nil "~A~A" s 229 ;; ANSI upper case vs lower case. 230 (ecase ext:*case-mode* (:upper "") (:lower "l"))) 231 #+ecl (format nil "~A~@[-~A~]" s 232 (let ((vcs-id (ext:lisp-implementation-vcs-id))) 233 (unless (equal vcs-id "UNKNOWN") 234 (subseq vcs-id 0 (min (length vcs-id) 8))))) 235 #+gcl (subseq s (1+ (position #\space s))) 236 #+genera 237 (multiple-value-bind (major minor) (sct:get-system-version "System") 238 (format nil "~D.~D" major minor)) 239 #+mcl (subseq s 8) ; strip the leading "Version " 240 #+mezzano (format nil "~A-~D" 241 (subseq s 0 (position #\space s)) ; strip commit hash 242 sys.int::*llf-version*) 243 ;; seems like there should be a shorter way to do this, like ACALL. 244 #+mkcl (or 245 (let ((fname (find-symbol* '#:git-describe-this-mkcl :mkcl nil))) 246 (when (and fname (fboundp fname)) 247 (funcall fname))) 248 s) 249 s)))) 250 251 (defun implementation-identifier () 252 "Return a string that identifies the ABI of the current implementation, 253 suitable for use as a directory name to segregate Lisp FASLs, C dynamic libraries, etc." 254 (substitute-if 255 #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) 256 (format nil "~(~a~@{~@[-~a~]~}~)" 257 (or (implementation-type) (lisp-implementation-type)) 258 (lisp-version-string) 259 (or (operating-system) (software-type)) 260 (or (architecture) (machine-type)))))) 261 262 263 ;;;; Other system information 264 265 (with-upgradability () 266 (defun hostname () 267 "return the hostname of the current host" 268 #+(or abcl clasp clozure cmucl ecl genera lispworks mcl mezzano mkcl sbcl scl xcl) (machine-instance) 269 #+cormanlisp "localhost" ;; is there a better way? Does it matter? 270 #+allegro (symbol-call :excl.osi :gethostname) 271 #+clisp (first (split-string (machine-instance) :separator " ")) 272 #+gcl (system:gethostname))) 273 274 275 ;;; Current directory 276 (with-upgradability () 277 278 #+cmucl 279 (defun parse-unix-namestring* (unix-namestring) 280 "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object" 281 (multiple-value-bind (host device directory name type version) 282 (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring)) 283 (make-pathname :host (or host lisp::*unix-host*) :device device 284 :directory directory :name name :type type :version version))) 285 286 (defun getcwd () 287 "Get the current working directory as per POSIX getcwd(3), as a pathname object" 288 (or #+(or abcl genera mezzano xcl) (truename *default-pathname-defaults*) ;; d-p-d is canonical! 289 #+allegro (excl::current-directory) 290 #+clisp (ext:default-directory) 291 #+clozure (ccl:current-directory) 292 #+(or cmucl scl) (#+cmucl parse-unix-namestring* #+scl lisp::parse-unix-namestring 293 (strcat (nth-value 1 (unix:unix-current-directory)) "/")) 294 #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return? 295 #+(or clasp ecl) (ext:getcwd) 296 #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p"")) 297 #+lispworks (hcl:get-working-directory) 298 #+mkcl (mk-ext:getcwd) 299 #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/)) 300 #+xcl (extensions:current-directory) 301 (not-implemented-error 'getcwd))) 302 303 (defun chdir (x) 304 "Change current directory, as per POSIX chdir(2), to a given pathname object" 305 (if-let (x (pathname x)) 306 #+(or abcl genera mezzano xcl) (setf *default-pathname-defaults* (truename x)) ;; d-p-d is canonical! 307 #+allegro (excl:chdir x) 308 #+clisp (ext:cd x) 309 #+clozure (setf (ccl:current-directory) x) 310 #+(or cmucl scl) (unix:unix-chdir (ext:unix-namestring x)) 311 #+cormanlisp (unless (zerop (win32::_chdir (namestring x))) 312 (error "Could not set current directory to ~A" x)) 313 #+ecl (ext:chdir x) 314 #+clasp (ext:chdir x t) 315 #+gcl (system:chdir x) 316 #+lispworks (hcl:change-directory x) 317 #+mkcl (mk-ext:chdir x) 318 #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))) 319 #-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mkcl sbcl scl xcl) 320 (not-implemented-error 'chdir)))) 321 322 323 ;;;; ----------------------------------------------------------------- 324 ;;;; Windows shortcut support. Based on: 325 ;;;; 326 ;;;; Jesse Hager: The Windows Shortcut File Format. 327 ;;;; http://www.wotsit.org/list.asp?fc=13 328 329 #-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it 330 (with-upgradability () 331 (defparameter *link-initial-dword* 76) 332 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) 333 334 (defun read-null-terminated-string (s) 335 "Read a null-terminated string from an octet stream S" 336 ;; note: doesn't play well with UNICODE 337 (with-output-to-string (out) 338 (loop :for code = (read-byte s) 339 :until (zerop code) 340 :do (write-char (code-char code) out)))) 341 342 (defun read-little-endian (s &optional (bytes 4)) 343 "Read a number in little-endian format from an byte (octet) stream S, 344 the number having BYTES octets (defaulting to 4)." 345 (loop :for i :from 0 :below bytes 346 :sum (ash (read-byte s) (* 8 i)))) 347 348 (defun parse-file-location-info (s) 349 "helper to parse-windows-shortcut" 350 (let ((start (file-position s)) 351 (total-length (read-little-endian s)) 352 (end-of-header (read-little-endian s)) 353 (fli-flags (read-little-endian s)) 354 (local-volume-offset (read-little-endian s)) 355 (local-offset (read-little-endian s)) 356 (network-volume-offset (read-little-endian s)) 357 (remaining-offset (read-little-endian s))) 358 (declare (ignore total-length end-of-header local-volume-offset)) 359 (unless (zerop fli-flags) 360 (cond 361 ((logbitp 0 fli-flags) 362 (file-position s (+ start local-offset))) 363 ((logbitp 1 fli-flags) 364 (file-position s (+ start 365 network-volume-offset 366 #x14)))) 367 (strcat (read-null-terminated-string s) 368 (progn 369 (file-position s (+ start remaining-offset)) 370 (read-null-terminated-string s)))))) 371 372 (defun parse-windows-shortcut (pathname) 373 "From a .lnk windows shortcut, extract the pathname linked to" 374 ;; NB: doesn't do much checking & doesn't look like it will work well with UNICODE. 375 (with-open-file (s pathname :element-type '(unsigned-byte 8)) 376 (handler-case 377 (when (and (= (read-little-endian s) *link-initial-dword*) 378 (let ((header (make-array (length *link-guid*)))) 379 (read-sequence header s) 380 (equalp header *link-guid*))) 381 (let ((flags (read-little-endian s))) 382 (file-position s 76) ;skip rest of header 383 (when (logbitp 0 flags) 384 ;; skip shell item id list 385 (let ((length (read-little-endian s 2))) 386 (file-position s (+ length (file-position s))))) 387 (cond 388 ((logbitp 1 flags) 389 (parse-file-location-info s)) 390 (t 391 (when (logbitp 2 flags) 392 ;; skip description string 393 (let ((length (read-little-endian s 2))) 394 (file-position s (+ length (file-position s))))) 395 (when (logbitp 3 flags) 396 ;; finally, our pathname 397 (let* ((length (read-little-endian s 2)) 398 (buffer (make-array length))) 399 (read-sequence buffer s) 400 (map 'string #'code-char buffer))))))) 401 (end-of-file (c) 402 (declare (ignore c)) 403 nil))))) 404 405