library/platform/native/stream.factor

   1 ! :folding=indent:collapseFolds=1:
   2
   3 ! $Id$
   4 !
   5 ! Copyright (C) 2004 Slava Pestov.
   6 !
   7 ! Redistribution and use in source and binary forms, with or without
   8 ! modification, are permitted provided that the following conditions are met:
   9 !
  10 ! 1. Redistributions of source code must retain the above copyright notice,
  11 !    this list of conditions and the following disclaimer.
  12 !
  13 ! 2. Redistributions in binary form must reproduce the above copyright notice,
  14 !    this list of conditions and the following disclaimer in the documentation
  15 !    and/or other materials provided with the distribution.
  16 !
  17 ! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
  18 ! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
  19 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  20 ! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  21 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  22 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
  23 ! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  24 ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  25 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  26 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27
  28 IN: streams
  29 USE: combinators
  30 USE: continuations
  31 USE: io-internals
  32 USE: errors
  33 USE: kernel
  34 USE: logic
  35 USE: stack
  36 USE: stdio
  37 USE: strings
  38 USE: namespaces
  39
  40 : <fd-stream> ( in out -- stream )
  41     #! Create a file descriptor stream object, wrapping a pair
  42     #! of file descriptor handles for input and output.
  43     <stream> [
  44         "out" set
  45         "in" set
  46
  47         ( str -- )
  48         [ "out" get blocking-write ] "fwrite" set
  49
  50         ( -- str )
  51         [ "in" get dup [ blocking-read-line ] when ] "freadln" set
  52
  53         ( -- )
  54         [ "out" get [ flush-fd ] when* ] "fflush" set
  55
  56         ( -- )
  57         [
  58             "out" get [ dup flush-fd close-fd ] when*
  59             "in" get [ close-fd ] when*
  60         ] "fclose" set
  61     ] extend ;
  62
  63 : <filecr> ( path -- stream )
  64     t f open-file f <fd-stream> ;
  65
  66 : <filecw> ( path -- stream )
  67     f t open-file f swap <fd-stream> ;
  68
  69 : <filebr> ( path -- stream )
  70     <filecr> ;
  71
  72 : <filebw> ( path -- stream )
  73     <filecw> ;
  74
  75 : <server> ( port -- stream )
  76     #! Starts listening on localhost:port. Returns a stream that
  77     #! you can close with fclose, and accept connections from
  78     #! with accept. No other stream operations are supported.
  79     server-socket <stream> [
  80         "socket" set
  81
  82         ( -- )
  83         [ "socket" get close-fd ] "fclose" set
  84     ] extend ;
  85
  86 : <client-stream> ( host port socket -- stream )
  87     dup <fd-stream> [ "port" set "client" set ] extend ;
  88
  89 : accept ( server -- client )
  90     #! Accept a connection from a server socket.
  91     "socket" swap get* blocking-accept <client-stream> ;
  92
  93 : init-stdio ( -- )
  94     stdin stdout <fd-stream> <stdio-stream> "stdio" set ;
  95
  96 : exists? ( file -- ? )
  97     #! This is terrible.
  98     [ <filebr> fclose t ] [ nip not ] catch ;