stk/Lib/winsocket.stklos

409 lines
12 KiB
Plaintext
Raw Normal View History

1999-09-05 07:16:41 -04:00
;;;;
;;;; w i n s o c k e t . s t k l o s -- Socket for Win32
;;;;
;;;; Copyright <20> 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works. Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;;
;;;; Author: Steve Pruitt [steve@pruitt.net]
;;;; Creation date: 13-Mar-1999 12:59
;;;; Last file update: 23-Aug-1999 00:12
;;;;
;;;; socket object class was provided to simulate stdio
;;;; when i/o ports can not be assigned to sockets.
;;;;
;;;; Limiting socket interface to these methods is more
;;;; portable than using standard i/o ports.
;;;;
;;;;
(unless (symbol-bound? '<socket-port>)
(require "stklos")
;;;;***********************************************************************
;;;;
;;;; socket-port class definitions (adds port i/o facilities)
;;;;
;;;;***********************************************************************
(define-class <socket-port> ()
((socket :accessor socket-of :init-keyword :socket :initform -1)
(buffer-size :init-keyword :buffer-size :initform 1024)
(output-buf :accessor buffer-of :initform 0)
(output-len :initform 0)
(input-buf :initform 0)
(input-loc :initform 0)
(input-len :initform 0)
;; default recv-monitor (count number of bytes input from socket)
(bytes-input :initform 0)
(recv-monitor :init-keyword :recv-monitor :initform
(lambda (self bytes-read)
(let* ((bytes-input (slot-ref self 'bytes-input)))
(slot-set! self 'bytes-input (+ bytes-input bytes-read))
)))
;; default send-monitor (count number of bytes output to socket)
(bytes-output :initform 0)
(send-monitor :init-keyword :send-monitor :initform
(lambda (self bytes-written)
(let* ((bytes-output (slot-ref self 'bytes-output)))
(slot-set! self 'bytes-output (+ bytes-output bytes-written))
)))
))
;;;;
;;;; Initialize socket
;;;;
(define-method initialize ((self <socket-port>) initargs)
(next-method)
(require "socket")
(if (not (socket? (socket-of self))) (slot-set! self 'buffer-size -1)
))
;;;;
;;;; handle-of (get socket-handle)
;;;;
(define-method handle-of ((self <socket-port>))
(socket-handle (socket-of self)))
;;;;
;;;; address-of (socket-local-address)
;;;;
(define-method address-of ((self <socket-port>))
(socket-local-address (socket-of self)))
;;;;
;;;; close-socket-port (socket-shutdown)
;;;;
(define-method close-socket-port ((self <socket-port>))
(if (> (slot-ref self 'buffer-size) 0)
(let* ((sock (socket-of self)))
(flush self)
(socket-shutdown sock)
(slot-set! self 'buffer-size -1)
(slot-set! self 'output-buf 0)
(slot-set! self 'input-buf 0)
)))
;;;;***********************************************************************
;;;;
;;;; client-socket class definition
;;;;
;;;;***********************************************************************
(define-class <client-socket> (<socket-port>)
((port :init-keyword :port :accessor port)
(host :init-keyword :host :accessor host)
))
;;;;
;;;; Initialize client-socket (make <client-socket>)
;;;;
(define-method initialize ((self <client-socket>) initargs)
(let* ((port (get-keyword :port initargs 21))
(host (get-keyword :host initargs "not-specified")))
(require "socket")
(slot-set! self 'socket (initialize-client-socket host port))
(slot-set! self 'port port)
(slot-set! self 'host host)
(next-method)
))
;;;;***********************************************************************
;;;;
;;;; server-socket class definition
;;;;
;;;;***********************************************************************
(define-class <server-socket> (<socket-port>)
((connection :accessor connection-of)
(port-number :init-keyword :port :accessor port-of)
))
;;;;
;;;; Initialize (make server socket)
;;;;
(define-method initialize ((self <server-socket>) initargs)
(let* ((port (get-keyword :port initargs 0)))
(require "socket")
(slot-set! self 'socket (make-server-socket port))
(slot-set! self 'port-number (socket-port-number (socket-of self)))
(slot-set! self 'connection -1)
(next-method)
))
;;;;
;;;; accept-server-connection (accept server connection)
;;;;
(define-method accept-server-connection ((self <server-socket>))
(let* ((sock (socket-of self)))
(slot-set! self 'connection (accept-connection sock))
))
;;;;
;;;; handle-of (get server connection handle)
;;;;
(define-method handle-of ((self <server-socket>))
(slot-ref self 'connection))
;;;;
;;;; close-server-connection (close server connection)
;;;;
(define-method close-server-connection ((self <server-socket>))
(let* ((connection (slot-ref self 'connection)))
(if (not (= connection -1)) (close-connection connection))
(slot-set! self 'connection -1)
))
;;;;
;;;; close-socket-port (close-server-connection and socket-shutdown)
;;;;
(define-method close-socket-port ((self <server-socket>))
(if (> (slot-ref self 'buffer-size) 0)
(let* ((sock (socket-of self)))
(flush self)
(close-server-connection self)
(socket-shutdown sock)
(slot-set! self 'buffer-size -1)
(slot-set! self 'output-buf 0)
(slot-set! self 'input-buf 0)
)))
;;;;***********************************************************************
;;;;
;;;; i/o utilities (commmon to all classes)
;;;;
;;;;***********************************************************************
;;;;
;;;; read-char
;;;;
(define-method read-char ((self <socket-port>))
(let* ((chr #\newline)
(loc (slot-ref self 'input-loc)))
(if (not (string? (slot-ref self 'input-buf)))
;; initialize buffer
(let* ((size (slot-ref self 'buffer-size)))
(if (> size 0)
(let* ((buffer (make-string size))
(len (socket-recv (handle-of self) buffer)))
(set! loc 0)
(slot-set! self 'input-buf buffer)
(set! chr (string-ref buffer 0))
(slot-set! self 'input-len 0)
(if (eof-object? len) (set! chr len)
(let* ((recv-monitor (slot-ref self 'recv-monitor)))
(slot-set! self 'input-len len)
(recv-monitor self len)
)))
))
;; get next character in buffer
(if (< loc (slot-ref self 'input-len))
(set! chr (string-ref (slot-ref self 'input-buf) loc))
;; buffer is empty, get another buffer from socket
(let* ((size (slot-ref self 'buffer-size)))
(if (> size 0)
(let* ((buffer (make-string size))
(len (socket-recv (handle-of self) buffer)))
(set! loc 0)
(slot-set! self 'input-buf buffer)
(set! chr (string-ref buffer 0))
(slot-set! self 'input-len 0)
(if (eof-object? len) (set! chr len)
(let* ((recv-monitor (slot-ref self 'recv-monitor)))
(slot-set! self 'input-len len)
(recv-monitor self len)
)))))
))
(slot-set! self 'input-loc (+ loc 1))
chr
))
;;;;
;;;; write-char
;;;;
(define-method write-char (chr (self <socket-port>))
(let* ((loc (slot-ref self 'output-len)))
(if (not (string? (slot-ref self 'output-buf)))
;; initialize buffer
(if (> (slot-ref self 'buffer-size) 0)
(let* ((size (slot-ref self 'buffer-size)))
(slot-set! self 'output-buf (make-string size chr))
(set! loc 0)
))
;; add character to end of buffer
(if (< loc (slot-ref self 'buffer-size))
(string-set! (slot-ref self 'output-buf) loc chr)
;; buffer is full, flush buffer
(if (> (slot-ref self 'buffer-size) 0)
(let* ((send-monitor (slot-ref self 'send-monitor))
(handle (handle-of self)))
(socket-send handle (slot-ref self 'output-buf) loc)
(send-monitor self loc)
(string-set! (slot-ref self 'output-buf) 0 chr)
(set! loc 0)
))
))
(slot-set! self 'output-len (+ loc 1))
))
;;;;
;;;; flush
;;;;
(define-method flush ((self <socket-port>))
(let* ((len (slot-ref self 'output-len)))
(if (> len 0)
(let* ((send-monitor (slot-ref self 'send-monitor)))
(socket-send (handle-of self) (buffer-of self) len)
(send-monitor self len)
(slot-set! self 'output-len 0)
))))
;;;;
;;;; read-line
;;;;
(define-method read-line ((self <socket-port>))
(let* ((lst ()))
(do ((chr (read-char self) (read-char self)))
((or (eof-object? chr) (char=? chr #\newline)))
(set! lst (cons chr lst)))
(list->string (reverse lst))
))
;;;;
;;;; write-line
;;;;
(define-method write-line ((self <socket-port>) line)
(let* ((handle (handle-of self))
(send-monitor (slot-ref self 'send-monitor))
(len (+ (string-length line) 1))
(buf (string-append line "\n")))
(socket-send handle buf len)
(send-monitor self len)
))
;;;;
;;;; copy-to-socket
;;;;
(define-method copy(from (self <socket-port>))
(let* ((chr (read-char from))
(count (slot-ref self 'output-len)))
(if (eof-object? chr) (flush self)
(let* ((num-chars (+ count 1)))
(write-char chr self)
(let* ((send-monitor (slot-ref self 'send-monitor))
(buffer-size (slot-ref self 'buffer-size)))
(set! count 0)
(while (not (eof-object? chr))
;; fill buffer with data
(let* ((to (handle-of self)))
(do ((i num-chars (+ i 1)))
((or (= i buffer-size) (eof-object? chr)))
(set! num-chars (+ num-chars 1))
(set! chr (read-char from))
(if (eof-object? chr) (set! num-chars i)
(string-set! (buffer-of self) i chr)
))
;; send buffer data to socket and flush
(if (> num-chars 0)
(socket-send to (buffer-of self) num-chars))
(send-monitor self num-chars)
(set! count (+ count num-chars))
(set! num-chars (- num-chars buffer-size))
))
(slot-set! self 'output-len 0)
)))
count
))
;;;;
;;;; copy-from-socket
;;;;
(define-method copy((self <socket-port>) to)
(let* ((chr (read-char self)))
(if (eof-object? chr) 0
(let* ((buffer (slot-ref self 'input-buf))
(recv-monitor (slot-ref self 'recv-monitor))
(from (handle-of self))
(count 0))
;; flush first input buffer
(let* ((loc (- (slot-ref self 'input-loc) 1))
(len (slot-ref self 'input-len)))
(set! count (- len loc))
(do ((i loc (+ i 1))) ((= i len))
(write-char (string-ref buffer i) to)
))
;; copy remaining buffers until no more left
(do ((num-chars (socket-recv from buffer)
(socket-recv from buffer))) ((eof-object? num-chars))
(set! count (+ count num-chars))
(recv-monitor self num-chars)
(do ((i 0 (+ i 1))) ((= i num-chars))
(write-char (string-ref buffer i) to)
))
count
))))
;;;;
;;;; copy-socket-to-socket
;;;;
(define-method copy((self <socket-port>) (output <socket-port>))
(let* ((chr (read-char self))
(count 0))
(if (not (eof-object? chr))
(let* ((buffer (slot-ref self 'input-buf))
(recv-monitor (slot-ref self 'recv-monitor))
(send-monitor (slot-ref self 'send-monitor))
(loc (- (slot-ref self 'input-loc) 1))
(len (slot-ref self 'input-len))
(from (handle-of self))
(to (handle-of output)))
(flush output)
;; flush first input buffer
(set! count (- len loc))
(socket-send to (substring buffer loc len) count)
(send-monitor self count)
;; copy remaining buffers until no more left
(do ((num-chars (socket-recv from buffer)
(socket-recv from buffer))) ((eof-object? num-chars))
(set! count (+ count num-chars))
(recv-monitor self num-chars)
(socket-send to buffer num-chars)
(send-monitor self num-chars)
))
count
)))
;;;;
;;;; close-input-port
;;;;
(define-method close-input-port ((self <socket-port>))
(close-socket-port self))
;;;;
;;;; close-output-port
;;;;
(define-method close-output-port ((self <socket-port>))
(close-socket-port self))
)