Commit 27de4941 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

UIOP: enhance ensure-pathname, add docstrings, fix getcwd on abcl (?)

parent cf23361e
......@@ -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)))
......
......@@ -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))
......
;;; -*- Lisp -*-
(in-package :asdf-test)
;;;---------------------------------------------------------------------------
;;; Check to see if the bundle functionality is doing something.
;;;---------------------------------------------------------------------------
......
......@@ -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))
......
......@@ -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)
......
......@@ -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 (pathname specifier))
(string (parse-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 (pathname spec))
(string (parse-native-namestring spec))
(pathname spec)
((eql :output)
(assert (equal operator " 2>"))
......
......@@ -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))))
......@@ -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)))
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