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 / microcode / pruxsock.c < prev    next >
C/C++ Source or Header  |  2001-06-01  |  9KB  |  323 lines
  1. /* -*-C-*-
  2.  
  3. $Id: pruxsock.c,v 1.20 2001/06/02 01:06:01 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. /* Primitives for socket control. */
  24.  
  25. #include "scheme.h"
  26. #include "prims.h"
  27.  
  28. /* This obtains the HAVE_SOCKETS definition.  */
  29. #ifdef __unix__
  30. #  include "ux.h"
  31. #endif
  32.  
  33. /* Under OS/2, socket support is the default but can be disabled.  */
  34. #ifdef __OS2__
  35. #  ifndef DISABLE_SOCKET_SUPPORT
  36. #    define HAVE_SOCKETS 1
  37. #    define HAVE_UNIX_SOCKETS 1
  38. #  endif
  39. #endif
  40.  
  41. /* Under Win32, socket support is the default but can be disabled.  */
  42. #ifdef __WIN32__
  43. #  ifndef DISABLE_SOCKET_SUPPORT
  44. #    define HAVE_SOCKETS 1
  45. #    undef HAVE_UNIX_SOCKETS
  46. #  endif
  47. #endif
  48.  
  49. #ifdef HAVE_SOCKETS
  50.  
  51. #include "uxsock.h"
  52. #define SOCKET_CODE(code) code
  53.  
  54. static PTR
  55. DEFUN (arg_host, (arg), unsigned int arg)
  56. {
  57.   CHECK_ARG (arg, STRING_P);
  58.   if ((STRING_LENGTH (ARG_REF (arg))) != (OS_host_address_length ()))
  59.     error_bad_range_arg (arg);
  60.   return (STRING_LOC ((ARG_REF (arg)), 0));
  61. }
  62.  
  63. static Tchannel
  64. DEFUN (arg_server_socket, (arg), unsigned int arg)
  65. {
  66.   Tchannel server_socket = (arg_nonnegative_integer (arg));
  67.   if ((OS_channel_type (server_socket)) != channel_type_tcp_server_socket)
  68.     error_bad_range_arg (arg);
  69.   return (server_socket);
  70. }
  71.  
  72. #else /* not HAVE_SOCKETS */
  73.  
  74. #define SOCKET_CODE(code)                        \
  75. {                                    \
  76.   signal_error_from_primitive (ERR_UNIMPLEMENTED_PRIMITIVE);        \
  77.   PRIMITIVE_RETURN (UNSPECIFIC);                    \
  78. }
  79.  
  80. #endif /* not HAVE_SOCKETS */
  81.  
  82. DEFINE_PRIMITIVE ("GET-SERVICE-BY-NAME", Prim_get_service_by_name, 2, 2,
  83.   "Given SERVICE-NAME and PROTOCOL-NAME, return a port number.\n\
  84. The result is a nonnegative integer, or #F if no such service exists.")
  85. {
  86.   PRIMITIVE_HEADER (2);
  87.   SOCKET_CODE
  88.     ({
  89.       int result
  90.     = (OS_get_service_by_name ((STRING_ARG (1)), (STRING_ARG (2))));
  91.       PRIMITIVE_RETURN ((result < 0) ? SHARP_F : (long_to_integer (result)));
  92.      });
  93. }
  94.  
  95. DEFINE_PRIMITIVE ("GET-SERVICE-BY-NUMBER", Prim_get_service_by_number, 1, 1,
  96.   "Given PORT-NUMBER, return it in the network encoding.")
  97. {
  98.   PRIMITIVE_HEADER (1);
  99.   SOCKET_CODE
  100.     ({
  101.       PRIMITIVE_RETURN
  102.     (ulong_to_integer (OS_get_service_by_number (arg_ulong_integer (1))));
  103.      });
  104. }
  105.  
  106. DEFINE_PRIMITIVE ("HOST-ADDRESS-LENGTH", Prim_host_address_length, 0, 0,
  107.   "The length of a host address string, in characters.")
  108. {
  109.   PRIMITIVE_HEADER (0);
  110.   SOCKET_CODE
  111.     ({
  112.       PRIMITIVE_RETURN (long_to_integer (OS_host_address_length ()));
  113.     });
  114. }
  115.  
  116. DEFINE_PRIMITIVE ("GET-HOST-BY-NAME", Prim_get_host_by_name, 1, 1,
  117.   "Given HOST-NAME, return its internet host numbers.\n\
  118. The result is a vector of strings, or #F if no such host exists.")
  119. {
  120.   PRIMITIVE_HEADER (1);
  121.   SOCKET_CODE
  122.     ({
  123.       char ** addresses = (OS_get_host_by_name (STRING_ARG (1)));
  124.       if (addresses == 0)
  125.     PRIMITIVE_RETURN (SHARP_F);
  126.       {
  127.     char ** end = addresses;
  128.     while ((*end++) != 0) ;
  129.     end -= 1;
  130.     {
  131.       SCHEME_OBJECT result =
  132.         (allocate_marked_vector (TC_VECTOR, (end - addresses), 1));
  133.       SCHEME_OBJECT * scan_result = (VECTOR_LOC (result, 0));
  134.       unsigned int length = (OS_host_address_length ());
  135.       while (addresses < end)
  136.         (*scan_result++) =
  137.           (memory_to_string (length, ((unsigned char *) (*addresses++))));
  138.       PRIMITIVE_RETURN (result);
  139.     }
  140.       }
  141.     });
  142. }
  143.  
  144. DEFINE_PRIMITIVE ("GET-HOST-NAME", Prim_get_host_name, 0, 0, 0)
  145. {
  146.   PRIMITIVE_HEADER (0);
  147.   SOCKET_CODE
  148.     ({
  149.       CONST char * host_name = (OS_get_host_name ());
  150.       if (host_name == 0)
  151.     PRIMITIVE_RETURN (SHARP_F);
  152.       {
  153.     SCHEME_OBJECT result
  154.       = (char_pointer_to_string ((unsigned char *) host_name));
  155.     OS_free ((PTR) host_name);
  156.     PRIMITIVE_RETURN (result);
  157.       }
  158.     });
  159. }
  160.  
  161. DEFINE_PRIMITIVE ("CANONICAL-HOST-NAME", Prim_canonical_host_name, 1, 1, 0)
  162. {
  163.   PRIMITIVE_HEADER (1);
  164.   SOCKET_CODE
  165.     ({
  166.       CONST char * host_name = (OS_canonical_host_name (STRING_ARG (1)));
  167.       if (host_name == 0)
  168.     PRIMITIVE_RETURN (SHARP_F);
  169.       {
  170.     SCHEME_OBJECT result
  171.       = (char_pointer_to_string ((unsigned char *) host_name));
  172.     OS_free ((PTR) host_name);
  173.     PRIMITIVE_RETURN (result);
  174.       }
  175.     });
  176. }
  177.  
  178. DEFINE_PRIMITIVE ("GET-HOST-BY-ADDRESS", Prim_get_host_by_address, 1, 1, 0)
  179. {
  180.   PRIMITIVE_HEADER (1);
  181.   SOCKET_CODE
  182.     ({
  183.       CONST char * host_name = (OS_get_host_by_address (STRING_ARG (1)));
  184.       if (host_name == 0)
  185.     PRIMITIVE_RETURN (SHARP_F);
  186.       {
  187.     SCHEME_OBJECT result
  188.       = (char_pointer_to_string ((unsigned char *) host_name));
  189.     OS_free ((PTR) host_name);
  190.     PRIMITIVE_RETURN (result);
  191.       }
  192.     });
  193. }
  194.  
  195. DEFINE_PRIMITIVE ("HOST-ADDRESS-ANY", Prim_host_address_any, 0, 0, 0)
  196. {
  197.   PRIMITIVE_HEADER (0);
  198.   SOCKET_CODE
  199.     ({
  200.       SCHEME_OBJECT result = (allocate_string (OS_host_address_length ()));
  201.       OS_host_address_any (STRING_LOC (result, 0));
  202.       PRIMITIVE_RETURN (result);
  203.     });
  204. }
  205.  
  206. DEFINE_PRIMITIVE ("HOST-ADDRESS-LOOPBACK", Prim_host_address_loopback, 0, 0, 0)
  207. {
  208.   PRIMITIVE_HEADER (0);
  209.   SOCKET_CODE
  210.     ({
  211.       SCHEME_OBJECT result = (allocate_string (OS_host_address_length ()));
  212.       OS_host_address_loopback (STRING_LOC (result, 0));
  213.       PRIMITIVE_RETURN (result);
  214.     });
  215. }
  216.  
  217. DEFINE_PRIMITIVE ("NEW-OPEN-TCP-STREAM-SOCKET", Prim_new_open_tcp_stream_socket, 3, 3,
  218.   "Given HOST-ADDRESS and PORT-NUMBER, open a TCP stream socket.\n\
  219. The opened socket is stored in the cdr of WEAK-PAIR.")
  220. {
  221.   PRIMITIVE_HEADER (3);
  222.   CHECK_ARG (3, WEAK_PAIR_P);
  223.   SOCKET_CODE
  224.     ({
  225.       SET_PAIR_CDR
  226.     ((ARG_REF (3)),
  227.      (long_to_integer
  228.       (OS_open_tcp_stream_socket ((arg_host (1)),
  229.                       (arg_nonnegative_integer (2))))));
  230.       PRIMITIVE_RETURN (SHARP_T);
  231.     });
  232. }
  233.  
  234. DEFINE_PRIMITIVE ("NEW-OPEN-UNIX-STREAM-SOCKET", Prim_new_open_unix_stream_socket, 2, 2,
  235.   "Open the unix stream socket FILENAME.\n\
  236. The opened socket is stored in the cdr of WEAK-PAIR.")
  237. {
  238.   PRIMITIVE_HEADER (2);
  239.   CHECK_ARG (2, WEAK_PAIR_P);
  240. #ifdef HAVE_UNIX_SOCKETS
  241.   SET_PAIR_CDR
  242.     ((ARG_REF (2)),
  243.      (long_to_integer (OS_open_unix_stream_socket (STRING_ARG (1)))));
  244. #else
  245.   signal_error_from_primitive (ERR_UNIMPLEMENTED_PRIMITIVE);
  246. #endif
  247.   PRIMITIVE_RETURN (SHARP_T);
  248. }
  249.  
  250. DEFINE_PRIMITIVE ("NEW-OPEN-TCP-SERVER-SOCKET", Prim_new_open_tcp_server_socket, 2, 2,
  251.   "Given PORT-NUMBER, open TCP server socket.\n\
  252. The opened socket is stored in the cdr of WEAK-PAIR.")
  253. {
  254.   PRIMITIVE_HEADER (2);
  255.   CHECK_ARG (2, WEAK_PAIR_P);
  256.   SOCKET_CODE
  257.     ({
  258.       Tchannel channel = (OS_create_tcp_server_socket ());
  259.       PTR address = (OS_malloc (OS_host_address_length ()));
  260.       OS_host_address_any (address);
  261.       OS_bind_tcp_server_socket
  262.     (channel, address, (arg_nonnegative_integer (1)));
  263.       OS_free (address);
  264.       OS_listen_tcp_server_socket (channel);
  265.       SET_PAIR_CDR ((ARG_REF (2)), (long_to_integer (channel)));
  266.       PRIMITIVE_RETURN (SHARP_T);
  267.     });
  268. }
  269.  
  270. DEFINE_PRIMITIVE ("CREATE-TCP-SERVER-SOCKET", Prim_create_tcp_server_socket, 0, 0, 0)
  271. {
  272.   PRIMITIVE_HEADER (0);
  273.   SOCKET_CODE
  274.     ({
  275.       PRIMITIVE_RETURN (long_to_integer (OS_create_tcp_server_socket ()));
  276.     });
  277. }
  278.  
  279. DEFINE_PRIMITIVE ("BIND-TCP-SERVER-SOCKET", Prim_bind_tcp_server_socket, 3, 3, 0)
  280. {
  281.   PRIMITIVE_HEADER (3);
  282.   SOCKET_CODE
  283.     ({
  284.       OS_bind_tcp_server_socket ((arg_server_socket (1)),
  285.                  (arg_host (2)),
  286.                  (arg_nonnegative_integer (3)));
  287.       PRIMITIVE_RETURN (UNSPECIFIC);
  288.     });
  289. }
  290.  
  291. DEFINE_PRIMITIVE ("LISTEN-TCP-SERVER-SOCKET", Prim_listen_tcp_server_socket, 1, 1, 0)
  292. {
  293.   PRIMITIVE_HEADER (1);
  294.   SOCKET_CODE
  295.     ({
  296.       OS_listen_tcp_server_socket (arg_server_socket (1));
  297.       PRIMITIVE_RETURN (UNSPECIFIC);
  298.     });
  299. }
  300.  
  301. DEFINE_PRIMITIVE ("NEW-TCP-SERVER-CONNECTION-ACCEPT", Prim_new_tcp_server_connection_accept, 3, 3,
  302.   "Poll SERVER-SOCKET for a connection.\n\
  303. If a connection is available, it is opened and #T is returned;\n\
  304. the opened socket is stored in the cdr of WEAK-PAIR.\n\
  305. Otherwise, if SERVER-SOCKET is non-blocking, returns #F.\n\
  306. Second argument PEER-ADDRESS, if not #F, must be a host address string.\n\
  307. It is filled with the peer's address if given.")
  308. {
  309.   PRIMITIVE_HEADER (3);
  310.   CHECK_ARG (3, WEAK_PAIR_P);
  311.   SOCKET_CODE
  312.     ({
  313.       Tchannel server_socket = (arg_server_socket (1));
  314.       PTR peer_host = (((ARG_REF (2)) == SHARP_F) ? 0 : (arg_host (2)));
  315.       Tchannel connection =
  316.     (OS_server_connection_accept (server_socket, peer_host, 0));
  317.       if (connection == NO_CHANNEL)
  318.     PRIMITIVE_RETURN (SHARP_F);
  319.       SET_PAIR_CDR ((ARG_REF (3)), (long_to_integer (connection)));
  320.       PRIMITIVE_RETURN (SHARP_T);
  321.     });
  322. }
  323.