tos.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP (HTM) git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/ (DIR) Log (DIR) Files (DIR) Refs (DIR) Tags (DIR) LICENSE --- tos.lisp (18003B) --- 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 #+clisp `(system::setenv ,x ,val) 127 #+clozure `(ccl:setenv ,x ,val) 128 #+cmucl `(unix:unix-setenv ,x ,val 1) 129 #+ecl `(ext:setenv ,x ,val) 130 #+lispworks `(hcl:setenv ,x ,val) 131 #+mkcl `(mkcl:setenv ,x ,val) 132 #+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))) 135 136 (defun getenvp (x) 137 "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 ;;;; implementation-identifier 143 ;; 144 ;; produce a string to identify current implementation. 145 ;; Initially stolen from SLIME's SWANK, completely rewritten since. 146 ;; We're back to runtime checking, for the sake of e.g. ABCL. 147 148 (with-upgradability () 149 (defun first-feature (feature-sets) 150 "A helper for various feature detection functions" 151 (dolist (x feature-sets) 152 (multiple-value-bind (short long feature-expr) 153 (if (consp x) 154 (values (first x) (second x) (cons :or (rest x))) 155 (values x x x)) 156 (when (featurep feature-expr) 157 (return (values short long)))))) 158 159 (defun implementation-type () 160 "The type of Lisp implementation used, as a short UIOP-standardized keyword" 161 (first-feature 162 '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) 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 (defvar *implementation-type* (implementation-type) 168 "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 '(:cygwin 174 (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! 175 (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd 176 (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd 177 (:solaris :solaris :sunos) 178 (:bsd :bsd :freebsd :netbsd :openbsd :dragonfly) 179 :unix 180 :genera 181 :mezzano))) 182 183 (defun architecture () 184 "The CPU architecture of the current host" 185 (first-feature 186 '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386)) 187 (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) 188 (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc) 189 :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc) 190 :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach 191 ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI, 192 ;; we may have to segregate the code still by architecture. 193 (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7)))) 194 195 #+clozure 196 (defun ccl-fasl-version () 197 ;; the fasl version is target-dependent from CCL 1.8 on. 198 (or (let ((s 'ccl::target-fasl-version)) 199 (and (fboundp s) (funcall s))) 200 (and (boundp 'ccl::fasl-version) 201 (symbol-value 'ccl::fasl-version)) 202 (error "Can't determine fasl version."))) 203 204 (defun lisp-version-string () 205 "return a string that identifies the current Lisp implementation version" 206 (let ((s (lisp-implementation-version))) 207 (car ; as opposed to OR, this idiom prevents some unreachable code warning 208 (list 209 #+allegro 210 (format nil "~A~@[~A~]~@[~A~]~@[~A~]" 211 excl::*common-lisp-version-number* 212 ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default) 213 (and (eq excl:*current-case-mode* :case-sensitive-lower) "M") 214 ;; Note if not using International ACL 215 ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm 216 (excl:ics-target-case (:-ics "8")) 217 (and (member :smp *features*) "S")) 218 #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) 219 #+clisp 220 (subseq s 0 (position #\space s)) ; strip build information (date, etc.) 221 #+clozure 222 (format nil "~d.~d-f~d" ; shorten for windows 223 ccl::*openmcl-major-version* 224 ccl::*openmcl-minor-version* 225 (logand (ccl-fasl-version) #xFF)) 226 #+cmucl (substitute #\- #\/ s) 227 #+scl (format nil "~A~A" s 228 ;; ANSI upper case vs lower case. 229 (ecase ext:*case-mode* (:upper "") (:lower "l"))) 230 #+ecl (format nil "~A~@[-~A~]" s 231 (let ((vcs-id (ext:lisp-implementation-vcs-id))) 232 (unless (equal vcs-id "UNKNOWN") 233 (subseq vcs-id 0 (min (length vcs-id) 8))))) 234 #+gcl (subseq s (1+ (position #\space s))) 235 #+genera 236 (multiple-value-bind (major minor) (sct:get-system-version "System") 237 (format nil "~D.~D" major minor)) 238 #+mcl (subseq s 8) ; strip the leading "Version " 239 #+mezzano (format nil "~A-~D" 240 (subseq s 0 (position #\space s)) ; strip commit hash 241 sys.int::*llf-version*) 242 ;; seems like there should be a shorter way to do this, like ACALL. 243 #+mkcl (or 244 (let ((fname (find-symbol* '#:git-describe-this-mkcl :mkcl nil))) 245 (when (and fname (fboundp fname)) 246 (funcall fname))) 247 s) 248 s)))) 249 250 (defun implementation-identifier () 251 "Return a string that identifies the ABI of the current implementation, 252 suitable for use as a directory name to segregate Lisp FASLs, C dynamic libraries, etc." 253 (substitute-if 254 #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) 255 (format nil "~(~a~@{~@[-~a~]~}~)" 256 (or (implementation-type) (lisp-implementation-type)) 257 (lisp-version-string) 258 (or (operating-system) (software-type)) 259 (or (architecture) (machine-type)))))) 260 261 262 ;;;; Other system information 263 264 (with-upgradability () 265 (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 #+cormanlisp "localhost" ;; is there a better way? Does it matter? 269 #+allegro (symbol-call :excl.osi :gethostname) 270 #+clisp (first (split-string (machine-instance) :separator " ")) 271 #+gcl (system:gethostname))) 272 273 274 ;;; Current directory 275 (with-upgradability () 276 277 #+cmucl 278 (defun parse-unix-namestring* (unix-namestring) 279 "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object" 280 (multiple-value-bind (host device directory name type version) 281 (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring)) 282 (make-pathname :host (or host lisp::*unix-host*) :device device 283 :directory directory :name name :type type :version version))) 284 285 (defun getcwd () 286 "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 #+allegro (excl::current-directory) 289 #+clisp (ext:default-directory) 290 #+clozure (ccl:current-directory) 291 #+(or cmucl scl) (#+cmucl parse-unix-namestring* #+scl lisp::parse-unix-namestring 292 (strcat (nth-value 1 (unix:unix-current-directory)) "/")) 293 #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return? 294 #+(or clasp ecl) (ext:getcwd) 295 #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p"")) 296 #+lispworks (hcl:get-working-directory) 297 #+mkcl (mk-ext:getcwd) 298 #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/)) 299 #+xcl (extensions:current-directory) 300 (not-implemented-error 'getcwd))) 301 302 (defun chdir (x) 303 "Change current directory, as per POSIX chdir(2), to a given pathname object" 304 (if-let (x (pathname x)) 305 #+(or abcl genera mezzano xcl) (setf *default-pathname-defaults* (truename x)) ;; d-p-d is canonical! 306 #+allegro (excl:chdir x) 307 #+clisp (ext:cd x) 308 #+clozure (setf (ccl:current-directory) x) 309 #+(or cmucl scl) (unix:unix-chdir (ext:unix-namestring x)) 310 #+cormanlisp (unless (zerop (win32::_chdir (namestring x))) 311 (error "Could not set current directory to ~A" x)) 312 #+(or clasp ecl) (ext:chdir x) 313 #+gcl (system:chdir x) 314 #+lispworks (hcl:change-directory x) 315 #+mkcl (mk-ext:chdir x) 316 #+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 ;;;; Windows shortcut support. Based on: 323 ;;;; 324 ;;;; Jesse Hager: The Windows Shortcut File Format. 325 ;;;; http://www.wotsit.org/list.asp?fc=13 326 327 #-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it 328 (with-upgradability () 329 (defparameter *link-initial-dword* 76) 330 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) 331 332 (defun read-null-terminated-string (s) 333 "Read a null-terminated string from an octet stream S" 334 ;; note: doesn't play well with UNICODE 335 (with-output-to-string (out) 336 (loop :for code = (read-byte s) 337 :until (zerop code) 338 :do (write-char (code-char code) out)))) 339 340 (defun read-little-endian (s &optional (bytes 4)) 341 "Read a number in little-endian format from an byte (octet) stream S, 342 the number having BYTES octets (defaulting to 4)." 343 (loop :for i :from 0 :below bytes 344 :sum (ash (read-byte s) (* 8 i)))) 345 346 (defun parse-file-location-info (s) 347 "helper to parse-windows-shortcut" 348 (let ((start (file-position s)) 349 (total-length (read-little-endian s)) 350 (end-of-header (read-little-endian s)) 351 (fli-flags (read-little-endian s)) 352 (local-volume-offset (read-little-endian s)) 353 (local-offset (read-little-endian s)) 354 (network-volume-offset (read-little-endian s)) 355 (remaining-offset (read-little-endian s))) 356 (declare (ignore total-length end-of-header local-volume-offset)) 357 (unless (zerop fli-flags) 358 (cond 359 ((logbitp 0 fli-flags) 360 (file-position s (+ start local-offset))) 361 ((logbitp 1 fli-flags) 362 (file-position s (+ start 363 network-volume-offset 364 #x14)))) 365 (strcat (read-null-terminated-string s) 366 (progn 367 (file-position s (+ start remaining-offset)) 368 (read-null-terminated-string s)))))) 369 370 (defun parse-windows-shortcut (pathname) 371 "From a .lnk windows shortcut, extract the pathname linked to" 372 ;; NB: doesn't do much checking & doesn't look like it will work well with UNICODE. 373 (with-open-file (s pathname :element-type '(unsigned-byte 8)) 374 (handler-case 375 (when (and (= (read-little-endian s) *link-initial-dword*) 376 (let ((header (make-array (length *link-guid*)))) 377 (read-sequence header s) 378 (equalp header *link-guid*))) 379 (let ((flags (read-little-endian s))) 380 (file-position s 76) ;skip rest of header 381 (when (logbitp 0 flags) 382 ;; skip shell item id list 383 (let ((length (read-little-endian s 2))) 384 (file-position s (+ length (file-position s))))) 385 (cond 386 ((logbitp 1 flags) 387 (parse-file-location-info s)) 388 (t 389 (when (logbitp 2 flags) 390 ;; skip description string 391 (let ((length (read-little-endian s 2))) 392 (file-position s (+ length (file-position s))))) 393 (when (logbitp 3 flags) 394 ;; finally, our pathname 395 (let* ((length (read-little-endian s 2)) 396 (buffer (make-array length))) 397 (read-sequence buffer s) 398 (map 'string #'code-char buffer))))))) 399 (end-of-file (c) 400 (declare (ignore c)) 401 nil))))) 402 403