Commit e5be6361 authored by Dave Cooper's avatar Dave Cooper
Browse files

reverted to a stable version for now

parent 5182b099
......@@ -23,9 +23,7 @@
(defgeneric zacl-cl:stream-external-format (stream)
(:method (stream)
(stream-external-format stream))
(:method ((stream broadcast-stream))
(zacl-cl:stream-external-format (alexandria:lastcar (broadcast-stream-streams stream)))))
(stream-external-format stream)))
(defgeneric (setf zacl-cl:stream-external-format) (new-value stream)
(:method (new-value stream)
......
......@@ -5,10 +5,6 @@
(in-package #:zacl)
(defparameter *encoding-external-format-key* (let ((babel (find-package :babel)))
(if (and babel (eql (symbol-package 'octets-to-string) babel))
:encoding :external-format)))
(defparameter *external-format-translations*
'((:octets . :latin1)
(:latin1-base . :latin1)
......@@ -47,6 +43,10 @@ longer anonymous, but has a meaningful name name."
(defun excl:featurep (feature)
(find feature *features*))
(defmacro excl::fast (&body body)
`(progn ,@body))
(defun excl:gc (&optional full)
(declare (ignorable full))
#+ccl
......@@ -110,62 +110,17 @@ longer anonymous, but has a meaningful name name."
(defmethod excl:stream-error-code (condition)
(socket-error-code condition))
;;; Concurrency
;;; Misc
;; FIXME: apparently using EXCL::FAST and EXCL::ATOMICALLY produces the same result
;; as EXCL:FAST-AND-CLEAN which in turn is a performant version of
;; EXCL:WITH-DELAYD-INTERRUPTS
;; https://franz.com/support/documentation/current/doc/operators/excl/fast-and-clean.htm
;; Additionally, not only these symbols not exported but they are also undocumented and
;; used unrestrainedly across ZACL and ZASERVE in all kinds of combinations...
(defmacro excl::fast (&body body)
`(progn ,@body))
(defstruct excl::ssl-context)
(defmacro excl::.atomically (&body body)
`(progn ,@body))
(defmacro excl::atomically (&body body)
`(progn ,@body))
`(bt:with-lock-held (*%atomic-lock%*) (progn ,@body)))
(defmacro excl:atomic-conditional-setf (place new-value old-value)
#-sbcl (declare (ignore old-value))
;; ATTENTION: the arguments in SB-EXT:COMPARE-AND-SWAP have a different order
#+sbcl `(sb-ext:compare-and-swap ,place ,old-value ,new-value)
#-sbcl `(setf ,place ,new-value))
#+nil
(defmacro excl:incf-atomic (place &optional (delta 1))
#+sbcl `(sb-ext:atomic-incf ,place ,delta)
#-sbcl `(incf ,place ,delta))
(defmacro excl:incf-atomic (place &optional (delta 1))
`(bt:with-lock-held (*%atomic-lock%*) (incf ,place ,delta)))
#+nil
(defmacro excl:decf-atomic (place &optional (delta 1))
#+sbcl `(sb-ext:atomic-decf ,place ,delta)
#-sbcl `(decf ,place ,delta))
(defmacro excl:decf-atomic (place &optional (delta 1))
`(bt:with-lock-held (*%atomic-lock%*) (decf ,place ,delta)))
(defmacro excl:pop-atomic (place)
#+sbcl `(sb-ext:atomic-pop ,place)
#-sbcl `(pop ,place))
(defmacro excl:push-atomic (value place)
#+sbcl `(sb-ext:atomic-push ,value ,place)
#-sbcl `(push ,value ,place))
;;; Misc
(defstruct (excl::ssl-context
(:constructor excl::make-ssl-context))
(open-ssl-context nil)
(key nil)
(key-password nil)
(certificate nil))
(declare (ignore old-value))
`(bt:with-lock-held (*%atomic-lock%*)
(setf ,place ,new-value)))
(defmacro excl:errorset (form &optional announce catch-breaks)
"Return NIL if FORM signals an error, T and values as multiple
......@@ -244,17 +199,14 @@ values otherwise."
,@body))
(defun excl:native-string-sizeof (string &key (external-format :latin1))
(length (string-to-octets string *encoding-external-format-key*
(translate-external-format external-format)
)))
(length (string-to-octets string :external-format (translate-external-format external-format))))
(defun excl:string-to-mb (string &key external-format mb-vector null-terminate)
(when null-terminate
(error "Cannot null-terminate"))
(let ((result
(string-to-octets string
*encoding-external-format-key* (translate-external-format external-format)
)))
:external-format (translate-external-format external-format))))
(if mb-vector
(replace mb-vector result)
result)))
......@@ -263,13 +215,12 @@ values otherwise."
(when null-terminate
(error "No null terminating!"))
(string-to-octets string
*encoding-external-format-key* (translate-external-format external-format)
))
:external-format (translate-external-format external-format)))
(defun excl:mb-to-string (string &key external-format (start 0)
(end (length string)))
(octets-to-string string
*encoding-external-format-key* (translate-external-format external-format)
:external-format (translate-external-format external-format)
:start start
:end end))
......@@ -281,8 +232,7 @@ values otherwise."
(octets-to-string octets
:start start
:end end
*encoding-external-format-key* (translate-external-format external-format)
))
:external-format (translate-external-format external-format)))
(defun excl:schedule-finalization (object fun)
;; Doesn't work; semantics differ.
......@@ -338,6 +288,14 @@ values otherwise."
(declare (ignore block non-smp))
`(call-with-locked-structure ,struct (lambda () ,@body)))
(defmacro excl:incf-atomic (place &optional (delta 1))
;; XXX FIXME
`(bt:with-lock-held (*%atomic-lock%*) (incf ,place ,delta)))
(defmacro excl:decf-atomic (place &optional (delta 1))
;; XXX FIXME
`(bt:with-lock-held (*%atomic-lock%*) (decf ,place (- ,delta))))
(defstruct (basic-lock (:include excl:synchronizing-structure))
name)
......@@ -364,20 +322,23 @@ values otherwise."
(defclass zacl-simple-stream (fundamental-binary-output-stream
fundamental-binary-input-stream)
(
;; The original SIMPLE-STREAMs in ACL contain only one buffer that is used
;; interchangeably between output and input in SINGLE-CHANNEL-SIMPLE-STREAMs
;; according to its MODE
;; For simplicity's sake, we use an additional buffer for output and keep
;; the original one for input.
(output-buffer
:initform (make-array 4096 :element-type '(unsigned-byte 8))
:accessor zacl-simple-stream-output-buffer)
(output-pointer
:initform 0
:accessor zacl-simple-stream-output-pointer)
(excl::buffer
())
;; Needed for SBCL
(defmethod stream-element-type ((stream zacl-simple-stream))
'(unsigned-byte 8))
(defmethod stream-write-char ((stream zacl-simple-stream) char)
(let ((buffer (string-to-octets (string char))))
(excl:device-write stream buffer 0 (length buffer) nil)))
(defmethod stream-write-byte ((stream zacl-simple-stream) byte)
(let ((buffer (make-array 1 :element-type '(unsigned-byte 8)
:initial-element byte)))
(excl:device-write stream buffer 0 1 nil)))
(defclass excl:single-channel-simple-stream (zacl-simple-stream)
((excl::buffer
:initform (make-array 1024 :element-type '(unsigned-byte 8))
:reader buffer)
(excl::output-handle
......@@ -394,128 +355,19 @@ values otherwise."
:initform :latin1
:accessor zacl-cl:stream-external-format)))
(defmethod shared-initialize :after ((stream zacl-simple-stream)
(defmethod shared-initialize :after ((stream
excl:single-channel-simple-stream)
slot-names
&rest initargs
&key &allow-other-keys)
&rest initargs &key &allow-other-keys)
(excl:device-open stream slot-names initargs))
(defmethod close ((stream zacl-simple-stream) &key abort)
(defmethod close ((stream excl:single-channel-simple-stream) &key abort)
(excl:device-close stream abort))
;; Needed for SBCL
(defmethod stream-element-type ((stream zacl-simple-stream))
'(unsigned-byte 8))
(defmethod stream-read-sequence ((stream zacl-simple-stream) sequence start end
&key &allow-other-keys)
(unless start (setf start 0))
(unless end (setf end (length sequence)))
(if (stringp sequence)
(let ((result (excl:device-read stream nil 0 nil nil))
(buffer (buffer stream )))
(when (minusp result)
(return-from stream-read-sequence 0))
(when (<= (- end start) result)
(error "Can't handle buffering yet"))
(let ((string (octets-to-string buffer
:end result
*encoding-external-format-key* (zacl-cl:stream-external-format stream)
)))
(replace sequence string :start1 start :end1 end)
(min end (+ start (length string)))))
(let ((result (excl:device-read stream sequence start end nil)))
(if (minusp result)
0
result))))
(defmethod stream-write-char ((stream zacl-simple-stream) char)
(stream-write-string stream (string char) 0 1)
char)
(defmethod stream-write-byte ((stream zacl-simple-stream) byte)
(let ((buffer (zacl-simple-stream-output-buffer stream)))
(when (= (length buffer) (zacl-simple-stream-output-pointer stream))
(force-output stream))
(setf (elt buffer (zacl-simple-stream-output-pointer stream)) byte)
(incf (zacl-simple-stream-output-pointer stream)))
byte)
(defmethod trivial-gray-streams::stream-write-string ((stream zacl-simple-stream) string &optional start end)
(unless start (setf start 0))
(unless end (setf end (length string)))
(let ((sequence (babel:string-to-octets string
:start start
:end end
*encoding-external-format-key* (zacl-cl:stream-external-format stream)
)))
(stream-write-sequence stream sequence 0 (length sequence)))
string)
(defmethod stream-write-sequence ((stream zacl-simple-stream) (sequence string) start end &key)
(unless start (setf start 0))
(unless end (setf end (length sequence)))
(stream-write-string stream sequence start end))
;;
;; FLAG -- the second version of stream-write-sequence below should in
;; principle work on CCL, but does not, so we have to fall back to the
;; simplified version for CCL until we can diagnose and fix the
;; problem with the second version which apparently is implementing
;; the chunking behavior.
;;
#+ccl
(defmethod stream-write-sequence ((stream zacl-simple-stream) sequence start end &key &allow-other-keys)
(unless start (setf start 0))
(unless end (setf end (length sequence)))
(excl:device-write stream sequence start end nil)
sequence)
#+sbcl
(defmethod stream-write-sequence ((stream zacl-simple-stream) sequence start end &key &allow-other-keys)
(unless start (setf start 0))
(unless end (setf end (length sequence)))
(let ((buffer (zacl-simple-stream-output-buffer stream)))
;; no space in buffer?
(when (> (+ (- end start) (zacl-simple-stream-output-pointer stream))
(length buffer))
;; flush it
(stream-force-output stream)
;; the sequence is still bigger than our buffer
;; let's write it directly to the output
(when (>= (- end start) (length buffer))
(excl:device-write stream sequence start end nil)
(return-from stream-write-sequence sequence)))
;; buffer it
(replace buffer sequence
:start1 (zacl-simple-stream-output-pointer stream)
:start2 start
:end2 end)
(incf (zacl-simple-stream-output-pointer stream) (- end start)))
sequence)
(defmethod stream-force-output ((stream zacl-simple-stream))
(let ((buffer (zacl-simple-stream-output-buffer stream)))
(excl:device-write stream buffer 0 (zacl-simple-stream-output-pointer stream) nil)
(setf (zacl-simple-stream-output-pointer stream) 0)))
(defmethod trivial-gray-streams:stream-fresh-line ((stream zacl-simple-stream))
;; This always prints a newline has we have no idea how to determine if we
;; are in the a new line or not
(trivial-gray-streams:stream-terpri stream)
t)
(defgeneric underlying-output-stream (stream)
(:method ((stream zacl-simple-stream))
(:method ((stream excl:single-channel-simple-stream))
(underlying-output-stream (slot-value stream 'excl::output-handle)))
(:method ((stream stream-usocket))
(socket-stream stream))
......@@ -525,24 +377,32 @@ values otherwise."
stream))
(defgeneric underlying-input-stream (stream)
(:method ((stream zacl-simple-stream))
(:method ((stream excl:single-channel-simple-stream))
(underlying-input-stream (slot-value stream 'excl::input-handle)))
(:method ((stream usocket))
(socket-stream stream))
(:method ((stream stream))
stream))
(defclass excl:single-channel-simple-stream (zacl-simple-stream)
())
(defmethod stream-write-string ((stream excl:single-channel-simple-stream) string &optional start end)
(unless start (setf start 0))
(unless end (setf end (length string)))
(let ((buffer (string-to-octets string :start start :end end
:external-format (zacl-cl:stream-external-format stream))))
(excl:device-write stream buffer 0 (length buffer) nil)))
(defmethod stream-write-sequence ((stream excl:single-channel-simple-stream) sequence start end &key &allow-other-keys)
(excl:device-write stream sequence start end nil)
sequence)
#+ccl
(defmethod ccl:stream-write-vector ((stream zacl-simple-stream) sequence start end)
(defmethod ccl:stream-write-vector ((stream excl:single-channel-simple-stream) sequence start end)
(unless start (setf start 0))
(unless end (setf end (length sequence)))
(excl:device-write stream sequence start end nil))
#+ccl
(defmethod ccl:stream-read-vector ((stream zacl-simple-stream) sequence start end)
(defmethod ccl:stream-read-vector ((stream excl:single-channel-simple-stream) sequence start end)
(unless start (setf start 0))
(unless end (setf end (length sequence)))
(if (stringp sequence)
......@@ -554,8 +414,28 @@ values otherwise."
(error "Can't handle buffering yet"))
(let ((string (octets-to-string buffer
:end result
*encoding-external-format-key* (zacl-cl:stream-external-format stream)
)))
:external-format (zacl-cl:stream-external-format stream))))
(replace sequence string :start1 start :end1 end)
(min end (+ start (length string)))))
(let ((result (excl:device-read stream sequence start end nil)))
(if (minusp result)
0
result))))
(defmethod stream-read-sequence ((stream excl:single-channel-simple-stream) sequence start end
&key &allow-other-keys)
(unless start (setf start 0))
(unless end (setf end (length sequence)))
(if (stringp sequence)
(let ((result (excl:device-read stream nil 0 nil nil))
(buffer (buffer stream )))
(when (minusp result)
(return-from stream-read-sequence 0))
(when (<= (- end start) result)
(error "Can't handle buffering yet"))
(let ((string (octets-to-string buffer
:end result
:external-format (zacl-cl:stream-external-format stream))))
(replace sequence string :start1 start :end1 end)
(min end (+ start (length string)))))
(let ((result (excl:device-read stream sequence start end nil)))
......@@ -563,6 +443,9 @@ values otherwise."
0
result))))
(defmethod stream-force-output ((stream excl:single-channel-simple-stream))
(force-output (underlying-output-stream stream)))
(defmethod stream-force-output ((stream usocket))
(force-output (underlying-output-stream stream)))
......@@ -599,6 +482,15 @@ values otherwise."
(or set
42))
(defmacro excl:pop-atomic (place)
`(bt:with-lock-held (*%atomic-lock%*) (pop ,place)))
(defmacro excl:push-atomic (value place)
`(bt:with-lock-held (*%atomic-lock%*) (push ,value ,place )))
;;; MD5
(defun excl:md5-init ()
......@@ -607,7 +499,7 @@ values otherwise."
(defun excl:md5-update (state data &key (start 0) end external-format)
(when (stringp data)
(setf data (string-to-octets data
*encoding-external-format-key* (or external-format :latin-1)
:external-format (or external-format :latin-1)
:start start
:end (or end (length data))))
(setf start 0)
......@@ -644,10 +536,7 @@ values otherwise."
(let ((octets
(with-output-to-sequence (s)
(store object stream))))
(write-string (octets-to-string octets
*encoding-external-format-key* :latin-1
) stream))))
(write-string (octets-to-string octets :external-format :latin-1) stream))))
(defun excl:fasl-read (file)
(with-open-file (stream file :element-type '(unsigned-byte 8))
......@@ -669,5 +558,3 @@ values otherwise."
(defun excl::acl-internal-real-time ()
(values (- (get-universal-time) 4165516800)
(/ (local-time:nsec-of (local-time:now)) 1000)))
......@@ -36,9 +36,7 @@
(make-process name :class 'process
:initial-bindings initial-bindings)))
(defgeneric mp:process-thread (process)
(:method ((process process))
(thread process)))
(defgeneric mp:process-thread (process))
(defgeneric mp:process-name (process)
(:method (process)
......
......@@ -2,8 +2,6 @@
(in-package #:zacl)
(defparameter *print-hostname-in-stream* nil)
(defun ip-address-integer (ip-address)
(check-type ip-address (simple-array * (4)) "octet vector")
(logand #xFFFFFFFF
......@@ -28,11 +26,9 @@
fundamental-character-input-stream)
((socket
:initarg :socket
:initform nil
:reader socket)
(real-stream
:initarg :real-stream
:initform nil
:accessor real-stream
:reader underlying-input-stream
:reader underlying-output-stream)
......@@ -46,21 +42,6 @@
:reader socket-ef
:accessor zacl-cl:stream-external-format)))
(defmethod print-object ((object zacl-socket) stream)
(print-unreadable-object (object stream :type t :identity t)
(let ((socket (socket object)))
(if (real-stream object)
(format stream
"connected from ~a:~a to ~a:~a"
(get-local-address socket)
(get-local-port socket)
(get-peer-address socket)
(get-peer-port socket))
(format stream
"waiting for connection at ~a:~a"
(get-local-address socket)
(get-local-port socket))))))
(defmethod stream-write-byte :after ((stream zacl-socket) byte)
(declare (ignore byte))
(incf (bytes-written stream)))
......@@ -71,10 +52,7 @@
(defmethod stream-write-char ((stream zacl-socket) char)
(map nil (lambda (octet)
(stream-write-byte stream octet))
(string-to-octets (string char)
:encoding (socket-ef stream)
;;:external-format (socket-ef stream)
)))
(string-to-octets (string char) :external-format (socket-ef stream))))
(defmethod stream-write-sequence :after ((stream zacl-socket) sequence
start end &key &allow-other-keys)
......@@ -91,9 +69,7 @@
&key &allow-other-keys)
(when (typep sequence 'string)
(setf sequence (string-to-octets sequence :start start :end end
:encoding (socket-ef stream)
;;:external-format (socket-ef stream)
))
:external-format (socket-ef stream)))
(setf start 0)
(setf end (length sequence)))
(write-sequence sequence (real-stream stream) :start start :end end))
......@@ -121,9 +97,7 @@
(buffer (make-array (- end start) :element-type '(unsigned-byte 8))))
(let* ((after-index (read-sequence buffer (real-stream stream)))
(string (octets-to-string buffer :start 0 :end after-index
:encoding :latin-1
;;:external-format :latin-1
)))
:external-format :latin-1)))
(replace sequence string :start1 start :end1 end
:start2 0 :end2 after-index)
(+ offset after-index)))
......@@ -138,9 +112,7 @@
(buffer (make-array (- end start) :element-type '(unsigned-byte 8))))
(let* ((after-index (read-sequence buffer (real-stream stream)))
(string (octets-to-string buffer :start 0 :end after-index
:encoding :latin-1
;;:external-format :latin-1
)))
:external-format :latin-1)))
(replace sequence string :start1 start :end1 end
:start2 0 :end2 after-index)
(+ offset after-index)))
......@@ -162,14 +134,13 @@
(ecase connect
(:passive
(let ((socket
(socket-listen local-host (or local-port 0)
(socket-listen local-host local-port
:reuseaddress reuse-address
:element-type '(unsigned-byte 8)
:backlog backlog)))
(make-instance 'zacl-socket
:socket socket)))
((nil :active)
((nil)
(let ((socket
(socket-connect remote-host remote-port
:nodelay nodelay
......@@ -194,9 +165,16 @@
(setf (socket-option (socket socket) :tcp-no-delay) nodelay))
(defun socket:remote-host (socket)
(ip-address-integer (get-peer-address (socket socket))))
(multiple-value-bind (result error)
(ignore-errors (ip-address-integer (get-peer-address (socket socket))))
(if (typep error 'error)
(progn (warn "~&socket:remote-host couldn't get peer address. Returning zero.~%") 0 )
result)))
(defun socket:ipaddr-to-dotted (ip-integer)
(unless (integerp ip-integer)
(warn "~&socket:ipaddr-to-dotted called with non-integer: ~a. Setting to zero.~%" ip-integer)
(setq ip-integer 0))
(format nil "~A.~A.~A.~A"
(ldb (byte 8 24) ip-integer)
(ldb (byte 8 16) ip-integer)
......@@ -232,12 +210,9 @@
`(progn ,@body))
(defun socket:ipaddr-to-hostname (ipaddr)
#+sbcl (sb-bsd-sockets:host-ent-name
(sb-bsd-sockets:get-host-by-address
(if (typep ipaddr 'string)
(sb-bsd-sockets:make-inet-address ipaddr)
ipaddr)))
#+ccl (ipaddr-to-hostname ipaddr))
#+sbcl(declare (ignore ipaddr))
#+ccl (ipaddr-to-hostname ipaddr)
#+sbcl (error "socket:ipaddr-to-hostname not implemented in ~a" (lisp-implementation-type)))
(defun socket:lookup-hostname (name)
#+ccl (lookup-hostname name)
......@@ -246,263 +221,25 @@
;;
#+sbcl (format nil "~{~a~^.~}" (coerce (get-host-by-name name) 'list)))
(defun make-ssl-stream (socket stream-type &key context
method
certificate key certificate-password
max-depth
ca-file ca-directory
ciphers
crl-check crl-file
verify
server-name)
(declare (ignore crl-check crl-file))
(ecase stream-type
((:client :server)))
(when (and ca-file
(pathnamep ca-file))
(setf ca-file (namestring ca-file)))
(when (and ca-directory
(pathnamep ca-directory))
(setf ca-directory (namestring ca-directory)))
(let ((stream (if context