Commit 234a14fc authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

More docstrings for UIOP.

parent b4dc78de
......@@ -32,8 +32,10 @@
(condition-arguments c))))))
(defun get-folder-path (folder)
(or ;; this semi-portably implements a subset of the functionality of lispworks' sys:get-folder-path
#+(and lispworks mswindows) (sys:get-folder-path folder)
"Semi-portable implementation of a subset of LispWorks' sys:get-folder-path,
this function tries to locate the Windows FOLDER for one of
:LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA."
(or #+(and lispworks mswindows) (sys:get-folder-path folder)
;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
(ecase folder
(:local-appdata (getenv-absolute-directory "LOCALAPPDATA"))
......@@ -42,6 +44,7 @@
(subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
(defun user-configuration-directories ()
"Determine user configuration directories"
(let ((dirs
`(,@(when (os-unix-p)
(cons
......@@ -56,6 +59,7 @@
:from-end t :test 'equal)))
(defun system-configuration-directories ()
"Determine system user configuration directories"
(cond
((os-unix-p) '(#p"/etc/common-lisp/"))
((os-windows-p)
......@@ -63,23 +67,28 @@
(list it)))))
(defun in-first-directory (dirs x &key (direction :input))
"Determine system user configuration directories"
(loop :with fun = (ecase direction
((nil :input :probe) 'probe-file*)
((:output :io) 'identity))
:for dir :in dirs
:thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir))))))
:thereis (and dir (funcall fun (subpathname (ensure-directory-pathname dir) x)))))
(defun in-user-configuration-directory (x &key (direction :input))
"return pathname under user configuration directory, subpathname X"
(in-first-directory (user-configuration-directories) x :direction direction))
(defun in-system-configuration-directory (x &key (direction :input))
"return pathname under system configuration directory, subpathname X"
(in-first-directory (system-configuration-directories) x :direction direction))
(defun configuration-inheritance-directive-p (x)
"Is X a configuration inheritance directive?"
(let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
(or (member x kw)
(and (length=n-p x 1) (member (car x) kw)))))
(defun report-invalid-form (reporter &rest args)
"Report an invalid form according to REPORTER and various ARGS"
(etypecase reporter
(null
(apply 'error 'invalid-configuration args))
......@@ -90,10 +99,12 @@
(cons
(apply 'apply (append reporter args)))))
(defvar *ignored-configuration-form* nil)
(defvar *ignored-configuration-form* nil
"Have configuration forms been ignored while parsing the configuration?")
(defun validate-configuration-form (form tag directive-validator
&key location invalid-form-reporter)
"Validate a configuration FORM"
(unless (and (consp form) (eq (car form) tag))
(setf *ignored-configuration-form* t)
(report-invalid-form invalid-form-reporter :form form :location location)
......@@ -122,6 +133,7 @@
(return (nreverse x))))
(defun validate-configuration-file (file validator &key description)
"Validate a configuration file for conformance of its form with the validator function"
(let ((forms (read-file-forms file)))
(unless (length=n-p forms 1)
(error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
......@@ -154,6 +166,7 @@ values of TAG include :source-registry and :output-translations."
:inherit-configuration)))
(defun resolve-relative-location (x &key ensure-directory wilden)
"Given a designator X for an relative location, resolve it to a pathname"
(ensure-pathname
(etypecase x
(pathname x)
......@@ -192,6 +205,7 @@ directive.")
"A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache")
(defun compute-user-cache ()
"Compute the location of the default user-cache for translate-output objects"
(setf *user-cache*
(flet ((try (x &rest sub) (and x `(,x ,@sub))))
(or
......@@ -204,6 +218,7 @@ directive.")
(register-image-restore-hook 'compute-user-cache)
(defun resolve-absolute-location (x &key ensure-directory wilden)
"Given a designator X for an absolute location, resolve it to a pathname"
(ensure-pathname
(etypecase x
(pathname x)
......@@ -244,6 +259,7 @@ directive.")
(:ensure-directory boolean)) t) resolve-location))
(defun* (resolve-location) (x &key ensure-directory wilden directory)
"Resolve location designator X into a PATHNAME"
;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory
(loop* :with dirp = (or directory ensure-directory)
:with (first . rest) = (if (atom x) (list x) x)
......@@ -261,6 +277,7 @@ directive.")
:finally (return path)))
(defun location-designator-p (x)
"Is X a designator for a location?"
(flet ((absolute-component-p (c)
(typep c '(or string pathname
(member :root :home :here :user-cache))))
......@@ -272,6 +289,7 @@ directive.")
(and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
(defun location-function-p (x)
"Is X the specification of a location function?"
(and
(length=n-p x 2)
(eq (car x) :function)))
......@@ -279,15 +297,17 @@ directive.")
(defvar *clear-configuration-hook* '())
(defun register-clear-configuration-hook (hook-function &optional call-now-p)
"Register a function to be called when clearing configuration"
(register-hook-function '*clear-configuration-hook* hook-function call-now-p))
(defun clear-configuration ()
"Call the functions in *CLEAR-CONFIGURATION-HOOK*"
(call-functions *clear-configuration-hook*))
(register-image-dump-hook 'clear-configuration)
;; If a previous version of ASDF failed to read some configuration, try again.
(defun upgrade-configuration ()
"If a previous version of ASDF failed to read some configuration, try again now."
(when *ignored-configuration-form*
(clear-configuration)
(setf *ignored-configuration-form* nil))))
......
......@@ -157,6 +157,9 @@ Try to override the defaults to not resolving symlinks, if implementation allows
'(:resolve-symlinks nil))))))
(defun filter-logical-directory-results (directory entries merger)
"Given ENTRIES in a DIRECTORY, remove if the directory is logical
the entries which are physical yet when transformed by MERGER have a different TRUENAME.
This function is used as a helper to DIRECTORY-FILES to avoid invalid entries when using logical-pathnames."
(if (logical-pathname-p directory)
;; Try hard to not resolve logical-pathname into physical pathnames;
;; otherwise logical-pathname users/lovers will be disappointed.
......@@ -166,7 +169,7 @@ Try to override the defaults to not resolving symlinks, if implementation allows
;; translating the LPN commute.
(loop :for f :in entries
:for p = (or (and (logical-pathname-p f) f)
(let* ((u (ignore-errors (funcall merger f))))
(let* ((u (ignore-errors (call-function merger f))))
;; The first u avoids a cumbersome (truename u) error.
;; At this point f should already be a truename,
;; but isn't quite in CLISP, for it doesn't have :version :newest
......@@ -201,6 +204,7 @@ which is not very portable to override. Try not resolve symlinks if implementati
:version (make-pathname-component-logical (pathname-version f))))))))
(defun subdirectories (directory)
"Given a DIRECTORY pathname designator, return a list of the subdirectories under it."
(let* ((directory (ensure-directory-pathname directory))
#-(or abcl cormanlisp genera xcl)
(wild (merge-pathnames*
......@@ -238,6 +242,9 @@ which is not very portable to override. Try not resolve symlinks if implementati
:directory (append prefix (make-pathname-component-logical (last dir)))))))))))
(defun collect-sub*directories (directory collectp recursep collector)
"Given a DIRECTORY, call-function the COLLECTOR function designator
on the directory if COLLECTP returns true when CALL-FUNCTION'ed with the directory,
and recurse each of its subdirectories on which the RECURSEP returns true when CALL-FUNCTION'ed with them."
(when (call-function collectp directory)
(call-function collector directory))
(dolist (subdir (subdirectories directory))
......
......@@ -131,6 +131,7 @@ This is designed to abstract away the implementation specific quit forms."
stream))
(defun print-backtrace (&rest keys &key stream count)
"Print a backtrace"
(declare (ignore stream count))
(with-safe-io-syntax (:package :cl)
(let ((*print-readably* nil)
......@@ -142,6 +143,7 @@ This is designed to abstract away the implementation specific quit forms."
(ignore-errors (apply 'raw-print-backtrace keys)))))
(defun print-condition-backtrace (condition &key (stream *stderr*) count)
"Print a condition after a backtrace triggered by that condition"
;; We print the condition *after* the backtrace,
;; for the sake of who sees the backtrace at a terminal.
;; It is up to the caller to print the condition *before*, with some context.
......@@ -151,10 +153,12 @@ This is designed to abstract away the implementation specific quit forms."
condition)))
(defun fatal-condition-p (condition)
"Is the CONDITION fatal? It is if it matches any in *FATAL-CONDITIONS*"
(match-any-condition-p condition *fatal-conditions*))
(defun handle-fatal-condition (condition)
"Depending on whether *LISP-INTERACTION* is set, enter debugger or die"
"Handle a fatal CONDITION:
depending on whether *LISP-INTERACTION* is set, enter debugger or die"
(cond
(*lisp-interaction*
(invoke-debugger condition))
......@@ -164,10 +168,12 @@ This is designed to abstract away the implementation specific quit forms."
(die 99 "~A" condition))))
(defun call-with-fatal-condition-handler (thunk)
"Call THUNK in a context where fatal conditions are appropriately handled"
(handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition))
(funcall thunk)))
(defmacro with-fatal-condition-handler ((&optional) &body body)
"Execute BODY in a context where fatal conditions are appropriately handled"
`(call-with-fatal-condition-handler #'(lambda () ,@body)))
(defun shell-boolean-exit (x)
......@@ -178,15 +184,19 @@ This is designed to abstract away the implementation specific quit forms."
;;; Using image hooks
(with-upgradability ()
(defun register-image-restore-hook (hook &optional (call-now-p t))
"Regiter a hook function to be run when restoring a dumped image"
(register-hook-function '*image-restore-hook* hook call-now-p))
(defun register-image-dump-hook (hook &optional (call-now-p nil))
"Register a the hook function to be run before to dump an image"
(register-hook-function '*image-dump-hook* hook call-now-p))
(defun call-image-restore-hook ()
"Call the hook functions registered to be run when restoring a dumped image"
(call-functions (reverse *image-restore-hook*)))
(defun call-image-dump-hook ()
"Call the hook functions registered to be run before to dump an image"
(call-functions *image-dump-hook*)))
......@@ -230,6 +240,8 @@ if we are not called from a directly executable image."
((:prelude *image-prelude*) *image-prelude*)
((:entry-point *image-entry-point*) *image-entry-point*)
(if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
"From a freshly restarted Lisp image, restore the saved Lisp environment
by setting appropriate variables, running various hooks, and calling any specified entry point."
(when *image-restored-p*
(if if-already-restored
(call-function if-already-restored "Image already ~:[being ~;~]restored" (eq *image-restored-p* t))
......@@ -255,6 +267,7 @@ if we are not called from a directly executable image."
((:postlude *image-postlude*) *image-postlude*)
((:dump-hook *image-dump-hook*) *image-dump-hook*)
#+clozure prepend-symbols #+clozure (purify t))
"Dump an image of the current Lisp environment at pathname FILENAME, with various options"
(declare (ignorable filename output-name executable))
(setf *image-dumped-p* (if executable :executable t))
(setf *image-restored-p* :in-regress)
......@@ -321,6 +334,7 @@ if we are not called from a directly executable image."
(entry-point () entry-point-p) build-args)
(declare (ignorable destination object-files kind output-name prologue-code epilogue-code
prelude preludep postlude postludep entry-point entry-point-p build-args))
"On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options"
;; Is it meaningful to run these in the current environment?
;; only if we also track the object files that constitute the "current" image,
;; and otherwise simulate dump-image, including quitting at the end.
......
......@@ -49,8 +49,10 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
;;; Optimization settings
(with-upgradability ()
(defvar *optimization-settings* nil)
(defvar *previous-optimization-settings* nil)
(defvar *optimization-settings* nil
"Optimization settings to be used by PROCLAIM-OPTIMIZATION-SETTINGS")
(defvar *previous-optimization-settings* nil
"Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS")
(defun get-optimization-settings ()
"Get current compiler optimization settings, ready to PROCLAIM again"
#-(or clisp clozure cmu ecl sbcl scl)
......@@ -79,6 +81,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
#+sbcl
(progn
(defun sb-grovel-unknown-constant-condition-p (c)
"Detect SB-GROVEL unknown-constant conditions on older versions of SBCL"
(and (typep c 'sb-int:simple-style-warning)
(string-enclosed-p
"Couldn't grovel for "
......@@ -124,16 +127,18 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
;;;; ----- Filtering conditions while building -----
(with-upgradability ()
(defun call-with-muffled-compiler-conditions (thunk)
"Call given THUNK in a context where uninteresting conditions and compiler conditions are muffled"
(call-with-muffled-conditions
thunk (append *uninteresting-conditions* *uninteresting-compiler-conditions*)))
(defmacro with-muffled-compiler-conditions ((&optional) &body body)
"Run BODY where uninteresting compiler conditions are muffled"
"Trivial syntax for CALL-WITH-MUFFLED-COMPILER-CONDITIONS"
`(call-with-muffled-compiler-conditions #'(lambda () ,@body)))
(defun call-with-muffled-loader-conditions (thunk)
"Call given THUNK in a context where uninteresting conditions and loader conditions are muffled"
(call-with-muffled-conditions
thunk (append *uninteresting-conditions* *uninteresting-loader-conditions*)))
(defmacro with-muffled-loader-conditions ((&optional) &body body)
"Run BODY where uninteresting compiler and additional loader conditions are muffled"
"Trivial syntax for CALL-WITH-MUFFLED-LOADER-CONDITIONS"
`(call-with-muffled-loader-conditions #'(lambda () ,@body))))
......@@ -159,6 +164,8 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
(defun check-lisp-compile-warnings (warnings-p failure-p
&optional context-format context-arguments)
"Given the warnings or failures as resulted from COMPILE-FILE or checking deferred warnings,
raise an error or warning as appropriate"
(when failure-p
(case *compile-file-failure-behaviour*
(:warn (warn 'compile-failed-warning
......@@ -184,6 +191,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
(defun check-lisp-compile-results (output warnings-p failure-p
&optional context-format context-arguments)
"Given the results of COMPILE-FILE, raise an error or warning as appropriate"
(unless output
(error 'compile-file-error :context-format context-format :context-arguments context-arguments))
(check-lisp-compile-warnings warnings-p failure-p context-format context-arguments)))
......@@ -196,6 +204,8 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
;;; See their respective docstrings.
(with-upgradability ()
(defun reify-simple-sexp (sexp)
"Given a simple SEXP, return a representation of it as a portable SEXP.
Simple means made of symbols, numbers, characters, simple-strings, pathnames, cons cells."
(etypecase sexp
(symbol (reify-symbol sexp))
((or number character simple-string pathname) sexp)
......@@ -203,6 +213,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
(simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list))))))
(defun unreify-simple-sexp (sexp)
"Given the portable output of REIFY-SIMPLE-SEXP, return the simple SEXP it represents"
(etypecase sexp
((or symbol number character simple-string pathname) sexp)
(cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp))))
......@@ -454,6 +465,8 @@ possibly in a different process."
(terpri s))))
(defun warnings-file-type (&optional implementation-type)
"The pathname type for warnings files on given IMPLEMENTATION-TYPE,
where NIL designates the current one"
(case (or implementation-type *implementation-type*)
((:acl :allegro) "allegro-warnings")
;;((:clisp) "clisp-warnings")
......@@ -463,21 +476,27 @@ possibly in a different process."
((:scl) "scl-warnings")))
(defvar *warnings-file-type* nil
"Type for warnings files")
"Pathname type for warnings files, or NIL if disabled")
(defun enable-deferred-warnings-check ()
"Enable the saving of deferred warnings"
(setf *warnings-file-type* (warnings-file-type)))
(defun disable-deferred-warnings-check ()
"Disable the saving of deferred warnings"
(setf *warnings-file-type* nil))
(defun warnings-file-p (file &optional implementation-type)
"Is FILE a saved warnings file for the given IMPLEMENTATION-TYPE?
If that given type is NIL, use the currently configured *WARNINGS-FILE-TYPE* instead."
(if-let (type (if implementation-type
(warnings-file-type implementation-type)
*warnings-file-type*))
(equal (pathname-type file) type)))
(defun check-deferred-warnings (files &optional context-format context-arguments)
"Given a list of FILES in which deferred warnings were saved by CALL-WITH-DEFERRED-WARNINGS,
re-intern and raise any warnings that are still meaningful."
(let ((file-errors nil)
(failure-p nil)
(warnings-p nil))
......@@ -518,6 +537,9 @@ possibly in a different process."
|#
(defun call-with-saved-deferred-warnings (thunk warnings-file)
"If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK
and save those warnings to the given file for latter use,
possibly in a different process. Otherwise just call THUNK."
(if warnings-file
(with-compilation-unit (:override t)
(unwind-protect
......@@ -529,21 +551,22 @@ possibly in a different process."
(funcall thunk)))
(defmacro with-saved-deferred-warnings ((warnings-file) &body body)
"If WARNINGS-FILE is not nil, records the deferred-warnings around the BODY
and saves those warnings to the given file for latter use,
possibly in a different process. Otherwise just run the BODY."
"Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS"
`(call-with-saved-deferred-warnings #'(lambda () ,@body) ,warnings-file)))
;;; from ASDF
(with-upgradability ()
(defun current-lisp-file-pathname ()
"Portably return the PATHNAME of the current Lisp source file being compiled or loaded"
(or *compile-file-pathname* *load-pathname*))
(defun load-pathname ()
*load-pathname*)
"Portably return the LOAD-PATHNAME of the current source file or fasl"
*load-pathname*) ;; see magic for GCL in uiop/common-lisp
(defun lispize-pathname (input-file)
"From a INPUT-FILE pathname, return a corresponding .lisp source pathname"
(make-pathname :type "lisp" :defaults input-file))
(defun compile-file-type (&rest keys)
......@@ -553,9 +576,11 @@ possibly in a different process. Otherwise just run the BODY."
#+(or ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys)))
(defun call-around-hook (hook function)
"Call a HOOK around the execution of FUNCTION"
(call-function (or hook 'funcall) function))
(defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
"Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*"
(let* ((keys
(remove-plist-keys `(#+(and allegro (not (version>= 8 2))) :external-format
,@(unless output-file '(:output-file))) keys)))
......@@ -664,6 +689,7 @@ it will filter them appropriately."
(values output-truename warnings-p failure-p))))
(defun load* (x &rest keys &key &allow-other-keys)
"Portable wrapper around LOAD that properly handles loading from a stream."
(etypecase x
((or pathname string #-(or allegro clozure gcl2.6 genera) stream)
(apply 'load x
......@@ -686,6 +712,7 @@ it will filter them appropriately."
;;; Links FASLs together
(with-upgradability ()
(defun combine-fasls (inputs output)
"Combine a list of FASLs INPUTS into a single FASL OUTPUT"
#-(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl)
(error "~A does not support ~S~%inputs ~S~%output ~S"
(implementation-type) 'combine-fasls inputs output)
......
......@@ -33,25 +33,30 @@ keywords explicitly."
(t (error "Malformed feature specification ~S" x))))
(defun os-unix-p ()
"Is the underlying operating system some Unix variant?"
(or #+abcl (featurep :unix)
#+(and (not abcl) (or unix cygwin darwin)) t))
(defun os-macosx-p ()
;; OS-MACOSX is not mutually exclusive with OS-UNIX, in fact the
;;former implies the latter.
"Is the underlying operating system MacOS X?"
;; OS-MACOSX is not mutually exclusive with OS-UNIX,
;; in fact the former implies the latter.
(or
#+allegro (featurep :macosx)
#+clisp (featurep :macos)
(featurep :darwin)))
(defun os-windows-p ()
"Is the underlying operating system Microsoft Windows?"
(or #+abcl (featurep :windows)
#+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
(defun os-genera-p ()
"Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?"
(or #+genera t))
(defun os-oldmac-p ()
"Is the underlying operating system an (emulated?) MacOS 9 or earlier?"
(or #+mcl t))
(defun detect-os ()
......@@ -117,6 +122,7 @@ then returning the non-empty string value of the variable"
(with-upgradability ()
(defun first-feature (feature-sets)
"A helper for various feature detection functions"
(dolist (x feature-sets)
(multiple-value-bind (short long feature-expr)
(if (consp x)
......@@ -126,15 +132,18 @@ then returning the non-empty string value of the variable"
(return (values short long))))))
(defun implementation-type ()
"The type of Lisp implementation used, as a short UIOP-standardized keyword"
(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)))
(defvar *implementation-type* (implementation-type))
(defvar *implementation-type* (implementation-type)
"The type of Lisp implementation used, as a short UIOP-standardized keyword")
(defun operating-system ()
"The operating system of the current host"
(first-feature
'(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
(:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
......@@ -143,6 +152,7 @@ then returning the non-empty string value of the variable"
:genera)))
(defun architecture ()
"The CPU architecture of the current host"
(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)
......@@ -163,6 +173,7 @@ then returning the non-empty string value of the variable"
(error "Can't determine fasl version.")))
(defun lisp-version-string ()
"return a string that identifies the current Lisp implementation version"
(let ((s (lisp-implementation-version)))
(car ; as opposed to OR, this idiom prevents some unreachable code warning
(list
......@@ -213,6 +224,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
(with-upgradability ()
(defun hostname ()
"return the hostname of the current host"
;; Note: untested on RMCL
#+(or abcl clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
#+cormanlisp "localhost" ;; is there a better way? Does it matter?
......@@ -226,6 +238,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
#+cmu
(defun parse-unix-namestring* (unix-namestring)
"variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object"
(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
......@@ -275,22 +288,27 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
;;;; Jesse Hager: The Windows Shortcut File Format.
;;;; http://www.wotsit.org/list.asp?fc=13
#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it
(with-upgradability ()
(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)
"Read a null-terminated string from an octet stream S"
;; note: doesn't play well with UNICODE
(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))
"Read a number in little-endian format from an byte (octet) stream S,
the number having BYTES octets (defaulting to 4)."
(loop :for i :from 0 :below bytes
:sum (ash (read-byte s) (* 8 i))))
(defun parse-file-location-info (s)
"helper to parse-windows-shortcut"
(let ((start (file-position s))
(total-length (read-little-endian s))
(end-of-header (read-little-endian s))
......@@ -314,6 +332,8 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
(read-null-terminated-string s))))))
(defun parse-windows-shortcut (pathname)
"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.
(with-open-file (s pathname :element-type '(unsigned-byte 8))
(handler-case
(when (and (= (read-little-endian s) *link-initial-dword*)
......
This diff is collapsed.
......@@ -92,6 +92,7 @@ omit the outer double-quotes if key argument :QUOTE is NIL"
(when quote (princ #\" s)))
(defun easy-sh-character-p (x)
"Is X an \"easy\" character that does not require quoting by the shell?"
(or (alphanumericp x) (find x "+-_.,%@:/")))
(defun escape-sh-token (token &optional s)
......@@ -101,6 +102,7 @@ for use within a POSIX Bourne shell, outputing to S."
:escaper 'escape-sh-token-within-double-quotes))
(defun escape-shell-token (token &optional s)
"Escape a token for the current operating system shell"
(cond
((os-unix-p) (escape-sh-token token s))
((os-windows-p) (escape-windows-token token s))))
......@@ -136,6 +138,10 @@ by /bin/sh in POSIX"
;;;; Slurping a stream, typically the output of another program
(with-upgradability ()
(defun call-stream-processor (fun processor stream)
"Given FUN (typically SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM,
a PROCESSOR specification which is either an atom or a list specifying
a processor an keyword arguments, call the specified processor with
the given STREAM as input"
(if (consp processor)
(apply fun (first processor) stream (rest processor))
(funcall fun processor stream)))
......@@ -664,6 +670,7 @@ It returns a process-info plist with possible keys:
(defun %use-run-program (command &rest keys
&key input output error-output ignore-error-status &allow-other-keys)
;; helper for RUN-PROGRAM when using %run-program
#+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl)
(error "Not implemented on this platform")
(assert (not (member :stream (list input output error-output))))
......@@ -716,13 +723,13 @@ It returns a process-info plist with possible keys:
:ignore-error-status ignore-error-status))))))))
(values output-result error-output-result exit-code)))
(defun %normalize-system-command (command)
(defun %normalize-system-command (command) ;; helper for %USE-SYSTEM
(etypecase command
(string command)
(list (escape-shell-command
(if (os-unix-p) (cons "exec" command) command)))))
(defun %redirected-system-command (command in out err directory)
(defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
(flet ((redirect (spec operator)
(let ((pathname
(typecase spec
......@@ -776,6 +783,7 @@ It returns a process-info plist with possible keys:
(defun %use-system (command &rest keys
&key input output error-output ignore-error-status &allow-other-keys)
;; helper for RUN-PROGRAM when using %system
(let (output-result error-output-result exit-code)
(with-program-output ((reduced-output)
output :keys keys :setf output-result)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment