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
Didier Verna
asdf
Commits
0b681897
Commit
0b681897
authored
Jan 16, 2013
by
Francois-Rene Rideau
Browse files
2.26.104: some more pathname munging.
parent
7ba708cb
Changes
7
Hide whitespace changes
Inline
Side-by-side
asdf.asd
View file @
0b681897
...
...
@@ -15,7 +15,7 @@
:licence
"MIT"
:description
"Another System Definition Facility"
:long-description
"ASDF builds Common Lisp software organized into defined systems."
:version
"2.26.10
4
"
;; to be automatically updated by bin/bump-revision
:version
"2.26.10
5
"
;; to be automatically updated by bin/bump-revision
:depends-on
()
:components
((
:module
"build"
:components
((
:file
"asdf"
))))
:in-order-to
(
#+
asdf2.27
(
compile-op
(
monolithic-load-concatenated-source-op
generate-asdf
))))
...
...
bin/make-tarball
View file @
0b681897
...
...
@@ -13,33 +13,37 @@
(describe (find-system :asdf))
(defparameter *ad* (find-system :asdf-driver))
(defparameter *asdf-directory* (system-source-directory *ad*))
(defparameter *version*
(safe-read-first-file-form (subpathname *asdf-directory* "version.lisp-expr")))
(DBG :foo *ad* *version* (asdf-version))
(defparameter *asdf-dir*
(ensure-pathname (system-source-directory *ad*)
:want-existing t :want-absolute t))
(defun apath (x) (subpathname *asdf-dir* x))
(defun ann (x) (native-namestring (apath x)))
(defparameter *build-dir* (apath "build/"))
(defparameter /build-dir/ (ann "build/"))
(defun bpath (x) (subpathname *build-dir* x))
(defun bnn (x) (native-namestring (bpath x)))
(defparameter *files*
(append
(loop :for c :in (operated-components *ad*
:goal-operation 'load-op
:keep-operation 'load-op)
:for n = (enough-namestring (component-pathname c) *asdf-directory*)
:when (typep c 'cl-source-file)
:collect n)
(list "version.lisp-expr" "asdf-driver.asd")))
;; make asdf:
;;;(run-program/ (list "make" "-C" (native-namestring *asdf-directory*) "build/asdf.lisp"))
#|
if [ -d "tmp" ]; then
rm -r tmp
fi
mkdir tmp
archive_file="tmp/asdf-$tag.tar.gz"
echo "Create tmp/asdf.tar.gz with tag $tag"
git archive $tag --prefix="asdf/" --format=tar | \
gzip > $archive_file
|#
\ No newline at end of file
(list* "asdf-driver.asd" "version.lisp-expr"
(loop :for c :in (operated-components
*ad* :goal-operation 'load-op
:keep-operation 'load-op)
:for n = (enough-namestring (component-pathname c)
*asdf-directory*)
:when (typep c 'cl-source-file)
:collect n)))
(defparameter *version*
(safe-read-first-file-form (apath "version.lisp-expr")))
(defparameter *name* (format nil "asdf-driver-~A" *version*))
(defparameter *tarname* (strcat *name* ".tar.gz"))
(defparameter dirname/ (strcat *name* "/"))
(defparameter *destination*
(ensure-pathname (bpath dirname/)
:want-directory t :want-absolute t))
(assert (< 6 (length (pathname-directory *destination*))))
(defparameter /destination/ (native-namestring *destination*))
(run-program/ `("rm" "-rf" ,/destination/))
(ensure-directory-exists *destination*)
(run-program/ `("ln" ,@(mapcar 'ann *files*) ,/destination/))
(run-program/ (format nil "cd ~S && tar zcf ~S ~S"
,/build-dir/, ,*tarname* ,dirname/))
(run-program/ `("rm" "-rf" ,/destination/))
configuration.lisp
View file @
0b681897
...
...
@@ -152,35 +152,34 @@ values of TAG include :source-registry and :output-translations."
:inherit-configuration
)))
(
defun*
resolve-relative-location-component
(
x
&key
want-directory
wilden
)
(
let*
((
r
(
etypecase
x
(
pathname
x
)
(
string
(
parse-unix-namestring
x
:want-directory
want-directory
))
(
cons
(
if
(
null
(
cdr
x
))
(
resolve-relative-location-component
(
car
x
)
:want-directory
want-directory
:wilden
wilden
)
(
let*
((
car
(
resolve-relative-location-component
(
car
x
)
:want-directory
t
:wilden
nil
)))
(
merge-pathnames*
(
resolve-relative-location-component
(
cdr
x
)
:want-directory
want-directory
:wilden
wilden
)
car
))))
((
eql
:*/
)
*wild-directory*
)
((
eql
:**/
)
*wild-inferiors*
)
((
eql
:*.*.*
)
*wild-file*
)
((
eql
:implementation
)
(
parse-unix-namestring
(
implementation-identifier
)
:want-directory
t
))
((
eql
:implementation-type
)
(
parse-unix-namestring
(
string-downcase
(
implementation-type
))
:want-directory
t
))
((
eql
:hostname
)
(
parse-unix-namestring
(
hostname
)
:want-directory
t
))))
(
w
(
if
(
and
wilden
(
not
(
pathnamep
x
))
(
not
(
member
x
'
(
:*/
:**/
:*.*.*
))))
(
wilden
r
)
r
)))
(
ensure-pathname
w
:want-relative
t
)))
(
ensure-pathname
(
etypecase
x
(
pathname
x
)
(
string
(
parse-unix-namestring
x
:want-directory
want-directory
))
(
cons
(
if
(
null
(
cdr
x
))
(
resolve-relative-location-component
(
car
x
)
:want-directory
want-directory
:wilden
wilden
)
(
let*
((
car
(
resolve-relative-location-component
(
car
x
)
:want-directory
t
:wilden
nil
)))
(
merge-pathnames*
(
resolve-relative-location-component
(
cdr
x
)
:want-directory
want-directory
:wilden
wilden
)
car
))))
((
eql
:*/
)
*wild-directory*
)
((
eql
:**/
)
*wild-inferiors*
)
((
eql
:*.*.*
)
*wild-file*
)
((
eql
:implementation
)
(
parse-unix-namestring
(
implementation-identifier
)
:want-directory
t
))
((
eql
:implementation-type
)
(
parse-unix-namestring
(
string-downcase
(
implementation-type
))
:want-directory
t
))
((
eql
:hostname
)
(
parse-unix-namestring
(
hostname
)
:want-directory
t
)))
:wilden
(
and
wilden
(
not
(
pathnamep
x
))
(
not
(
member
x
'
(
:*/
:**/
:*.*.*
))))
:want-relative
t
))
(
defvar
*here-directory*
nil
"This special variable is bound to the currect directory during calls to
...
...
@@ -203,39 +202,38 @@ directive.")
(
register-image-restore-hook
'compute-user-cache
)
(
defun*
resolve-absolute-location-component
(
x
&key
want-directory
wilden
)
(
let*
((
r
(
etypecase
x
(
pathname
x
)
(
string
(
let
((
p
#-
mcl
(
parse-namestring
x
)
#+
mcl
(
probe-posix
x
)))
#+
mcl
(
unless
p
(
error
"POSIX pathname ~S does not exist"
x
))
(
if
want-directory
(
ensure-directory-pathname
p
)
p
)))
(
cons
(
return-from
resolve-absolute-location-component
(
if
(
null
(
cdr
x
))
(
resolve-absolute-location-component
(
car
x
)
:want-directory
want-directory
:wilden
wilden
)
(
merge-pathnames*
(
resolve-relative-location-component
(
cdr
x
)
:want-directory
want-directory
:wilden
wilden
)
(
resolve-absolute-location-component
(
car
x
)
:want-directory
t
:wilden
nil
)))))
((
eql
:root
)
;; special magic! we return a relative pathname,
;; but what it means to the output-translations is
;; "relative to the root of the source pathname's host and device".
(
return-from
resolve-absolute-location-component
(
let
((
p
(
make-pathname*
:directory
'
(
:relative
))))
(
if
wilden
(
wilden
p
)
p
))))
((
eql
:home
)
(
user-homedir
))
((
eql
:here
)
(
resolve-absolute-location-component
*here-directory*
:want-directory
t
:wilden
nil
))
((
eql
:user-cache
)
(
resolve-absolute-location-component
*user-cache*
:want-directory
t
:wilden
nil
))))
(
w
(
if
(
and
wilden
(
not
(
pathnamep
x
)))
(
wilden
r
)
r
)))
(
ensure-pathname
w
:want-absolute
t
)))
(
ensure-pathname
(
etypecase
x
(
pathname
x
)
(
string
(
let
((
p
#-
mcl
(
parse-namestring
x
)
#+
mcl
(
probe-posix
x
)))
#+
mcl
(
unless
p
(
error
"POSIX pathname ~S does not exist"
x
))
(
if
want-directory
(
ensure-directory-pathname
p
)
p
)))
(
cons
(
return-from
resolve-absolute-location-component
(
if
(
null
(
cdr
x
))
(
resolve-absolute-location-component
(
car
x
)
:want-directory
want-directory
:wilden
wilden
)
(
merge-pathnames*
(
resolve-relative-location-component
(
cdr
x
)
:want-directory
want-directory
:wilden
wilden
)
(
resolve-absolute-location-component
(
car
x
)
:want-directory
t
:wilden
nil
)))))
((
eql
:root
)
;; special magic! we return a relative pathname,
;; but what it means to the output-translations is
;; "relative to the root of the source pathname's host and device".
(
return-from
resolve-absolute-location-component
(
let
((
p
(
make-pathname*
:directory
'
(
:relative
))))
(
if
wilden
(
wilden
p
)
p
))))
((
eql
:home
)
(
user-homedir
))
((
eql
:here
)
(
resolve-absolute-location-component
*here-directory*
:want-directory
t
:wilden
nil
))
((
eql
:user-cache
)
(
resolve-absolute-location-component
*user-cache*
:want-directory
t
:wilden
nil
)))
:wilden
(
and
wilden
(
not
(
pathnamep
x
)))
:want-absolute
t
))
(
defun*
resolve-location
(
x
&key
want-directory
wilden
directory
)
(
when
directory
(
setf
want-directory
t
))
;; :directory backward compatibility, until 2014-01-16.
...
...
header.lisp
View file @
0b681897
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.10
4
: Another System Definition Facility.
;;; This is ASDF 2.26.10
5
: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
...
...
pathname.lisp
View file @
0b681897
...
...
@@ -931,9 +931,11 @@ Otherwise, this will be the root of some implementation-dependent filesystem hos
(
defun*
ensure-pathname
(
pathname
&key
want-pathname
want-existing
want-absolute
want-relative
want-directory
want-file
want-wild
want-non-wild
want-truename
truenamize
error-arguments
)
want-absolute
want-relative
want-logical
want-physical
ensure-physical
want-wild
want-non-wild
wilden
ensure-directory
want-directory
want-file
want-truename
truenamize
error-arguments
)
"Coerces its argument into a PATHNAME, and checks 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-NAMESTRING.
...
...
@@ -968,30 +970,42 @@ in case you use the long variant."
(
string
(
setf
pathname
(
parse-namestring
pathname
)))
(
pathname
))
(
when
want-logical
(
unless
(
typep
pathname
'logical-pathname
)
(
err
want-logical
"Expected a logical pathname, got"
)))
(
when
want-physical
(
unless
(
physical-pathname-p
pathname
)
(
err
want-physical
"Expected a physical pathname, got"
)))
(
when
ensure-physical
(
setf
pathname
(
translate-logical-pathname
pathname
)))
(
when
want-absolute
(
unless
(
absolute-pathname-p
pathname
)
(
err
want-absolute
"Expected an absolute pathname, got"
)))
(
when
want-relative
(
when
(
absolute-pathname-p
pathname
)
(
err
want-relative
"Expected a relative pathname, got"
)))
(
when
want-directory
(
unless
(
directory-pathname-p
pathname
)
(
err
want-directory
"Expected a directory pathname, got"
)))
(
when
want-file
(
unless
(
pathname-name
pathname
)
(
err
want-file
"Expected a file pathname, got"
)))
(
when
want-wild
(
unless
(
wild-pathname-p
pathname
)
(
err
want-wild
"Expected a wildcard pathname, got"
)))
(
when
(
or
want-non-wild
want-existing
)
(
when
(
wild-pathname-p
pathname
)
(
err
want-non-wild
"Expected a non-wildcard pathname, got"
)))
(
when
(
and
wilden
(
not
(
wild-pathname-p
pathname
)))
(
setf
pathname
(
wilden
pathname
)))
(
when
ensure-directory
(
setf
pathname
(
ensure-directory-pathname
pathname
)))
(
when
want-directory
(
unless
(
directory-pathname-p
pathname
)
(
err
want-directory
"Expected a directory pathname, got"
)))
(
when
want-file
(
unless
(
pathname-name
pathname
)
(
err
want-file
"Expected a file pathname, got"
)))
(
when
want-existing
(
let
((
existing
(
probe-file*
pathname
)))
(
if
existing
(
err
want-existing
"Expected an existing pathname, got"
)
(
when
(
or
want-truename
truenamize
)
(
return
existing
)))))
(
return
existing
))
(
err
want-existing
"Expected an existing pathname, got"
))))
(
when
want-truename
(
let
((
truename
(
truename*
pathname
)))
(
if
truename
...
...
upgrade.lisp
View file @
0b681897
...
...
@@ -45,7 +45,7 @@
;; "2.345.6" would be a development version in the official upstream
;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
(
asdf-version
"2.26.10
4
"
)
(
asdf-version
"2.26.10
5
"
)
(
existing-asdf
(
find-class
(
find-symbol*
:component
:asdf
nil
)
nil
))
(
existing-version
*asdf-version*
)
(
already-there
(
equal
asdf-version
existing-version
)))
...
...
version.lisp-expr
View file @
0b681897
"2.26.10
4
"
"2.26.10
5
"
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