Skip to content
Snippets Groups Projects
Commit 3900a1f0 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

More docstrings.

parent 3176b414
No related branches found
No related tags found
No related merge requests found
......@@ -63,10 +63,12 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
;;; Probing the filesystem
(with-upgradability ()
(defun truename* (p)
"Nicer variant of TRUENAME that plays well with NIL and avoids logical pathname contexts"
;; avoids both logical-pathname merging and physical resolution issues
(and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil))))
(defun safe-file-write-date (pathname)
"Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
;; If FILE-WRITE-DATE returns NIL, it's possible that
;; the user or some other agent has deleted an input file.
;; Also, generated files will not exist at the time planning is done
......@@ -133,14 +135,18 @@ or the original (parsed) pathname if it is false (the default)."
(file-error () nil)))))))
(defun directory-exists-p (x)
"Is X the name of a directory that exists on the filesystem?"
(let ((p (probe-file* x :truename t)))
(and (directory-pathname-p p) p)))
(defun file-exists-p (x)
"Is X the name of a file that exists on the filesystem?"
(let ((p (probe-file* x :truename t)))
(and (file-pathname-p p) p)))
(defun directory* (pathname-spec &rest keys &key &allow-other-keys)
"Return a list of the entries in a directory by calling DIRECTORY.
Try to override the defaults to not resolving symlinks, if implementation allows."
(apply 'directory pathname-spec
(append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
#+(or clozure digitool) '(:follow-links nil)
......@@ -169,6 +175,8 @@ or the original (parsed) pathname if it is false (the default)."
entries))
(defun directory-files (directory &optional (pattern *wild-file*))
"Return a list of the files in a directory according to the PATTERN,
which is not very portable to override. Try not resolve symlinks if implementation allows."
(let ((dir (pathname directory)))
(when (logical-pathname-p dir)
;; Because of the filtering we do below,
......@@ -263,6 +271,7 @@ or the original (parsed) pathname if it is false (the default)."
:finally (return p))))))
(defun resolve-symlinks (path)
"Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH."
#-allegro (truenamize path)
#+allegro
(if (physical-pathname-p path)
......@@ -274,6 +283,7 @@ or the original (parsed) pathname if it is false (the default)."
Defaults to T.")
(defun resolve-symlinks* (path)
"RESOLVE-SYMLINKS in PATH iff *RESOLVE-SYMLINKS* is T (the default)."
(if *resolve-symlinks*
(and path (resolve-symlinks path))
path)))
......@@ -404,10 +414,14 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
;;; Pathname defaults
(with-upgradability ()
(defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*))
"Find the actual DEFAULTS to use for pathnames, including
resolving them with respect to GETCWD if the DEFAULTS were relative"
(or (absolute-pathname-p defaults)
(merge-pathnames* defaults (getcwd))))
(defun call-with-current-directory (dir thunk)
"call the THUNK in a context where the current directory was changed to DIR, if not NIL.
Note that this operation is usually NOT thread-safe."
(if dir
(let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir))))
(cwd (getcwd))
......@@ -426,13 +440,18 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
;;; Environment pathnames
(with-upgradability ()
(defun inter-directory-separator ()
"What character does the current OS conventionally uses to separate directories?"
(if (os-unix-p) #\: #\;))
(defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
"Given a string of pathnames specified in native OS syntax, separate them in a list,
check constraints and normalize each one as per ENSURE-PATHNAME."
(loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
:collect (apply 'parse-native-namestring namestring constraints)))
(defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys)
"Extract a pathname from a user-configured environment variable, as per native OS,
check constraints and normalize as per ENSURE-PATHNAME."
;; For backward compatibility with ASDF 2, want-directory implies ensure-directory
(apply 'parse-native-namestring (getenvp x)
:ensure-directory (or ensure-directory want-directory)
......@@ -440,16 +459,23 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
`(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
constraints))
(defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
"Extract a list of pathname from a user-configured environment variable, as per native OS,
check constraints and normalize each one as per ENSURE-PATHNAME."
(apply 'split-native-pathnames-string (getenvp x)
:on-error (or on-error
`(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
constraints))
(defun getenv-absolute-directory (x)
"Extract an absolute directory pathname from a user-configured environment variable,
as per native OS"
(getenv-pathname x :want-absolute t :ensure-directory t))
(defun getenv-absolute-directories (x)
"Extract a list of absolute directories from a user-configured environment variable,
as per native OS"
(getenv-pathnames x :want-absolute t :ensure-directory t))
(defun lisp-implementation-directory (&key truename)
"Where are the system files of the current installation of the CL implementation?"
(declare (ignorable truename))
#+(or clozure ecl gcl mkcl sbcl)
(let ((dir
......@@ -465,6 +491,7 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
dir)))
(defun lisp-implementation-pathname-p (pathname)
"Is the PATHNAME under the current installation of the CL implementation?"
;; Other builtin systems are those under the implementation directory
(and (when pathname
(if-let (impdir (lisp-implementation-directory))
......@@ -479,11 +506,14 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
;;; Simple filesystem operations
(with-upgradability ()
(defun ensure-all-directories-exist (pathnames)
"Ensure that for every pathname in PATHNAMES, we ensure its directories exist"
(dolist (pathname pathnames)
(when pathname
(ensure-directories-exist (translate-logical-pathname pathname)))))
(defun rename-file-overwriting-target (source target)
"Rename a file, overwriting any previous file with the TARGET name,
in an atomic way if the implementation allows."
#+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic
(posix:copy-file source target :method :rename)
#-clisp
......@@ -491,6 +521,7 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
#+clozure :if-exists #+clozure :rename-and-delete))
(defun delete-file-if-exists (x)
"Delete a file X if it already exists"
(when x (handler-case (delete-file x) (file-error () nil))))
(defun delete-empty-directory (directory-pathname)
......
......@@ -20,6 +20,11 @@
;;; Features
(with-upgradability ()
(defun featurep (x &optional (*features* *features*))
"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."
(cond
((atom x) (and (member x *features*) t))
((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x))))
......@@ -50,6 +55,8 @@
(or #+mcl t))
(defun detect-os ()
"Detects the current operating system. Only needs be run at compile-time,
except on ABCL where it might change between FASL compilation and runtime."
(loop* :with o
:for (feature . detect) :in '((:os-unix . os-unix-p) (:os-windows . os-windows-p)
(:os-macosx . os-macosx-p)
......@@ -66,6 +73,9 @@ that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port
(with-upgradability ()
(defun getenv (x)
"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."
(declare (ignorable x))
#+(or abcl clisp ecl xcl) (ext:getenv x)
#+allegro (sys:getenv x)
......@@ -188,6 +198,8 @@ then returning the non-empty string value of the variable"
s))))
(defun implementation-identifier ()
"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."
(substitute-if
#\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
(format nil "~(~a~@{~@[-~a~]~}~)"
......
......@@ -258,6 +258,7 @@ Other keys are accepted but discarded."
&key element-type external-format if-does-not-exist)
&body body)
(declare (ignore element-type external-format if-does-not-exist))
"Evaluate BODY in a context when VAR is bound to an input stream accessing the null device."
`(call-with-null-input #'(lambda (,var) ,@body) ,@keys))
(defun call-with-null-output (fun
&key (element-type *default-stream-element-type*)
......@@ -271,6 +272,7 @@ Other keys are accepted but discarded."
(defmacro with-null-output ((var &rest keys
&key element-type external-format if-does-not-exist if-exists)
&body body)
"Evaluate BODY in a context when VAR is bound to an output stream accessing the null device."
(declare (ignore element-type external-format if-exists if-does-not-exist))
`(call-with-null-output #'(lambda (,var) ,@body) ,@keys)))
......@@ -293,6 +295,8 @@ Useful for portably flushing I/O before user input or program exit."
(finish-outputs stream))
(defun safe-format! (stream format &rest args)
"Variant of FORMAT that is safe against both
dangerous syntax configuration and errors while printing."
(with-safe-io-syntax ()
(ignore-errors (apply 'format! stream format args))
(finish-outputs stream)))) ; just in case format failed
......@@ -322,6 +326,7 @@ Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
(when (< end buffer-size) (return))))))
(defun concatenate-files (inputs output)
"create a new OUTPUT file the contents of which a the concatenate of the INPUTS files."
(with-open-file (o output :element-type '(unsigned-byte 8)
:direction :output :if-exists :rename-and-delete)
(dolist (input inputs)
......@@ -330,6 +335,7 @@ Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
(copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
(defun copy-file (input output)
"Copy contents of the INPUT file to the OUTPUT file"
;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f)
(concatenate-files (list input) output))
......@@ -472,15 +478,18 @@ If a string, repeatedly read and evaluate from it, returning the last values."
(with-upgradability ()
(defun println (x &optional (stream *standard-output*))
"Variant of PRINC that also calls TERPRI afterwards"
(princ x stream) (terpri stream) (values))
(defun writeln (x &rest keys &key (stream *standard-output*) &allow-other-keys)
"Variant of WRITE that also calls TERPRI afterwards"
(apply 'write x keys) (terpri stream) (values)))
;;; Using temporary files
(with-upgradability ()
(defun default-temporary-directory ()
"Return a default directory to use for temporary files"
(or
(when (os-unix-p)
(or (getenv-pathname "TMPDIR" :ensure-directory t)
......@@ -489,12 +498,14 @@ If a string, repeatedly read and evaluate from it, returning the last values."
(getenv-pathname "TEMP" :ensure-directory t))
(subpathname (user-homedir-pathname) "tmp/")))
(defvar *temporary-directory* nil)
(defvar *temporary-directory* nil "User-configurable location for temporary files")
(defun temporary-directory ()
"Return a directory to use for temporary files"
(or *temporary-directory* (default-temporary-directory)))
(defun setup-temporary-directory ()
"Configure a default temporary directory to use."
(setf *temporary-directory* (default-temporary-directory))
;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1
#+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*))
......@@ -504,6 +515,10 @@ If a string, repeatedly read and evaluate from it, returning the last values."
prefix keep (direction :io)
(element-type *default-stream-element-type*)
(external-format *utf-8-external-format*))
"Call a THUNK with STREAM and PATHNAME arguments identifying a temporary file.
The pathname will be based on appending a random suffix to PREFIX.
This utility will KEEP the file past its extent if and only if explicitly requested.
The file will be open with specified DIRECTION, ELEMENT-TYPE and EXTERNAL-FORMAT."
#+gcl2.6 (declare (ignorable external-format))
(check-type direction (member :output :io))
(loop
......@@ -531,8 +546,10 @@ If a string, repeatedly read and evaluate from it, returning the last values."
prefix keep direction element-type external-format)
&body body)
"Evaluate BODY where the symbols specified by keyword arguments
STREAM and PATHNAME are bound corresponding to a newly created temporary file
ready for I/O. Unless KEEP is specified, delete the file afterwards."
STREAM and PATHNAME (if respectively specified) are bound corresponding
to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE.
The STREAM will be closed if no binding is specified.
Unless KEEP is specified, delete the file afterwards."
(check-type stream symbol)
(check-type pathname symbol)
`(flet ((think (,stream ,pathname)
......@@ -550,10 +567,12 @@ ready for I/O. Unless KEEP is specified, delete the file afterwards."
;; Temporary pathnames in simple cases where no contention is assumed
(defun add-pathname-suffix (pathname suffix)
"Add a SUFFIX to the name of a PATHNAME, return a new pathname"
(make-pathname :name (strcat (pathname-name pathname) suffix)
:defaults pathname))
(defun tmpize-pathname (x)
"Return a new pathname modified from X by adding a trivial deterministic suffix"
(add-pathname-suffix x "-ASDF-TMP"))
(defun call-with-staging-pathname (pathname fun)
......
......@@ -194,10 +194,12 @@ Returns two values: \(A B C\) and \(1 2 3\)."
;;; Strings
(with-upgradability ()
(defun base-string-p (string)
"Does the STRING only contain BASE-CHARs?"
(declare (ignorable string))
(and #+non-base-chars-exist-p (eq 'base-char (array-element-type string))))
(defun strings-common-element-type (strings)
"What least subtype of CHARACTER can contain all the elements of all the STRINGS?"
(declare (ignorable strings))
#-non-base-chars-exist-p 'character
#+non-base-chars-exist-p
......@@ -220,12 +222,16 @@ NIL is interpreted as an empty string. A character is interpreted as a string of
:finally (return output)))
(defun strcat (&rest strings)
"Concatenate strings.
NIL is interpreted as an empty string, a character as a string of length one."
(reduce/strcat strings))
(defun first-char (s)
"Return the first character of a non-empty string S, or NIL"
(and (stringp s) (plusp (length s)) (char s 0)))
(defun last-char (s)
"Return the last character of a non-empty string S, or NIL"
(and (stringp s) (plusp (length s)) (char s (1- (length s)))))
(defun split-string (string &key max (separator '(#\Space #\Tab)))
......@@ -253,6 +259,8 @@ starting the separation from the end, e.g. when called with arguments
(defvar *crlf* (coerce #(#\cr #\newline) 'string))
(defun stripln (x)
"Strip a string X from any ending CR, LF or CRLF.
Return two values, the stripped string and the strip that was stripped"
(check-type x string)
(let* ((len (length x))
(endlfp (equal (last-char x) #\linefeed))
......@@ -295,7 +303,7 @@ starting the separation from the end, e.g. when called with arguments
(symbol (find-class x errorp environment)))))
;;; stamps: a REAL or boolean where NIL=-infinity, T=+infinity
;;; stamps: a REAL or a boolean where NIL=-infinity, T=+infinity
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
(deftype stamp () '(or real boolean)))
(with-upgradability ()
......@@ -489,6 +497,7 @@ or a string describing the format-control of a simple-condition."
(loop :for x :in conditions :thereis (match-condition-p x condition)))
(defun call-with-muffled-conditions (thunk conditions)
"calls the THUNK in a context where the CONDITIONS are muffled"
(handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
(muffle-warning c)))))
(funcall thunk)))
......@@ -496,4 +505,3 @@ or a string describing the format-control of a simple-condition."
(defmacro with-muffled-conditions ((conditions) &body body)
`(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment