/pliant/language/os/socket.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # 
 3  # This program is free software; you can redistribute it and/or 
 4  # modify it under the terms of the GNU General Public License version 2 
 5  # as published by the Free Software Foundation. 
 6  # 
 7  # This program is distributed in the hope that it will be useful, 
 8  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 9  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 10  # GNU General Public License for more details. 
 11  # 
 12  # You should have received a copy of the GNU General Public License 
 13  # version 2 along with this program; if not, write to the Free Software 
 14  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 15   
 16  module "/pliant/install/ring2.pli" 
 17  module "/pliant/language/stream/openmode.pli" 
 18   
 19   
 20  constant uselibc os_api<>"linux" 
 21  if os_api="linux" or os_api="posix" 
 22    constant os_socket_filename os_libc_filename 
 23  eif os_api="win32" 
 24    constant os_socket_filename "wsock32.dll" 
 25  eif os_api="os2" 
 26    constant os_socket_filename "so32dll.dll" 
 27  constant uselibcfornames os_socket_filename<>"" 
 28  constant os_usesendrecv os_api="win32" or os_api="os2" 
 29   
 30  if os_api="os2" 
 31    function dll s1 -> s2 
 32      arg Str s1 s2 
 33      has_no_side_effect 
 34      s2 := upper s1 
 35    constant os_socket_filename2 "tcp32dll.dll" 
 36  else 
 37    function dll s1 -> s2 
 38      arg Str s1 s2 
 39      has_no_side_effect 
 40      s2 := s1 
 41    constant os_socket_filename2 os_socket_filename 
 42   
 43  export os_usesendrecv 
 44   
 45   
 46 
 
 47   
 48   
 49  function ip_dot_notation ip -> s 
 50    arg uInt ip ; arg Str s 
 51    := "" 
 52    for (var Int u) 0 3 
 53      if u>0 
 54        := s+"." 
 55      := s+(string (ip\2^(8*(3-u))).and.255) 
 56   
 57   
 58  function ip_match ip filter -> m 
 59    arg Str ip filter ; arg CBool m 
 60    if filter="" 
 61      := true 
 62    eif (filter parse any:(var Str filter1) "+" any:(var Str filter2)) 
 63      := (ip_match ip filter1) or (ip_match ip filter2) 
 64    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)) 
 65      := i1=f1 and i2=f2 and i3=f3 and i4=f4 
 66    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)) 
 67      := (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) 
 68    else 
 69      := false 
 70   
 71  export ip_dot_notation ip_match 
 72   
 73   
 74 
 
 75   
 76   
 77  if not uselibc 
 78    function socketcall op args -> err 
 79      arg Int op err ; arg Address args 
 80      kernel_function 102 
 81   
 82   
 83  function os_socket domain type protocol -> s 
 84    arg Int domain type protocol s 
 85    if uselibc 
 86      external os_socket_filename dll:"socket" 
 87    else 
 88      external_calling_convention 
 89      := socketcall addressof:domain 
 90   
 91  public 
 92    if os_api="linux" 
 93      constant os_AF_INET 2 
 94      constant os_AF_INET6 10 
 95      constant os_SOCK_STREAM 1 
 96      constant os_SOCK_DGRAM 2 
 97      constant os_SOCK_RAW 3 
 98    eif os_api="posix" 
 99      os_constant os_AF_INET "sys/socket.h" AF_INET 
 100      os_constant os_AF_INET6 "sys/socket.h" AF_INET6 
 101      os_constant os_SOCK_STREAM "sys/socket.h" SOCK_STREAM 
 102      os_constant os_SOCK_DGRAM "sys/socket.h" SOCK_DGRAM 
 103      os_constant os_SOCK_RAW "sys/socket.h" SOCK_RAW 
 104    eif os_api="win32" 
 105      constant os_AF_INET 2 
 106      constant os_AF_INET6 23 
 107      constant os_SOCK_STREAM 1 
 108      constant os_SOCK_DGRAM 2 
 109      constant os_SOCK_RAW 3 
 110    eif os_api="os2" 
 111      constant os_AF_INET 2 
 112      constant os_SOCK_STREAM 1 
 113      constant os_SOCK_DGRAM 2 
 114      constant os_SOCK_RAW 3 
 115   
 116    type os_sockaddr 
 117      void 
 118     
 119    if os_api="linux" or os_api="win32" or os_api="os2" 
 120      type os_sockaddr_in 
 121        packed 
 122        field uInt16 sin_family 
 123        field uInt16_hi sin_port 
 124        field uInt32_hi sin_addr 
 125        field Int pad1 pad2 
 126    eif os_api="posix" 
 127      os_type os_sockaddr_in "netinet/in.h" sockaddr_in 
 128        field uInt sin_family 
 129        field uInt_hi sin_port 
 130        field uInt_hi sin_addr 
 131     
 132    os_sockaddr maybe os_sockaddr_in 
 133   
 134   
 135  function os_bind s addr addrlen -> err 
 136    arg Int addrlen err ; arg os_sockaddr addr 
 137    if uselibc 
 138      external os_socket_filename dll:"bind" 
 139    else 
 140      external_calling_convention 
 141      err := socketcall addressof:s 
 142   
 143   
 144  function os_connect s addr addrlen -> err 
 145    arg Int addrlen err ; arg os_sockaddr addr 
 146    if uselibc 
 147      external os_socket_filename dll:"connect" 
 148    else 
 149      external_calling_convention 
 150      err := socketcall addressof:s 
 151   
 152   
 153  function os_listen s backlog -> err 
 154    arg Int backlog err 
 155    if uselibc 
 156      external os_socket_filename dll:"listen" 
 157    else 
 158      external_calling_convention 
 159      err := socketcall addressof:s 
 160   
 161   
 162  function os_accept s addr addrlen -> err 
 163    arg Int err ; arg_w os_sockaddr addr ; arg_rw Int addrlen 
 164    if uselibc 
 165      external os_socket_filename dll:"accept" 
 166    else 
 167      external_calling_convention 
 168      err := socketcall addressof:s 
 169   
 170   
 171  function os_shutdown s how -> err 
 172    arg Int how err 
 173    if uselibc 
 174      external os_socket_filename dll:"shutdown" 
 175    else 
 176      external_calling_convention 
 177      err := socketcall 13 addressof:s 
 178   
 179   
 180  function os_setsockopt s level optname optval optlen -> err 
 181    arg Int level optname optlen err ; arg Address optval 
 182    if uselibc 
 183      external os_socket_filename dll:"setsockopt" 
 184    else 
 185      external_calling_convention 
 186      err := socketcall 14 addressof:s 
 187   
 188  function os_getsockopt s level optname optval optlen -> err 
 189    arg Int level optname err ; arg Address optval ; arg_rw Int optlen 
 190    if uselibc 
 191      external os_socket_filename dll:"getsockopt" 
 192    else 
 193      external_calling_convention 
 194      err := socketcall 15 addressof:s 
 195   
 196   
 197  function os_getsockname s addr addrlen -> err 
 198    arg Int err ; arg_w os_sockaddr addr ; arg_rw Int addrlen 
 199    if uselibc 
 200      external os_socket_filename dll:"getsockname" 
 201    else 
 202      external_calling_convention 
 203      err := socketcall addressof:s 
 204   
 205   
 206  function os_getpeername s addr addrlen -> err 
 207    arg Int err ; arg_w os_sockaddr addr ; arg_rw Int addrlen 
 208    if uselibc 
 209      external os_socket_filename dll:"getpeername" 
 210    else 
 211      external_calling_convention 
 212      err := socketcall addressof:s 
 213   
 214   
 215  if os_usesendrecv 
 216   
 217    function os_send s buf len flags -> err 
 218      arg Int s len flags err ; arg Address buf 
 219      if uselibc 
 220        external os_socket_filename dll:"send" 
 221      else 
 222        external_calling_convention 
 223        err := socketcall 9 addressof:s 
 224   
 225    function os_recv s buf len flags -> err 
 226      arg Int s len flags err ; arg Address buf 
 227      if uselibc 
 228        external os_socket_filename dll:"recv" 
 229      else 
 230        external_calling_convention 
 231        err := socketcall 10 addressof:s 
 232   
 233    export os_send os_recv 
 234   
 235   
 236  function os_sendto s msg len flags to tolen -> err 
 237    arg Int len flags tolen err ; arg Address msg ; arg os_sockaddr to 
 238    if uselibc 
 239      external os_socket_filename dll:"sendto" 
 240    else 
 241      external_calling_convention 
 242      err := socketcall 11 addressof:s 
 243   
 244  function os_recvfrom s buf len flags from fromlen -> err 
 245    arg Int len flags err ; arg Address buf ; arg_rw os_sockaddr from ; arg_rw Int fromlen 
 246    if uselibc 
 247      external os_socket_filename dll:"recvfrom" 
 248    else 
 249      external_calling_convention 
 250      err := socketcall 12 addressof:s 
 251    
 252  export os_socket os_bind os_connect os_listen os_accept os_shutdown 
 253  export os_setsockopt os_getsockopt os_getsockname os_getpeername 
 254  export os_sendto os_recvfrom 
 255   
 256   
 257  if os_api="win32" 
 258   
 259    type os_timeval 
 260      packed 
 261      field Int tv_sec tv_usec 
 262   
 263    function os_win32_select n readfds writefds exceptfds timeout -> fd 
 264      arg Int n ; arg Address readfds writefds exceptfds ; arg_rw os_timeval timeout ; arg Int fd 
 265      external os_socket_filename dll:"select" 
 266   
 267    export os_win32_select 
 268   
 269   
 270  function os_socket_wait s mode timeout -> status 
 271    arg Int s ; arg Int mode ; arg Float timeout ; arg Status status 
 272    if (constant os_api="linux" and (os_version parse (var Int r1) "." (var Int r2) "." any) and (r1>or r1=and r2>=2)) or os_api="posix" 
 273      var os_pollfd fd 
 274      fd fd := s 
 275      fd events := (shunt (mode .and. in)<>0 os_POLLIN 0)+(shunt (mode .and. out)<>0 os_POLLOUT 0)+os_POLLERR+os_POLLHUP 
 276      var Int count := os_poll addressof:fd 1 (cast timeout*1000 Int) 
 277      status := shunt count>=1 success failure 
 278    eif os_api="win32" 
 279      var Int none := 0 
 280      var (Array Int 2) fds ; fds 0 := 1 ; fds 1 := s 
 281      var os_timeval time 
 282      time tv_sec := cast timeout-0.5 Int 
 283      time tv_usec := cast (timeout-time:tv_sec)*1e6 Int 
 284      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 
 285      status := shunt count>=1 success failure 
 286    else 
 287      if s<or s>=1024 
 288        return success 
 289      var Address fds := memory_zallocate 1024\8 null 
 290      (fds translate Byte s\8) map uInt8 := 2^(s%8) 
 291      var Address none := memory_zallocate 1024\8 null 
 292      var os_timeval time 
 293      time tv_sec := cast timeout-0.5 Int 
 294      time tv_usec := cast (timeout-time:tv_sec)*1e6 Int 
 295      var Int count := os_select s+1 (shunt (mode .and. in)<>fds none) (shunt(mode .and. out)<>fds none) fds time 
 296      memory_free fds 
 297      memory_free none 
 298      status := shunt count>=1 success failure 
 299   
 300  export os_socket_wait 
 301   
 302   
 303  public 
 304   
 305    if os_api="linux" 
 306      constant os_SOL_SOCKET 1 
 307      constant os_SO_REUSEADDR 2 
 308      constant os_SO_KEEPALIVE 9 
 309    eif os_api="posix" 
 310      os_constant os_SOL_SOCKET "sys/socket.h" SOL_SOCKET 
 311      os_constant os_SO_REUSEADDR "sys/socket.h" SO_REUSEADDR 
 312      os_constant os_SO_KEEPALIVE "sys/socket.h" SO_KEEPALIVE 
 313    eif os_api="win32" or os_api="os2" 
 314      constant os_SOL_SOCKET 0FFFFh 
 315      constant os_SO_REUSEADDR 4 
 316      constant os_SO_KEEPALIVE 8 
 317   
 318    if os_api="linux" 
 319      constant os_IPPROTO_IP 0 
 320      constant os_IP_TOS 1 
 321      constant os_IPTOS_LOWCOST 2 
 322      constant os_IPTOS_RELIABILITY 4 
 323      constant os_IPTOS_THROUGHPUT 8 
 324      constant os_IPTOS_LOWDELAY 16 
 325     
 326    if os_api="linux" or os_api="os2" 
 327      type os_hostent 
 328        packed 
 329        field Address h_name 
 330        field Address h_aliases 
 331        field Int h_addrtype 
 332        field Int h_length 
 333        field Address h_addr_list 
 334    eif os_api="posix" 
 335      os_type os_hostent "netdb.h" hostent 
 336        field Address h_name 
 337        field Address h_aliases 
 338        field Int h_addrtype 
 339        field Int h_length 
 340        field Address h_addr_list 
 341    eif os_api="win32" 
 342      type os_hostent 
 343        packed 
 344        field Address h_name 
 345        field Address h_aliases 
 346        field Int16 h_addrtype 
 347        field Int16 h_length 
 348        field Address h_addr_list 
 349   
 350   
 351  if uselibcfornames 
 352   
 353    function os_gethostbyname name -> h 
 354      arg CStr name ; arg_R os_hostent h 
 355      external os_socket_filename2 dll:"gethostbyname" 
 356   
 357    function os_gethostbyaddr addr addrlen type -> h 
 358      arg Address addr ; arg Int addrlen type ; arg_R os_hostent h 
 359      external os_socket_filename2 dll:"gethostbyaddr" 
 360   
 361    export os_gethostbyname os_gethostbyaddr 
 362   
 363   
 364  if os_api="win32" 
 365   
 366    type os_WSADATA 
 367      field Int wVersion 
 368      field Int wHighVersion 
 369      field (Array Char 257) szDescription 
 370      field (Array Char 129) szSystemStatus 
 371      field uInt16 iMaxSockets 
 372      field uInt16 iMaxUdpDg 
 373      field Address lpVendorInfo 
 374   
 375    function os_WSAStartup version data -> err 
 376      arg Int version ; arg_w os_WSADATA data ; arg Int err 
 377      external os_socket_filename "WSAStartup" 
 378   
 379    function socket_init parameter filehandle 
 380      arg Address parameter ; arg Int filehandle 
 381      os_WSAStartup 0002h (var os_WSADATA data) 
 382    socket_init null 0 
 383    gvar DelayedAction da 
 384    da function :> the_function socket_init Address Int 
 385    pliant_restore_actions append addressof:da 
 386   
 387    function os_close s -> err 
 388      arg Int s err 
 389      external os_socket_filename "closesocket" 
 390   
 391    export os_close 
 392   
 393  eif os_api="os2" 
 394   
 395    function os_close s -> err 
 396      arg Int s err 
 397      external os_socket_filename dll:"soclose" 
 398   
 399    export os_close 
 400   
 401   
 402 
 
 403   
 404   
 405  function dns_query_prototype name fun -> ip 
 406    arg Str name ip ; arg Function fun 
 407    indirect 
 408   
 409  function dns_query_os name -> ip 
 410    arg Str name ip 
 411    ip := "" 
 412    if uselibcfornames 
 413      var Pointer:os_hostent host :> os_gethostbyname name 
 414      if addressof:host=null 
 415        return 
 416      var Address h_addr := host:h_addr_list map Address 
 417      for (var Int i) 0 3 
 418        ip += (shunt i="" ".")+string:(cast ((h_addr translate uInt8 i) map uInt8) Int) 
 419   
 420  gvar Link:Function dns_query_function :> the_function dns_query_os Str -> Str 
 421   
 422  export dns_query_prototype dns_query_function dns_query_os 
 423   
 424