Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
A
asdf
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Container Registry
Model registry
Operate
Environments
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Jan Moringen
asdf
Commits
3900a1f0
Commit
3900a1f0
authored
11 years ago
by
Francois-Rene Rideau
Browse files
Options
Downloads
Patches
Plain Diff
More docstrings.
parent
3176b414
No related branches found
Branches containing commit
No related tags found
Tags containing commit
No related merge requests found
Changes
4
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
uiop/filesystem.lisp
+31
-0
31 additions, 0 deletions
uiop/filesystem.lisp
uiop/os.lisp
+12
-0
12 additions, 0 deletions
uiop/os.lisp
uiop/stream.lisp
+22
-3
22 additions, 3 deletions
uiop/stream.lisp
uiop/utility.lisp
+10
-2
10 additions, 2 deletions
uiop/utility.lisp
with
75 additions
and
5 deletions
uiop/filesystem.lisp
+
31
−
0
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
)
...
...
This diff is collapsed.
Click to expand it.
uiop/os.lisp
+
12
−
0
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~]~}~)"
...
...
This diff is collapsed.
Click to expand it.
uiop/stream.lisp
+
22
−
3
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
)
...
...
This diff is collapsed.
Click to expand it.
uiop/utility.lisp
+
10
−
2
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
)))
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment