Patch title: Release 81 bulk changes
Abstract:
File: /pliant/language/os/socket.pli
Key:
    Removed line
    Added line
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

module "/pliant/install/ring2.pli"
module "/pliant/language/stream/openmode.pli"


constant uselibc os_api<>"linux"
if os_api="linux" or os_api="posix"
  constant os_socket_filename os_libc_filename
eif os_api="win32"
  constant os_socket_filename "wsock32.dll"
eif os_api="os2"
  constant os_socket_filename "so32dll.dll"
constant uselibcfornames os_socket_filename<>""
constant os_usesendrecv os_api="win32" or os_api="os2"

if os_api="os2"
  function dll s1 -> s2
    arg Str s1 s2
    has_no_side_effect
    s2 := upper s1
  constant os_socket_filename2 "tcp32dll.dll"
else
  function dll s1 -> s2
    arg Str s1 s2
    has_no_side_effect
    s2 := s1
  constant os_socket_filename2 os_socket_filename

export os_usesendrecv


#----------------------------------------------------------------


function ip_dot_notation ip -> s
  arg uInt ip ; arg Str s
  s := ""
  for (var Int u) 0 3
    if u>0
      s := s+"."
    s := s+(string (ip\2^(8*(3-u))).and.255)


function ip_match ip filter -> m
  arg Str ip filter ; arg CBool m
  if filter=""
    m := true
  eif (filter parse any:(var Str filter1) "+" any:(var Str filter2))
    m := (ip_match ip filter1) or (ip_match ip filter2)
  eif (ip eparse (var Int i1) "." (var Int i2) "." (var Int i3) "." (var Int i4)) and (filter eparse (var Int f1) "." (var Int f2) "." (var Int f3) "." (var Int f4))
    m := i1=f1 and i2=f2 and i3=f3 and i4=f4
  eif (ip eparse i1 "." i2 "." i3 "." i4) and (filter eparse f1 "." f2 "." f3 "." f4 "/"  (var Int m1) "." (var Int m2) "." (var Int m3) "." (var Int m4))
    m := (i1 .and. m1)=(f1 .and. m1) and (i2 .and. m2)=(f2 .and. m2) and (i3 .and. m3)=(f3 .and. m3) and (i4 .and. m4)=(f4 .and. m4)
  else
    m := false

export ip_dot_notation ip_match


#----------------------------------------------------------------


if not uselibc
  function socketcall op args -> err
    arg Int op err ; arg Address args
    kernel_function 102


function os_socket domain type protocol -> s
  arg Int domain type protocol s
  if uselibc
    external os_socket_filename dll:"socket"
  else
    external_calling_convention
    s := socketcall 1 addressof:domain

public
  if os_api="linux"
    constant os_AF_INET 2
    constant os_AF_INET6 10
    constant os_SOCK_STREAM 1
    constant os_SOCK_DGRAM 2
    constant os_SOCK_RAW 3
  eif os_api="posix"
    os_constant os_AF_INET "sys/socket.h" AF_INET
    os_constant os_AF_INET6 "sys/socket.h" AF_INET6
    os_constant os_SOCK_STREAM "sys/socket.h" SOCK_STREAM
    os_constant os_SOCK_DGRAM "sys/socket.h" SOCK_DGRAM
    os_constant os_SOCK_RAW "sys/socket.h" SOCK_RAW
  eif os_api="win32"
    constant os_AF_INET 2
    constant os_AF_INET6 23
    constant os_SOCK_STREAM 1
    constant os_SOCK_DGRAM 2
    constant os_SOCK_RAW 3
  eif os_api="os2"
    constant os_AF_INET 2
    constant os_SOCK_STREAM 1
    constant os_SOCK_DGRAM 2
    constant os_SOCK_RAW 3

  type os_sockaddr
    void
  
  if os_api="linux" or os_api="win32" or os_api="os2"
    type os_sockaddr_in
      packed
      field uInt16 sin_family
      field uInt16_hi sin_port
      field uInt32_hi sin_addr
      field Int pad1 pad2
  eif os_api="posix"
    os_type os_sockaddr_in "netinet/in.h" sockaddr_in
      field uInt sin_family
      field uInt_hi sin_port
      field uInt_hi sin_addr
  
  os_sockaddr maybe os_sockaddr_in


function os_bind s addr addrlen -> err
  arg Int s addrlen err ; arg os_sockaddr addr
  if uselibc
    external os_socket_filename dll:"bind"
  else
    external_calling_convention
    err := socketcall 2 addressof:s


