Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
asdf
asdf
Commits
27de4941
Commit
27de4941
authored
Nov 20, 2013
by
Francois-Rene Rideau
Browse files
UIOP: enhance ensure-pathname, add docstrings, fix getcwd on abcl (?)
parent
cf23361e
Changes
8
Hide whitespace changes
Inline
Side-by-side
bundle.lisp
View file @
27de4941
...
...
@@ -257,7 +257,7 @@
(
let*
((
operation-name
(
select-bundle-operation
type
monolithic
))
(
move-here-path
(
if
(
and
move-here
(
typep
move-here
'
(
or
pathname
string
)))
(
pathname
move-here
)
(
ensure-
pathname
move-here
:namestring
:lisp
:ensure-directory
t
)
(
system-relative-pathname
system
"asdf-output/"
)))
(
operation
(
apply
#'
operate
operation-name
system
...
...
@@ -409,7 +409,7 @@
(
assert
(
eq
(
not
input-files
)
(
not
output-files
)))
(
when
input-files
(
when
non-fasl-files
(
error
"On ~A, asdf
-
bundle can only bundle FASL files, but these were also produced: ~S"
(
error
"On ~A, asdf
/
bundle can only bundle FASL files, but these were also produced: ~S"
(
implementation-type
)
non-fasl-files
))
(
when
(
and
(
typep
o
'monolithic-bundle-op
)
(
or
(
monolithic-op-prologue-code
o
)
(
monolithic-op-epilogue-code
o
)))
...
...
find-system.lisp
View file @
27de4941
...
...
@@ -177,9 +177,7 @@ Going forward, we recommend new users should be using the source-registry.
:name
(
strcat
name
".asd"
)
:type
"lnk"
)))
(
when
(
probe-file*
shortcut
)
(
let
((
target
(
parse-windows-shortcut
shortcut
)))
(
when
target
(
return
(
pathname
target
))))))))))
(
ensure-pathname
(
parse-windows-shortcut
shortcut
)
:namestring
:native
)))))))
(
defun
sysdef-central-registry-search
(
system
)
(
let
((
name
(
primary-system-name
system
))
...
...
test/test-bundle.script
View file @
27de4941
;;; -*- Lisp -*-
(in-package :asdf-test)
;;;---------------------------------------------------------------------------
;;; Check to see if the bundle functionality is doing something.
;;;---------------------------------------------------------------------------
...
...
uiop/filesystem.lisp
View file @
27de4941
...
...
@@ -313,7 +313,7 @@ Defaults to T.")
(
defun
ensure-pathname
(
pathname
&key
on-error
defaults
type
dot-dot
defaults
type
dot-dot
namestring
want-pathname
want-logical
want-physical
ensure-physical
want-relative
want-absolute
ensure-absolute
ensure-subpath
...
...
@@ -327,10 +327,17 @@ optionally doing some transformations and checking specified constraints.
If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
If the argument is a STRING, it is first converted to a pathname via PARSE-UNIX-NAMESTRING
reusing the keywords DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE;
then the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true,
and the all the checks and transformations are run.
If the argument is a STRING, it is first converted to a pathname via
PARSE-UNIX-NAMESTRING, PARSE-NAMESTRING or PARSE-NATIVE-NAMESTRING respectively
depending on the NAMESTRING argument being :UNIX, :LISP or :NATIVE respectively,
or else by using CALL-FUNCTION on the NAMESTRING argument;
if :UNIX is specified (or NIL, the default, which specifies the same thing),
then PARSE-UNIX-NAMESTRING it is called with the keywords
DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE, and
the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true.
The pathname passed or resulting from parsing the string
is then subjected to all the checks and transformations below are run.
Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE.
The boolean T is an alias for ERROR.
...
...
@@ -389,11 +396,22 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
(
etypecase
p
((
or
null
pathname
))
(
string
(
setf
p
(
parse-unix-namestring
p
:defaults
defaults
:type
type
:dot-dot
dot-dot
:ensure-directory
ensure-directory
:want-relative
want-relative
))))
(
check
want-pathname
(
pathnamep
p
)
"Expected a pathname, not NIL"
)
(
unless
(
pathnamep
p
)
(
return
nil
))
(
setf
p
(
case
namestring
((
:unix
nil
)
(
parse-unix-namestring
p
:defaults
defaults
:type
type
:dot-dot
dot-dot
:ensure-directory
ensure-directory
:want-relative
want-relative
))
((
:native
)
(
parse-native-namestring
p
))
((
:lisp
)
(
parse-namestring
p
))
(
t
(
call-function
namestring
p
))))))
(
etypecase
p
(
pathname
)
(
null
(
check
want-pathname
(
pathnamep
p
)
"Expected a pathname, not NIL"
)
(
return
nil
)))
(
check
want-logical
(
logical-pathname-p
p
)
"Expected a logical pathname"
)
(
check
want-physical
(
physical-pathname-p
p
)
"Expected a physical pathname"
)
(
transform
ensure-physical
()
(
physicalize-pathname
p
))
...
...
uiop/os.lisp
View file @
27de4941
...
...
@@ -246,7 +246,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
(
defun
getcwd
()
"Get the current working directory as per POSIX getcwd(3), as a pathname object"
(
or
#+
abcl
(
parse-namestring
(
or
#+
abcl
(
parse-
native-
namestring
(
java:jstatic
"getProperty"
"java.lang.System"
"user.dir"
)
:ensure-directory
t
)
#+
allegro
(
excl::current-directory
)
#+
clisp
(
ext:default-directory
)
...
...
@@ -266,7 +266,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie
(
defun
chdir
(
x
)
"Change current directory, as per POSIX chdir(2), to a given pathname object"
(
if-let
(
x
(
pathname
x
))
(
or
#+
abcl
(
java:jstatic
"setProperty"
"java.lang.System"
"user.dir"
(
namestring
x
))
(
or
#+
abcl
(
java:jstatic
"setProperty"
"java.lang.System"
"user.dir"
(
native-
namestring
x
))
#+
allegro
(
excl:chdir
x
)
#+
clisp
(
ext:cd
x
)
#+
clozure
(
setf
(
ccl:current-directory
)
x
)
...
...
uiop/run-program.lisp
View file @
27de4941
...
...
@@ -379,7 +379,7 @@ argument to pass to the internal RUN-PROGRAM"
(
declare
(
ignorable
role
))
(
etypecase
specifier
(
null
(
or
#+
(
or
allegro
lispworks
)
(
null-device-pathname
)))
(
string
(
pa
thname
specifier
))
(
string
(
pa
rse-native-namestring
specifier
))
(
pathname
specifier
)
(
stream
specifier
)
((
eql
:stream
)
:stream
)
...
...
@@ -745,7 +745,7 @@ It returns a process-info plist with possible keys:
(
let
((
pathname
(
typecase
spec
(
null
(
null-device-pathname
))
(
string
(
pa
thname
spec
))
(
string
(
pa
rse-native-namestring
spec
))
(
pathname
spec
)
((
eql
:output
)
(
assert
(
equal
operator
" 2>"
))
...
...
uiop/stream.lisp
View file @
27de4941
...
...
@@ -267,19 +267,22 @@ and always returns EOF when read from"
((
os-windows-p
)
#p"NUL"
)
;; Q: how many Lisps accept the #p"NUL:" syntax?
(
t
(
error
"No /dev/null on your OS"
))))
(
defun
call-with-null-input
(
fun
&rest
keys
&key
element-type
external-format
if-does-not-exist
)
"Call FUN with an input stream from the null device; pass keyword arguments to OPEN."
(
declare
(
ignore
element-type
external-format
if-does-not-exist
))
(
apply
'call-with-input-file
(
null-device-pathname
)
fun
keys
))
(
defmacro
with-null-input
((
var
&rest
keys
&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."
"Evaluate BODY in a context when VAR is bound to an input stream accessing the null device.
Pass keyword arguments to OPEN."
`
(
call-with-null-input
#'
(
lambda
(
,
var
)
,@
body
)
,@
keys
))
(
defun
call-with-null-output
(
fun
&key
(
element-type
*default-stream-element-type*
)
(
external-format
*utf-8-external-format*
)
(
if-exists
:overwrite
)
(
if-does-not-exist
:error
))
"Call FUN with an output stream to the null device; pass keyword arguments to OPEN."
(
call-with-output-file
(
null-device-pathname
)
fun
:element-type
element-type
:external-format
external-format
...
...
@@ -287,7 +290,8 @@ and always returns EOF when read from"
(
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."
"Evaluate BODY in a context when VAR is bound to an output stream accessing the null device.
Pass keyword arguments to OPEN."
(
declare
(
ignore
element-type
external-format
if-exists
if-does-not-exist
))
`
(
call-with-null-output
#'
(
lambda
(
,
var
)
,@
body
)
,@
keys
)))
...
...
@@ -554,11 +558,15 @@ Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'e
(
check-type
direction
(
member
:output
:io
))
(
assert
(
or
want-stream-p
want-pathname-p
))
(
loop
:with
prefix
=
(
namestring
(
ensure-absolute-pathname
(
or
prefix
"tmp"
)
(
or
directory
#'
temporary-directory
)))
:with
prefix
=
(
native-namestring
(
ensure-absolute-pathname
(
or
prefix
"tmp"
)
(
or
(
ensure-pathname
directory
:namestring
:native
:ensure-directory
t
)
#'
temporary-directory
)))
:with
results
=
()
:for
counter
:from
(
random
(
expt
36
#-
gcl
8
#+
gcl
5
))
:for
pathname
=
(
pathname
(
format
nil
"~A~36R~@[~A~]~@[.~A~]"
prefix
counter
suffix
type
))
:for
pathname
=
(
parse-native-namestring
(
format
nil
"~A~36R~@[~A~]~@[.~A~]"
prefix
counter
suffix
type
))
:for
okp
=
nil
:do
;; TODO: on Unix, do something about umask
;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
...
...
@@ -648,11 +656,10 @@ Further KEYS can be passed to MAKE-PATHNAME."
(
add-pathname-suffix
x
"-TMP"
))
(
defun
call-with-staging-pathname
(
pathname
fun
)
"Calls fun with a staging pathname, and atomically
renames the staging pathname to the pathname in the end.
Note: this protects only against failure of the program,
not against concurrent attempts.
For the latter case, we ought pick random suffix and atomically open it."
"Calls FUN with a staging pathname, and atomically
renames the staging pathname to the PATHNAME in the end.
NB: this protects only against failure of the program, not against concurrent attempts.
For the latter case, we ought pick a random suffix and atomically open it."
(
let*
((
pathname
(
pathname
pathname
))
(
staging
(
tmpize-pathname
pathname
)))
(
unwind-protect
...
...
@@ -662,5 +669,6 @@ For the latter case, we ought pick random suffix and atomically open it."
(
delete-file-if-exists
staging
))))
(
defmacro
with-staging-pathname
((
pathname-var
&optional
(
pathname-value
pathname-var
))
&body
body
)
"Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME"
`
(
call-with-staging-pathname
,
pathname-value
#'
(
lambda
(
,
pathname-var
)
,@
body
))))
uiop/utility.lisp
View file @
27de4941
...
...
@@ -80,6 +80,11 @@
(
defdef
defgeneric*
defgeneric
)
(
defdef
defun*
defun
))
(
defmacro
with-upgradability
((
&optional
)
&body
body
)
"Evaluate BODY at compile- load- and run- times, with DEFUN and DEFGENERIC modified
to also declare the functions NOTINLINE and to accept a wrapping the function name
specification into a list with keyword argument SUPERSEDE (which defaults to T if the name
is not wrapped, and NIL if it is wrapped). If SUPERSEDE is true, call UNDEFINE-FUNCTION
to supersede any previous definition."
`
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
,@
(
loop
:for
form
:in
body
:collect
(
if
(
consp
form
)
...
...
@@ -549,5 +554,6 @@ or a string describing the format-control of a simple-condition."
(
funcall
thunk
)))
(
defmacro
with-muffled-conditions
((
conditions
)
&body
body
)
"Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS"
`
(
call-with-muffled-conditions
#'
(
lambda
()
,@
body
)
,
conditions
)))
Write
Preview
Supports
Markdown
0%
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!
Cancel
Please
register
or
sign in
to comment