Skip to content

Commit

Permalink
Simplified feature tests for Lispworks.
Browse files Browse the repository at this point in the history
  • Loading branch information
@rwiker
rwiker committed Nov 7, 2022
1 parent 9403a47 commit 7d47963
Show file tree
Hide file tree
Showing 3 changed files with 43 additions and 19 deletions.
25 changes: 20 additions & 5 deletions drakma.asd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,21 +29,35 @@

(in-package :cl-user)

#+:lispworks
(unless (find-symbol "STREAM-WRITE-TIMEOUT" :stream)
(pushnew :lw-does-not-have-write-timeout *features*))

(defpackage :drakma-asd
(:use :cl :asdf))

(in-package :drakma-asd)

;;; When working on drakma under Lispworks, run (setup-lw-features)
;;; to ensure that the Lispworks-related features are added.
#+:lispworks
(defun setup-lw-features ()
(unless (find-symbol "STREAM-WRITE-TIMEOUT" :stream)
(pushnew :lw-does-not-have-write-timeout *features*))
#+(or :lispworks4 :lispworks5 :lispworks6)
(pushnew :lw-simple-char *features*)
#-(or :lispworks4 :lispworks5 :lispworks6)
(pushnew :lw-use-comm *features*))

(defsystem :drakma
:description "Full-featured http/https client based on usocket"
:author "Dr. Edi Weitz"
:license "BSD"
:serial t
:version "2.0.9"
#+:lispworks
:around-compile
#+:lispworks
(lambda (next)
(let ((*features* (copy-seq *features*)))
(setup-lw-features)
(funcall next)))
:components ((:file "packages")
(:file "specials")
(:file "conditions")
Expand All @@ -59,7 +73,8 @@
:cl-ppcre
#-:drakma-no-chipz :chipz
#-:lispworks :usocket
#-(or :lispworks7.1 (and :allegro (not :allegro-cl-express)) :mocl-ssl :drakma-no-ssl) :cl+ssl)
#-(or :lw-use-comm (and :allegro (not :allegro-cl-express)) :mocl-ssl :drakma-no-ssl)
:cl+ssl)
:perform (test-op (o s)
(asdf:load-system :drakma-test)
(asdf:perform 'asdf:test-op :drakma-test)))
33 changes: 21 additions & 12 deletions request.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -160,7 +160,8 @@ headers of the chunked stream \(if any) as a second value."
(header-value :content-length headers)))
(parse-integer value)))
(element-type (if textp
#+:lispworks7.1 'lw:simple-char #-:lispworks7.1 'character
#+:lw-simple-char 'lw:simple-char
#-:lw-simple-char 'character
'octet)))
(values (cond ((eql content-length 0) nil)
(content-length
Expand Down Expand Up @@ -239,8 +240,8 @@ headers of the chunked stream \(if any) as a second value."
decode-content ; default to nil for backwards compatibility
#+(or abcl clisp lispworks mcl openmcl sbcl)
(connection-timeout 20)
#+:lispworks7.1 (read-timeout 20)
#+(and :lispworks7.1 (not :lw-does-not-have-write-timeout))
#+:lispworks (read-timeout 20)
#+(and :lispworks (not :lw-does-not-have-write-timeout))
(write-timeout 20 write-timeout-provided-p)
#+:openmcl
deadline
Expand Down Expand Up @@ -489,8 +490,9 @@ decoded according to any encodings specified in the Content-Encoding
header. The actual decoding is done by the DECODE-STREAM generic function,
and you can implement new methods to support additional encodings.
Any encodings in Transfer-Encoding, such as chunking, are always performed."
#+lispworks7.1
(declare (ignore certificate key certificate-password verify max-depth ca-file ca-directory))
#+:lw-use-comm
(declare (ignore certificate key certificate-password max-depth ca-file ca-directory))
(declare (ignorable write-timeout-provided-p))
(unless (member protocol '(:http/1.0 :http/1.1) :test #'eq)
(parameter-error "Don't know how to handle protocol ~S." protocol))
(setq uri (cond ((puri:uri-p uri) (puri:copy-uri uri))
Expand Down Expand Up @@ -565,7 +567,7 @@ Any encodings in Transfer-Encoding, such as chunking, are always performed."
(drakma-warn "Disabling WRITE-TIMEOUT because it doesn't mix well with SSL."))
(setq write-timeout nil))
(setq http-stream (or stream
#+:lispworks7.1
#+:lw-use-comm
(comm:open-tcp-stream host port
:element-type 'octet
:timeout connection-timeout
Expand All @@ -575,7 +577,7 @@ Any encodings in Transfer-Encoding, such as chunking, are always performed."
#-:lw-does-not-have-write-timeout
write-timeout
:errorp t)
#-:lispworks7.1
#-:lw-use-comm
(usocket:socket-stream
(usocket:socket-connect host port
:element-type 'octet
Expand Down Expand Up @@ -607,14 +609,19 @@ Any encodings in Transfer-Encoding, such as chunking, are always performed."
(when (and use-ssl
;; don't attach SSL to existing streams
(not stream))
#+:lispworks7.1
#+:lw-use-comm
(comm:attach-ssl http-stream
:ssl-side :client
:ssl-ctx (comm:create-ssl-client-context
:verify-callback (ecase verify
((nil) nil)
((:optional) :try)
((:required) t)))
#-(or lispworks4 lispworks5 lispworks6)
:tlsext-host-name
#-(or lispworks4 lispworks5 lispworks6)
(puri:uri-host uri))
#-:lispworks7.1
#-:lw-use-comm
(setq http-stream (make-ssl-stream http-stream
:hostname (puri:uri-host uri)
:certificate certificate
Expand All @@ -626,7 +633,8 @@ Any encodings in Transfer-Encoding, such as chunking, are always performed."
:ca-directory ca-directory)))
(cond (stream
(setf (flexi-stream-element-type http-stream)
#+:lispworks6 'lw:simple-char #-:lispworks6 'character
#+:lw-simple-char 'lw:simple-char
#-:lw-simple-char 'character
(flexi-stream-external-format http-stream) +latin-1+))
(t
(setq http-stream (wrap-stream http-stream))))
Expand All @@ -648,14 +656,14 @@ Any encodings in Transfer-Encoding, such as chunking, are always performed."
;; got a connection; we have to read a blank line,
;; turn on SSL, and then we can transmit
(read-line* http-stream)
#+:lispworks7.1
#+:lw-use-comm
(comm:attach-ssl raw-http-stream
:ssl-side :client
#-(or lispworks4 lispworks5 lispworks6)
:tlsext-host-name
#-(or lispworks4 lispworks5 lispworks6)
(puri:uri-host uri))
#-:lispworks7.1
#-:lw-use-comm
(setq http-stream (wrap-stream
(make-ssl-stream raw-http-stream
:hostname (puri:uri-host uri)
Expand Down Expand Up @@ -900,3 +908,4 @@ Any encodings in Transfer-Encoding, such as chunking, are always performed."
(not want-stream)))
(not (eq content :continuation)))
(ignore-errors (close http-stream)))))))

4 changes: 2 additions & 2 deletions util.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,7 +29,7 @@

(in-package :drakma)

#+:lispworks
#+:lw-use-comm
(require "comm")

#+:lispworks
Expand Down Expand Up @@ -295,7 +295,7 @@ which are not meant as separators."
(setq cookie-start (1+ end-pos))
(go next-cookie))))))

#-:lispworks7.1
#-:lw-use-comm
(defun make-ssl-stream (http-stream &key certificate key certificate-password verify (max-depth 10) ca-file ca-directory
hostname)
"Attaches SSL to the stream HTTP-STREAM and returns the SSL stream
Expand Down

0 comments on commit 7d47963

Please sign in to comment.