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
8e07148e
Commit
8e07148e
authored
Dec 31, 2009
by
Peter Van Eynde
Browse files
imported new upstream, keeping the modified loop construct for ecl
parents
8e6d7adb
f6dfe94d
Changes
61
Expand all
Hide whitespace changes
Inline
Side-by-side
.gitignore
View file @
8e07148e
...
...
@@ -5,10 +5,14 @@ common-lisp.net
init-lisp.lisp
website/changelog.xml
# Test stuff
test/results/
# We build these at various stages in the make process
LICENSE
website/output/
test-results/
tmp/
lift-local.config
*.dribble
*.fasl
...
...
@@ -16,3 +20,4 @@ lift-local.config
*.cfsl
*.fas
*.lib
*.o
GNUmakefile
View file @
8e07148e
...
...
@@ -7,7 +7,7 @@ clnet_home := "/project/asdf/public_html/"
sourceDirectory
:=
$(
shell
pwd
)
lisps
=
allegro allegromodern ccl clisp sbcl
lisps
=
allegro allegromodern ccl clisp sbcl
ifndef
lisp
lisp
:=
sbcl
...
...
@@ -17,7 +17,11 @@ endif
install
:
archive-copy
bump_revision
:
FORCE
bin/bump-revision-and-tag.sh
archive
:
FORCE
sbcl
--userinit
/dev/null
--sysinit
/dev/null
--load
bin/make-helper.lisp
\
--eval
"(rewrite-license)"
--eval
"(quit)"
bin/build-tarball.sh
...
...
@@ -27,6 +31,7 @@ archive-copy: archive
bin/link-tarball.sh
$(clnet_home)
$(user)
bin/rsync-cp.sh tmp/asdf.lisp
$(webhome_private)
git push cl.net
git push
--tags
cl.net
website-copy
:
FORCE
bin/rsync-cp.sh website/output/
$(webhome_private)
...
...
@@ -49,8 +54,7 @@ clean: FORCE
done
test
:
FORCE
@
cd test
;
./run-tests.sh
$(lisp)
$
(
test-regex
)
echo
"My foot is
$?
"
@
cd test
;
make clean
;
./run-tests.sh
$(lisp)
$
(
test-regex
)
test-all
:
FORCE
@
for
lisp
in
$(lisps)
;
do
\
...
...
README
View file @
8e07148e
ASDF: another system definition facility
ASDF: another system definition facility
========================================
If you want to use ASDF to load systems, see the getting
...
...
asdf-ecl.lisp
0 → 100644
View file @
8e07148e
;;; Copyright (c) 2005, Michael Goffioul (michael dot goffioul at swing dot be)
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; See file '../../Copyright' for full details.
;;;
;;; ECL SPECIFIC OPERATIONS FOR ASDF
;;;
(
in-package
:asdf
)
(
require
'cmp
)
;;;
;;; COMPILE-OP / LOAD-OP
;;;
;;; We change these operations to produce both FASL files and the
;;; object files that they are built from. Having both of them allows
;;; us to later on reuse the object files for bundles, libraries,
;;; standalone executables, etc.
;;;
(
defmethod
initialize-instance
:after
((
instance
compile-op
)
&key
&allow-other-keys
)
(
setf
(
slot-value
instance
'flags
)
'
(
:system-p
t
)))
(
defmethod
output-files
((
o
compile-op
)
(
c
cl-source-file
))
(
list
(
compile-file-pathname
(
component-pathname
c
)
:type
:object
)
(
compile-file-pathname
(
component-pathname
c
)
:type
:fasl
)))
(
defmethod
perform
:after
((
o
compile-op
)
(
c
cl-source-file
))
;; Note how we use OUTPUT-FILES to find the binary locations
;; This allows the user to override the names.
(
let*
((
input
(
output-files
o
c
))
(
output
(
compile-file-pathname
(
first
input
)
:type
:fasl
)))
(
c:build-fasl
output
:lisp-files
(
remove
"fas"
input
:key
#'
pathname-type
:test
#'
string=
))))
(
defmethod
perform
((
o
load-op
)
(
c
cl-source-file
))
(
loop
for
i
in
(
input-files
o
c
)
unless
(
string=
(
pathname-type
i
)
"fas"
)
collect
(
let
((
output
(
compile-file-pathname
i
)))
(
load
output
))))
;;;
;;; BUNDLE-OP
;;;
;;; This operation takes all components from one or more systems and
;;; creates a single output file, which may be a FASL, a statically
;;; linked library, a shared library, etc The different targets are
;;; defined by specialization.
;;;
(
defclass
bundle-op
(
operation
)
((
type
:reader
bundle-op-type
)
(
monolithic
:initform
nil
:reader
bundle-op-monolithic-p
)
(
name-suffix
:initarg
:name-suffix
:initform
nil
)
(
build-args
:initarg
:args
:initform
nil
:accessor
bundle-op-build-args
)))
(
defclass
fasl-op
(
bundle-op
)
((
type
:initform
:fasl
)))
(
defclass
lib-op
(
bundle-op
)
((
type
:initform
:lib
)))
(
defclass
dll-op
(
bundle-op
)
((
type
:initform
:dll
)))
(
defclass
monolithic-bundle-op
(
bundle-op
)
((
monolithic
:initform
t
)
(
prologue-code
:accessor
monolithic-op-prologue-code
)
(
epilogue-code
:accessor
monolithic-op-epilogue-code
)))
(
defclass
monolithic-fasl-op
(
fasl-op
monolithic-bundle-op
)
())
(
defclass
monolithic-lib-op
(
lib-op
monolithic-bundle-op
)
((
type
:initform
:lib
)))
(
defclass
monolithic-dll-op
(
dll-op
monolithic-bundle-op
)
((
type
:initform
:dll
)))
(
defclass
program-op
(
monolithic-bundle-op
)
((
type
:initform
:program
)))
(
defmethod
initialize-instance
:after
((
instance
bundle-op
)
&rest
initargs
&key
(
name-suffix
nil
name-suffix-p
)
&allow-other-keys
)
(
unless
name-suffix-p
(
setf
(
slot-value
instance
'name-suffix
)
(
if
(
bundle-op-monolithic-p
instance
)
"-mono"
""
)))
(
when
(
typep
instance
'monolithic-bundle-op
)
(
destructuring-bind
(
&rest
original-initargs
&key
prologue-code
epilogue-code
&allow-other-keys
)
(
slot-value
instance
'original-initargs
)
(
setf
(
slot-value
instance
'original-initargs
)
(
remove-keys
'
(
epilogue-code
prologue-code
)
original-initargs
)
(
monolithic-op-prologue-code
instance
)
prologue-code
(
monolithic-op-epilogue-code
instance
)
epilogue-code
)))
(
setf
(
bundle-op-build-args
instance
)
(
remove-keys
'
(
type
monolithic
name-suffix
)
(
slot-value
instance
'original-initargs
))))
(
defvar
*force-load-p*
nil
)
(
defmethod
operation-done-p
:around
((
operation
load-op
)
c
)
(
if
*force-load-p*
nil
(
call-next-method
)))
(
defun
gather-components
(
op-type
system
&key
filter-system
filter-type
include-self
)
;; This function creates a list of components, matched together with an
;; operation. This list may be restricted to sub-components of SYSTEM if
;; GATHER-ALL = NIL (default), and it may include the system itself.
(
let*
((
operation
(
make-instance
op-type
))
(
*force-load-p*
t
)
(
tree
(
traverse
(
make-instance
'load-op
)
system
)))
(
append
(
loop
for
(
op
.
component
)
in
tree
when
(
and
(
typep
op
'load-op
)
(
typep
component
filter-type
)
(
or
(
not
filter-system
)
(
eq
(
component-system
component
)
filter-system
)))
collect
(
progn
(
when
(
eq
component
system
)
(
setf
include-self
nil
))
(
cons
operation
component
)))
(
and
include-self
(
list
(
cons
operation
system
))))))
;;;
;;; BUNDLE-SUB-OPERATIONS
;;;
;;; Builds a list of pairs (operation . component) which contains all the
;;; dependencies of this bundle. This list is used by TRAVERSE and also
;;; by INPUT-FILES. The dependencies depend on the strategy, as explained
;;; below.
;;;
(
defgeneric
bundle-sub-operations
(
operation
component
))
;;;
;;; First we handle monolithic bundles. These are standalone systems
;;; which contain everything, including other ASDF systems required
;;; by the current one. A PROGRAM is always monolithic.
;;;
;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
;;;
;;; Gather the static libraries of all components.
;;;
(
defmethod
bundle-sub-operations
((
o
monolithic-bundle-op
)
c
)
(
gather-components
'lib-op
c
:filter-type
'system
:include-self
t
))
;;;
;;; STATIC LIBRARIES
;;;
;;; Gather the object files of all components and, if monolithic, also
;;; of systems and subsystems.
;;;
(
defmethod
bundle-sub-operations
((
o
lib-op
)
c
)
(
gather-components
'compile-op
c
:filter-system
(
and
(
not
(
bundle-op-monolithic-p
o
))
c
)
:filter-type
'
(
not
system
)))
;;;
;;; SHARED LIBRARIES
;;;
;;; Gather the dynamically linked libraries of all components.
;;; They will be linked into this new shared library, together
;;; with the static library of this module.
;;;
(
defmethod
bundle-sub-operations
((
o
dll-op
)
c
)
(
list
(
cons
(
make-instance
'lib-op
)
c
)))
;;;
;;; FASL FILES
;;;
;;; Gather the statically linked library of this component.
;;;
(
defmethod
bundle-sub-operations
((
o
fasl-op
)
c
)
(
list
(
cons
(
make-instance
'lib-op
)
c
)))
(
defmethod
component-depends-on
((
o
bundle-op
)
(
c
system
))
(
loop
for
(
op
.
dep
)
in
(
bundle-sub-operations
o
c
)
when
(
typep
dep
'system
)
collect
(
list
(
class-name
(
class-of
op
))
(
component-name
dep
))))
(
defmethod
component-depends-on
((
o
lib-op
)
(
c
system
))
(
list
(
list
'compile-op
(
component-name
c
))))
(
defmethod
component-depends-on
((
o
bundle-op
)
c
)
nil
)
(
defmethod
input-files
((
o
bundle-op
)
(
c
system
))
(
loop
for
(
sub-op
.
sub-c
)
in
(
bundle-sub-operations
o
c
)
nconc
(
output-files
sub-op
sub-c
)))
(
defmethod
output-files
((
o
bundle-op
)
(
c
system
))
(
let
((
name
(
concatenate
'base-string
(
component-name
c
)
(
slot-value
o
'name-suffix
))))
(
list
(
merge-pathnames
(
compile-file-pathname
name
:type
(
bundle-op-type
o
))
(
component-relative-pathname
c
)))))
(
defmethod
output-files
((
o
fasl-op
)
(
c
system
))
(
loop
for
file
in
(
call-next-method
)
collect
(
make-pathname
:type
"fasb"
:defaults
file
)))
(
defmethod
perform
((
o
bundle-op
)
(
c
t
))
t
)
(
defmethod
operation-done-p
((
o
bundle-op
)
(
c
source-file
))
t
)
(
defmethod
perform
((
o
bundle-op
)
(
c
system
))
(
let*
((
object-files
(
remove
"fas"
(
input-files
o
c
)
:key
#'
pathname-type
:test
#'
string=
))
(
output
(
output-files
o
c
)))
(
ensure-directories-exist
(
first
output
))
(
apply
#'
c::builder
(
bundle-op-type
o
)
(
first
output
)
:lisp-files
object-files
(
append
(
bundle-op-build-args
o
)
(
when
(
and
(
typep
o
'monolithic-bundle-op
)
(
monolithic-op-prologue-code
o
))
`
(
:prologue-code
,
(
monolithic-op-prologue-code
o
)))
(
when
(
and
(
typep
o
'monolithic-bundle-op
)
(
monolithic-op-epilogue-code
o
))
`
(
:epilogue-code
,
(
monolithic-op-epilogue-code
o
)))))))
(
defun
select-operation
(
monolithic
type
)
(
ecase
type
((
:dll
:shared-library
)
(
if
monolithic
'monolithic-dll-op
'dll-op
))
((
:lib
:static-library
)
(
if
monolithic
'monolithic-lib-op
'lib-op
))
((
:fasl
)
(
if
monolithic
'monolithic-fasl-op
'fasl-op
))
((
:program
)
'program-op
)))
(
defun
make-build
(
system
&rest
args
&key
(
monolithic
nil
)
(
type
:fasl
)
&allow-other-keys
)
(
apply
#'
operate
(
select-operation
monolithic
type
)
system
(
remove-keys
'
(
monolithic
type
)
args
)))
;;;
;;; LOAD-FASL-OP
;;;
;;; This is like ASDF's LOAD-OP, but using monolithic fasl files.
;;;
(
defclass
load-fasl-op
(
operation
)
())
(
defun
trivial-system-p
(
c
)
(
every
#'
(
lambda
(
c
)
(
typep
c
'compiled-file
))
(
module-components
c
)))
(
defmethod
component-depends-on
((
o
load-fasl-op
)
(
c
system
))
(
unless
(
trivial-system-p
c
)
(
subst
'load-fasl-op
'load-op
(
subst
'fasl-op
'compile-op
(
component-depends-on
(
make-instance
'load-op
)
c
)))))
(
defmethod
input-files
((
o
load-fasl-op
)
(
c
system
))
(
unless
(
trivial-system-p
c
)
(
output-files
(
make-instance
'fasl-op
)
c
)))
(
defmethod
perform
((
o
load-fasl-op
)
(
c
t
))
nil
)
(
defmethod
perform
((
o
load-fasl-op
)
(
c
system
))
(
let
((
l
(
input-files
o
c
)))
(
and
l
(
load
(
first
l
))
(
loop
for
i
in
(
module-components
c
)
do
(
setf
(
gethash
'load-op
(
component-operation-times
i
))
(
get-universal-time
))))))
;;;
;;; PRECOMPILED FILES
;;;
;;; This component can be used to distribute ASDF libraries in precompiled
;;; form. Only useful when the dependencies have also been precompiled.
;;;
(
defclass
compiled-file
(
component
)
())
(
defmethod
component-relative-pathname
((
component
compiled-file
))
(
compile-file-pathname
(
merge-component-relative-pathname
(
slot-value
component
'relative-pathname
)
(
component-name
component
)
"fas"
)))
(
defmethod
output-files
(
o
(
c
compiled-file
))
nil
)
(
defmethod
input-files
(
o
(
c
compiled-file
))
nil
)
(
defmethod
perform
((
o
load-op
)
(
c
compiled-file
))
(
load
(
component-pathname
c
)))
(
defmethod
perform
((
o
load-fasl-op
)
(
c
compiled-file
))
(
load
(
component-pathname
c
)))
(
defmethod
perform
(
o
(
c
compiled-file
))
nil
)
;;;
;;; Final integration steps
;;;
(
export
'
(
make-build
load-fasl-op
))
(
push
'
(
"fasb"
.
si::load-binary
)
si::*load-hooks*
)
(
require
'cmp
)
(
defvar
*require-asdf-operator*
'load-op
)
(
defun
module-provide-asdf
(
name
)
(
handler-bind
((
style-warning
#'
muffle-warning
))
(
let*
((
*verbose-out*
(
make-broadcast-stream
))
(
system
(
asdf:find-system
name
nil
)))
(
when
system
(
asdf:operate
*require-asdf-operator*
name
)
t
))))
(
defun
register-pre-built-system
(
name
)
(
register-system
name
(
make-instance
'system
:name
name
)))
(
setf
si::*module-provider-functions*
(
loop
for
f
in
si::*module-provider-functions*
unless
(
eq
f
'module-provide-asdf
)
collect
#'
(
lambda
(
name
)
(
let
((
l
(
multiple-value-list
(
funcall
f
name
))))
(
and
(
first
l
)
(
register-pre-built-system
name
))
(
values-list
l
)))))
#+
win32
(
push
'
(
"asd"
.
si::load-source
)
si::*load-hooks*
)
(
pushnew
'module-provide-asdf
ext:*module-provider-functions*
)
(
pushnew
(
translate-logical-pathname
"SYS:"
)
*central-registry*
)
(
provide
'asdf
)
asdf-install.lisp
View file @
8e07148e
...
...
@@ -40,7 +40,7 @@ an immediate concern
(
defpackage
:asdf-install
(
:use
"CL"
"SB-EXT"
"SB-BSD-SOCKETS"
)
(
:export
#:*proxy*
#:*cclan-mirror*
#:*sbcl-home*
#:*verify-gpg-signatures*
#:*locations*
))
#:*verify-gpg-signatures*
#:*locations*
))
(
defpackage
:asdf-install-customize
(
:use
"CL"
"SB-EXT"
"SB-BSD-SOCKETS"
"ASDF-INSTALL"
))
...
...
@@ -57,16 +57,16 @@ an immediate concern
;; want a directory
(
let
((
path
(
pathname
name
)))
(
if
(
pathname-name
path
)
(
merge-pathnames
(
make-pathname
:directory
`
(
:relative
,
(
pathname-name
path
))
:name
""
)
path
)
path
)))
(
merge-pathnames
(
make-pathname
:directory
`
(
:relative
,
(
pathname-name
path
))
:name
""
)
path
)
path
)))
(
defvar
*sbcl-home*
(
directorify
(
posix-getenv
"SBCL_HOME"
)))
(
defvar
*dot-sbcl*
(
merge-pathnames
(
make-pathname
:directory
'
(
:relative
".sbcl"
))
(
user-homedir-pathname
)))
(
user-homedir-pathname
)))
(
defvar
*verify-gpg-signatures*
t
)
...
...
@@ -80,28 +80,28 @@ an immediate concern
(
let*
((
*package*
(
find-package
:asdf-install-customize
))
(
file
(
probe-file
(
merge-pathnames
(
make-pathname
:name
".asdf-install"
)
(
user-homedir-pathname
)))))
(
make-pathname
:name
".asdf-install"
)
(
user-homedir-pathname
)))))
(
when
file
(
load
file
)))
(
define-condition
download-error
(
error
)
((
url
:initarg
:url
:reader
download-url
)
(
response
:initarg
:response
:reader
download-response
))
(
:report
(
lambda
(
c
s
)
(
format
s
"Server responded ~A for GET ~A"
(
download-response
c
)
(
download-url
c
)))))
(
format
s
"Server responded ~A for GET ~A"
(
download-response
c
)
(
download-url
c
)))))
(
define-condition
signature-error
(
error
)
((
cause
:initarg
:cause
:reader
signature-error-cause
))
(
:report
(
lambda
(
c
s
)
(
format
s
"Cannot verify package signature: ~A"
(
signature-error-cause
c
)))))
(
format
s
"Cannot verify package signature: ~A"
(
signature-error-cause
c
)))))
(
defun
url-host
(
url
)
(
assert
(
string-equal
url
"http://"
:end1
7
))
(
let*
((
port-start
(
position
#\:
url
:start
7
))
(
host-end
(
min
(
or
(
position
#\/
url
:start
7
)
(
length
url
))
(
or
port-start
(
length
url
)))))
(
host-end
(
min
(
or
(
position
#\/
url
:start
7
)
(
length
url
))
(
or
port-start
(
length
url
)))))
(
subseq
url
7
host-end
)))
(
defun
url-port
(
url
)
...
...
@@ -111,8 +111,8 @@ an immediate concern
(
defun
url-connection
(
url
)
(
let
((
s
(
make-instance
'inet-socket
:type
:stream
:protocol
:tcp
))
(
host
(
url-host
url
))
(
port
(
url-port
url
)))
(
host
(
url-host
url
))
(
port
(
url-port
url
)))
(
socket-connect
s
(
car
(
host-ent-addresses
(
get-host-by-name
(
url-host
(
or
*proxy*
url
)))))
(
url-port
(
or
*proxy*
url
)))
...
...
@@ -120,101 +120,101 @@ an immediate concern
;; we are exceedingly unportable about proper line-endings here.
;; Anyone wishing to run this under non-SBCL should take especial care
(
format
stream
"GET ~A HTTP/1.0~%Host: ~A~%Cookie: CCLAN-SITE=~A~%~%"
url
host
*cclan-mirror*
)
url
host
*cclan-mirror*
)
(
force-output
stream
)
(
list
(
let*
((
l
(
read-line
stream
))
(
space
(
position
#\Space
l
)))
(
parse-integer
l
:start
(
1+
space
)
:junk-allowed
t
))
(
space
(
position
#\Space
l
)))
(
parse-integer
l
:start
(
1+
space
)
:junk-allowed
t
))
(
loop
for
line
=
(
read-line
stream
nil
nil
)
until
(
or
(
null
line
)
(
eql
(
elt
line
0
)
(
code-char
13
)))
collect
(
let
((
colon
(
position
#\:
line
)))
(
cons
(
intern
(
string-upcase
(
subseq
line
0
colon
))
:keyword
)
(
string-trim
(
list
#\Space
(
code-char
13
))
(
subseq
line
(
1+
colon
))))))
until
(
or
(
null
line
)
(
eql
(
elt
line
0
)
(
code-char
13
)))
collect
(
let
((
colon
(
position
#\:
line
)))
(
cons
(
intern
(
string-upcase
(
subseq
line
0
colon
))
:keyword
)
(
string-trim
(
list
#\Space
(
code-char
13
))
(
subseq
line
(
1+
colon
))))))
stream
))))
(
defun
download
(
package-name-or-url
file-name
)
(
let
((
url
(
if
(
=
(
mismatch
package-name-or-url
"http://"
)
7
)
package-name-or-url
(
format
nil
"http://www.cliki.net/~A?download"
package-name-or-url
))))
(
if
(
=
(
mismatch
package-name-or-url
"http://"
)
7
)
package-name-or-url
(
format
nil
"http://www.cliki.net/~A?download"
package-name-or-url
))))
(
destructuring-bind
(
response
headers
stream
)
(
block
got
(
loop
(
destructuring-bind
(
response
headers
stream
)
(
url-connection
url
)
(
unless
(
member
response
'
(
301
302
))
(
return-from
got
(
list
response
headers
stream
)))
(
close
stream
)
(
setf
url
(
cdr
(
assoc
:location
headers
))))))
(
block
got
(
loop
(
destructuring-bind
(
response
headers
stream
)
(
url-connection
url
)
(
unless
(
member
response
'
(
301
302
))
(
return-from
got
(
list
response
headers
stream
)))
(
close
stream
)
(
setf
url
(
cdr
(
assoc
:location
headers
))))))
(
if
(
>=
response
400
)
(
error
'download-error
:url
url
:response
response
))
(
error
'download-error
:url
url
:response
response
))
(
let
((
length
(
parse-integer
(
or
(
cdr
(
assoc
:content-length
headers
))
""
)
:junk-allowed
t
)))
(
format
t
"Downloading ~A bytes from ~A ..."
(
if
length
length
"some unknown number of"
)
url
)
(
force-output
)
(
with-open-file
(
o
file-name
:direction
:output
)
(
if
length
(
let
((
buf
(
make-array
length
:element-type
(
stream-element-type
stream
)
)))
(
read-sequence
buf
stream
)
(
write-sequence
buf
o
))
(
sb-executable:copy-stream
stream
o
))))
(
or
(
cdr
(
assoc
:content-length
headers
))
""
)
:junk-allowed
t
)))
(
format
t
"Downloading ~A bytes from ~A ..."
(
if
length
length
"some unknown number of"
)
url
)
(
force-output
)
(
with-open-file
(
o
file-name
:direction
:output
)
(
if
length
(
let
((
buf
(
make-array
length
:element-type
(
stream-element-type
stream
)
)))
(
read-sequence
buf
stream
)
(
write-sequence
buf
o
))
(
sb-executable:copy-stream
stream
o
))))
(
close
stream
)
(
terpri
)
;; seems to have worked. let's try for a detached gpg signature too
(
when
*verify-gpg-signatures*
(
verify-gpg-signature
url
file-name
)))))
(
verify-gpg-signature
url
file-name
)))))
(
defun
verify-gpg-signature
(
url
file-name
)
(
destructuring-bind
(
response
headers
stream
)
(
url-connection
(
concatenate
'string
url
".asc"
))
(
declare
(
ignore
headers
))
(
unwind-protect
(
if
(
=
response
200
)
;; sadly, we can't pass the stream directly to run-program,
;; because (at least in sbcl 0.8) that ignores existing buffered
;; data and only reads new fresh data direct from the file
;; descriptor
(
let
((
data
(
make-string
(
parse-integer
(
cdr
(
assoc
:content-length
headers
))
:junk-allowed
t
))))
(
read-sequence
data
stream
)
(
let
((
ret
(
process-exit-code
(
sb-ext:run-program
"/usr/bin/gpg"
(
list
"--verify"
"-"
(
namestring
file-name
))
:output
t
:input
(
make-string-input-stream
data
)
:wait
t
))))
(
unless
(
zerop
ret
)
(
error
'signature-error
:cause
(
make-condition
'simple-error
:format-control
"GPG returned exit status ~A"
:format-arguments
(
list
ret
))))))
(
error
'signature-error
:cause
(
make-condition
'download-error
:url
(
concatenate
'string
url
".asc"
)
:response
response
)))
(
if
(
=
response
200
)
;; sadly, we can't pass the stream directly to run-program,
;; because (at least in sbcl 0.8) that ignores existing buffered
;; data and only reads new fresh data direct from the file
;; descriptor
(
let
((
data
(
make-string
(
parse-integer
(
cdr
(
assoc
:content-length
headers
))
:junk-allowed
t
))))
(
read-sequence
data
stream
)
(
let
((
ret
(
process-exit-code
(
sb-ext:run-program
"/usr/bin/gpg"
(
list
"--verify"
"-"
(
namestring
file-name
))
:output
t
:input
(
make-string-input-stream
data
)
:wait
t
))))
(
unless
(
zerop
ret
)
(
error
'signature-error
:cause
(
make-condition
'simple-error