409 lines
12 KiB
Plaintext
409 lines
12 KiB
Plaintext
![]() |
;;;;
|
|||
|
;;;; 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))
|
|||
|
|
|||
|
)
|