cl-acl-compat 1.2.42+cvs.2010.02.08-dfsg-1.2 / usr / share / common-lisp / source / cl-acl-compat / acl-socket-corman.lisp

;;;; ACL socket wrapper library for Corman Lisp - Version 1.1
;;;;
;;;; Copyright (C) 2000 Christopher Double. All Rights Reserved.
;;;; 
;;;; License
;;;; =======
;;;; This software is provided 'as-is', without any express or implied
;;;; warranty. In no event will the author be held liable for any damages
;;;; arising from the use of this software.
;;;;
;;;; Permission is granted to anyone to use this software for any purpose,
;;;; including commercial applications, and to alter it and redistribute
;;;; it freely, subject to the following restrictions:
;;;;
;;;; 1. The origin of this software must not be misrepresented; you must
;;;;    not claim that you wrote the original software. If you use this
;;;;    software in a product, an acknowledgment in the product documentation
;;;;    would be appreciated but is not required.
;;;;
;;;; 2. Altered source versions must be plainly marked as such, and must
;;;;    not be misrepresented as being the original software.
;;;;
;;;; 3. This notice may not be removed or altered from any source 
;;;;    distribution.
;;;;
;;;; Notes
;;;; =====
;;;; A simple wrapper around the SOCKETS package to present an interface
;;;; similar to the Allegro Common Lisp SOCKET package. Based on a package
;;;; by David Bakhash for LispWorks. For documentation on the ACL SOCKET
;;;; package see:
;;;;
;;;;   http://www.franz.com/support/documentation/5.0.1/doc/cl/socket.htm
;;;;
;;;; More recent versions of this software may be available at:
;;;;   http://www.double.co.nz/cl
;;;;
;;;; Comments, suggestions and bug reports to the author, 
;;;; Christopher Double, at: chris@double.co.nz
;;;;
;;;; 17/09/2000 - 1.0 
;;;;              Initial release.
;;;;
;;;; 20/09/2000 - 1.1
;;;;              Added SOCKET-CONTROL function.
;;;;
;;;; 27/02/2001 - 1.2
;;;;              Added ability to create SSL sockets. Doesn't use
;;;;              same interface as Allegro 6 - need to look into
;;;;              how that works.
;;;;
;;;; 03/01/2003 - 1.3
;;;;              Added to PortableAllegroServe.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :sockets)
  (require :ssl-sockets))

(sockets:start-sockets)
(ssl-sockets:start-ssl-sockets)

(defpackage socket
  (:use "COMMON-LISP")
  (:export 
		"MAKE-SOCKET"
		"ACCEPT-CONNECTION"
		"DOTTED-TO-IPADDR"
		"IPADDR-TO-DOTTED"
		"IPADDR-TO-HOSTNAME"
		"LOOKUP-HOSTNAME"
		"REMOTE-HOST"
		"LOCAL-HOST"
		"LOCAL-PORT"
		"SOCKET-CONTROL"
		))

(in-package :socket)

(defmethod accept-connection ((server-socket sockets::server-socket)
			      &key (wait t))
	(unless wait
		(error "WAIT keyword to ACCEPT-CONNECTION not implemented."))
	(sockets:make-socket-stream 
		(sockets:accept-socket server-socket)))

(defun make-socket (&key 
        (remote-host "0.0.0.0") ;;localhost?
		type
		local-port
		remote-port 
		(connect :active)
		(format :text)
		ssl
        &allow-other-keys)
    (check-type remote-host string)
	(when (eq type :datagram)
		(error ":DATAGRAM keyword to MAKE-SOCKET not implemented."))
	(when (eq format :binary)
		(warn ":BINARY keyword to MAKE-SOCKET partially implemented."))
	
	(ecase connect
		(:passive
			(sockets:make-server-socket 
				:host remote-host
				:port local-port))
		(:active			
			(sockets:make-socket-stream
				(if ssl
					(ssl-sockets:make-client-ssl-socket
						:host remote-host
						:port remote-port)
					(sockets:make-client-socket
						:host remote-host
						:port remote-port))))))
					

(defun dotted-to-ipaddr (dotted &key errorp)
	(when errorp
		(warn ":ERRORP keyword to DOTTED-TO-IPADDR not supported."))
	(sockets:host-to-ipaddr dotted))

(defun ipaddr-to-dotted (ipaddr &key values)
	(when values
		(error ":VALUES keyword to IPADDR-TO-DOTTED not supported."))
	(sockets:ipaddr-to-dotted ipaddr))

(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
	(when ignore-cache
		(warn ":IGNORE-CACHE keyword to IPADDR-TO-HOSTNAME not supported."))
	(sockets:ipaddr-to-name ipaddr))

(defun lookup-hostname (host &key ignore-cache)
	(when ignore-cache
		(warn ":IGNORE-CACHE keyword to IPADDR-TO-HOSTNAME not supported."))
	(if (stringp host)
		(sockets:host-to-ipaddr host)
		(dotted-to-ipaddr (ipaddr-to-dotted host))))	

(defun remote-host (socket-or-stream)
	(let ((socket (if (typep socket-or-stream 'sockets:base-socket)
					socket-or-stream
					(sockets:stream-socket-handle socket-or-stream))))
		(sockets::remote-socket-ipaddr socket)))

(defun local-host (socket-or-stream)
	(let ((socket (if (typep socket-or-stream 'sockets:base-socket)
					socket-or-stream
					(sockets:stream-socket-handle socket-or-stream))))
        (if (not (typep socket 'sockets:local-socket))
            16777343
            (sockets::socket-host-ipaddr socket))))

(defun local-port (socket-or-stream)
	(let ((socket (if (typep socket-or-stream 'sockets:base-socket)
					socket-or-stream
					(sockets:stream-socket-handle socket-or-stream))))
		(sockets:socket-port socket)))

(defun socket-control (stream &key output-chunking output-chunking-eof input-chunking)
	(declare (ignore stream output-chunking output-chunking-eof input-chunking))
	(warn "SOCKET-CONTROL function not implemented."))

;; Some workarounds to get combined text/binary socket streams working
(defvar old-read-byte #'cl::read-byte)

(defun new-read-byte (stream &optional (eof-error-p t) (eof-value nil))
	"Replacement for Corman Lisp READ-BYTE to work with socket streams correctly."
	(if (eq (cl::stream-subclass stream) 'sockets::socket-stream)
        (char-int (read-char stream eof-error-p eof-value))
		(funcall old-read-byte stream eof-error-p eof-value)))

(setf (symbol-function 'common-lisp::read-byte) #'new-read-byte)

(in-package :cl)

(defun write-sequence (sequence stream &key start end)
	(let ((element-type (stream-element-type stream))
			(start (if start start 0))
			(end (if end end (length sequence))))
		(if (eq element-type 'character)
			(do ((n start (+ n 1)))
				((= n end))
				(write-char (if (typep (elt sequence n) 'number) (ccl:int-char (elt sequence n)) (elt sequence n)) stream))
			(do ((n start (+ n 1)))
				((= n end))
				(write-byte (elt sequence n) stream))))		;; recoded to avoid LOOP, because it isn't loaded yet
			;(loop for n from start below end do
			;	(write-char (elt sequence n) stream))
			;(loop for n from start below end do
			;	(write-byte (elt sequence n) stream))
	(force-output stream))

(provide 'acl-socket)