Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
asdf
asdf
Commits
3900a1f0
Commit
3900a1f0
authored
Sep 28, 2013
by
Francois-Rene Rideau
Browse files
More docstrings.
parent
3176b414
Changes
4
Hide whitespace changes
Inline
Side-by-side
uiop/filesystem.lisp
View file @
3900a1f0
...
...
@@ -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
)
...
...
uiop/os.lisp
View file @
3900a1f0
...
...
@@ -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~]~}~)"
...
...
uiop/stream.lisp
View file @
3900a1f0
...
...
@@ -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
)
...
...
uiop/utility.lisp
View file @
3900a1f0
...
...
@@ -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
)))
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment