Clean up buffers and re-add stream-read-until on binary streams

extra/io/buffers/buffers-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax byte-arrays alien ;
+USING: help.markup help.syntax byte-arrays alien destructors ;
 IN: io.buffers
 
 ARTICLE: "buffers" "Locked I/O buffers"
@@ -7,8 +7,8 @@ $nl
 "Buffer words are found in the " { $vocab-link "buffers" } " vocabulary."
 { $subsection buffer }
 { $subsection <buffer> }
-"Buffers must be manually deallocated:"
+"Buffers must be manually deallocated by calling " { $link dispose } "."
-{ $subsection buffer-free }
+$nl
 "Buffer operations:"
 { $subsection buffer-reset }
 { $subsection buffer-length }
@@ -40,11 +40,6 @@ HELP: <buffer>
 { $values { "n" "a non-negative integer" } { "buffer" buffer } }
 { $description "Creates a buffer with an initial capacity of " { $snippet "n" } " bytes." } ;
 
-HELP: buffer-free
-{ $values { "buffer" buffer } }
-{ $description "De-allocates a buffer's underlying storage. The buffer may not be used after being freed." }
-{ $warning "You " { $emphasis "must" } " free a buffer using this word, before letting the GC collect the buffer tuple instance." } ;
-
 HELP: buffer-reset
 { $values { "n" "a non-negative integer" } { "buffer" buffer } }
 { $description "Resets the fill pointer to 0 and the position to " { $snippet "count" } "." } ;
@@ -61,10 +56,6 @@ HELP: buffer-end
 { $values { "buffer" buffer } { "alien" alien } }
 { $description "Outputs the memory address of the current fill-pointer." } ;
 
-HELP: (buffer-read)
-{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } }
-{ $description "Outputs a byte array of the first " { $snippet "n" } " bytes at the buffer's current position. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } ;
-
 HELP: buffer-read
 { $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } }
 { $description "Collects a byte array of " { $snippet "n" } " bytes starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } ;

extra/io/buffers/buffers-tests.factor

@@ -1,6 +1,7 @@
 IN: io.buffers.tests
 USING: alien alien.c-types io.buffers kernel kernel.private libc
-sequences tools.test namespaces byte-arrays strings accessors ;
+sequences tools.test namespaces byte-arrays strings accessors
+destructors ;
 
 : buffer-set ( string buffer -- )
     over >byte-array over buffer-ptr byte-array>memory
@@ -18,7 +19,7 @@ sequences tools.test namespaces byte-arrays strings accessors ;
     65536 <buffer>
     dup buffer-read-all
     over buffer-capacity
-    rot buffer-free
+    rot dispose
 ] unit-test
 
 [ "hello world" "" ] [
@@ -26,34 +27,34 @@ sequences tools.test namespaces byte-arrays strings accessors ;
     dup buffer-read-all >string
     0 pick buffer-reset
     over buffer-read-all >string
-    rot buffer-free
+    rot dispose
 ] unit-test
 
 [ "hello" ] [
     "hello world" string>buffer
-    5 over buffer-read >string swap buffer-free
+    5 over buffer-read >string swap dispose
 ] unit-test
 
 [ 11 ] [
     "hello world" string>buffer
-    [ buffer-length ] keep buffer-free
+    [ buffer-length ] keep dispose
 ] unit-test
 
 [ "hello world" ] [
     "hello" 1024 <buffer> [ buffer-set ] keep
     " world" >byte-array over >buffer
-    dup buffer-read-all >string swap buffer-free
+    dup buffer-read-all >string swap dispose
 ] unit-test
 
 [ CHAR: e ] [
     "hello" string>buffer
-    1 over buffer-consume [ buffer-pop ] keep buffer-free
+    1 over buffer-consume [ buffer-pop ] keep dispose
 ] unit-test
 
 "hello world" string>buffer "b" set
 [ "hello world" ] [ 1000 "b" get buffer-read >string ] unit-test
-"b" get buffer-free
+"b" get dispose
 
 100 <buffer> "b" set
 [ 1000 "b" get n>buffer >string ] must-fail
-"b" get buffer-free
+"b" get dispose

extra/io/buffers/buffers.factor

@@ -1,77 +1,100 @@
 ! Copyright (C) 2004, 2005 Mackenzie Straight.
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors alien.c-types alien.syntax kernel
+USING: accessors alien alien.accessors alien.c-types
-kernel.private libc math sequences byte-arrays strings hints
+alien.syntax kernel libc math sequences byte-arrays strings
-accessors math.order ;
+hints accessors math.order destructors combinators ;
 IN: io.buffers
 
-TUPLE: buffer size ptr fill pos ;
+TUPLE: buffer size ptr fill pos disposed ;
 
 : <buffer> ( n -- buffer )
-    dup malloc 0 0 buffer boa ;
+    dup malloc 0 0 f buffer boa ;
 
-: buffer-free ( buffer -- )
+M: buffer dispose* ptr>> free ;
-    dup buffer-ptr free  f swap set-buffer-ptr ;
 
 : buffer-reset ( n buffer -- )
-    0 swap { set-buffer-fill set-buffer-pos } set-slots ;
+    swap >>fill 0 >>pos drop ;
-
-: buffer-consume ( n buffer -- )
-    [ buffer-pos + ] keep
-    [ buffer-fill min ] keep
-    [ set-buffer-pos ] keep
-    dup buffer-pos over buffer-fill >= [
-        0 over set-buffer-pos
-        0 over set-buffer-fill
-    ] when drop ;
-
-: buffer@ ( buffer -- alien )
-    dup buffer-pos swap buffer-ptr <displaced-alien> ;
-
-: buffer-end ( buffer -- alien )
-    dup buffer-fill swap buffer-ptr <displaced-alien> ;
-
-: buffer-peek ( buffer -- byte )
-    buffer@ 0 alien-unsigned-1 ;
-
-: buffer-pop ( buffer -- byte )
-    dup buffer-peek 1 rot buffer-consume ;
-
-: (buffer-read) ( n buffer -- byte-array )
-    [ [ fill>> ] [ pos>> ] bi - min ] keep
-    buffer@ swap memory>byte-array ;
-
-: buffer-read ( n buffer -- byte-array )
-    [ (buffer-read) ] [ buffer-consume ] 2bi ;
-
-: buffer-length ( buffer -- n )
-    [ fill>> ] [ pos>> ] bi - ;
 
 : buffer-capacity ( buffer -- n )
-    [ size>> ] [ fill>> ] bi - ;
+    [ size>> ] [ fill>> ] bi - ; inline
 
 : buffer-empty? ( buffer -- ? )
     fill>> zero? ;
 
+: buffer-consume ( n buffer -- )
+    [ + ] change-pos
+    dup [ pos>> ] [ fill>> ] bi <
+    [ 0 >>pos 0 >>fill ] unless drop ; inline
+
+: buffer-peek ( buffer -- byte )
+    [ ptr>> ] [ pos>> ] bi alien-unsigned-1 ; inline
+
+: buffer-pop ( buffer -- byte )
+    [ buffer-peek ] [ 1 swap buffer-consume ] bi ;
+
+HINTS: buffer-pop buffer ;
+
+: buffer-length ( buffer -- n )
+    [ fill>> ] [ pos>> ] bi - ; inline
+
+: buffer@ ( buffer -- alien )
+    [ pos>> ] [ ptr>> ] bi <displaced-alien> ;
+
+: buffer-read ( n buffer -- byte-array )
+    [ buffer-length min ] keep
+    [ buffer@ ] [ buffer-consume ] 2bi
+    swap memory>byte-array ;
+
+HINTS: buffer-read fixnum buffer ;
+
 : extend-buffer ( n buffer -- )
-    2dup buffer-ptr swap realloc
+    2dup ptr>> swap realloc >>ptr swap >>size drop ;
-    over set-buffer-ptr set-buffer-size ;
+    inline
 
 : check-overflow ( n buffer -- )
     2dup buffer-capacity > [ extend-buffer ] [ 2drop ] if ;
+    inline
 
-: >buffer ( byte-array buffer -- )
+: buffer-end ( buffer -- alien )
-    over length over check-overflow
+    [ fill>> ] [ ptr>> ] bi <displaced-alien> ; inline
-    [ buffer-end byte-array>memory ] 2keep
-    [ buffer-fill swap length + ] keep set-buffer-fill ;
-
-: byte>buffer ( byte buffer -- )
-    1 over check-overflow
-    [ buffer-end 0 set-alien-unsigned-1 ] keep
-    [ 1+ ] change-fill drop ;
 
 : n>buffer ( n buffer -- )
-    [ buffer-fill + ] keep 
+    [ + ] change-fill
-    [ buffer-size > [ "Buffer overflow" throw ] when ] 2keep
+    [ fill>> ] [ size>> ] bi >
-    set-buffer-fill ;
+    [ "Buffer overflow" throw ] when ; inline
+
+: >buffer ( byte-array buffer -- )
+    [ [ length ] dip check-overflow ]
+    [ buffer-end byte-array>memory ]
+    [ [ length ] dip n>buffer ]
+    2tri ;
+
+HINTS: >buffer byte-array buffer ;
+
+: byte>buffer ( byte buffer -- )
+    [ 1 swap check-overflow ]
+    [ [ ptr>> ] [ fill>> ] bi set-alien-unsigned-1 ]
+    [ 1 swap n>buffer ]
+    tri ;
+
+HINTS: byte>buffer fixnum buffer ;
+
+: search-buffer-until ( pos fill ptr separators -- n )
+    [ [ swap alien-unsigned-1 ] dip memq? ] 2curry find-from drop ;
+
+: finish-buffer-until ( buffer n -- byte-array separator )
+    [
+        over pos>> -
+        over buffer-read
+        swap buffer-pop
+    ] [
+        buffer>> f
+    ] if* ;
+
+: buffer-until ( separators buffer -- byte-array separator )
+    swap [ { [ ] [ pos>> ] [ fill>> ] [ ptr>> ] } cleave ] dip
+    search-buffer-until
+    finish-buffer-until ;
+
+HINTS: buffer-until { string buffer } ;

extra/io/ports/ports.factor

@@ -71,6 +71,28 @@ M: input-port stream-read
         ] [ 2nip ] if
     ] [ 2nip ] if ;
 
+: read-until-step ( separators port -- string/f separator/f )
+    dup wait-to-read [ 2drop f f ] [ buffer>> buffer-until ] if ;
+
+: read-until-loop ( seps port buf -- separator/f )
+    2over read-until-step over [
+        >r over push-all r> dup [
+            >r 3drop r>
+        ] [
+            drop read-until-loop
+        ] if
+    ] [
+        >r 2drop 2drop r>
+    ] if ;
+
+M: input-port stream-read-until ( seps port -- str/f sep/f )
+    2dup read-until-step dup [ >r 2nip r> ] [
+        over [
+            drop
+            BV{ } like [ read-until-loop ] keep B{ } like swap
+        ] [ >r 2nip r> ] if
+    ] if ;
+
 TUPLE: output-port < buffered-port ;
 
 : <output-port> ( handle -- output-port )
@@ -121,7 +143,7 @@ M: output-port dispose*
 
 M: buffered-port dispose*
     [ call-next-method ]
-    [ [ [ buffer-free ] when* f ] change-buffer drop ]
+    [ [ [ dispose ] when* f ] change-buffer drop ]
     bi ;
 
 M: port cancel-operation handle>> cancel-operation ;