function os_connect s addr addrlen -> err
  arg Int s addrlen err ; arg os_sockaddr addr
  if uselibc
    external os_socket_filename dll:"connect"
  else
    external_calling_convention
    err := socketcall 3 addressof:s


function os_listen s backlog -> err
  arg Int s backlog err
  if uselibc
    external os_socket_filename dll:"listen"
  else
    external_calling_convention
    err := socketcall 4 addressof:s


function os_accept s addr addrlen -> err
  arg Int s err ; arg_w os_sockaddr addr ; arg_rw Int addrlen
  if uselibc
    external os_socket_filename dll:"accept"
  else
    external_calling_convention
    err := socketcall 5 addressof:s


function os_shutdown s how -> err
  arg Int s how err
  if uselibc
    external os_socket_filename dll:"shutdown"
  else
    external_calling_convention
    err := socketcall 13 addressof:s


function os_setsockopt s level optname optval optlen -> err
  arg Int s level optname optlen err ; arg Address optval
  if uselibc
    external os_socket_filename dll:"setsockopt"
  else
    external_calling_convention
    err := socketcall 14 addressof:s

function os_getsockopt s level optname optval optlen -> err
  arg Int s level optname err ; arg Address optval ; arg_rw Int optlen
  if uselibc
    external os_socket_filename dll:"getsockopt"
  else
    external_calling_convention
    err := socketcall 15 addressof:s


function os_getsockname s addr addrlen -> err
  arg Int s err ; arg_w os_sockaddr addr ; arg_rw Int addrlen
  if uselibc
    external os_socket_filename dll:"getsockname"
  else
    external_calling_convention
    err := socketcall 6 addressof:s


function os_getpeername s addr addrlen -> err
  arg Int s err ; arg_w os_sockaddr addr ; arg_rw Int addrlen
  if uselibc
    external os_socket_filename dll:"getpeername"
  else
    external_calling_convention
    err := socketcall 7 addressof:s


if os_usesendrecv

  function os_send s buf len flags -> err
    arg Int s len flags err ; arg Address buf
    if uselibc
      external os_socket_filename dll:"send"
    else
      external_calling_convention
      err := socketcall 9 addressof:s

  function os_recv s buf len flags -> err
    arg Int s len flags err ; arg Address buf
    if uselibc
      external os_socket_filename dll:"recv"
    else
      external_calling_convention
      err := socketcall 10 addressof:s

  export os_send os_recv


function os_sendto s msg len flags to tolen -> err
  arg Int s len flags tolen err ; arg Address msg ; arg os_sockaddr to
  if uselibc
    external os_socket_filename dll:"sendto"
  else
    external_calling_convention
    err := socketcall 11 addressof:s

function os_recvfrom s buf len flags from fromlen -> err
  arg Int s len flags err ; arg Address buf ; arg_rw os_sockaddr from ; arg_rw Int fromlen
  if uselibc
    external os_socket_filename dll:"recvfrom"
  else
    external_calling_convention
    err := socketcall 12 addressof:s
 
export os_socket os_bind os_connect os_listen os_accept os_shutdown
export os_setsockopt os_getsockopt os_getsockname os_getpeername
export os_sendto os_recvfrom


if os_api="win32"

  type os_timeval
    packed
    field Int tv_sec tv_usec

  function os_win32_select n readfds writefds exceptfds timeout -> fd
    arg Int n ; arg Address readfds writefds exceptfds ; arg_rw os_timeval timeout ; arg Int fd
    external os_socket_filename dll:"select"

  export os_win32_select


function os_socket_wait s mode timeout -> status
  arg Int s ; arg Int mode ; arg Float timeout ; arg Status status
  if (constant os_api="linux" and (os_version parse (var Int r1) "." (var Int r2) "." any) and (r1>2 or r1=2 and r2>=2)) or os_api="posix"
    var os_pollfd fd
    fd fd := s
    fd events := (shunt (mode .and. in)<>0 os_POLLIN 0)+(shunt (mode .and. out)<>0 os_POLLOUT 0)+os_POLLERR+os_POLLHUP
    var Int count := os_poll addressof:fd 1 (cast timeout*1000 Int)
    status := shunt count>=1 success failure
  eif os_api="win32"
    var Int none := 0
    var (Array Int 2) fds ; fds 0 := 1 ; fds 1 := s
    var os_timeval time
    time tv_sec := cast timeout-0.5 Int
    time tv_usec := cast (timeout-time:tv_sec)*1e6 Int
    var Int count := os_win32_select 0 (shunt (mode .and. in)<>0 addressof:fds addressof:none) (shunt(mode .and. out)<>0 addressof:fds addressof:none) addressof:fds time
    status := shunt count>=1 success failure
  else
    if s<0 or s>=1024
      return success
    var Address fds := memory_zallocate 1024\8 null
    (fds translate Byte s\8) map uInt8 := 2^(s%8)
    var Address none := memory_zallocate 1024\8 null
    var os_timeval time
    time tv_sec := cast timeout-0.5 Int
    time tv_usec := cast (timeout-time:tv_sec)*1e6 Int
    var Int count := os_select s+1 (shunt (mode .and. in)<>0 fds none) (shunt(mode .and. out)<>0 fds none) fds time
    memory_free fds
    memory_free none
    status := shunt count>=1 success failure

export os_socket_wait


public

  if os_api="linux"
    constant os_SOL_SOCKET 1
    constant os_SO_REUSEADDR 2
    constant os_SO_KEEPALIVE 9
  eif os_api="posix"
    os_constant os_SOL_SOCKET "sys/socket.h" SOL_SOCKET
    os_constant os_SO_REUSEADDR "sys/socket.h" SO_REUSEADDR
    os_constant os_SO_KEEPALIVE "sys/socket.h" SO_KEEPALIVE
  eif os_api="win32" or os_api="os2"
    constant os_SOL_SOCKET 0FFFFh
    constant os_SO_REUSEADDR 4
    constant os_SO_KEEPALIVE 8

  if os_api="linux"
    constant os_IPPROTO_IP 0
    constant os_IP_TOS 1
    constant os_IPTOS_LOWCOST 2
    constant os_IPTOS_RELIABILITY 4
    constant os_IPTOS_THROUGHPUT 8
    constant os_IPTOS_LOWDELAY 16
  
  if os_api="linux" or os_api="os2"
    type os_hostent
      packed
      field Address h_name
      field Address h_aliases
      field Int h_addrtype
      field Int h_length
      field Address h_addr_list
  eif os_api="posix"
    os_type os_hostent "netdb.h" hostent
      field Address h_name
      field Address h_aliases
      field Int h_addrtype
      field Int h_length
      field Address h_addr_list
  eif os_api="win32"
    type os_hostent
      packed
      field Address h_name
      field Address h_aliases
      field Int16 h_addrtype
      field Int16 h_length
      field Address h_addr_list


if uselibcfornames

  function os_gethostbyname name -> h
    arg CStr name ; arg_R os_hostent h
    external os_socket_filename2 dll:"gethostbyname"

  function os_gethostbyaddr addr addrlen type -> h
    arg Address addr ; arg Int addrlen type ; arg_R os_hostent h
    external os_socket_filename2 dll:"gethostbyaddr"

  export os_gethostbyname os_gethostbyaddr


if os_api="win32"

  type os_WSADATA
    field Int wVersion
    field Int wHighVersion
    field (Array Char 257) szDescription
    field (Array Char 129) szSystemStatus
    field uInt16 iMaxSockets
    field uInt16 iMaxUdpDg
    field Address lpVendorInfo

  function os_WSAStartup version data -> err
    arg Int version ; arg_w os_WSADATA data ; arg Int err
    external os_socket_filename "WSAStartup"

  function socket_init parameter filehandle
    arg Address parameter ; arg Int filehandle
    os_WSAStartup 0002h (var os_WSADATA data)
  socket_init null 0
  gvar DelayedAction da
  da function :> the_function socket_init Address Int
  pliant_restore_actions append addressof:da

  function os_close s -> err
    arg Int s err
    external os_socket_filename "closesocket"

  export os_close

eif os_api="os2"

  function os_close s -> err
    arg Int s err
    external os_socket_filename dll:"soclose"

  export os_close


#----------------------------------------------------------------


function dns_query_prototype name fun -> ip
  arg Str name ip ; arg Function fun
  indirect

function dns_query_os name -> ip
  arg Str name ip
  ip := ""
  if uselibcfornames
    var Pointer:os_hostent host :> os_gethostbyname name
    if addressof:host=null
      return
    var Address h_addr := host:h_addr_list map Address
    for (var Int i) 0 3
      ip += (shunt i=0 "" ".")+string:(cast ((h_addr translate uInt8 i) map uInt8) Int)

gvar Link:Function dns_query_function :> the_function dns_query_os Str -> Str

export dns_query_prototype dns_query_function dns_query_os