home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / socket.scm < prev    next >
Text File  |  2001-06-04  |  5KB  |  144 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: socket.scm,v 1.17 2001/06/05 02:46:59 cph Exp $
  4.  
  5. Copyright (c) 1990-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
  20. USA.
  21. |#
  22.  
  23. ;;;; Socket Support
  24. ;;; package: (runtime socket)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define (open-tcp-stream-socket host-name service
  29.                 #!optional buffer-size line-translation)
  30.   (socket-port (open-tcp-stream-socket-channel host-name service)
  31.            (if (default-object? buffer-size) #f buffer-size)
  32.            (if (default-object? line-translation) #f line-translation)))
  33.  
  34. (define (open-unix-stream-socket filename
  35.                 #!optional buffer-size line-translation)
  36.   (socket-port (open-unix-stream-socket-channel filename)
  37.            (if (default-object? buffer-size) #f buffer-size)
  38.            (if (default-object? line-translation) #f line-translation)))
  39.  
  40. (define (socket-port channel buffer-size line-translation)
  41.   (let ((buffer-size (or buffer-size 4096))
  42.     (line-translation (or line-translation 'DEFAULT)))
  43.     (make-generic-i/o-port channel channel
  44.                buffer-size buffer-size
  45.                line-translation line-translation)))
  46.  
  47. (define (open-tcp-stream-socket-channel host-name service)
  48.   (let ((host (vector-ref (get-host-by-name host-name) 0))
  49.     (port (tcp-service->port service)))
  50.     (open-channel
  51.      (lambda (p)
  52.        (with-thread-timer-stopped
  53.      (lambda ()
  54.        ((ucode-primitive new-open-tcp-stream-socket 3) host port p)))))))
  55.  
  56. (define (open-unix-stream-socket-channel filename)
  57.   (open-channel
  58.    (lambda (p)
  59.      (with-thread-timer-stopped
  60.        (lambda ()
  61.      ((ucode-primitive new-open-unix-stream-socket 2) filename p))))))
  62.  
  63. (define (open-tcp-server-socket service #!optional host)
  64.   (open-channel
  65.    (lambda (p)
  66.      (with-thread-timer-stopped
  67.        (lambda ()
  68.      (let ((channel ((ucode-primitive create-tcp-server-socket 0))))
  69.        (system-pair-set-cdr! p channel)
  70.        ((ucode-primitive bind-tcp-server-socket 3)
  71.         channel
  72.         (if (or (default-object? host) (not host))
  73.         ((ucode-primitive host-address-any 0))
  74.         host)
  75.         (tcp-service->port service))
  76.        ((ucode-primitive listen-tcp-server-socket 1) channel)))))))
  77.  
  78. (define (tcp-service->port service)
  79.   (if (exact-nonnegative-integer? service)
  80.       ((ucode-primitive get-service-by-number 1) service)
  81.       ((ucode-primitive get-service-by-name 2) service "tcp")))
  82.  
  83. (define (close-tcp-server-socket server-socket)
  84.   (channel-close server-socket))
  85.  
  86. (define (tcp-server-connection-accept server-socket block? peer-address)
  87.   (let ((channel
  88.      (with-thread-events-blocked
  89.        (lambda ()
  90.          (let ((do-test
  91.             (lambda (k)
  92.               (let ((result (test-for-input-on-channel server-socket)))
  93.             (case result
  94.               ((INPUT-AVAILABLE)
  95.                (open-channel
  96.                 (lambda (p)
  97.                   (with-thread-timer-stopped
  98.                 (lambda ()
  99.                   ((ucode-primitive
  100.                     new-tcp-server-connection-accept
  101.                     3)
  102.                    (channel-descriptor server-socket)
  103.                    peer-address
  104.                    p))))))
  105.               ((PROCESS-STATUS-CHANGE)
  106.                (handle-subprocess-status-change)
  107.                (if (channel-closed? server-socket) #f (k)))
  108.               (else
  109.                (k)))))))
  110.            (if block?
  111.            (let loop () (do-test loop))
  112.            (do-test (lambda () #f))))))))
  113.     (and channel
  114.      (make-generic-i/o-port channel channel 4096 4096))))
  115.  
  116. (define (get-host-by-name host-name)
  117.   (with-thread-timer-stopped
  118.     (lambda ()
  119.       ((ucode-primitive get-host-by-name 1) host-name))))
  120.  
  121. (define (get-host-by-address host-address)
  122.   (with-thread-timer-stopped
  123.     (lambda ()
  124.       ((ucode-primitive get-host-by-address 1) host-address))))
  125.  
  126. (define (canonical-host-name host-name)
  127.   (with-thread-timer-stopped
  128.     (lambda ()
  129.       ((ucode-primitive canonical-host-name 1) host-name))))
  130.  
  131. (define get-host-name
  132.   (ucode-primitive get-host-name 0))
  133.  
  134. (define (os/hostname)
  135.   (canonical-host-name (get-host-name)))
  136.  
  137. (define (allocate-host-address)
  138.   (string-allocate ((ucode-primitive host-address-length 0))))
  139.  
  140. (define host-address-any
  141.   (ucode-primitive host-address-any 0))
  142.  
  143. (define host-address-loopback
  144.   (ucode-primitive host-address-loopback 0))