;;; system-dependent parts of pg-dot-lisp

(in-package :pg)

(eval-when (:compile-toplevel :load-toplevel :execute)
  #+allegro (require :socket)
  #+lispworks (require "comm")
  #+cormanlisp (require :sockets)
  #+sbcl (progn (require :asdf) (require :sb-bsd-sockets))
  #+(and mcl (not openmcl)) (require "OPENTRANSPORT"))


#+(and cmu glibc2)
(eval-when (:compile-toplevel :load-toplevel)
  (format t ";; Loading libcrypt~%")
  ;; (ext:load-foreign "/lib/libcrypt.so.1")
  (sys::load-object-file "/usr/lib/libcrypt.so"))

#+(and cmu glibc2)
(defun crypt (key salt)
  (declare (type string key salt))
  (alien:alien-funcall
   (alien:extern-alien "crypt"
          (function c-call:c-string c-call:c-string c-call:c-string))
   key salt))

#-(and cmu glibc2)
(defun crypt (key salt)
  (declare (ignore salt))
  key)


;; this is a little fiddly, because CLISP can be built without support
;; for the Linux package
;; #+CLISP
;; (defun crypt (key salt)
;;   (linux::crypt key salt))


;; bug in WRITE-SEQUENCE in CMUCL
#+(or cmu18c cmu18d)
(defun write-sequence (seq stream &key start end)
  (declare (ignore start end))
  (loop :for element :across seq
        :do (write-byte element stream)))



#+cmu
(defun socket-connect (port host)
  (declare (type integer port))
  (handler-case
   (let ((fd (if host
                 (ext:connect-to-inet-socket host port)
                 (ext:connect-to-unix-socket
                  (format nil "/var/run/postgresql/.s.PGSQL.~D" port)))))
     (sys:make-fd-stream fd :input t :output t
                         :element-type '(unsigned-byte 8)))
   (error (e)
      (declare (ignore e))
      (error 'connection-failure :host host :port port))))

#+clisp
(defun socket-connect (port host)
  (declare (type integer port))
  (handler-case
   (#+lisp=cl socket:socket-connect
    #-lisp=cl lisp:socket-connect
    port host :element-type '(unsigned-byte 8))
   (error (e)
      (declare (ignore e))
      (error 'connection-failure :host host :port port))))


#+db-sockets
(defun socket-connect (port host)
  (declare (type integer port))
  (handler-case
   (let ((s (sockets:make-inet-socket :stream :tcp))
         (num (car (sockets:host-ent-addresses
                    (sockets:get-host-by-name host)))))
     (sockets:socket-connect s num port)
     (sockets:socket-make-stream s :element-type '(unsigned-byte 8)
                                 :input t :output t :buffering :none))
   (error (e)
      (error 'connection-failure
             :host host
             :port port
             :transport-error e))))

#+sbcl
(defun socket-connect (port host)
  (declare (type integer port))
  (handler-case
      (sb-bsd-sockets:socket-make-stream
       (if host
	   (let ((s (make-instance 'sb-bsd-sockets:inet-socket
                                   :type :stream :protocol :tcp))
		 (num (car (sb-bsd-sockets:host-ent-addresses
			    (sb-bsd-sockets:get-host-by-name host)))))
	     (sb-bsd-sockets:socket-connect s num port)
             s)
	   (let ((s (make-instance 'sb-bsd-sockets:local-socket :type :stream)))
	     (sb-bsd-sockets:socket-connect
	      s (format nil "/var/run/postgresql/.s.PGSQL.~D" port))
	     s))
       :element-type '(unsigned-byte 8)
       :input t
       :output t
       :buffering :none)
    (error (e)
      (error 'connection-failure :host host :port port :transport-error e))))

#+allegro
(defun socket-connect (port host)
  (declare (type integer port))
  (handler-case
   (socket:make-socket :remote-host host
                       :remote-port port
                       :format :binary)
   (error (e)
      (signal 'connection-failure
              :host host
              :port port
              :transport-error e))))

;; Lispworks 4.2 doesn't seem to implement WRITE-SEQUENCE on binary
;; streams
#+lispworks
(defun socket-connect (port host)
  (declare (type integer port))
  (comm:open-tcp-stream host port
			:element-type '(unsigned-byte 8)
			:direction :io))

;; this doesn't work, since the Corman sockets module doesn't support
;; binary I/O on socket streams.
#+cormanlisp
(defun socket-connect (port host)
  (declare (type integer port))
  (handler-case
   (sockets:sockets-start)
   (let ((sock (make-client-socket :host host :port port)))
     (sockets:make-socket-stream sock))
   (error (e)
      (declare (ignore e))
      (error 'connection-failure :host host :port port))))

#+openmcl
(defun socket-connect (port host)
  (declare (type integer port))
  (let ((sock (make-socket :type :stream
                           :connect :active
                           :format :binary
                           :remote-host host
                           :remote-port port)))
    sock))

;; from John DeSoi
#+(and mcl (not openmcl))
(defun socket-connect (port host)
  (declare (type integer port))
  (ccl::open-tcp-stream host port :element-type '(unsigned-byte 8)))

;; There is a bug in MCL (4.3.1 tested) where read-sequence and
;; write-sequence fail with binary tcp streams. These two methods
;; provide a work-around.
#+(and mcl (not openmcl))
(defmethod ccl:stream-write-sequence ((s ccl::opentransport-binary-tcp-stream)
                                      (sequence ccl::simple-unsigned-byte-vector)
                                      &key (start 0) end)
  (ccl::stream-write-vector s sequence start (or end (length sequence)))
  s)

#+(and mcl (not openmcl))
(defmethod ccl:stream-read-sequence ((s ccl::opentransport-binary-tcp-stream)
                                     (sequence ccl::simple-unsigned-byte-vector)
                                     &key (start 0) (end (length sequence)))
  (ccl::io-buffer-read-bytes-to-vector (ccl::stream-io-buffer s)
                                       sequence (- end start) start)
  end)


#+ecl
(defun socket-connect (port host)
  (declare (type integer port))
  (si:open-client-stream host port))


;; as of version 2.6 GCL is way too broken to run this: DEFPACKAGE doesn't
;; work, DEFINE-CONDITION not implemented, ...
#+gcl
(defun socket-connect (port host)
  (declare (type integer port))
  (si::socket port :host host))


#+armedbear
(defun socket-connect (port host)
  (declare (type integer port))
  (ext:make-binary-socket host port))

#+armedbear
(defun cl:write-sequence (seq stream &key (start 0) (end (length seq)))
  (declare (ignore start end))
  (loop :for element :across seq
        :do (write-byte element stream)))

#+armedbear
(defun read-bytes (connection howmany)
  (let ((v (make-array howmany :element-type '(unsigned-byte 8)))
        (s (pgcon-stream connection)))
    (loop :for pos :below howmany
          :do (setf (aref v pos) (read-byte s)))
    v))

#+armedbear
(defun cl:read-sequence (seq stream &key (start 0) (end (length seq)))
  (loop :for pos :from start :below end
        :do (setf (aref seq pos) (read-byte stream))))

;; EOF