cl-pg 1:20061216-5 / usr / share / common-lisp / source / pg / sysdep.lisp

;;; sysdep.lisp -- system-dependent parts of pg-dot-lisp
;;;
;;; Author: Eric Marsden <eric.marsden@free.fr>
;;; Time-stamp: <2006-11-19 emarsden>
;;
;;

(in-package :postgresql)

(eval-when (:compile-toplevel :load-toplevel :execute)
  #+lispworks (require "comm")
  #+cormanlisp (require :sockets)
  #+armedbear (require :socket))


(defmacro %sysdep (desc &rest forms)
  (when (null forms)
    (error "No system dependent code to ~A" desc))
  (car forms))


#+(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)


(defun md5-digest (string &rest strings)
  (declare (type simple-string string))
  (let ((vec (md5sum-sequence
              (map '(vector (unsigned-byte 8)) #'char-code 
                   (apply #'concatenate 'string string strings)))))
    (format nil "~(~{~2,'0X~}~)" (coerce vec 'list))))

(defun md5-encode-password (user password salt)
  (concatenate 'string "md5"
               (md5-digest (md5-digest password user) salt)))



;; 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)))



;; work around bug in FASL fop dumping 
#+cmu (setf c::top-level-lambda-max 0)


#+(and cmu ssl)
(defun socket-connect (port host)
  (declare (type integer port))
  (handler-case
      (let ((fd (ext:connect-to-inet-socket host port)))
        (ssl:make-ssl-client-stream fd))
    (error (e)
      (error 'connection-failure
             :host host
             :port port
             :transport-error e))))


#+cmu
(defun socket-connect (port host)
  (declare (type integer port))
  (let ((host (if (typep host 'pathname)
                  (namestring host)
                  host)))
    (handler-case
        (let ((fd (if (eql #\/ (char host 0))
                      (ext:connect-to-unix-socket
                       (format nil "~A.s.PGSQL.~D" (string host) port))
                      (ext:connect-to-inet-socket host port))))
          (sys:make-fd-stream fd :input t :output t
                              :element-type '(unsigned-byte 8)))
      (error (e)
        (error 'connection-failure
               :host host
               :port port
               :transport-error e)))))

;; this doesn't currently work, because WRITE-SEQUENCE is not
;; implemented
#+(and cmu simple-streams broken)
(defun socket-connect (port host)
  (declare (type integer port))
  (handler-case
      (make-instance 'stream:socket-simple-stream
                     :remote-host host
                     :remote-port port
                     :direction :io)
    (error (e)
      (error 'connection-failure
             :host host
             :port port
             :transport-error e))))

#+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)
    :buffered t)
   (error (e)
      (declare (ignore e))
      (error 'connection-failure :host host :port port))))


#+sbcl
(defun socket-connect (port host-name)
  (declare (type integer port))
  (let ((host (if (typep host-name 'pathname)
                  (namestring host-name)
                  host-name)))
    (handler-case
        (sb-bsd-sockets:socket-make-stream
         (if (eql #\/ (char host 0))
             (let ((s (make-instance 'sb-bsd-sockets:local-socket :type :stream)))
               (sb-bsd-sockets:socket-connect
                s (format nil  "~A.s.PGSQL.~D" (string host) port))
               s)
             (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))
         :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
      (if (eql #\/ (char host 0))
          (socket:make-socket :type :stream
                              :address-family :file
                              :connect :active
                              :remote-filename (format nil "~A.s.PGSQL.~D" (string host) port)
                              :format :binary)
          (socket:make-socket :remote-host host
                              :remote-port port
                              :connect :active
                              :format :binary))
    (error (e)
      (error 'connection-failure
             :host host
             :port port
             :transport-error e))))

;; Lispworks 4.2 doesn't seem to implement WRITE-SEQUENCE on binary
;; streams. Fixed in version 4.3. 
#+lispworks
(defun socket-connect (port host)
  (declare (type integer port))
  (handler-case
      (comm:open-tcp-stream host port
                            :element-type '(unsigned-byte 8)
                            :direction :io)
    ;; note that Lispworks (at least 4.3) does not signal an error if
    ;; the hostname cannot be resolved; it simply returns NIL
    (error (e)
      (error 'connection-failure
             :host host
             :port port
             :transport-error e))))

;; 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
      (progn
        (sockets:start-sockets)
        (let ((sock (sockets:make-client-socket :host host :port port)))
          (sockets:make-socket-stream sock)))
    (error (e)
      (error 'connection-failure
             :host host
             :port port
             :transport-error e))))

#+openmcl
(defun socket-connect (port host)
  (declare (type integer port))
  (let ((host (if (typep host 'pathname)
                  (namestring host)
                  host)))
    (handler-case
        (if (eql #\/ (char host 0))
            (make-socket :address-family :file
                         :type :stream
                         :connect :active
                         :format :binary
                         :remote-filename (format nil "~A.s.PGSQL.~D" (string host) port))
            (make-socket :address-family :internet
                         :type :stream
                         :connect :active
                         :format :binary
                         :remote-host host
                         :remote-port port))
      (error (e)
        (error 'connection-failure
               :host host
               :port port
               :transport-error e)))))

;; 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))
  (handler-case 
      (si:open-client-stream host port)
    (error (e)
      (error 'connection-failure
             :host host
             :port port
             :transport-error e))))



;; 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
(eval-when (:load-toplevel :execute :compile-toplevel)
  (require :socket))

;; could provide support for connections via a unix-domain socket by
;; using http://freshmeat.net/projects/j-buds/ (requires linking to a
;; shared libary)
#+armedbear
(defun socket-connect (port host)
  (declare (type integer port))
  (handler-case
      (ext:get-socket-stream (ext:make-socket host port)
                             :element-type '(unsigned-byte 8))
    (error (e)
      (error 'connection-failure
             :host host
             :port port
             :transport-error e))))


;; for Lispworks
;;     (defun encode-lisp-string (string)
;;       (translate-string-via-fli string :utf-8 :latin-1))
;; 
;;     (defun decode-external-string (string)
;;       (translate-string-via-fli string :latin-1 :utf-8))
;; 
;;     ;; Note that a :utf-8 encoding of a null in a latin-1 string is
;;     ;; also null, and vice versa.  So don't have to worry about
;;     ;; null-termination or length. (If we were translating to/from
;;     ;; :unicode, this would become an issue.)
;; 
;;     (defun translate-string-via-fli (string from to)
;;       (fli:with-foreign-string (ptr elements bytes :external-format from)
;; 	  string
;; 	(declare (ignore elements bytes))
;; 	(fli:convert-from-foreign-string ptr :external-format to)))


;;; character encoding support

(defvar *pg-client-encoding*)

(defun implementation-name-for-encoding (encoding)
  (%sysdep "convert from client encoding to external format name"
     #+(and clisp unicode)
     (cond ((string-equal encoding "SQL_ASCII") charset:ascii)
           ((string-equal encoding "LATIN1") charset:iso-8859-1)
           ((string-equal encoding "LATIN2") charset:iso-8859-2)
           ((string-equal encoding "LATIN9") charset:iso-8859-9)
           ((string-equal encoding "UTF8") charset:utf-8)
           (t (error "unknown encoding ~A" encoding)))
     #+(and allegro ics)
     (cond ((string-equal encoding "SQL_ASCII") :ascii)
           ((string-equal encoding "LATIN1") :latin1)
           ((string-equal encoding "LATIN9") :latin9)
           ((string-equal encoding "UTF8") :utf8)
           (t (error "unknown encoding ~A" encoding)))
     #+(and sbcl sb-unicode)
     (cond ((string-equal encoding "SQL_ASCII") :ascii)
           ((string-equal encoding  "LATIN1") :iso-8859-1)
           ((string-equal encoding  "LATIN2") :iso-8859-2)
           ((string-equal encoding "LATIN9") :iso-8859-9)
           ((string-equal encoding "UTF8") :utf8)
           (t (error "unknown encoding ~A" encoding)))
     #+(or cmu gcl ecl abcl openmcl lispworks)
     nil))

(defun convert-string-to-bytes (string encoding)
  (declare (type string string))
  (%sysdep "convert string to octet-array"
     #+(and clisp unicode)
     (ext:convert-string-to-bytes string (implementation-name-for-encoding encoding))
     #+(and allegro ics)
     (excl:string-to-octets string :null-terminate nil
			    :external-format (implementation-name-for-encoding encoding))
     #+(and :sbcl :sb-unicode)
     (sb-ext:string-to-octets string
                              :external-format (implementation-name-for-encoding encoding))
     #+(or cmu gcl ecl abcl openmcl lispworks)
     (if (member encoding '("SQL_ASCII" "LATIN1" "LATIN9") :test #'string-equal)
         (let ((octets (make-array (length string) :element-type '(unsigned-byte 8))))
           (map-into octets #'char-code string))
         (error "Can't convert ~A string to octets" encoding))))

(defun convert-string-from-bytes (bytes encoding)
  (declare (type (vector (unsigned-byte 8)) bytes))
  (%sysdep "convert octet-array to string"
    #+(and clisp unicode)
    (ext:convert-string-from-bytes bytes (implementation-name-for-encoding encoding))
    #+(and allegro ics)
    (excl:octets-to-string bytes :external-format (implementation-name-for-encoding encoding))
    #+(and :sbcl :sb-unicode)
    (sb-ext:octets-to-string bytes :external-format (implementation-name-for-encoding encoding))
    ;; for implementations that have no support for character
    ;; encoding, we assume that the encoding is an octet-for-octet
    ;; encoding, and convert directly
    #+(or cmu (and sbcl (not :sb-unicode)) gcl ecl abcl openmcl lispworks)
    (let ((string (make-string (length bytes))))
      (map-into string #'code-char bytes))))


;; EOF