Merge branch 'master' of git://factorcode.org/git/factor into unicode

core/bootstrap/primitives.factor

@@ -78,6 +78,7 @@ call
     "strings"
     "strings.private"
     "system"
+    "system.private"
     "threads.private"
     "tools.profiler.private"
     "tuples"
@@ -274,7 +275,7 @@ define-builtin
     }
     {
         { "object" "kernel" }
-        "?"
+        "compiled?"
         { "compiled?" "words" }
         f
     }
@@ -623,6 +624,7 @@ builtins get num-tags get tail f union-class define-class
     { "fopen" "io.streams.c" }
     { "fgetc" "io.streams.c" }
     { "fread" "io.streams.c" }
+    { "fputc" "io.streams.c" }
     { "fwrite" "io.streams.c" }
     { "fflush" "io.streams.c" }
     { "fclose" "io.streams.c" }
@@ -645,7 +647,8 @@ builtins get num-tags get tail f union-class define-class
     { "innermost-frame-scan" "kernel.private" }
     { "set-innermost-frame-quot" "kernel.private" }
     { "call-clear" "kernel" }
-    { "(os-envs)" "system" }
+    { "(os-envs)" "system.private" }
+    { "(set-os-envs)" "system.private" }
     { "resize-byte-array" "byte-arrays" }
     { "resize-bit-array" "bit-arrays" }
     { "resize-float-array" "float-arrays" }

core/hashtables/hashtables.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private slots.private math assocs
-math.private sequences sequences.private vectors ;
+       math.private sequences sequences.private vectors ;
 IN: hashtables
 
 <PRIVATE
@@ -16,15 +16,16 @@ IN: hashtables
     2 fixnum+fast over wrap ; inline
 
 : (key@) ( key keys i -- array n ? )
-    3dup swap array-nth dup ((tombstone)) eq? [
+    3dup swap array-nth
-        2drop probe (key@)
+    dup ((empty)) eq?
-    ] [
+      [ 3drop nip f f ]
-        dup ((empty)) eq? [
+      [
-            3drop nip f f
+        =
-        ] [
+          [ rot drop t ]
-            = [ rot drop t ] [ probe (key@) ] if
+          [ probe (key@) ]
-        ] if
+        if
-    ] if ; inline
+      ]
+    if ; inline
 
 : key@ ( key hash -- array n ? )
     hash-array 2dup hash@ (key@) ; inline

core/inference/known-words/known-words.factor

@@ -10,7 +10,8 @@ namespaces.private parser prettyprint quotations
 quotations.private sbufs sbufs.private sequences
 sequences.private slots.private strings strings.private system
 threads.private tuples tuples.private vectors vectors.private
-words words.private assocs inspector compiler.units ;
+words words.private assocs inspector compiler.units
+system.private ;
 IN: inference.known-words
 
 ! Shuffle words
@@ -538,6 +539,8 @@ set-primitive-effect
 
 \ fwrite { string alien } { } <effect> set-primitive-effect
 
+\ fputc { object alien } { } <effect> set-primitive-effect
+
 \ fread { integer string } { object } <effect> set-primitive-effect
 
 \ fflush { alien } { } <effect> set-primitive-effect
@@ -595,6 +598,8 @@ set-primitive-effect
 
 \ (os-envs) { } { array } <effect> set-primitive-effect
 
+\ (set-os-envs) { array } { } <effect> set-primitive-effect
+
 \ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
 
 \ dll-valid? { object } { object } <effect> set-primitive-effect

core/io/binary/binary.factor

@@ -10,7 +10,7 @@ IN: io.binary
 
 : nth-byte ( x n -- b ) -8 * shift mask-byte ; inline
 
-: >le ( x n -- str ) [ nth-byte ] with "" map-as ;
+: >le ( x n -- str ) [ nth-byte ] with B{ } map-as ;
 : >be ( x n -- str ) >le dup reverse-here ;
 
 : d>w/w ( d -- w1 w2 )

core/io/files/files-docs.factor

@@ -89,7 +89,6 @@ ARTICLE: "io.files" "Basic file operations"
 { $subsection "fs-meta" }
 { $subsection "directories" }
 { $subsection "delete-move-copy" }
-{ $subsection "unique" }
 { $see-also "os" } ;
 
 ABOUT: "io.files"

core/io/files/files.factor

@@ -71,6 +71,7 @@ TUPLE: no-parent-directory path ;
 TUPLE: file-info type size permissions modified ;
 
 HOOK: file-info io-backend ( path -- info )
+HOOK: link-info io-backend ( path -- info )
 
 SYMBOL: +regular-file+
 SYMBOL: +directory+

core/io/io-tests.factor

@@ -1,5 +1,6 @@
 USING: arrays io io.files kernel math parser strings system
-tools.test words namespaces io.encodings.ascii io.encodings.binary ;
+tools.test words namespaces io.encodings.latin1
+io.encodings.binary ;
 IN: io.tests
 
 [ f ] [
@@ -8,7 +9,7 @@ IN: io.tests
 ] unit-test
 
 : <resource-reader> ( resource -- stream )
-    resource-path binary <file-reader> ;
+    resource-path latin1 <file-reader> ;
 
 [
     "This is a line.\rThis is another line.\r"
@@ -31,10 +32,10 @@ IN: io.tests
 
 ! [ ] [ "123" write 9000 CHAR: x <string> write flush ] unit-test
 
-[ "" ] [
+[
     "/core/io/test/binary.txt" <resource-reader>
     [ 0.2 read ] with-stream
-] unit-test
+] must-fail
 
 [
     {

core/io/streams/c/c-tests.factor

@@ -1,4 +1,5 @@
-USING: tools.test io.files io io.streams.c io.encodings.ascii ;
+USING: tools.test io.files io io.streams.c
+io.encodings.ascii strings ;
 IN: io.streams.c.tests
 
 [ "hello world" ] [
@@ -7,4 +8,5 @@ IN: io.streams.c.tests
     ] with-file-writer
 
     "test.txt" temp-file "rb" fopen <c-reader> contents
+    >string
 ] unit-test

core/io/streams/c/c.factor

@@ -1,9 +1,8 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel kernel.private namespaces io io.encodings
-strings sequences math generic threads.private classes
+sequences math generic threads.private classes io.backend
-io.backend io.streams.duplex io.files continuations
+io.streams.duplex io.files continuations byte-arrays ;
-io.encodings.utf8 ;
 IN: io.streams.c
 
 TUPLE: c-writer handle ;
@@ -11,10 +10,10 @@ TUPLE: c-writer handle ;
 C: <c-writer> c-writer
 
 M: c-writer stream-write1
-    >r 1string r> stream-write ;
+    c-writer-handle fputc ;
 
 M: c-writer stream-write
-    >r >string r> c-writer-handle fwrite ;
+    c-writer-handle fwrite ;
 
 M: c-writer stream-flush
     c-writer-handle fflush ;
@@ -27,7 +26,7 @@ TUPLE: c-reader handle ;
 C: <c-reader> c-reader
 
 M: c-reader stream-read
-    >r >fixnum r> c-reader-handle fread ;
+    c-reader-handle fread ;
 
 M: c-reader stream-read-partial
     stream-read ;
@@ -43,7 +42,7 @@ M: c-reader stream-read1
     ] if ;
 
 M: c-reader stream-read-until
-    [ swap read-until-loop ] "" make swap
+    [ swap read-until-loop ] B{ } make swap
     over empty? over not and [ 2drop f f ] when ;
 
 M: c-reader dispose
@@ -76,4 +75,6 @@ M: object (file-appender)
     #! print stuff from contexts where the I/O system would
     #! otherwise not work (tools.deploy.shaker, the I/O
     #! multiplexer thread).
-    "\r\n" append stdout-handle fwrite stdout-handle fflush ;
+    "\r\n" append >byte-array
+    stdout-handle fwrite
+    stdout-handle fflush ;

core/mirrors/mirrors-docs.factor

@@ -20,7 +20,7 @@ HELP: object-slots
 HELP: mirror
 { $class-description "An associative structure which wraps an object and presents itself as a mapping from slot names to the object's slot values. Mirrors are used to build reflective developer tools."
 $nl
-"Mirrors are mutable, however new keys cannot be inserted and keys cannot be deleted, only values of existing keys can be changed."
+"Mirrors are mutable, however new keys cannot be inserted, only values of existing keys can be changed. Deleting a key has the effect of setting its value to " { $link f } "."
 $nl
 "Mirrors are created by calling " { $link <mirror> } " or " { $link make-mirror } "." } ;
 
@@ -33,7 +33,7 @@ HELP: <mirror>
         "TUPLE: circle center radius ;"
         "C: <circle> circle"
         "{ 100 50 } 15 <circle> <mirror> >alist ."
-        "{ { circle-center { 100 50 } } { circle-radius 15 } }"
+        "{ { \"center\" { 100 50 } } { \"radius\" 15 } }"
     }
 } ;
 
@@ -47,5 +47,5 @@ $nl
 "Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ;
 
 HELP: make-mirror
-{ $values { "obj" object } { "assoc" "an assoc" } }
+{ $values { "obj" object } { "assoc" assoc } }
 { $description "Creates an assoc which reflects the internal structure of the object." } ;

core/mirrors/mirrors-tests.factor

@@ -5,12 +5,12 @@ TUPLE: foo bar baz ;
 
 C: <foo> foo
 
-[ { foo-bar foo-baz } ] [ 1 2 <foo> <mirror> keys ] unit-test
+[ { "bar" "baz" } ] [ 1 2 <foo> <mirror> keys ] unit-test
 
-[ 1 t ] [ \ foo-bar 1 2 <foo> <mirror> at* ] unit-test
+[ 1 t ] [ "bar" 1 2 <foo> <mirror> at* ] unit-test
 
 [ f f ] [ "hi" 1 2 <foo> <mirror> at* ] unit-test
 
 [ 3 ] [
-    3 \ foo-baz 1 2 <foo> [ <mirror> set-at ] keep foo-baz
+    3 "baz" 1 2 <foo> [ <mirror> set-at ] keep foo-baz
 ] unit-test

core/mirrors/mirrors.factor

@@ -21,12 +21,14 @@ TUPLE: mirror object slots ;
 : >mirror< ( mirror -- obj slots )
     dup mirror-object swap mirror-slots ;
 
+: mirror@ ( slot-name mirror -- obj slot-spec )
+    >mirror< swapd slot-named ;
+
 M: mirror at*
-    >mirror< swapd slot-of-reader
+    mirror@ dup [ slot-spec-offset slot t ] [ 2drop f f ] if ;
-    dup [ slot-spec-offset slot t ] [ 2drop f f ] if ;
 
 M: mirror set-at ( val key mirror -- )
-    >mirror< swapd slot-of-reader dup [
+    mirror@ dup [
         dup slot-spec-writer [
             slot-spec-offset set-slot
         ] [
@@ -42,7 +44,7 @@ M: mirror delete-at ( key mirror -- )
 M: mirror >alist ( mirror -- alist )
     >mirror<
     [ [ slot-spec-offset slot ] with map ] keep
-    [ slot-spec-reader ] map swap 2array flip ;
+    [ slot-spec-name ] map swap 2array flip ;
 
 M: mirror assoc-size mirror-slots length ;
 

core/slots/slots.factor

@@ -110,3 +110,6 @@ PREDICATE: word slot-writer "writing" word-prop >boolean ;
 
 : slot-of-writer ( writer specs -- spec/f )
     [ slot-spec-writer eq? ] with find nip ;
+
+: slot-named ( string specs -- spec/f )
+    [ slot-spec-name = ] with find nip ;

core/system/system-tests.factor

@@ -1,6 +1,17 @@
-USING: math tools.test system prettyprint ;
+USING: math tools.test system prettyprint namespaces kernel ;
 IN: system.tests
 
 [ t ] [ cell integer? ] unit-test
 [ t ] [ bootstrap-cell integer? ] unit-test
-[ ] [ os-envs . ] unit-test
+
+wince? [
+    [ ] [ os-envs . ] unit-test
+] unless
+
+unix? [
+    [ ] [ os-envs "envs" set ] unit-test
+    [ ] [ { { "A" "B" } } set-os-envs ] unit-test
+    [ "B" ] [ "A" os-env ] unit-test
+    [ ] [ "envs" get set-os-envs ] unit-test
+    [ t ] [ os-envs "envs" get = ] unit-test
+] when

core/system/system.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: system
 USING: kernel kernel.private sequences math namespaces
-splitting assocs ;
+splitting assocs system.private ;
 
 : cell ( -- n ) 7 getenv ; foldable
 
@@ -59,3 +59,6 @@ splitting assocs ;
 
 : os-envs ( -- assoc )
     (os-envs) [ "=" split1 ] H{ } map>assoc ;
+
+: set-os-envs ( assoc -- )
+    [ "=" swap 3append ] { } assoc>map (set-os-envs) ;

core/words/words-tests.factor

@@ -141,7 +141,11 @@ SYMBOL: quot-uses-b
 
 [ { + } ] [ \ quot-uses-b uses ] unit-test
 
-[ "IN: words.tests FORGET: undef-test : undef-test ; << undef-test >>" eval ]
+"undef-test" "words.tests" lookup [
+    [ forget ] with-compilation-unit
+] when*
+
+[ "IN: words.tests : undef-test ; << undef-test >>" eval ]
 [ [ undefined? ] is? ] must-fail-with
 
 [ ] [

extra/alarms/alarms.factor

@@ -85,5 +85,8 @@ PRIVATE>
 : later ( quot dt -- alarm )
     from-now f add-alarm ;
 
+: every ( quot dt -- alarm )
+    [ from-now ] keep add-alarm ;
+
 : cancel-alarm ( alarm -- )
     alarm-entry [ alarms get-global heap-delete ] if-box? ;

extra/builder/builder.factor

@@ -2,6 +2,7 @@
 USING: kernel namespaces sequences splitting system combinators continuations
        parser io io.files io.launcher io.sockets prettyprint threads
        bootstrap.image benchmark vars bake smtp builder.util accessors
+       io.encodings.utf8
        calendar
        builder.common
        builder.benchmark
@@ -35,20 +36,20 @@ IN: builder
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : git-id ( -- id )
-  { "git" "show" } <process-stream> [ readln ] with-stream " " split second ;
+  { "git" "show" } utf8 <process-stream>
+  [ readln ] with-stream " " split second ;
 
-: record-git-id ( -- ) git-id "../git-id" [ . ] with-file-writer ;
+: record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ;
 
-: do-make-clean ( -- desc ) { "make" "clean" } try-process ;
+: do-make-clean ( -- ) { "make" "clean" } try-process ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : make-vm ( -- desc )
-  <process*>
+  <process>
-    { "make" }       >>arguments
+    { "make" }       >>command
     "../compile-log" >>stdout
-    +stdout+         >>stderr
+    +stdout+         >>stderr ;
-  >desc ;
 
 : do-make-vm ( -- )
   make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ;
@@ -65,13 +66,12 @@ IN: builder
   { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
 
 : bootstrap ( -- desc )
-  <process*>
+  <process>
-    bootstrap-cmd >>arguments
+    bootstrap-cmd >>command
     +closed+      >>stdin
     "../boot-log" >>stdout
     +stdout+      >>stderr
-    20 minutes    >>timeout
+    20 minutes    >>timeout ;
-  >desc ;
 
 : do-bootstrap ( -- )
   bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ;
@@ -80,13 +80,12 @@ IN: builder
   { "./factor" "-run=builder.test" } to-strings ;
 
 : builder-test ( -- desc )
-  <process*>
+  <process>
-    builder-test-cmd >>arguments
+    builder-test-cmd >>command
     +closed+         >>stdin
     "../test-log"    >>stdout
     +stdout+         >>stderr
-    45 minutes       >>timeout
+    45 minutes       >>timeout ;
-  >desc ;
 
 : do-builder-test ( -- )
   builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;
@@ -103,7 +102,7 @@ SYMBOL: build-status
 
   enter-build-dir
 
-  "report"
+  "report" utf8
     [
       "Build machine:   " write host-name print
       "CPU:             " write cpu       print

extra/builder/release/release.factor

@@ -19,7 +19,7 @@ IN: builder.release
   {
     "boot.x86.32.image"
     "boot.x86.64.image"
-    "boot.macosx-ppc.boot"
+    "boot.macosx-ppc.image"
     "vm"
     "temp"
     "logs"

extra/builder/test/test.factor

@@ -6,22 +6,24 @@ USING: kernel namespaces sequences assocs builder continuations
        prettyprint
        tools.browser
        tools.test
+       io.encodings.utf8
        bootstrap.stage2 benchmark builder.util ;
 
 IN: builder.test
 
 : do-load ( -- )
-  try-everything keys "../load-everything-vocabs" [ . ] with-file-writer ;
+  try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ;
 
 : do-tests ( -- )
-  run-all-tests keys "../test-all-vocabs" [ . ] with-file-writer ;
+  run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ;
 
-: do-benchmarks ( -- ) run-benchmarks "../benchmarks" [ . ] with-file-writer ;
+: do-benchmarks ( -- )
+  run-benchmarks "../benchmarks" utf8 [ . ] with-file-writer ;
 
 : do-all ( -- )
-  bootstrap-time get   "../boot-time" [ . ] with-file-writer
+  bootstrap-time get   "../boot-time" utf8 [ . ] with-file-writer
-  [ do-load  ] runtime "../load-time" [ . ] with-file-writer
+  [ do-load  ] runtime "../load-time" utf8 [ . ] with-file-writer
-  [ do-tests ] runtime "../test-time" [ . ] with-file-writer
+  [ do-tests ] runtime "../test-time" utf8 [ . ] with-file-writer
   do-benchmarks ;
 
 MAIN: do-all

extra/builder/util/util.factor

@@ -4,6 +4,7 @@ USING: kernel words namespaces classes parser continuations
        math math.parser
        combinators sequences splitting quotations arrays strings tools.time
        sequences.deep new-slots accessors assocs.lib
+       io.encodings.utf8
        combinators.cleave bake calendar calendar.format ;
 
 IN: builder.util
@@ -14,7 +15,7 @@ IN: builder.util
 
 : minutes>ms ( min -- ms ) 60 * 1000 * ;
 
-: file>string ( file -- string ) [ stdio get contents ] with-file-reader ;
+: file>string ( file -- string ) utf8 [ stdio get contents ] with-file-reader ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -39,18 +40,18 @@ DEFER: to-strings
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-TUPLE: process* arguments stdin stdout stderr timeout ;
+! TUPLE: process* arguments stdin stdout stderr timeout ;
 
-: <process*> process* construct-empty ;
+! : <process*> process* construct-empty ;
 
-: >desc ( process* -- desc )
+! : >desc ( process* -- desc )
-  H{ } clone
+!   H{ } clone
-    over arguments>> [ +arguments+ swap put-at ] when*
+!     over arguments>> [ +arguments+ swap put-at ] when*
-    over stdin>>     [ +stdin+     swap put-at ] when*
+!     over stdin>>     [ +stdin+     swap put-at ] when*
-    over stdout>>    [ +stdout+    swap put-at ] when*
+!     over stdout>>    [ +stdout+    swap put-at ] when*
-    over stderr>>    [ +stderr+    swap put-at ] when*
+!     over stderr>>    [ +stderr+    swap put-at ] when*
-    over timeout>>   [ +timeout+   swap put-at ] when*
+!     over timeout>>   [ +timeout+   swap put-at ] when*
-  nip ;
+!   nip ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -69,9 +70,9 @@ TUPLE: process* arguments stdin stdout stderr timeout ;
 : milli-seconds>time ( n -- string )
   1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
 
-: eval-file ( file -- obj ) file-contents eval ;
+: eval-file ( file -- obj ) utf8 file-contents eval ;
 
-: cat ( file -- ) file-contents print ;
+: cat ( file -- ) utf8 file-contents print ;
 
 : run-or-bail ( desc quot -- )
   [ [ try-process ] curry   ]
@@ -96,7 +97,7 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ;
   if ;
 
 : cat-n ( file n -- )
-  [ file-lines ] [ ] bi*
+  [ utf8 file-lines ] [ ] bi*
   maybe-tail*
   [ print ] each ;
 
@@ -104,7 +105,7 @@ USING: bootstrap.image bootstrap.image.download io.streams.null ;
 
 USE: prettyprint
 
-: to-file ( object file -- ) [ . ] with-file-writer ;
+: to-file ( object file -- ) utf8 [ . ] with-file-writer ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/calendar/format/format.factor

@@ -36,8 +36,12 @@ M: timestamp year. ( timestamp -- )
 
 : pad-00 number>string 2 CHAR: 0 pad-left ;
 
+: pad-0000 number>string 4 CHAR: 0 pad-left ;
+
 : write-00 pad-00 write ;
 
+: write-0000 pad-0000 write ;
+
 : (timestamp>string) ( timestamp -- )
     dup day-of-week day-abbreviations3 nth write ", " write
     dup day>> number>string write bl
@@ -107,24 +111,68 @@ M: timestamp year. ( timestamp -- )
         60 / + *
     ] if ;
 
+: read-ymd ( -- y m d )
+    read-0000 "-" expect read-00 "-" expect read-00 ;
+
+: read-hms ( -- h m s )
+    read-00 ":" expect read-00 ":" expect read-00 ;
+
 : (rfc3339>timestamp) ( -- timestamp )
-    read-0000 ! year
+    read-ymd
-    "-" expect
-    read-00 ! month
-    "-" expect
-    read-00 ! day
     "Tt" expect
-    read-00 ! hour
+    read-hms
-    ":" expect
-    read-00 ! minute
-    ":" expect
-    read-00 ! second
     read-rfc3339-gmt-offset ! timezone
     <timestamp> ;
 
 : rfc3339>timestamp ( str -- timestamp )
     [ (rfc3339>timestamp) ] with-string-reader ;
 
+: (ymdhms>timestamp) ( -- timestamp )
+    read-ymd " " expect read-hms 0 <timestamp> ;
+
+: ymdhms>timestamp ( str -- timestamp )
+    [ (ymdhms>timestamp) ] with-string-reader ;
+
+: (hms>timestamp) ( -- timestamp )
+    f f f read-hms f <timestamp> ;
+
+: hms>timestamp ( str -- timestamp )
+    [ (hms>timestamp) ] with-string-reader ;
+
+: (ymd>timestamp) ( -- timestamp )
+    read-ymd f f f f <timestamp> ;
+
+: ymd>timestamp ( str -- timestamp )
+    [ (ymd>timestamp) ] with-string-reader ;
+
+: (timestamp>ymd) ( timestamp -- )
+    dup timestamp-year write-0000
+    "-" write
+    dup timestamp-month write-00
+    "-" write
+    timestamp-day write-00 ;
+
+: timestamp>ymd ( timestamp -- str )
+    [ (timestamp>ymd) ] with-string-writer ;
+
+: (timestamp>hms)
+    dup timestamp-hour write-00
+    ":" write
+    dup timestamp-minute write-00
+    ":" write
+    timestamp-second >integer write-00 ;
+
+: timestamp>hms ( timestamp -- str )
+    [ (timestamp>hms) ] with-string-writer ;
+
+: timestamp>ymdhms ( timestamp -- str )
+    >gmt
+    [
+        dup (timestamp>ymd)
+        " " write
+        (timestamp>hms)
+    ] with-string-writer ;
+
 : file-time-string ( timestamp -- string )
     [
         [ month>> month-abbreviations nth write ] keep bl

extra/db/db.factor

@@ -34,7 +34,7 @@ HOOK: db-close db ( handle -- )
 TUPLE: statement handle sql in-params out-params bind-params bound? ;
 TUPLE: simple-statement ;
 TUPLE: prepared-statement ;
-TUPLE: result-set sql params handle n max ;
+TUPLE: result-set sql in-params out-params handle n max ;
 : <statement> ( sql in out -- statement )
     { (>>sql) (>>in-params) (>>out-params) } statement construct ;
 
@@ -47,6 +47,7 @@ GENERIC: query-results ( query -- result-set )
 GENERIC: #rows ( result-set -- n )
 GENERIC: #columns ( result-set -- n )
 GENERIC# row-column 1 ( result-set n -- obj )
+GENERIC# row-column-typed 1 ( result-set n -- sql )
 GENERIC: advance-row ( result-set -- )
 GENERIC: more-rows? ( result-set -- ? )
 
@@ -67,13 +68,16 @@ GENERIC: more-rows? ( result-set -- ? )
     0 >>n drop ;
 
 : <result-set> ( query handle tuple -- result-set )
-    >r >r { sql>> in-params>> } get-slots r>
+    >r >r { sql>> in-params>> out-params>> } get-slots r>
-    { (>>sql) (>>params) (>>handle) } result-set
+    { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set
     construct r> construct-delegate ;
 
 : sql-row ( result-set -- seq )
     dup #columns [ row-column ] with map ;
 
+: sql-row-typed ( result-set -- seq )
+    dup #columns [ row-column-typed ] with map ;
+
 : query-each ( statement quot -- )
     over more-rows? [
         [ call ] 2keep over advance-row query-each

extra/db/sqlite/lib/lib.factor

@@ -2,7 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types arrays assocs kernel math math.parser
 namespaces sequences db.sqlite.ffi db combinators
-continuations db.types ;
+continuations db.types calendar.format serialize
+io.streams.string byte-arrays ;
+USE: tools.walker
 IN: db.sqlite.lib
 
 : sqlite-error ( n -- * )
@@ -55,6 +57,10 @@ IN: db.sqlite.lib
 : sqlite-bind-null ( handle i -- )
     sqlite3_bind_null sqlite-check-result ;
 
+: sqlite-bind-blob ( handle i byte-array -- )
+    dup length SQLITE_TRANSIENT
+    sqlite3_bind_blob sqlite-check-result ;
+
 : sqlite-bind-text-by-name ( handle name text -- )
     parameter-index sqlite-bind-text ;
 
@@ -67,20 +73,32 @@ IN: db.sqlite.lib
 : sqlite-bind-double-by-name ( handle name double -- )
     parameter-index sqlite-bind-double ;
 
+: sqlite-bind-blob-by-name ( handle name blob -- )
+    parameter-index sqlite-bind-blob ;
+
 : sqlite-bind-null-by-name ( handle name obj -- )
     parameter-index drop sqlite-bind-null ;
 
 : sqlite-bind-type ( handle key value type -- )
+    over [ drop NULL ] unless
     dup array? [ first ] when
     {
         { INTEGER [ sqlite-bind-int-by-name ] }
-        { BIG_INTEGER [ sqlite-bind-int64-by-name ] }
+        { BIG-INTEGER [ sqlite-bind-int64-by-name ] }
         { TEXT [ sqlite-bind-text-by-name ] }
         { VARCHAR [ sqlite-bind-text-by-name ] }
         { DOUBLE [ sqlite-bind-double-by-name ] }
-        { TIMESTAMP [ sqlite-bind-double-by-name ] }
+        { DATE [ sqlite-bind-text-by-name ] }
+        { TIME [ sqlite-bind-text-by-name ] }
+        { DATETIME [ sqlite-bind-text-by-name ] }
+        { TIMESTAMP [ sqlite-bind-text-by-name ] }
+        { BLOB [ sqlite-bind-blob-by-name ] }
+        { FACTOR-BLOB [
+            [ serialize ] with-string-writer >byte-array
+            sqlite-bind-blob-by-name
+        ] }
         { +native-id+ [ sqlite-bind-int-by-name ] }
-        ! { NULL [ sqlite-bind-null-by-name ] }
+        { NULL [ sqlite-bind-null-by-name ] }
         [ no-sql-type ]
     } case ;
 
@@ -93,21 +111,38 @@ IN: db.sqlite.lib
 : sqlite-#columns ( query -- int )
     sqlite3_column_count ;
 
-! TODO
 : sqlite-column ( handle index -- string )
     sqlite3_column_text ;
 
+: sqlite-column-blob ( handle index -- byte-array/f )
+    [ sqlite3_column_bytes ] 2keep
+    pick zero? [
+        3drop f
+    ] [
+        sqlite3_column_blob swap memory>byte-array
+    ] if ;
+
 : sqlite-column-typed ( handle index type -- obj )
+    dup array? [ first ] when
     {
+        { +native-id+ [ sqlite3_column_int64 ] }
         { INTEGER [ sqlite3_column_int ] }
-        { BIG_INTEGER [ sqlite3_column_int64 ] }
+        { BIG-INTEGER [ sqlite3_column_int64 ] }
         { TEXT [ sqlite3_column_text ] }
+        { VARCHAR [ sqlite3_column_text ] }
         { DOUBLE [ sqlite3_column_double ] }
-        { TIMESTAMP [ sqlite3_column_double ] }
+        { DATE [ sqlite3_column_text dup [ ymd>timestamp ] when ] }
+        { TIME [ sqlite3_column_text dup [ hms>timestamp ] when ] }
+        { TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
+        { DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
+        { BLOB [ sqlite-column-blob ] }
+        { FACTOR-BLOB [
+            sqlite-column-blob [ deserialize ] with-string-reader
+        ] }
+        ! { NULL [ 2drop f ] }
         [ no-sql-type ]
     } case ;
 
-! TODO
 : sqlite-row ( handle -- seq )
     dup sqlite-#columns [ sqlite-column ] with map ;
 

extra/db/sqlite/sqlite-tests.factor

@@ -3,7 +3,7 @@ prettyprint tools.test db.sqlite db sequences
 continuations db.types db.tuples unicode.case ;
 IN: db.sqlite.tests
 
-: db-path "extra/db/sqlite/test.db" resource-path ;
+: db-path "test.db" temp-file ;
 : test.db db-path sqlite-db ;
 
 [ ] [ [ db-path delete-file ] ignore-errors ] unit-test

extra/db/sqlite/sqlite.factor

@@ -5,7 +5,7 @@ hashtables io.files kernel math math.parser namespaces
 prettyprint sequences strings tuples alien.c-types
 continuations db.sqlite.lib db.sqlite.ffi db.tuples
 words combinators.lib db.types combinators tools.walker
-combinators.cleave io ;
+combinators.cleave io namespaces.lib ;
 IN: db.sqlite
 
 TUPLE: sqlite-db path ;
@@ -80,8 +80,9 @@ M: sqlite-result-set #columns ( result-set -- n )
 M: sqlite-result-set row-column ( result-set n -- obj )
     >r result-set-handle r> sqlite-column ;
 
-M: sqlite-result-set row-column-typed ( result-set n type -- obj )
+M: sqlite-result-set row-column-typed ( result-set n -- obj )
-    >r result-set-handle r> sqlite-column-typed ;
+    dup pick result-set-out-params nth sql-spec-type
+    >r >r result-set-handle r> r> sqlite-column-typed ;
 
 M: sqlite-result-set advance-row ( result-set -- )
     [ result-set-handle sqlite-next ] keep
@@ -141,6 +142,10 @@ M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
     " where " 0%
     find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ;
 
+: where-clause ( specs -- )
+    " where " 0%
+    [ " and " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ;
+
 M: sqlite-db <update-tuple-statement> ( class -- statement )
     [
         "update " 0%
@@ -173,14 +178,7 @@ M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
 
         " from " 0% 0%
         [ sql-spec-slot-name swap get-slot-named ] with subset
-        dup empty? [
+        dup empty? [ drop ] [ where-clause ] if ";" 0%
-            drop
-        ] [
-            " where " 0%
-            [ ", " 0% ]
-            [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
-        ] if
-        ";" 0%
     ] sqlite-make ;
 
 M: sqlite-db modifier-table ( -- hashtable )
@@ -209,8 +207,13 @@ M: sqlite-db type-table ( -- assoc )
         { INTEGER "integer" }
         { TEXT "text" }
         { VARCHAR "text" }
+        { DATE "date" }
+        { TIME "time" }
+        { DATETIME "datetime" }
         { TIMESTAMP "timestamp" }
         { DOUBLE "real" }
+        { BLOB "blob" }
+        { FACTOR-BLOB "blob" }
     } ;
 
 M: sqlite-db create-type-table

extra/db/tuples/tuples-tests.factor

@@ -1,40 +1,47 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.files kernel tools.test db db.tuples
-db.types continuations namespaces db.postgresql math
+db.types continuations namespaces math
-prettyprint tools.walker db.sqlite ;
+prettyprint tools.walker db.sqlite calendar
+math.intervals ;
 IN: db.tuples.tests
 
-TUPLE: person the-id the-name the-number the-real ;
+TUPLE: person the-id the-name the-number the-real ts date time blob ;
-: <person> ( name age real -- person )
+: <person> ( name age real ts date time blob -- person )
     {
         set-person-the-name
         set-person-the-number
         set-person-the-real
+        set-person-ts
+        set-person-date
+        set-person-time
+        set-person-blob
     } person construct ;
 
-: <assigned-person> ( id name number the-real -- obj )
+: <assigned-person> ( id name age real ts date time blob -- person )
     <person> [ set-person-the-id ] keep ;
 
-SYMBOL: the-person1
+SYMBOL: person1
-SYMBOL: the-person2
+SYMBOL: person2
+SYMBOL: person3
+SYMBOL: person4
 
 : test-tuples ( -- )
     [ person drop-table ] [ drop ] recover
     [ ] [ person create-table ] unit-test
     [ person create-table ] must-fail
     
-    [ ] [ the-person1 get insert-tuple ] unit-test
+    [ ] [ person1 get insert-tuple ] unit-test
 
-    [ 1 ] [ the-person1 get person-the-id ] unit-test
+    [ 1 ] [ person1 get person-the-id ] unit-test
 
-    200 the-person1 get set-person-the-number
+    200 person1 get set-person-the-number
 
-    [ ] [ the-person1 get update-tuple ] unit-test
+    [ ] [ person1 get update-tuple ] unit-test
 
     [ T{ person f 1 "billy" 200 3.14 } ]
     [ T{ person f 1 } select-tuple ] unit-test
-    [ ] [ the-person2 get insert-tuple ] unit-test
+    [ ] [ person2 get insert-tuple ] unit-test
     [
         {
             T{ person f 1 "billy" 200 3.14 }
@@ -48,9 +55,33 @@ SYMBOL: the-person2
         }
     ] [ T{ person f } select-tuples ] unit-test
 
+    [
+        {
+            T{ person f 2 "johnny" 10 3.14 }
+        }
+    ] [ T{ person f f f 10 3.14 } select-tuples ] unit-test
 
-    [ ] [ the-person1 get delete-tuple ] unit-test
+
+    [ ] [ person1 get delete-tuple ] unit-test
     [ f ] [ T{ person f 1 } select-tuple ] unit-test
+
+    [ ] [ person3 get insert-tuple ] unit-test
+
+    [
+        T{
+            person
+            f
+            3
+            "teddy"
+            10
+            3.14
+            T{ timestamp f 2008 3 5 16 24 11 0 }
+            T{ timestamp f 2008 11 22 f f f f }
+            T{ timestamp f f f f 12 34 56 f }
+            B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
+        }
+    ] [ T{ person f 3 } select-tuple ] unit-test
+
     [ ] [ person drop-table ] unit-test ;
 
 : make-native-person-table ( -- )
@@ -67,9 +98,14 @@ SYMBOL: the-person2
         { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
         { "the-number" "AGE" INTEGER { +default+ 0 } }
         { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
+        { "ts" "TS" TIMESTAMP }
+        { "date" "D" DATE }
+        { "time" "T" TIME }
+        { "blob" "B" BLOB }
     } define-persistent
-    "billy" 10 3.14 <person> the-person1 set
+    "billy" 10 3.14 f f f f <person> person1 set
-    "johnny" 10 3.14 <person> the-person2 set ;
+    "johnny" 10 3.14 f f f f <person> person2 set
+    "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } <person> person3 set ;
 
 : assigned-person-schema ( -- )
     person "PERSON"
@@ -78,10 +114,14 @@ SYMBOL: the-person2
         { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
         { "the-number" "AGE" INTEGER { +default+ 0 } }
         { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
+        { "ts" "TS" TIMESTAMP }
+        { "date" "D" DATE }
+        { "time" "T" TIME }
+        { "blob" "B" BLOB }
     } define-persistent
-    1 "billy" 10 3.14 <assigned-person> the-person1 set
+    1 "billy" 10 3.14 f f f f <assigned-person> person1 set
-    2 "johnny" 10 3.14 <assigned-person> the-person2 set ;
+    2 "johnny" 10 3.14 f f f f <assigned-person> person2 set
-
+    3 "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } <assigned-person> person3 set ;
 
 TUPLE: paste n summary author channel mode contents timestamp annotations ;
 TUPLE: annotation n paste-id summary author mode contents ;
@@ -118,14 +158,54 @@ TUPLE: annotation n paste-id summary author mode contents ;
     ! [ ] [ annotation create-table ] unit-test
 ! ] with-db
 
-
 : test-sqlite ( quot -- )
-    >r "tuples-test.db" resource-path sqlite-db r> with-db ;
+    >r "tuples-test.db" temp-file sqlite-db r> with-db ;
 
-: test-postgresql ( -- )
+! : test-postgresql ( -- )
-    >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ;
+!    >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ;
 
 [ native-person-schema test-tuples ] test-sqlite
 [ assigned-person-schema test-tuples ] test-sqlite
 
-! [ make-native-person-table ] test-sqlite
+TUPLE: serialize-me id data ;
+
+: test-serialize ( -- )
+    serialize-me "SERIALIZED"
+    {
+        { "id" "ID" +native-id+ }
+        { "data" "DATA" FACTOR-BLOB }
+    } define-persistent
+    [ serialize-me drop-table ] [ drop ] recover
+    [ ] [ serialize-me create-table ] unit-test
+
+    [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test
+    [
+        { T{ serialize-me f 1 H{ { 1 2 } } } }
+    ] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
+
+! [ test-serialize ] test-sqlite
+
+TUPLE: exam id name score ; 
+
+: test-ranges ( -- )
+    exam "EXAM"
+    {
+        { "id" "ID" +native-id+ }
+        { "name" "NAME" TEXT }
+        { "score" "SCORE" INTEGER }
+    } define-persistent
+    [ exam drop-table ] [ drop ] recover
+    [ ] [ exam create-table ] unit-test
+
+    [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test
+    [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test
+    [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
+    [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
+
+    [
+        T{ exam f 3 "Kenny" 60 }
+        T{ exam f 4 "Cartman" 41 }
+    ] [ T{ exam f 4 f T{ interval f { 0 t } { 70 t } } } select-tuples ] unit-test
+    ;
+
+! [ test-ranges ] test-sqlite

extra/db/tuples/tuples.factor

@@ -37,27 +37,24 @@ HOOK: <delete-tuples-statement> db ( class -- obj )
 
 HOOK: <select-by-slots-statement> db ( tuple -- tuple )
 
-HOOK: row-column-typed db ( result-set n type -- sql )
 HOOK: insert-tuple* db ( tuple statement -- )
 
 : resulting-tuple ( row out-params -- tuple )
     dup first sql-spec-class construct-empty [
         [
-            >r [ sql-spec-type sql-type>factor-type ] keep
+            >r sql-spec-slot-name r> set-slot-named
-            sql-spec-slot-name r> set-slot-named
         ] curry 2each
     ] keep ;
 
 : query-tuples ( statement -- seq )
     [ statement-out-params ] keep query-results [
-        [ sql-row swap resulting-tuple ] with query-map
+        [ sql-row-typed swap resulting-tuple ] with query-map
     ] with-disposal ;
  
 : query-modify-tuple ( tuple statement -- )
-    [ query-results [ sql-row ] with-disposal ] keep
+    [ query-results [ sql-row-typed ] with-disposal ] keep
     statement-out-params rot [
-        >r [ sql-spec-type sql-type>factor-type ] keep
+        >r sql-spec-slot-name r> set-slot-named
-        sql-spec-slot-name r> set-slot-named
     ] curry 2each ;
 
 : sql-props ( class -- columns table )

extra/db/types/types.factor

@@ -3,7 +3,8 @@
 USING: arrays assocs db kernel math math.parser
 sequences continuations sequences.deep sequences.lib
 words namespaces tools.walker slots slots.private classes
-mirrors tuples combinators ;
+mirrors tuples combinators calendar.format serialize
+io.streams.string ;
 IN: db.types
 
 HOOK: modifier-table db ( -- hash )
@@ -60,14 +61,19 @@ SYMBOL: +has-many+
 : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
 
 SYMBOL: INTEGER
-SYMBOL: BIG_INTEGER
+SYMBOL: BIG-INTEGER
 SYMBOL: DOUBLE
 SYMBOL: REAL
 SYMBOL: BOOLEAN
 SYMBOL: TEXT
 SYMBOL: VARCHAR
-SYMBOL: TIMESTAMP
 SYMBOL: DATE
+SYMBOL: TIME
+SYMBOL: DATETIME
+SYMBOL: TIMESTAMP
+SYMBOL: BLOB
+SYMBOL: FACTOR-BLOB
+SYMBOL: NULL
 
 : spec>tuple ( class spec -- tuple )
     [ ?first3 ] keep 3 ?tail*
@@ -80,15 +86,6 @@ SYMBOL: DATE
     } sql-spec construct
     dup normalize-spec ;
 
-: sql-type-hash ( -- assoc )
-    H{
-        { INTEGER "integer" }
-        { TEXT "text" }
-        { VARCHAR "varchar" }
-        { DOUBLE "real" }
-        { TIMESTAMP "timestamp" }
-    } ;
-
 TUPLE: no-sql-type ;
 : no-sql-type ( -- * ) T{ no-sql-type } throw ;
 
@@ -156,33 +153,6 @@ TUPLE: no-sql-modifier ;
     [ lookup-modifier ] map " " join
     dup empty? [ " " swap append ] unless ;
 
-SYMBOL: building-seq 
-: get-building-seq ( n -- seq )
-    building-seq get nth ;
-
-: n, get-building-seq push ;
-: n% get-building-seq push-all ;
-: n# >r number>string r> n% ;
-
-: 0, 0 n, ;
-: 0% 0 n% ;
-: 0# 0 n# ;
-: 1, 1 n, ;
-: 1% 1 n% ;
-: 1# 1 n# ;
-: 2, 2 n, ;
-: 2% 2 n% ;
-: 2# 2 n# ;
-
-: nmake ( quot exemplars -- seqs )
-    dup length dup zero? [ 1+ ] when
-    [
-        [
-            [ drop 1024 swap new-resizable ] 2map
-            [ building-seq set call ] keep
-        ] 2keep >r [ like ] 2map r> firstn 
-    ] with-scope ;
-
 HOOK: bind% db ( spec -- )
 
 TUPLE: no-slot-named ;
@@ -210,15 +180,3 @@ TUPLE: no-slot-named ;
         >r dup sql-spec-type swap sql-spec-slot-name r>
         get-slot-named swap
     ] curry { } map>assoc ;
-
-: sql-type>factor-type ( obj type -- obj )
-    dup array? [ first ] when
-    {
-        { +native-id+ [ string>number ] }
-        { INTEGER [ string>number ] }
-        { DOUBLE [ string>number ] }
-        { REAL [ string>number ] }
-        { TEXT [ ] }
-        { VARCHAR [ ] }
-        [ "no conversion from sql type to factor type" throw ]
-    } case ;

extra/destructors/destructors-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax libc kernel ;
+USING: help.markup help.syntax libc kernel continuations ;
 IN: destructors
 
 HELP: free-always
@@ -23,7 +23,7 @@ HELP: close-later
 
 HELP: with-destructors
 { $values { "quot" "a quotation" } }
-{ $description "Calls a quotation within a new dynamic scope.  This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link destruct } " on that object type.  After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown.  However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
+{ $description "Calls a quotation within a new dynamic scope.  This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type.  After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown.  However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
 { $notes "Destructors are not allowed to throw exceptions.  No exceptions." }
 { $examples
     { $code "[ 10 malloc free-always ] with-destructors" }

extra/destructors/destructors-tests.factor

@@ -9,7 +9,7 @@ TUPLE: dummy-destructor obj ;
 
 C: <dummy-destructor> dummy-destructor
 
-M: dummy-destructor destruct ( obj -- )
+M: dummy-destructor dispose ( obj -- )
     dummy-destructor-obj t swap set-dummy-obj-destroyed? ;
 
 : destroy-always

extra/destructors/destructors.factor

@@ -4,18 +4,16 @@ USING: continuations io.backend libc kernel namespaces
 sequences system vectors ;
 IN: destructors
 
-GENERIC: destruct ( obj -- )
-
 SYMBOL: error-destructors
 SYMBOL: always-destructors
 
 TUPLE: destructor object destroyed? ;
 
-M: destructor destruct
+M: destructor dispose
     dup destructor-destroyed? [
         drop
     ] [
-        dup destructor-object destruct
+        dup destructor-object dispose 
         t swap set-destructor-destroyed?
     ] if ;
 
@@ -29,10 +27,10 @@ M: destructor destruct
     <destructor> always-destructors get push ;
 
 : do-always-destructors ( -- )
-    always-destructors get [ destruct ] each ;
+    always-destructors get [ dispose ] each ;
 
 : do-error-destructors ( -- )
-    error-destructors get [ destruct ] each ;
+    error-destructors get [ dispose ] each ;
 
 : with-destructors ( quot -- )
     [
@@ -47,7 +45,7 @@ TUPLE: memory-destructor alien ;
 
 C: <memory-destructor> memory-destructor
 
-M: memory-destructor destruct ( obj -- )
+M: memory-destructor dispose ( obj -- )
     memory-destructor-alien free ;
 
 : free-always ( alien -- )
@@ -63,7 +61,7 @@ C: <handle-destructor> handle-destructor
 
 HOOK: destruct-handle io-backend ( obj -- )
 
-M: handle-destructor destruct ( obj -- )
+M: handle-destructor dispose ( obj -- )
     handle-destructor-alien destruct-handle ;
 
 : close-always ( handle -- )
@@ -79,7 +77,7 @@ C: <socket-destructor> socket-destructor
 
 HOOK: destruct-socket io-backend ( obj -- )
 
-M: socket-destructor destruct ( obj -- )
+M: socket-destructor dispose ( obj -- )
     socket-destructor-alien destruct-socket ;
 
 : close-socket-always ( handle -- )

extra/editors/jedit/jedit.factor

@@ -1,9 +1,10 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays definitions io kernel math
 namespaces parser prettyprint sequences strings words
-editors io.files io.sockets io.streams.string io.binary
+editors io.files io.sockets io.streams.byte-array io.binary
-math.parser io.encodings.ascii ;
+math.parser io.encodings.ascii io.encodings.binary
+io.encodings.utf8 ;
 IN: editors.jedit
 
 : jedit-server-info ( -- port auth )
@@ -14,17 +15,17 @@ IN: editors.jedit
     ] with-file-reader ;
 
 : make-jedit-request ( files -- code )
-    [
+    utf8 [
         "EditServer.handleClient(false,false,false," write
         cwd pprint
         "," write
         "new String[] {" write
         [ pprint "," write ] each
         "null});\n" write
-    ] with-string-writer ;
+    ] with-byte-writer ;
 
 : send-jedit-request ( request -- )
-    jedit-server-info swap "localhost" swap <inet> <client> [
+    jedit-server-info "localhost" rot <inet> binary <client> [
         4 >be write
         dup length 2 >be write
         write

extra/farkup/farkup-tests.factor

@@ -42,3 +42,7 @@ IN: farkup.tests
 
 [ "<p><strong>foo</strong>\n</p><h1>aheading</h1>\n<p>adfasd</p>" ]
 [ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test
+
+[ "<p>=foo\n</p>" ] [ "=foo\n" convert-farkup ] unit-test
+[ "<h1>foo</h1>\n" ] [ "=foo=\n" convert-farkup ] unit-test
+[ "<p>lol</p><h1>foo</h1>\n" ] [ "lol=foo=\n" convert-farkup ] unit-test

extra/fry/fry-docs.factor

@@ -0,0 +1,108 @@
+USING: help.markup help.syntax quotations kernel ;
+IN: fry
+
+HELP: ,
+{ $description "Fry specifier. Inserts a literal value into the fried quotation." } ;
+
+HELP: @
+{ $description "Fry specifier. Splices a quotation into the fried quotation." } ;
+
+HELP: _
+{ $description "Fry specifier. Shifts all fry specifiers to the left down by one stack position." } ;
+
+HELP: fry
+{ $values { "quot" quotation } { "quot'" quotation } }
+{ $description "Outputs a quotation that when called, fries " { $snippet "quot" } " by taking values from the stack and substituting them in." }
+{ $notes "This word is used to implement " { $link POSTPONE: '[ } "; the following two lines are equivalent:"
+    { $code "[ X ] fry call" "'[ X ]" }
+} ;
+
+HELP: '[
+{ $syntax "code... ]" }
+{ $description "Literal fried quotation. Expands into code which takes values from the stack and substituting them in." } ;
+
+ARTICLE: "fry.examples" "Examples of fried quotations"
+"Conceptually, " { $link fry } " is tricky however the general idea is easy to grasp once presented with examples."
+$nl
+"If a quotation does not contain any fry specifiers, then " { $link POSTPONE: '[ } " behaves just like " { $link POSTPONE: [ } ":"
+{ $code "{ 10 20 30 } '[ . ] each" }
+"Occurrences of " { $link , } " on the left map directly to " { $link curry } ". That is, the following three lines are equivalent:"
+{ $code 
+    "{ 10 20 30 } 5 '[ , + ] map"
+    "{ 10 20 30 } 5 [ + ] curry map"
+    "{ 10 20 30 } [ 5 + ] map"
+}
+"Occurrences of " { $link , } " in the middle of a quotation map to more complex quotation composition patterns. The following three lines are equivalent:"
+{ $code 
+    "{ 10 20 30 } 5 '[ 3 , / ] map"
+    "{ 10 20 30 } 5 [ 3 ] swap [ / ] curry compose map"
+    "{ 10 20 30 } [ 3 5 / ] map"
+}
+"Occurrences of " { $link @ } " are simply syntax sugar for " { $snippet ", call" } ". The following three lines are equivalent:"
+{ $code 
+    "{ 10 20 30 } [ sq ] '[ @ . ] map"
+    "{ 10 20 30 } [ sq ] [ . ] compose map"
+    "{ 10 20 30 } [ sq . ] map"
+}
+"The " { $link , } " and " { $link @ } " specifiers may be freely mixed:"
+{ $code
+    "{ 8 13 14 27 } [ even? ] 5 [ @ dup , ? ] map"
+    "{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map"
+    "{ 8 13 14 27 } [ even? dup 5 ? ] map"
+}
+"Occurrences of " { $link _ } " have the effect of enclosing all code to their left with " { $link >r } " and " { $link r> } ":"
+{ $code 
+    "{ 10 20 30 } 1 '[ , _ / ] map"
+    "{ 10 20 30 } 1 [ swap / ] curry map"
+    "{ 10 20 30 } [ 1 swap / ] map"
+}
+"For any quotation body " { $snippet "X" } ", the following two are equivalent:"
+{ $code
+    "[ >r X r> ]"
+    "[ X _ ]"
+}
+"Here are some built-in combinators rewritten in terms of fried quotations:"
+{ $table
+    { { $link literalize } { $snippet ": literalize '[ , ] ;" } }
+    { { $link slip } { $snippet ": slip '[ @ , ] call ;" } }
+    { { $link dip } { $snippet ": dip '[ @ _ ] call ;" } }
+    { { $link curry } { $snippet ": curry '[ , @ ] ;" } }
+    { { $link with } { $snippet ": with swapd '[ , _ @ ] ;" } }
+    { { $link compose } { $snippet ": compose '[ @ @ ] ;" } }
+    { { $link 2apply } { $snippet ": 2apply tuck '[ , @ , @ ] call ;" } }
+} ;
+
+ARTICLE: "fry.philosophy" "Fried quotation philosophy"
+"Fried quotations generalize quotation-building words such as " { $link curry } " and " { $link compose } "."
+$nl
+"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a ``let'' form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
+{ $code
+    "'[ 3 , + 4 , / ]"
+    "[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]"
+}
+"The " { $link _ } " fry specifier has no direct analogue in " { $vocab-link "locals" } ", however closure conversion together with the " { $link dip } " combinator achieve the same effect:"
+{ $code
+    "'[ , 2 + , * _ / ]"
+    "[let | a [ ] b [ ] | [ [ a 2 + b * ] dip / ] ]"
+} ;
+
+ARTICLE: "fry.limitations" "Fried quotation limitations"
+"As with " { $link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". Unlike " { $link "locals" } ", using " { $link dip } " is not a suitable workaround since unlike closure conversion, fry conversion is not recursive, and so the quotation passed to " { $link dip } " cannot contain fry specifiers." ;
+
+ARTICLE: "fry" "Fried quotations"
+"A " { $emphasis "fried quotation" } " differs from a literal quotation in that when it is evaluated, instead of just pushing itself on the stack, it consumes zero or more stack values and inserts them into the quotation."
+$nl
+"Fried quotations are denoted with a special parsing word:"
+{ $subsection POSTPONE: '[ }
+"Fried quotations contain zero or more " { $emphasis "fry specifiers" } ":"
+{ $subsection , }
+{ $subsection @ }
+{ $subsection _ }
+"When a fried quotation is being evaluated, values are consumed from the stack and spliced into the quotation from right to left."
+{ $subsection "fry.examples" }
+{ $subsection "fry.philosophy" }
+{ $subsection "fry.limitations" }
+"Quotations can also be fried without using a parsing word:"
+{ $subsection fry } ;
+
+ABOUT: "fry"

extra/furnace/authors.txt

@@ -1,2 +0,0 @@
-Slava Pestov
-Doug Coleman

extra/furnace/furnace-tests.factor

@@ -1,47 +0,0 @@
-USING: kernel sequences namespaces math tools.test furnace furnace.validator ;
-IN: furnace.tests
-
-TUPLE: test-tuple m n ;
-
-[ H{ { "m" 3 } { "n" 2 } } ]
-[
-    [ T{ test-tuple f 3 2 } explode-tuple ] H{ } make-assoc
-] unit-test
-
-[
-    { 3 }
-] [
-    H{ { "n" "3" } } { { "n" v-number } }
-    [ action-param drop ] with map
-] unit-test
-
-: foo ;
-
-\ foo { { "foo" "2" v-default } { "bar" v-required } } define-action
-
-[ t ] [ [ 1 2 foo ] action-call? ] unit-test
-[ f ] [ [ 2 + ] action-call? ] unit-test
-
-[
-    { "2" "hello" }
-] [
-    [
-        H{
-            { "bar" "hello" }
-        } \ foo query>seq
-    ] with-scope
-] unit-test
-
-[
-    H{ { "foo" "1" } { "bar" "2" } }
-] [
-    { "1" "2" } \ foo quot>query
-] unit-test
-
-[
-    "/responder/furnace.tests/foo?foo=3"
-] [
-    [
-        [ "3" foo ] quot-link
-    ] with-scope
-] unit-test

extra/furnace/furnace.factor

@@ -1,217 +0,0 @@
-! Copyright (C) 2006, 2008 Slava Pestov, Doug Coleman
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs calendar debugger furnace.sessions
-furnace.validator hashtables heaps html.elements http
-http.server.responders http.server.templating io.files kernel
-math namespaces quotations sequences splitting words strings
-vectors webapps.callback continuations tuples classes vocabs
-html io io.encodings.binary ;
-IN: furnace
-
-: code>quotation ( word/quot -- quot )
-    dup word? [ 1quotation ] when ;
-
-SYMBOL: default-action
-SYMBOL: template-path
-
-: render-template ( template -- )
-    template-path get swap path+
-    ".furnace" append resource-path
-    run-template-file ;
-
-: define-action ( word hash -- )
-    over t "action" set-word-prop
-    "action-params" set-word-prop ;
-
-: define-form ( word1 word2 hash -- )
-    dupd define-action
-    swap code>quotation "form-failed" set-word-prop ;
-
-: default-values ( word hash -- )
-    "default-values" set-word-prop ;
-
-SYMBOL: request-params
-SYMBOL: current-action
-SYMBOL: validators-errored
-SYMBOL: validation-errors
-
-: build-url ( str query-params -- newstr )
-    [
-        over %
-        dup assoc-empty? [
-            2drop
-        ] [
-            CHAR: ? rot member? "&" "?" ? %
-            assoc>query %
-        ] if
-    ] "" make ;
-
-: action-link ( query action -- url )
-    [
-        "/responder/" %
-        dup word-vocabulary "webapps." ?head drop %
-        "/" %
-        word-name %
-    ] "" make swap build-url ;
-
-: action-param ( hash paramsepc -- obj error/f )
-    unclip rot at swap >quotation apply-validators ;
-
-: query>seq ( hash word -- seq )
-    "action-params" word-prop [
-        dup first -rot
-        action-param [
-            t validators-errored >session
-            rot validation-errors session> set-at
-        ] [
-            nip
-        ] if*
-    ] with map ;
-
-: lookup-session ( hash -- session )
-    "furnace-session-id" over at get-session
-    [ ] [ new-session "furnace-session-id" roll set-at ] ?if ;
-
-: quot>query ( seq action -- hash )
-    >r >array r> "action-params" word-prop
-    [ first swap 2array ] 2map >hashtable ;
-
-PREDICATE: word action "action" word-prop ;
-
-: action-call? ( quot -- ? )
-    >vector dup pop action? >r [ word? not ] all? r> and ;
-
-: unclip* dup 1 head* swap peek ;
-
-: quot-link ( quot -- url )
-    dup action-call? [
-        unclip* [ quot>query ] keep action-link
-    ] [
-        t register-html-callback
-    ] if ;
-
-: replace-variables ( quot -- quot )
-    [ dup string? [ request-params session> at ] when ] map ;
-
-: furnace-session-id ( -- hash )
-    "furnace-session-id" request-params session> at
-    "furnace-session-id" associate ;
-
-: redirect-to-action ( -- )
-    current-action session>
-    "form-failed" word-prop replace-variables
-    quot-link furnace-session-id build-url permanent-redirect ;
-
-: if-form-page ( if then -- )
-    current-action session> "form-failed" word-prop -rot if ;
-
-: do-action
-    current-action session> [ query>seq ] keep add >quotation call ;
-
-: process-form ( -- )
-    H{ } clone validation-errors >session
-    request-params session> current-action session> query>seq
-    validators-errored session> [
-        drop redirect-to-action
-    ] [
-        current-action session> add >quotation call
-    ] if ;
-
-: page-submitted ( -- )
-    [ process-form ] [ request-params session> do-action ] if-form-page ;
-
-: action-first-time ( -- )
-    request-params session> current-action session>
-    [ "default-values" word-prop swap union request-params >session ] keep
-    request-params session> do-action ;
-
-: page-not-submitted ( -- )
-    [ redirect-to-action ] [ action-first-time ] if-form-page ;
-
-: setup-call-action ( hash word -- )
-    over lookup-session session set
-    current-action >session
-    request-params session> swap union
-    request-params >session
-    f validators-errored >session ;
-
-: call-action ( hash word -- )
-    setup-call-action
-    "furnace-form-submitted" request-params session> at
-    [ page-submitted ] [ page-not-submitted ] if ;
-
-: responder-vocab ( str -- newstr )
-    "webapps." swap append ;
-
-: lookup-action ( str webapp -- word )
-    responder-vocab lookup dup [
-        dup "action" word-prop [ drop f ] unless
-    ] when ;
-
-: truncate-url ( str -- newstr )
-    CHAR: / over index [ head ] when* ;
-
-: parse-action ( str -- word/f )
-    dup empty? [ drop default-action get ] when
-    truncate-url "responder" get lookup-action ;
-
-: service-request ( hash str -- )
-    parse-action [
-        [ call-action ] [ <pre> print-error </pre> ] recover
-    ] [
-        "404 no such action: " "argument" get append httpd-error
-    ] if* ;
-
-: service-get
-    "query" get swap service-request ;
-
-: service-post
-    "response" get swap service-request ;
-
-: web-app ( name defaul path -- )
-    [
-        template-path set
-        default-action set
-        "responder" set
-        [ service-get ] "get" set
-        [ service-post ] "post" set
-    ] make-responder ;
-
-: explode-tuple ( tuple -- )
-    dup tuple-slots swap class "slot-names" word-prop
-    [ set ] 2each ;
-
-SYMBOL: model
-
-: with-slots ( model quot -- )
-    [
-        >r [ dup model set explode-tuple ] when* r> call
-    ] with-scope ;
-
-: render-component ( model template -- )
-    swap [ render-template ] with-slots ;
-
-: browse-webapp-source ( vocab -- )
-    <a vocab browser-link-href =href a>
-        "Browse source" write
-    </a> ;
-
-: send-resource ( name -- )
-    template-path get swap path+ resource-path binary <file-reader>
-    stdio get stream-copy ;
-
-: render-link ( quot name -- )
-    <a swap quot-link =href a> write </a> ;
-
-: session-var ( str -- newstr )
-    request-params session> at ;
-
-: render ( str -- )
-    request-params session> at [ write ] when* ;
-
-: render-error ( str error-str -- )
-    swap validation-errors session> at validation-error? [
-        write
-    ] [
-        drop
-    ] if ;

extra/furnace/sessions/sessions.factor

@@ -1,50 +0,0 @@
-USING: assocs calendar init kernel math.parser
-namespaces random boxes alarms combinators.lib ;
-IN: furnace.sessions
-
-SYMBOL: sessions
-
-: timeout ( -- dt ) 20 minutes ;
-
-[
-    H{ } clone sessions set-global
-] "furnace.sessions" add-init-hook
-
-: new-session-id ( -- str )
-    [ 4 big-random >hex ]
-    [ sessions get-global key? not ] generate ;
-
-TUPLE: session id namespace alarm user-agent ;
-
-: cancel-timeout ( session -- )
-    session-alarm ?box [ cancel-alarm ] [ drop ] if ;
-
-: delete-session ( session -- )
-    sessions get-global delete-at*
-    [ cancel-timeout ] [ drop ] if ;
-
-: touch-session ( session -- )
-    dup cancel-timeout
-    dup [ session-id delete-session ] curry timeout later
-    swap session-alarm >box ;
-
-: <session> ( id -- session )
-    H{ } clone <box> f session construct-boa ;
-
-: new-session ( -- session id )
-    new-session-id [
-        dup <session> [
-            [ sessions get-global set-at ] keep
-            touch-session
-        ] keep
-    ] keep ;
-
-: get-session ( id -- session/f )
-    sessions get-global at*
-    [ dup touch-session ] when ;
-
-: session> ( str -- obj )
-    session get session-namespace at ;
-
-: >session ( value key -- )
-    session get session-namespace set-at ;

extra/furnace/summary.txt

@@ -1 +0,0 @@
-Action-based web framework

extra/furnace/tags.txt

@@ -1 +0,0 @@
-enterprise

extra/furnace/validator/authors.txt

@@ -1 +0,0 @@
-Doug Coleman

extra/furnace/validator/validator-tests.factor

@@ -1,30 +0,0 @@
-IN: furnace.validator.tests
-USING: kernel sequences tools.test furnace.validator furnace ;
-
-[
-    123 f
-] [
-    H{ { "foo" "123" } } { "foo" v-number } action-param
-] unit-test
-
-: validation-fails
-    [ action-param nip not ] append [ f ] swap unit-test ;
-
-[ H{ { "foo" "12X3" } } { "foo" v-number } ] validation-fails
-
-[ H{ { "foo" "" } } { "foo" 4 v-min-length } ] validation-fails
-
-[ "ABCD" f ]
-[ H{ { "foo" "ABCD" } } { "foo" 4 v-min-length } action-param ]
-unit-test
-
-[ H{ { "foo" "ABCD" } } { "foo" 2 v-max-length } ]
-validation-fails
-
-[ "AB" f ]
-[ H{ { "foo" "AB" } } { "foo" 2 v-max-length } action-param ]
-unit-test
-
-[ "AB" f ]
-[ H{ { "foo" f } } { "foo" "AB" v-default } action-param ]
-unit-test

extra/furnace/validator/validator.factor

@@ -1,43 +0,0 @@
-! Copyright (C) 2006 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations sequences math namespaces math.parser ;
-IN: furnace.validator
-
-TUPLE: validation-error reason ;
-
-: apply-validators ( string quot -- obj error/f )
-    [
-        call f
-    ] [
-        dup validation-error? [ >r 2drop f r> ] [ rethrow ] if
-    ] recover ;
-
-: validation-error ( msg -- * )
-    \ validation-error construct-boa throw ;
-
-: v-default ( obj value -- obj )
-    over empty? [ nip ] [ drop ] if ;
-
-: v-required ( str -- str )
-    dup empty? [ "required" validation-error ] when ;
-
-: v-min-length ( str n -- str )
-    over length over < [
-        [ "must be at least " % # " characters" % ] "" make
-        validation-error
-    ] [
-        drop
-    ] if ;
-
-: v-max-length ( str n -- str )
-    over length over > [
-        [ "must be no more than " % # " characters" % ] "" make
-        validation-error
-    ] [
-        drop
-    ] if ;
-
-: v-number ( str -- n )
-    string>number [
-        "must be a number" validation-error
-    ] unless* ;

extra/help/markup/markup.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays definitions generic io kernel assocs hashtables
 namespaces parser prettyprint sequences strings io.styles
@@ -42,9 +42,9 @@ M: f print-element drop ;
     [ print-element ] with-style ;
 
 : with-default-style ( quot -- )
-    default-style get [
+    default-span-style get [
         last-element off
-        default-style get swap with-nesting
+        default-block-style get swap with-nesting
     ] with-style ; inline
 
 : print-content ( element -- )

extra/help/stylesheet/stylesheet.factor

@@ -3,13 +3,17 @@
 USING: io.styles namespaces ;
 IN: help.stylesheet
 
-SYMBOL: default-style
+SYMBOL: default-span-style
 H{
     { font "sans-serif" }
     { font-size 12 }
     { font-style plain }
+} default-span-style set-global
+
+SYMBOL: default-block-style
+H{
     { wrap-margin 500 }
-} default-style set-global
+} default-block-style set-global
 
 SYMBOL: link-style
 H{

extra/html/parser/analyzer/analyzer.factor

@@ -1,8 +1,44 @@
 USING: assocs html.parser kernel math sequences strings ascii
-arrays shuffle unicode.case namespaces splitting
+arrays shuffle unicode.case namespaces splitting http
-http.server.responders ;
+sequences.lib ;
 IN: html.parser.analyzer
 
+: (find-relative)
+    [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ;
+
+: find-relative ( seq quot n -- i elt )
+    >r over [ find drop ] dip r> swap pick
+    (find-relative) ;
+
+: (find-all) ( n seq quot -- )
+    2dup >r >r find* [
+        dupd 2array , 1+ r> r> (find-all)
+    ] [
+        r> r> 3drop
+    ] if* ;
+
+: find-all ( seq quot -- alist )
+    [ 0 -rot (find-all) ] { } make ;
+
+: (find-nth) ( offset seq quot n count -- obj )
+    >r >r [ find* ] 2keep 4 npick [
+        r> r> 1+ 2dup <= [
+            4drop
+        ] [
+            >r >r >r >r drop 1+ r> r> r> r>
+            (find-nth)
+        ] if
+    ] [
+        2drop r> r> 2drop
+    ] if ;
+
+: find-nth ( seq quot n -- i elt )
+    0 -roll 0 (find-nth) ;
+
+: find-nth-relative ( seq quot n offest -- i elt )
+    >r [ find-nth ] 3keep 2drop nip r> swap pick
+    (find-relative) ;
+
 : remove-blank-text ( vector -- vector' )
     [
         dup tag-name text = [
@@ -52,29 +88,33 @@ IN: html.parser.analyzer
     >r >lower r>
     [ tag-attributes at over = ] with find rot drop ;
 
-: find-between ( i/f tag/f vector -- vector )
+: find-between* ( i/f tag/f vector -- vector )
     pick integer? [
-        rot 1+ tail-slice
+        rot tail-slice
         >r tag-name r>
-        [ find-matching-close drop ] keep swap head
+        [ find-matching-close drop 1+ ] keep swap head
     ] [
         3drop V{ } clone
     ] if ;
+    
+: find-between ( i/f tag/f vector -- vector )
+    find-between* dup length 3 >= [
+        [ 1 tail-slice 1 head-slice* ] keep like
+    ] when ;
+
+: find-between-first ( string vector -- vector' )
+    [ find-first-name ] keep find-between ;
+
+: tag-link ( tag -- link/f )
+    tag-attributes [ "href" swap at ] [ f ] if* ;
 
 : find-links ( vector -- vector )
     [ tag-name "a" = ] subset
-    [ tag-attributes "href" swap at ] map
+    [ tag-link ] subset ;
-    [ ] subset ;
 
-: (find-all) ( n seq quot -- )
-    2dup >r >r find* [
-        dupd 2array , 1+ r> r> (find-all)
-    ] [
-        r> r> 3drop
-    ] if* ;
 
-: find-all ( seq quot -- alist )
+: find-by-text ( seq quot -- tag )
-    [ 0 -rot (find-all) ] { } make ;
+    [ dup tag-name text = ] swap compose find drop ;
 
 : find-opening-tags-by-name ( name seq -- seq )
     [ [ tag-name = ] keep tag-closing? not and ] with find-all ;
@@ -82,8 +122,8 @@ IN: html.parser.analyzer
 : href-contains? ( str tag -- ? )
     tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ;
 
-: query>hash* ( str -- hash )
+: query>assoc* ( str -- hash )
-    "?" split1 nip query>hash ;
+    "?" split1 nip query>assoc ;
 
 ! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map
 
@@ -91,5 +131,5 @@ IN: html.parser.analyzer
 ! "a" over find-opening-tags-by-name
 ! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-subset
 ! first first 8 + over nth
-! tag-attributes "href" swap at query>hash*
+! tag-attributes "href" swap at query>assoc*
 ! "lat" over at "lon" rot at

extra/http/client/client-tests.factor

@@ -23,6 +23,5 @@ tuple-syntax namespaces ;
     [
         "http://www.apple.com/index.html"
         <get-request>
-        request-with-url
     ] with-scope
 ] unit-test

extra/http/client/client.factor

@@ -2,75 +2,80 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs http kernel math math.parser namespaces sequences
 io io.sockets io.streams.string io.files io.timeouts strings
-splitting calendar continuations accessors vectors io.encodings.binary ;
+splitting calendar continuations accessors vectors io.encodings.latin1
+io.encodings.binary ;
 IN: http.client
 
+DEFER: http-request
+
+<PRIVATE
+
 : parse-url ( url -- resource host port )
     "http://" ?head [ "Only http:// supported" throw ] unless
     "/" split1 [ "/" swap append ] [ "/" ] if*
     swap parse-host ;
 
-<PRIVATE
-
 : store-path ( request path -- request )
     "?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
 
-! This is all pretty complex because it needs to handle
-! HTTP redirects, which might be absolute or relative
 : request-with-url ( url request -- request )
-    clone dup "request" set
     swap parse-url >r >r store-path r> >>host r> >>port ;
 
-DEFER: (http-request)
+! This is all pretty complex because it needs to handle
-
+! HTTP redirects, which might be absolute or relative
 : absolute-redirect ( url -- request )
-    "request" get request-with-url ;
+    request get request-with-url ;
 
 : relative-redirect ( path -- request )
-    "request" get swap store-path ;
+    request get swap store-path ;
 
 : do-redirect ( response -- response stream )
     dup response-code 300 399 between? [
+        stdio get dispose
         header>> "location" swap at
         dup "http://" head? [
             absolute-redirect
         ] [
             relative-redirect
-        ] if "GET" >>method (http-request)
+        ] if "GET" >>method http-request
     ] [
         stdio get
     ] if ;
 
-: (http-request) ( request -- response stream )
+: request-addr ( request -- addr )
-    dup host>> over port>> <inet> <client> stdio set
+    dup host>> swap port>> <inet> ;
-    dup "r" set-global  write-request flush read-response
+
-    do-redirect ;
+: close-on-error ( stream quot -- )
+    [ with-stream* ] curry [ ] pick [ dispose ] curry cleanup ;
+    inline
 
 PRIVATE>
 
-: http-request ( url request -- response stream )
+: http-request ( request -- response stream )
-    [
+    dup request [
-        request-with-url
+        dup request-addr latin1 <client>
+        1 minutes over set-timeout
         [
-            (http-request)
+            write-request flush
-            1 minutes over set-timeout
+            read-response
-        ] [ ] [ stdio get dispose ] cleanup
+            do-redirect
-    ] with-scope ;
+        ] close-on-error
+    ] with-variable ;
 
-: <get-request> ( -- request )
+: <get-request> ( url -- request )
-    <request> "GET" >>method ;
+    <request> request-with-url "GET" >>method ;
 
 : http-get-stream ( url -- response stream )
     <get-request> http-request ;
 
 : success? ( code -- ? ) 200 = ;
 
-: check-response ( response stream -- stream )
+: check-response ( response -- )
-    swap code>> success?
+    code>> success?
-    [ dispose "HTTP download failed" throw ] unless ;
+    [ "HTTP download failed" throw ] unless ;
 
 : http-get ( url -- string )
-    http-get-stream check-response contents ;
+    http-get-stream contents swap check-response ;
 
 : download-name ( url -- name )
     file-name "?" split1 drop "/" ?tail drop ;
@@ -83,12 +88,13 @@ PRIVATE>
 : download ( url -- )
     dup download-name download-to ;
 
-: <post-request> ( content-type content -- request )
+: <post-request> ( content-type content url -- request )
     <request>
+    request-with-url
     "POST" >>method
     swap >>post-data
     swap >>post-data-type ;
 
 : http-post ( content-type content url -- response string )
     #! The content is URL encoded for you.
-    -rot url-encode <post-request> http-request contents ;
+    >r url-encode r> <post-request> http-request contents ;

extra/http/http-tests.factor

@@ -127,3 +127,30 @@ read-response-test-1' 1array [
     "rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT"
     dup parse-cookies unparse-cookies =
 ] unit-test
+
+! Live-fire exercise
+USING: http.server http.server.static http.server.actions
+http.client io.server io.files io accessors namespaces threads
+io.encodings.ascii ;
+
+[ ] [
+    [
+        <dispatcher>
+        <action>
+            [ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>get
+        "quit" add-responder
+        "extra/http/test" resource-path <static> >>default
+        default-host set
+
+        [ 1237 httpd ] "HTTPD test" spawn drop
+    ] with-scope
+] unit-test
+
+[ t ] [
+    "extra/http/test/foo.html" resource-path ascii file-contents
+    "http://localhost:1237/foo.html" http-get =
+] unit-test
+
+[ "Goodbye" ] [
+    "http://localhost:1237/quit" http-get
+] unit-test

extra/http/server/actions/actions-tests.factor

@@ -1,11 +1,12 @@
 IN: http.server.actions.tests
 USING: http.server.actions tools.test math math.parser
 multiline namespaces http io.streams.string http.server
-sequences ;
+sequences accessors ;
 
-[ + ]
+<action>
-{ { "a" [ string>number ] } { "b" [ string>number ] } }
+    [ "a" get "b" get + ] >>get
-"GET" <action> "action-1" set
+    { { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params
+"action-1" set
 
 STRING: action-request-test-1
 GET http://foo/bar?a=12&b=13 HTTP/1.1
@@ -19,9 +20,10 @@ blah
     "action-1" get call-responder
 ] unit-test
 
-[ "X" <repetition> concat append ]
+<action>
-{ { +path+ [ ] } { "xxx" [ string>number ] } }
+    [ +path+ get "xxx" get "X" <repetition> concat append ] >>post
-"POST" <action> "action-2" set
+    { { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params
+"action-2" set
 
 STRING: action-request-test-2
 POST http://foo/bar/baz HTTP/1.1

extra/http/server/actions/actions.factor

@@ -1,14 +1,18 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors new-slots sequences kernel assocs combinators
-http.server http hashtables namespaces ;
+http.server http.server.validators http hashtables namespaces ;
 IN: http.server.actions
 
 SYMBOL: +path+
 
-TUPLE: action quot params method ;
+TUPLE: action get get-params post post-params revalidate ;
 
-C: <action> action
+: <action>
+    action construct-empty
+    [ <400> ] >>get
+    [ <400> ] >>post
+    [ <400> ] >>revalidate ;
 
 : extract-params ( request path -- assoc )
     >r dup method>> {
@@ -16,15 +20,22 @@ C: <action> action
         { "POST" [ post-data>> query>assoc ] }
     } case r> +path+ associate union ;
 
-: push-params ( assoc action -- ... )
+: action-params ( request path param -- error? )
-    params>> [ first2 >r swap at r> call ] with each ;
+    -rot extract-params validate-params ;
+
+: get-action ( request path -- response )
+    action get get-params>> action-params
+    [ <400> ] [ action get get>> call ] if ;
+
+: post-action ( request path -- response )
+    action get post-params>> action-params
+    [ action get revalidate>> ] [ action get post>> ] if call ;
 
 M: action call-responder ( request path action -- response )
-    pick request set
+    action set
-    pick method>> over method>> = [
+    over request set
-        >r extract-params r>
+    over method>>
-        [ push-params ] keep
+    {
-        quot>> call
+        { "GET" [ get-action ] }
-    ] [
+        { "POST" [ post-action ] }
-        3drop <400>
+    } case ;
-    ] if ;

extra/http/server/auth/basic/basic.factor

@@ -0,0 +1,41 @@
+! Copyright (c) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors new-slots quotations assocs kernel splitting
+base64 html.elements io combinators http.server
+http.server.auth.providers http.server.auth.providers.null
+http sequences ;
+IN: http.server.auth.basic
+
+TUPLE: basic-auth responder realm provider ;
+
+C: <basic-auth> basic-auth
+
+: authorization-ok? ( provider header -- ? )
+    #! Given the realm and the 'Authorization' header,
+    #! authenticate the user.
+    dup [
+        " " split1 swap "Basic" = [
+            base64> ":" split1 spin check-login
+        ] [
+            2drop f
+        ] if
+    ] [
+        2drop f
+    ] if ;
+
+: <401> ( realm -- response )
+    401 "Unauthorized" <trivial-response>
+    "Basic realm=\"" rot "\"" 3append
+    "WWW-Authenticate" set-header
+    [
+        <html> <body>
+            "Username or Password is invalid" write
+        </body> </html>
+    ] >>body ;
+
+: logged-in? ( request responder -- ? )
+    provider>> swap "authorization" header authorization-ok? ;
+
+M: basic-auth call-responder ( request path responder -- response )
+    pick over logged-in?
+    [ responder>> call-responder ] [ 2nip realm>> <401> ] if ;

extra/http/server/auth/login/login.factor

@@ -0,0 +1,69 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors new-slots quotations assocs kernel splitting
+base64 html.elements io combinators http.server
+http.server.auth.providers http.server.actions
+http.server.sessions http.server.templating.fhtml http sequences
+io.files namespaces ;
+IN: http.server.auth.login
+
+TUPLE: login-auth responder provider ;
+
+C: (login-auth) login-auth
+
+SYMBOL: logged-in?
+SYMBOL: provider
+SYMBOL: post-login-url
+
+: login-page ( -- response )
+    "text/html" <content> [
+        "extra/http/server/auth/login/login.fhtml"
+        resource-path run-template-file
+    ] >>body ;
+
+: <login-action>
+    <action>
+        [ login-page ] >>get
+
+        {
+            { "name" [ ] }
+            { "password" [ ] }
+        } >>post-params
+        [
+            "password" get
+            "name" get
+            provider sget check-login [
+                t logged-in? sset
+                post-login-url sget <permanent-redirect>
+            ] [
+                login-page
+            ] if
+        ] >>post ;
+
+: <logout-action>
+    <action>
+        [
+            f logged-in? sset
+            request get "login" <permanent-redirect>
+        ] >>post ;
+
+M: login-auth call-responder ( request path responder -- response )
+    logged-in? sget
+    [ responder>> call-responder ] [
+        pick method>> "GET" = [
+            nip
+            provider>> provider sset
+            dup request-url post-login-url sset
+            "login" f session-link <permanent-redirect>
+        ] [
+            3drop <400>
+        ] if
+    ] if ;
+
+: <login-auth> ( responder provider -- auth )
+        (login-auth)
+        <dispatcher>
+            swap >>default
+            <login-action> "login" add-responder
+            <logout-action> "logout" add-responder
+    <cookie-sessions> ;

extra/http/server/auth/login/login.fhtml

@@ -0,0 +1,25 @@
+<html>
+<body>
+<h1>Login required</h1>
+
+<form method="POST" action="login">
+<table>
+
+<tr>
+<td>User name:</td>
+<td><input name="name" /></td>
+</tr>
+
+<tr>
+<td>Password:</td>
+<td><input type="password" name="password" /></td>
+</tr>
+
+</table>
+
+<input type="submit" value="Log in" />
+
+</form>
+
+</body>
+</html>

extra/http/server/auth/providers/assoc/assoc-tests.factor

@@ -0,0 +1,18 @@
+IN: http.server.auth.providers.assoc.tests
+USING: http.server.auth.providers 
+http.server.auth.providers.assoc tools.test
+namespaces ;
+
+<assoc-auth-provider> "provider" set
+
+"slava" "provider" get new-user
+
+[ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with
+
+[ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test
+
+[ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with
+
+"fdasf" "slava" "provider" get set-password
+
+[ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test

extra/http/server/auth/providers/assoc/assoc.factor

@@ -0,0 +1,23 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: http.server.auth.providers.assoc
+USING: new-slots accessors assocs kernel
+http.server.auth.providers ;
+
+TUPLE: assoc-auth-provider assoc ;
+
+: <assoc-auth-provider> ( -- provider )
+    H{ } clone assoc-auth-provider construct-boa ;
+
+M: assoc-auth-provider check-login
+    assoc>> at = ;
+
+M: assoc-auth-provider new-user
+    assoc>>
+    2dup key? [ drop user-exists ] when
+    t -rot set-at ;
+
+M: assoc-auth-provider set-password
+    assoc>>
+    2dup key? [ drop no-such-user ] unless
+    set-at ;

extra/http/server/auth/providers/db/db-tests.factor

@@ -0,0 +1,25 @@
+IN: http.server.auth.providers.db.tests
+USING: http.server.auth.providers
+http.server.auth.providers.db tools.test
+namespaces db db.sqlite db.tuples continuations
+io.files ;
+
+db-auth-provider "provider" set
+
+"auth-test.db" temp-file sqlite-db [
+    
+    [ user drop-table ] ignore-errors
+    [ user create-table ] ignore-errors
+
+    "slava" "provider" get new-user
+
+    [ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with
+
+    [ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test
+
+    [ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with
+
+    "fdasf" "slava" "provider" get set-password
+
+    [ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test
+] with-db

extra/http/server/auth/providers/db/db.factor

@@ -0,0 +1,53 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db db.tuples db.types new-slots accessors
+http.server.auth.providers kernel ;
+IN: http.server.auth.providers.db
+
+TUPLE: user name password ;
+
+: <user> user construct-empty ;
+
+user "USERS"
+{
+    { "name" "NAME" { VARCHAR 256 } +assigned-id+ }
+    { "password" "PASSWORD" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+: init-users-table ( -- )
+    user create-table ;
+
+TUPLE: db-auth-provider ;
+
+: db-auth-provider T{ db-auth-provider } ;
+
+M: db-auth-provider check-login
+    drop
+    <user>
+    swap >>name
+    swap >>password
+    select-tuple >boolean ;
+
+M: db-auth-provider new-user
+    drop
+    [
+        <user>
+        swap >>name
+
+        dup select-tuple [ name>> user-exists ] when
+
+        "unassigned" >>password
+
+        insert-tuple
+    ] with-transaction ;
+
+M: db-auth-provider set-password
+    drop
+    [
+        <user>
+        swap >>name
+
+        dup select-tuple [ ] [ no-such-user ] ?if
+
+        swap >>password update-tuple
+    ] with-transaction ;

extra/http/server/auth/providers/null/null.factor

@@ -0,0 +1,14 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: http.server.auth.providers kernel ;
+IN: http.server.auth.providers.null
+
+TUPLE: null-auth-provider ;
+
+: null-auth-provider T{ null-auth-provider } ;
+
+M: null-auth-provider check-login 3drop f ;
+
+M: null-auth-provider new-user 3drop f ;
+
+M: null-auth-provider set-password 3drop f ;

extra/http/server/auth/providers/providers.factor

@@ -0,0 +1,18 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel ;
+IN: http.server.auth.providers
+
+GENERIC: check-login ( password user provider -- ? )
+
+GENERIC: new-user ( user provider -- )
+
+GENERIC: set-password ( password user provider -- )
+
+TUPLE: user-exists name ;
+
+: user-exists ( name -- * ) \ user-exists construct-boa throw ;
+
+TUPLE: no-such-user name ;
+
+: no-such-user ( name -- * ) \ no-such-user construct-boa throw ;

extra/http/server/cgi/cgi.factor

@@ -41,18 +41,17 @@ IN: http.server.cgi
         ] when
     ] H{ } make-assoc ;
 
-: cgi-descriptor ( name -- desc )
+: <cgi-process> ( name -- desc )
-    [
+    <process>
-        dup 1array +arguments+ set
+        over 1array >>command
-        cgi-variables +environment+ set
+        swap cgi-variables >>environment ;
-    ] H{ } make-assoc ;
     
 : serve-cgi ( name -- response )
     <raw-response>
     200 >>code
     "CGI output follows" >>message
     swap [
-        stdio get swap cgi-descriptor <process-stream> [
+        stdio get swap <cgi-process> <process-stream> [
             post? [
                 request get post-data>> write flush
             ] when

extra/http/server/components/components.factor

@@ -0,0 +1,125 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: new-slots html.elements http.server.validators
+accessors namespaces kernel io farkup math.parser assocs
+classes words tuples arrays sequences io.files
+http.server.templating.fhtml splitting mirrors ;
+IN: http.server.components
+
+SYMBOL: components
+
+TUPLE: component id ;
+
+: component ( name -- component )
+    dup components get at
+    [ ] [ "No such component: " swap append throw ] ?if ;
+
+GENERIC: validate* ( string component -- result )
+GENERIC: render-view* ( value component -- )
+GENERIC: render-edit* ( value component -- )
+GENERIC: render-error* ( reason value component -- )
+
+SYMBOL: values
+
+: value values get at ;
+
+: render-view ( component -- )
+    dup id>> value swap render-view* ;
+
+: render-error ( error -- )
+    <span "error" =class span> write </span> ;
+
+: render-edit ( component -- )
+    dup id>> value dup validation-error? [
+        dup reason>> swap value>> rot render-error*
+    ] [
+        swap render-edit*
+    ] if ;
+
+: <component> ( id string -- component )
+    >r \ component construct-boa r> construct-delegate ; inline
+
+TUPLE: string min max ;
+
+: <string> ( id -- component ) string <component> ;
+
+M: string validate*
+    [ min>> v-min-length ] keep max>> v-max-length ;
+
+M: string render-view*
+    drop write ;
+
+: render-input
+    <input "text" =type id>> dup =id =name =value input/> ;
+
+M: string render-edit*
+    render-input ;
+
+M: string render-error*
+    render-input render-error ;
+
+TUPLE: text ;
+
+: <text> ( id -- component ) <string> text construct-delegate ;
+
+: render-textarea
+    <textarea id>> dup =id =name textarea> write </textarea> ;
+
+M: text render-edit*
+    render-textarea ;
+
+M: text render-error*
+    render-textarea render-error ;
+
+TUPLE: farkup ;
+
+: <farkup> ( id -- component ) <text> farkup construct-delegate ;
+
+M: farkup render-view*
+    drop string-lines "\n" join convert-farkup write ;
+
+TUPLE: number min max ;
+
+: <number> ( id -- component ) number <component> ;
+
+M: number validate*
+    >r v-number r> [ min>> v-min-value ] keep max>> v-max-value ;
+
+M: number render-view*
+    drop number>string write ;
+
+M: number render-edit*
+    >r number>string r> render-input ;
+
+M: number render-error*
+    render-input render-error ;
+
+: with-components ( tuple components quot -- )
+    [
+        >r components set
+        dup make-mirror values set
+        tuple set
+        r> call
+    ] with-scope ; inline
+
+TUPLE: form view-template edit-template components ;
+
+: <form> ( id view-template edit-template -- form )
+    V{ } clone form construct-boa
+    swap \ component construct-boa
+    over set-delegate ;
+
+: add-field ( form component -- form )
+    dup id>> pick components>> set-at ;
+
+M: form render-view* ( value form -- )
+    dup components>>
+    swap view-template>>
+    [ resource-path run-template-file ] curry
+    with-components ;
+
+M: form render-edit* ( value form -- )
+    dup components>>
+    swap edit-template>>
+    [ resource-path run-template-file ] curry
+    with-components ;

extra/http/server/crud/crud.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: http.server.crud
+USING: kernel namespaces db.tuples math.parser
+http.server.actions accessors ;
+
+: by-id ( class -- tuple )
+    construct-empty "id" get >>id ;
+
+: <delete-action> ( class -- action )
+    <action>
+        { { "id" [ string>number ] } } >>post-params
+        swap [ by-id delete-tuple f ] curry >>post ;

extra/http/server/db/db.factor

@@ -1,14 +1,18 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: db http.server kernel new-slots accessors
-continuations namespaces ;
+continuations namespaces destructors ;
 IN: http.server.db
 
 TUPLE: db-persistence responder db params ;
 
 C: <db-persistence> db-persistence
 
+: connect-db ( db-persistence -- )
+    dup db>> swap params>> make-db
+    dup db set
+    dup db-open
+    add-always-destructor ;
+
 M: db-persistence call-responder
-    dup db>> over params>> make-db dup db-open [
+    dup connect-db responder>> call-responder ;
-        db set responder>> call-responder
-    ] with-disposal ;

extra/http/server/server.factor

@@ -4,7 +4,7 @@ USING: assocs kernel namespaces io io.timeouts strings splitting
 threads http sequences prettyprint io.server logging calendar
 new-slots html.elements accessors math.parser combinators.lib
 vocabs.loader debugger html continuations random combinators
-io.encodings.latin1  ;
+destructors io.encodings.latin1 ;
 IN: http.server
 
 GENERIC: call-responder ( request path responder -- response )
@@ -136,7 +136,7 @@ SYMBOL: development-mode
     swap method>> "HEAD" =
     [ drop ] [ write-response-body ] if ;
 
-: do-request ( request -- request )
+: do-request ( request -- response )
     [
         dup dup path>> over host>>
         find-virtual-host call-responder
@@ -150,13 +150,18 @@ LOG: httpd-hit NOTICE
 : log-request ( request -- )
     { method>> host>> path>> } map-exec-with httpd-hit ;
 
-: handle-client ( -- )
+: ?refresh-all ( -- )
-    default-timeout
     development-mode get-global
-    [ global [ refresh-all ] bind ] when
+    [ global [ refresh-all ] bind ] when ;
-    read-request
+
-    dup log-request
+: handle-client ( -- )
-    do-request do-response ;
+    [
+        default-timeout
+        ?refresh-all
+        read-request
+        dup log-request
+        do-request do-response
+    ] with-destructors ;
 
 : httpd ( port -- )
     internet-server "http.server"

extra/http/server/sessions/sessions-tests.factor

@@ -4,6 +4,12 @@ kernel accessors ;
 
 : with-session \ session swap with-variable ; inline
 
+TUPLE: foo ;
+
+C: <foo> foo
+
+M: foo init-session drop 0 "x" sset ;
+
 "1234" f <session> [
     [ ] [ 3 "x" sset ] unit-test
     
@@ -18,8 +24,7 @@ kernel accessors ;
 [ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
 
 [ ] [
-    f <url-sessions>
+    <foo> <url-sessions>
-        [ 0 "x" sset ] >>init
     "manager" set
 ] unit-test
 

extra/http/server/sessions/sessions.factor

@@ -11,6 +11,8 @@ IN: http.server.sessions
 
 GENERIC: init-session ( responder -- )
 
+M: dispatcher init-session drop ;
+
 TUPLE: session-manager responder sessions ;
 
 : <session-manager> ( responder class -- responder' )

extra/http/server/static/static.factor

@@ -3,7 +3,7 @@
 USING: calendar html io io.files kernel math math.parser http
 http.server namespaces parser sequences strings assocs
 hashtables debugger http.mime sorting html.elements logging
-calendar.format new-slots accessors ;
+calendar.format new-slots accessors io.encodings.binary ;
 IN: http.server.static
 
 SYMBOL: responder
@@ -33,7 +33,7 @@ TUPLE: file-responder root hook special ;
         <content>
         over file-length "content-length" set-header
         over file-http-date "last-modified" set-header
-        swap [ <file-reader> stdio get stream-copy ] curry >>body
+        swap [ binary <file-reader> stdio get stream-copy ] curry >>body
     ] <file-responder> ;
 
 : serve-static ( filename mime-type -- response )

extra/http/server/templating/fhtml/fhtml-tests.factor

@@ -1,9 +1,9 @@
-USING: io io.files io.streams.string http.server.templating kernel tools.test
+USING: io io.files io.streams.string io.encodings.utf8
-    sequences io.encodings.utf8 ;
+http.server.templating.fhtml kernel tools.test sequences ;
-IN: http.server.templating.tests
+IN: http.server.templating.fhtml.tests
 
 : test-template ( path -- ? )
-    "extra/http/server/templating/test/" swap append
+    "extra/http/server/templating/fhtml/test/" swap append
     [
         ".fhtml" append resource-path
         [ run-template-file ] with-string-writer

extra/http/server/templating/fhtml/fhtml.factor

@@ -7,9 +7,9 @@ source-files debugger combinators math quotations generic
 strings splitting accessors http.server.static http.server
 assocs io.encodings.utf8 ;
 
-IN: http.server.templating
+IN: http.server.templating.fhtml
 
-: templating-vocab ( -- vocab-name ) "http.server.templating" ;
+: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ;
 
 ! See apps/http-server/test/ or libs/furnace/ for template usage
 ! examples

extra/http/server/validators/validators-tests.factor

@@ -0,0 +1,4 @@
+IN: http.server.validators.tests
+USING: kernel sequences tools.test http.server.validators ;
+
+[ t t ] [ "foo" [ v-number ] with-validator >r validation-error? r> ] unit-test

extra/http/server/validators/validators.factor

@@ -0,0 +1,64 @@
+! Copyright (C) 2006, 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel continuations sequences math namespaces
+math.parser assocs new-slots ;
+IN: http.server.validators
+
+TUPLE: validation-error value reason ;
+
+: validation-error ( value reason -- * )
+    \ validation-error construct-boa throw ;
+
+: with-validator ( string quot -- result error? )
+    [ f ] compose curry
+    [ dup validation-error? [ t ] [ rethrow ] if ] recover ; inline
+
+: validate-param ( name validator assoc -- error? )
+    swap pick
+    >r >r at r> with-validator swap r> set ;
+
+: validate-params ( validators assoc -- error? )
+    [ validate-param ] curry { } assoc>map [ ] contains? ;
+
+: v-default ( str def -- str )
+    over empty? spin ? ;
+
+: v-required ( str -- str )
+    dup empty? [ "required" validation-error ] when ;
+
+: v-min-length ( str n -- str )
+    over length over < [
+        [ "must be at least " % # " characters" % ] "" make
+        validation-error
+    ] [
+        drop
+    ] if ;
+
+: v-max-length ( str n -- str )
+    over length over > [
+        [ "must be no more than " % # " characters" % ] "" make
+        validation-error
+    ] [
+        drop
+    ] if ;
+
+: v-number ( str -- n )
+    dup string>number [ ] [
+        "must be a number" validation-error
+    ] ?if ;
+
+: v-min-value ( str n -- str )
+    2dup < [
+        [ "must be at least " % # ] "" make
+        validation-error
+    ] [
+        drop
+    ] if ;
+
+: v-max-value ( str n -- str )
+    2dup > [
+        [ "must be no more than " % # ] "" make
+        validation-error
+    ] [
+        drop
+    ] if ;

extra/http/test/foo.html

@@ -0,0 +1 @@
+<html><head><title>Hello</title></head><body>HTTPd test</body></html>

extra/io/launcher/authors.txt

@@ -1 +1,2 @@
 Doug Coleman
+Slava Pestov

extra/io/launcher/launcher-docs.factor

@@ -4,102 +4,71 @@ USING: help.markup help.syntax quotations kernel io math
 calendar ;
 IN: io.launcher
 
-HELP: +command+
+ARTICLE: "io.launcher.command" "Specifying a command"
-{ $description "Launch descriptor key. A command line string, to be processed by the system's shell." } ;
+"The " { $snippet "command" } " slot of a " { $link process } " can contain either a string or a sequence of strings. In the first case, the string is processed in an operating system-specific manner. In the second case, the first element is a program name and the remaining elements are passed to the program as command-line arguments." ;
 
-HELP: +arguments+
+ARTICLE: "io.launcher.detached" "Running processes in the background"
-{ $description "Launch descriptor key. A sequence of command line argument strings. The first element is the program to launch and the remaining arguments are passed to the program without further processing." } ;
+"By default, " { $link run-process } " waits for the process to complete. To run a process without waiting for it to finish, set the " { $snippet "detached" } " slot of a " { $link process } ", or use the following word:"
+{ $subsection run-detached } ;
 
-HELP: +detached+
+ARTICLE: "io.launcher.environment" "Setting environment variables"
-{ $description "Launch descriptor key. A boolean indicating whether " { $link run-process } " will return immediately, rather than wait for the program to complete."
+"The " { $snippet "environment" } " slot of a " { $link process } " contains an association mapping environment variable names to values. The interpretation of environment variables is operating system-specific."
 $nl
-"Default value is " { $link f } "." }
+"The " { $snippet "environment-mode" } " slot controls how the environment of the current Factor instance is composed with the value of the " { $snippet "environment" } " slot:"
-{ $notes "Cannot be used with " { $link <process-stream> } "." }
+{ $subsection +prepend-environment+ }
-{ $see-also run-detached } ;
+{ $subsection +replace-environment+ }
+{ $subsection +append-environment+ }
+"The default value is " { $link +append-environment+ } "." ;
 
-HELP: +environment+
+ARTICLE: "io.launcher.redirection" "Input/output redirection"
-{ $description "Launch descriptor key. An association mapping strings to strings, specifying environment variables to set for the spawned process. The association is combined with the current environment using the operation specified by the " { $link +environment-mode+ } " launch descriptor key."
+"On all operating systems except for Windows CE, the default input/output/error streams can be redirected."
 $nl
-"Default value is an empty association." } ;
+"To specify redirection, set the " { $snippet "stdin" } ", " { $snippet "stdout" } " and " { $snippet "stderr" } " slots of a " { $link process } " to one of the following values:"
-
+{ $list
-HELP: +environment-mode+
+    { { $link f } " - default value; the stream is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
-{ $description "Launch descriptor key. Must equal of the following:"
+    { { $link +inherit+ } " - the stream is inherited from the current process, overriding a " { $link <process-stream> } " pipe" }
-    { $list
+    { { $link +closed+ } " - the stream is closed; reads will return end of file and writes will fails" }
-        { $link +prepend-environment+ }
+    { { $link +stdout+ } " - a special value for the " { $snippet "stderr" } " slot only, indicating that the standard output and standard error streams should be merged" }
-        { $link +replace-environment+ }
+    { "a path name - the stream is sent to the given file, which must exist for input and is created automatically on output" }
-        { $link +append-environment+ }
+    { "a file stream or a socket - the stream is connected to the given Factor stream, which cannot be used again from within Factor and must be closed after the process has been started" }
-    }
-"Default value is " { $link +append-environment+ } "."
-} ;
-
-HELP: +stdin+
-{ $description "Launch descriptor key. Must equal one of the following:"
-    { $list
-        { { $link f } " - standard input is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
-        { { $link +inherit+ } " - standard input is inherited from the current process" }
-        { { $link +closed+ } " - standard input is closed" }
-        { "a path name - standard input is read from the given file, which must exist" }
-        { "a file stream or a socket - standard input is read from the given stream, which must be closed after the process has been started" }
-    }
-} ;
-
-HELP: +stdout+
-{ $description "Launch descriptor key. Must equal one of the following:"
-    { $list
-        { { $link f } " - standard output is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
-        { { $link +inherit+ } " - standard output is inherited from the current process" }
-        { { $link +closed+ } " - standard output is closed" }
-        { "a path name - standard output is written to the given file, which is overwritten if it already exists" }
-        { "a file stream or a socket - standard output is written to the given stream, which must be closed after the process has been started" }
-    }
-} ;
-
-HELP: +stderr+
-{ $description "Launch descriptor key. Must equal one of the following:"
-    { $list
-        { { $link f } " - standard error is inherited from the current process" }
-        { { $link +inherit+ } " - same as above" }
-        { { $link +stdout+ } " - standard error is merged with standard output" }
-        { { $link +closed+ } " - standard error is closed" }
-        { "a path name - standard error is written to the given file, which is overwritten if it already exists" }
-        { "a file stream or a socket - standard error is written to the given stream, which must be closed after the process has been started" }
-    }
 } ;
 
 HELP: +closed+
-{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
+{ $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ;
 
 HELP: +inherit+
-{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
+{ $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ;
+
+HELP: +stdout+
+{ $description "Possible value for the " { $snippet "stderr" } " slot of a " { $link process } "." } ;
 
 HELP: +prepend-environment+
-{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence."
+{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "."
+$nl
+"If this value is set, the child process environment consists of the value of the " { $snippet "environment" } " slot together with the current environment, with entries from the current environment taking precedence."
 $nl
 "This is used in situations where you want to spawn a child process with some default environment variables set, but allowing the user to override these defaults by changing the environment before launching Factor." } ;
 
 HELP: +replace-environment+
-{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key."
+{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "."
+$nl
+"The child process environment consists of the value of the " { $snippet "environment" } " slot."
 $nl
 "This is used in situations where you want full control over a child process environment, perhaps for security or testing." } ;
 
 HELP: +append-environment+
-{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the current environment together with the value of the " { $link +environment+ } " key, with entries from the " { $link +environment+ } " key taking precedence."
+{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "."
+$nl
+"The child process environment consists of the current environment together with the value of the " { $snippet "environment" } " key, with entries from the " { $snippet "environment" } " key taking precedence."
 $nl
 "This is used in situations where you want a spawn child process with some overridden environment variables." } ;
 
-HELP: +timeout+
+ARTICLE: "io.launcher.timeouts" "Process run-time timeouts"
-{ $description "Launch descriptor key. If set to a " { $link duration } ", specifies a maximum running time for the process. If the process runs longer than this time, it will be killed." } ;
+"The " { $snippet "timeout" } " slot of a " { $link process } " can be set to a " { $link duration } " specifying a maximum running time for the process. If " { $link wait-for-process } " is called and the process does not exit before the duration expires, it will be killed." ;
-
-HELP: default-descriptor
-{ $description "Association storing default values for launch descriptor keys." } ;
-
-HELP: with-descriptor
-{ $values { "desc" "a launch descriptor" } { "quot" quotation } } 
-{ $description "Calls the quotation in a dynamic scope where keys from " { $snippet "desc" } " can be read as variables, and any keys not supplied assume their default value as set in " { $link default-descriptor } "." } ;
 
 HELP: get-environment
-{ $values { "env" "an association" } }
+{ $values { "process" process } { "env" "an association" } }
-{ $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ;
+{ $description "Combines the current environment with the value of the " { $snippet "environment" } " slot of the " { $link process } " using the " { $snippet "environment-mode" } " slot." } ;
 
 HELP: current-process-handle
 { $values { "handle" "a process handle" } }
@@ -110,20 +79,16 @@ HELP: run-process*
 { $contract "Launches a process using the launch descriptor." }
 { $notes "User code should call " { $link run-process } " instead." } ;
 
-HELP: >descriptor
-{ $values { "desc" "a launch descriptor" } { "desc" "a launch descriptor" } }
-{ $description "Creates a launch descriptor from an object. See " { $link "io.launcher.descriptors" } " for details." } ;
-
 HELP: run-process
 { $values { "desc" "a launch descriptor" } { "process" process } }
-{ $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." }
+{ $description "Launches a process. The object can either be a string, a sequence of strings or a " { $link process } ". See " { $link "io.launcher.descriptors" } " for details." }
 { $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ;
 
 HELP: run-detached
 { $values { "desc" "a launch descriptor" } { "process" process } }
-{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link "io.launcher.descriptors" } " for details." }
+{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a " { $link process } ". See " { $link "io.launcher.descriptors" } " for details." }
 { $notes
-    "This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set."
+    "This word is functionally identical to passing a " { $link process } " to " { $link run-process } " having the " { $snippet "detached" } " slot set."
     $nl
     "The output value can be passed to " { $link wait-for-process } " to get an exit code."
 } ;
@@ -147,11 +112,11 @@ HELP: kill-process*
 { $notes "User code should call " { $link kill-process } " intead." } ;
 
 HELP: process
-{ $class-description "A class representing an active or finished process."
+{ $class-description "A class representing a process. Instances are created by calling " { $link <process> } "." } ;
-$nl
+
-"Processes are output by " { $link run-process } " and " { $link run-detached } ", and are stored in the " { $link process-stream-process } " slot of " { $link process-stream } " instances."
+HELP: <process>
-$nl
+{ $values { "process" process } }
-"Processes can be passed to " { $link wait-for-process } "." } ;
+{ $description "Creates a new, empty process. It must be filled in before being passed to " { $link run-process } "." } ;
 
 HELP: process-stream
 { $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link <process-stream> } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ;
@@ -161,8 +126,7 @@ HELP: <process-stream>
   { "desc" "a launch descriptor" }
   { "encoding" "an encoding descriptor" }
   { "stream" "a bidirectional stream" } }
-{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." }
+{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ;
-{ $notes "Closing the stream will block until the process exits." } ;
 
 HELP: with-process-stream
 { $values
@@ -176,41 +140,82 @@ HELP: wait-for-process
 { $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ;
 
 ARTICLE: "io.launcher.descriptors" "Launch descriptors"
-"Words which launch processes can take either a command line string, a sequence of command line arguments, or an assoc:"
+"Words which launch processes can take either a command line string, a sequence of command line arguments, or a " { $link process } "."
-{ $list
+$nl
-    { "strings are wrapped in an assoc with a single " { $link +command+ } " key" }
+"Strings and string arrays are wrapped in a new empty " { $link process } " with the " { $snippet "command" } " slot set. This covers basic use-cases where no launch parameters need to be set."
-    { "sequences of strings are wrapped in an assoc with a single " { $link +arguments+ } " key" }
+$nl
-    { "associations can be passed in, which allows finer control over launch parameters" }
+"A " { $link process } " instance can be created directly and passed to launching words for more control. It must be a fresh instance which has never been spawned before. To spawn a process several times from the same descriptor, " { $link clone } " the descriptor first." ;
-}
-"The associations can contain the following keys:"
-{ $subsection +command+ }
-{ $subsection +arguments+ }
-{ $subsection +detached+ }
-{ $subsection +environment+ }
-{ $subsection +environment-mode+ }
-{ $subsection +timeout+ }
-{ $subsection +stdin+ }
-{ $subsection +stdout+ }
-{ $subsection +stderr+ } ;
 
-ARTICLE: "io.launcher" "Launching OS processes"
+ARTICLE: "io.launcher.lifecycle" "The process lifecycle"
-"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
+"A freshly instantiated " { $link process } " represents a set of launch parameters."
-{ $subsection "io.launcher.descriptors" }
+{ $subsection process }
-"The following words are used to launch processes:"
+{ $subsection <process> }
+"Words for launching processes take a fresh process which has never been started before as input, and output a copy as output."
+{ $subsection process-started? }
+"The " { $link process } " instance output by launching words contains all original slot values in addition to the " { $snippet "handle" } " slot, which indicates the process is currently running."
+{ $subsection process-running? }
+"It is possible to wait for a process to exit:"
+{ $subsection wait-for-process }
+"A running process can also be killed:"
+{ $subsection kill-process } ;
+
+ARTICLE: "io.launcher.launch" "Launching processes"
+"Launching processes:"
 { $subsection run-process }
-{ $subsection run-detached }
 { $subsection try-process }
-"Stopping processes:"
-{ $subsection kill-process }
-"Finding the current process handle:"
-{ $subsection current-process-handle }
 "Redirecting standard input and output to a pipe:"
 { $subsection <process-stream> }
-{ $subsection with-process-stream }
+{ $subsection with-process-stream } ;
-"A class representing an active or finished process:"
+
-{ $subsection process }
+ARTICLE: "io.launcher.examples" "Launcher examples"
-"Waiting for a process to end, or getting the exit code of a finished process:"
+"Starting a command and waiting for it to finish:"
-{ $subsection wait-for-process }
+{ $code
-"Processes support the " { $link "io.timeouts" } "; the timeout specifies an upper bound on the running time of the process." ;
+    "\"ls /etc\" run-process"
+}
+"Starting a program in the background:"
+{ $code
+    "{ \"emacs\" \"foo.txt\" } run-detached"
+}
+"Running a command, throwing an exception if it exits unsuccessfully:"
+{ $code
+    "\"make clean all\" try-process"
+}
+"Running a command, throwing an exception if it exits unsuccessfully or if it takes too long to run:"
+{ $code
+    "<process>"
+    "    \"make test\" >>command"
+    "    5 minutes >>timeout"
+    "try-process"
+}
+"Running a command, throwing an exception if it exits unsuccessfully, and redirecting output and error messages to a log file:"
+{ $code
+    "<process>"
+    "    \"make clean all\" >>command"
+    "    \"log.txt\" >>stdout"
+    "    +stdout+ >>stderr"
+    "try-process"
+}
+"Running a command, appending error messages to a log file, and reading the output for further processing:"
+{ $code
+    "\"log.txt\" <file-appender> ["
+    "    <process>"
+    "        swap >>stderr"
+    "        \"report\" >>command"
+    "    ascii <process-stream> lines sort reverse [ print ] each"
+    "] with-disposal"
+} ;
+
+ARTICLE: "io.launcher" "Operating system processes"
+"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
+{ $subsection "io.launcher.examples" }
+{ $subsection "io.launcher.descriptors" }
+{ $subsection "io.launcher.launch" }
+"Advanced topics:"
+{ $subsection "io.launcher.lifecycle" }
+{ $subsection "io.launcher.command" }
+{ $subsection "io.launcher.detached" }
+{ $subsection "io.launcher.environment" }
+{ $subsection "io.launcher.redirection" }
+{ $subsection "io.launcher.timeouts" } ;
 
 ABOUT: "io.launcher"

extra/io/launcher/launcher.factor

@@ -3,68 +3,71 @@
 USING: io io.backend io.timeouts system kernel namespaces
 strings hashtables sequences assocs combinators vocabs.loader
 init threads continuations math io.encodings io.streams.duplex
-io.nonblocking ;
+io.nonblocking new-slots accessors ;
 IN: io.launcher
 
+
+TUPLE: process
+
+command
+detached
+
+environment
+environment-mode
+
+stdin
+stdout
+stderr
+
+timeout
+
+handle status
+killed ;
+
+SYMBOL: +closed+
+SYMBOL: +inherit+
+SYMBOL: +stdout+
+
+SYMBOL: +prepend-environment+
+SYMBOL: +replace-environment+
+SYMBOL: +append-environment+
+
+: <process> ( -- process )
+    process construct-empty
+    H{ } clone >>environment
+    +append-environment+ >>environment-mode ;
+
+: process-started? ( process -- ? )
+    dup handle>> swap status>> or ;
+
+: process-running? ( process -- ? )
+    process-handle >boolean ;
+
 ! Non-blocking process exit notification facility
 SYMBOL: processes
 
 [ H{ } clone processes set-global ] "io.launcher" add-init-hook
 
-TUPLE: process handle status killed? timeout ;
-
 HOOK: register-process io-backend ( process -- )
 
 M: object register-process drop ;
 
-: <process> ( handle -- process )
+: process-started ( process handle -- )
-    f f f process construct-boa
+    >>handle
     V{ } clone over processes get set-at
-    dup register-process ;
+    register-process ;
 
 M: process equal? 2drop f ;
 
 M: process hashcode* process-handle hashcode* ;
 
-: process-running? ( process -- ? ) process-status not ;
+: pass-environment? ( process -- ? )
+    dup environment>> assoc-empty? not
+    swap environment-mode>> +replace-environment+ eq? or ;
 
-SYMBOL: +command+
+: get-environment ( process -- env )
-SYMBOL: +arguments+
+    dup environment>>
-SYMBOL: +detached+
+    swap environment-mode>> {
-SYMBOL: +environment+
-SYMBOL: +environment-mode+
-SYMBOL: +stdin+
-SYMBOL: +stdout+
-SYMBOL: +stderr+
-
-SYMBOL: +timeout+
-
-SYMBOL: +prepend-environment+
-SYMBOL: +replace-environment+
-SYMBOL: +append-environment+
-
-SYMBOL: +closed+
-SYMBOL: +inherit+
-
-: default-descriptor
-    H{
-        { +command+ f }
-        { +arguments+ f }
-        { +detached+ f }
-        { +environment+ H{ } }
-        { +environment-mode+ +append-environment+ }
-    } ;
-
-: with-descriptor ( desc quot -- )
-    default-descriptor [ >r clone r> bind ] bind ; inline
-
-: pass-environment? ( -- ? )
-    +environment+ get assoc-empty? not
-    +environment-mode+ get +replace-environment+ eq? or ;
-
-: get-environment ( -- env )
-    +environment+ get
-    +environment-mode+ get {
         { +prepend-environment+ [ os-envs union ] }
         { +append-environment+ [ os-envs swap union ] }
         { +replace-environment+ [ ] }
@@ -73,78 +76,81 @@ SYMBOL: +inherit+
 : string-array? ( obj -- ? )
     dup sequence? [ [ string? ] all? ] [ drop f ] if ;
 
-: >descriptor ( desc -- desc )
+GENERIC: >process ( obj -- process )
-    {
+
-        { [ dup string? ] [ +command+ associate ] }
+M: process >process
-        { [ dup string-array? ] [ +arguments+ associate ] }
+    dup process-started? [
-        { [ dup assoc? ] [ >hashtable ] }
+        "Process has already been started once" throw
-    } cond ;
+    ] when
+    clone ;
+
+M: object >process <process> swap >>command ;
 
 HOOK: current-process-handle io-backend ( -- handle )
 
-HOOK: run-process* io-backend ( desc -- handle )
+HOOK: run-process* io-backend ( process -- handle )
 
 : wait-for-process ( process -- status )
     [
-        dup process-handle
+        dup handle>>
         [
             dup [ processes get at push ] curry
             "process" suspend drop
         ] when
-        dup process-killed?
+        dup killed>>
-        [ "Process was killed" throw ] [ process-status ] if
+        [ "Process was killed" throw ] [ status>> ] if
     ] with-timeout ;
 
-: run-process ( desc -- process )
-    >descriptor
-    dup run-process*
-    +timeout+ pick at [ over set-timeout ] when*
-    +detached+ rot at [ dup wait-for-process drop ] unless ;
-
 : run-detached ( desc -- process )
-    >descriptor H{ { +detached+ t } } union run-process ;
+    >process
+    dup dup run-process* process-started
+    dup timeout>> [ over set-timeout ] when* ;
+
+: run-process ( desc -- process )
+    run-detached
+    dup detached>> [ dup wait-for-process drop ] unless ;
 
 TUPLE: process-failed code ;
 
 : process-failed ( code -- * )
     \ process-failed construct-boa throw ;
 
-: try-process ( desc -- )
+: try-process ( command/process -- )
     run-process wait-for-process dup zero?
     [ drop ] [ process-failed ] if ;
 
 HOOK: kill-process* io-backend ( handle -- )
 
 : kill-process ( process -- )
-    t over set-process-killed?
+    t >>killed
-    process-handle [ kill-process* ] when* ;
+    handle>> [ kill-process* ] when* ;
 
-M: process timeout process-timeout ;
+M: process timeout timeout>> ;
 
 M: process set-timeout set-process-timeout ;
 
 M: process timed-out kill-process ;
 
-HOOK: (process-stream) io-backend ( desc -- in out process )
+HOOK: (process-stream) io-backend ( process -- handle in out )
 
 TUPLE: process-stream process ;
 
 : <process-stream> ( desc encoding -- stream )
-    swap >descriptor
+    >r >process dup dup (process-stream)
-    [ (process-stream) >r rot <encoder-duplex> r> ] keep
+    >r >r process-started process-stream construct-boa
-    +timeout+ swap at [ over set-timeout ] when*
+    r> r> <reader&writer> r> <encoder-duplex>
-    { set-delegate set-process-stream-process }
+    over set-delegate ;
-    process-stream construct ;
 
 : with-process-stream ( desc quot -- status )
     swap <process-stream>
     [ swap with-stream ] keep
-    process-stream-process wait-for-process ; inline
+    process>> wait-for-process ; inline
 
-: notify-exit ( status process -- )
+: notify-exit ( process status -- )
-    [ set-process-status ] keep
+    >>status
     [ processes get delete-at* drop [ resume ] each ] keep
-    f swap set-process-handle ;
+    f >>handle
+    drop ;
 
 GENERIC: underlying-handle ( stream -- handle )
 

extra/io/nonblocking/nonblocking.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.nonblocking
 USING: math kernel io sequences io.buffers io.timeouts generic
-sbufs system io.streams.duplex io.encodings
+byte-vectors system io.streams.duplex io.encodings
 io.backend continuations debugger classes byte-arrays namespaces
 splitting dlists assocs io.encodings.binary ;
 
@@ -71,7 +71,7 @@ GENERIC: (wait-to-read) ( port -- )
 M: input-port stream-read1
     dup wait-to-read1 [ buffer-pop ] unless-eof ;
 
-: read-step ( count port -- string/f )
+: read-step ( count port -- byte-array/f )
     [ wait-to-read ] 2keep
     [ dupd buffer> ] unless-eof nip ;
 
@@ -90,10 +90,10 @@ M: input-port stream-read
     >r 0 max >fixnum r>
     2dup read-step dup [
         pick over length > [
-            pick <sbuf>
+            pick <byte-vector>
             [ push-all ] keep
             [ read-loop ] keep
-            "" like
+            B{ } like
         ] [
             2nip
         ] if
@@ -101,7 +101,7 @@ M: input-port stream-read
         2nip
     ] if ;
 
-: read-until-step ( separators port -- string/f separator/f )
+: read-until-step ( separators port -- byte-array/f separator/f )
     dup wait-to-read1
     dup port-eof? [
         f swap set-port-eof? drop f f
@@ -109,7 +109,7 @@ M: input-port stream-read
         buffer-until
     ] if ;
 
-: read-until-loop ( seps port sbuf -- separator/f )
+: read-until-loop ( seps port byte-vector -- separator/f )
     2over read-until-step over [
         >r over push-all r> dup [
             >r 3drop r>
@@ -120,18 +120,20 @@ M: input-port stream-read
         >r 2drop 2drop r>
     ] if ;
 
-M: input-port stream-read-until ( seps port -- str/f sep/f )
+M: input-port stream-read-until ( seps port -- byte-array/f sep/f )
     2dup read-until-step dup [
         >r 2nip r>
     ] [
         over [
-            drop >sbuf [ read-until-loop ] keep "" like swap
+            drop >byte-vector
+            [ read-until-loop ] keep
+            B{ } like swap
         ] [
             >r 2nip r>
         ] if
     ] if ;
 
-M: input-port stream-read-partial ( max stream -- string/f )
+M: input-port stream-read-partial ( max stream -- byte-array/f )
     >r 0 max >fixnum r> read-step ;
 
 : can-write? ( len writer -- ? )
@@ -169,7 +171,7 @@ M: port dispose
     [ dup port-type >r closed over set-port-type r> close-port ]
     if ;
 
-TUPLE: server-port addr client encoding ;
+TUPLE: server-port addr client client-addr encoding ;
 
 : <server-port> ( handle addr encoding -- server )
     rot f server-port <port>

extra/io/server/server.factor

@@ -40,11 +40,11 @@ PRIVATE>
     f swap t resolve-host ;
 
 : with-server ( seq service encoding quot -- )
-    V{ } clone [
+    V{ } clone servers [
-        swap servers [
+        [
             [ server-loop ] 2curry with-logging
-        ] with-variable
+        ] 3curry parallel-each
-    ] 3curry curry parallel-each ; inline
+    ] with-variable ; inline
 
 : stop-server ( -- )
     servers get [ dispose ] each ;

extra/io/sockets/sockets.factor

@@ -33,17 +33,19 @@ M: array client* [ (client) 2array ] attempt-all first2 ;
 M: object client* (client) ;
 
 : <client> ( addrspec encoding -- stream )
-    over client* rot <encoder-duplex> <client-stream> ;
+    >r client* r> <encoder-duplex> ;
 
 HOOK: (server) io-backend ( addrspec -- handle )
 
 : <server> ( addrspec encoding -- server )
     >r [ (server) ] keep r> <server-port> ;
 
-HOOK: (accept) io-backend ( server -- stream-in stream-out )
+HOOK: (accept) io-backend ( server -- addrspec handle )
 
 : accept ( server -- client )
-    [ (accept) ] keep server-port-encoding <encoder-duplex> ;
+    [ (accept) dup <reader&writer> ] keep
+    server-port-encoding <encoder-duplex>
+    <client-stream> ;
 
 HOOK: <datagram> io-backend ( addrspec -- datagram )
 

extra/io/unix/files/files.factor

@@ -90,3 +90,12 @@ M: unix-io file-info ( path -- info )
         [ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
     } cleave
     \ file-info construct-boa ;
+
+M: unix-io link-info ( path -- info )
+    lstat* {
+        [ stat>type ]
+        [ stat-st_size ]
+        [ stat-st_mode ]
+        [ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
+    } cleave
+    \ file-info construct-boa ;

extra/io/unix/kqueue/kqueue.factor

@@ -31,7 +31,8 @@ M: output-task io-task-filter drop EVFILT_WRITE ;
     swap io-task-filter over set-kevent-filter ;
 
 : register-kevent ( kevent mx -- )
-    mx-fd swap 1 f 0 f kevent io-error ;
+    mx-fd swap 1 f 0 f kevent
+    0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
 
 M: kqueue-mx register-io-task ( task mx -- )
     over EV_ADD make-kevent over register-kevent
@@ -53,7 +54,7 @@ M: kqueue-mx unregister-io-task ( task mx -- )
 
 : kevent-proc-task ( pid -- )
     dup wait-for-pid swap find-process
-    dup [ notify-exit ] [ 2drop ] if ;
+    dup [ swap notify-exit ] [ 2drop ] if ;
 
 : handle-kevent ( mx kevent -- )
     dup kevent-ident swap kevent-filter {

extra/io/unix/launcher/launcher-tests.factor

@@ -1,6 +1,7 @@
 IN: io.unix.launcher.tests
 USING: io.files tools.test io.launcher arrays io namespaces
-continuations math io.encodings.ascii ;
+continuations math io.encodings.ascii io.encodings.latin1
+accessors kernel sequences ;
 
 [ ] [
     [ "launcher-test-1" temp-file delete-file ] ignore-errors
@@ -20,10 +21,10 @@ continuations math io.encodings.ascii ;
 ] unit-test
 
 [ ] [
-    [
+    <process>
-        "echo Hello" +command+ set
+        "echo Hello" >>command
-        "launcher-test-1" temp-file +stdout+ set
+        "launcher-test-1" temp-file >>stdout
-    ] { } make-assoc try-process
+    try-process
 ] unit-test
 
 [ "Hello\n" ] [
@@ -34,12 +35,12 @@ continuations math io.encodings.ascii ;
 ] unit-test
 
 [ "" ] [
-    [
+    <process>
         "cat"
         "launcher-test-1" temp-file
-        2array +arguments+ set
+        2array >>command
-        +inherit+ +stdout+ set
+        +inherit+ >>stdout
-    ] { } make-assoc ascii <process-stream> contents
+    ascii <process-stream> contents
 ] unit-test
 
 [ ] [
@@ -47,11 +48,11 @@ continuations math io.encodings.ascii ;
 ] unit-test
 
 [ ] [
-    [
+    <process>
-        "cat" +command+ set
+        "cat" >>command
-        +closed+ +stdin+ set
+        +closed+ >>stdin
-        "launcher-test-1" temp-file +stdout+ set
+        "launcher-test-1" temp-file >>stdout
-    ] { } make-assoc try-process
+    try-process
 ] unit-test
 
 [ "" ] [
@@ -64,10 +65,10 @@ continuations math io.encodings.ascii ;
 [ ] [
     2 [
         "launcher-test-1" temp-file ascii <file-appender> [
-            [
+            <process>
-                +stdout+ set
+                swap >>stdout
-                "echo Hello" +command+ set
+                "echo Hello" >>command
-            ] { } make-assoc try-process
+            try-process
         ] with-disposal
     ] times
 ] unit-test
@@ -78,3 +79,19 @@ continuations math io.encodings.ascii ;
     2array
     ascii <process-stream> contents
 ] unit-test
+
+[ t ] [
+    <process>
+        "env" >>command
+        { { "A" "B" } } >>environment
+    latin1 <process-stream> lines
+    "A=B" swap member?
+] unit-test
+
+[ { "A=B" } ] [
+    <process>
+        "env" >>command
+        { { "A" "B" } } >>environment
+        +replace-environment+ >>environment-mode
+    latin1 <process-stream> lines
+] unit-test

extra/io/unix/launcher/launcher.factor

@@ -4,14 +4,14 @@ USING: io io.backend io.launcher io.nonblocking io.unix.backend
 io.unix.files io.nonblocking sequences kernel namespaces math
 system alien.c-types debugger continuations arrays assocs
 combinators unix.process strings threads unix
-io.unix.launcher.parser io.encodings.latin1 ;
+io.unix.launcher.parser io.encodings.latin1 accessors new-slots ;
 IN: io.unix.launcher
 
 ! Search unix first
 USE: unix
 
-: get-arguments ( -- seq )
+: get-arguments ( process -- seq )
-    +command+ get [ tokenize-command ] [ +arguments+ get ] if* ;
+    command>> dup string? [ tokenize-command ] when ;
 
 : assoc>env ( assoc -- env )
     [ "=" swap 3append ] { } assoc>map ;
@@ -44,28 +44,27 @@ USE: unix
 
 : ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
 
-: setup-redirection ( -- )
+: setup-redirection ( process -- process )
-    +stdin+ get ?closed read-flags 0 redirect
+    dup stdin>> ?closed read-flags 0 redirect
-    +stdout+ get ?closed write-flags 1 redirect
+    dup stdout>> ?closed write-flags 1 redirect
-    +stderr+ get dup +stdout+ eq?
+    dup stderr>> dup +stdout+ eq?
     [ drop 1 2 dup2 io-error ] [ ?closed write-flags 2 redirect ] if ;
 
-: spawn-process ( -- )
+: spawn-process ( process -- * )
     [
         setup-redirection
-        get-arguments
+        dup pass-environment? [
-        pass-environment?
+            dup get-environment set-os-envs
-        [ get-environment assoc>env exec-args-with-env ]
+        ] when
-        [ exec-args-with-path ] if
+
-        io-error
+        get-arguments exec-args-with-path
-    ] [ error. :c flush ] recover 1 exit ;
+        (io-error)
+    ] [ 255 exit ] recover ;
 
 M: unix-io current-process-handle ( -- handle ) getpid ;
 
-M: unix-io run-process* ( desc -- pid )
+M: unix-io run-process* ( process -- pid )
-    [
+    [ spawn-process ] curry [ ] with-fork ;
-        [ spawn-process ] [ ] with-fork <process>
-    ] with-descriptor ;
 
 M: unix-io kill-process* ( pid -- )
     SIGTERM kill io-error ;
@@ -78,21 +77,15 @@ M: unix-io kill-process* ( pid -- )
     2dup first close second close
     >r first 0 dup2 drop r> second 1 dup2 drop ;
 
-: spawn-process-stream ( -- in out pid )
-    open-pipe open-pipe [
-        setup-stdio-pipe
-        spawn-process
-    ] [
-        -rot 2dup second close first close
-    ] with-fork first swap second rot <process> ;
-
 M: unix-io (process-stream)
-    [
+    >r open-pipe open-pipe r>
-        spawn-process-stream >r <reader&writer> r>
+    [ >r setup-stdio-pipe r> spawn-process ] curry
-    ] with-descriptor ;
+    [ -rot 2dup second close first close ]
+    with-fork
+    first swap second ;
 
 : find-process ( handle -- process )
-    processes get swap [ nip swap process-handle = ] curry
+    processes get swap [ nip swap handle>> = ] curry
     assoc-find 2drop ;
 
 ! Inefficient process wait polling, used on Linux and Solaris.
@@ -103,7 +96,7 @@ M: unix-io (process-stream)
         2drop t
     ] [
         find-process dup [
-            >r *int WEXITSTATUS r> notify-exit f
+            swap *int WEXITSTATUS notify-exit f
         ] [
             2drop f
         ] if

extra/io/unix/sockets/sockets.factor

@@ -42,7 +42,7 @@ M: connect-task do-io-task
 : wait-to-connect ( port -- )
     [ <connect-task> add-io-task ] with-port-continuation drop ;
 
-M: unix-io (client) ( addrspec -- stream )
+M: unix-io (client) ( addrspec -- client-in client-out )
     dup make-sockaddr/size >r >r
     protocol-family SOCK_STREAM socket-fd
     dup r> r> connect
@@ -71,10 +71,10 @@ TUPLE: accept-task ;
     dup <c-object> [ swap heap-size <int> accept ] keep ; inline
 
 : do-accept ( port fd sockaddr -- )
-    rot [
+    rot
-        server-port-addr parse-sockaddr
+    [ server-port-addr parse-sockaddr ] keep
-        swap dup <reader&writer> <duplex-stream> <client-stream>
+    [ set-server-port-client-addr ] keep
-    ] keep set-server-port-client ;
+    set-server-port-client ;
 
 M: accept-task do-io-task
     io-task-port dup accept-sockaddr
@@ -95,13 +95,13 @@ M: unix-io (server) ( addrspec -- handle )
     SOCK_STREAM server-fd
     dup 10 listen zero? [ dup close (io-error) ] unless ;
 
-M: unix-io (accept) ( server -- client-in client-out )
+M: unix-io (accept) ( server -- addrspec handle )
     #! Wait for a client connection.
     dup check-server-port
     dup wait-to-accept
     dup pending-error
-    server-port-client
+    dup server-port-client-addr
-    { duplex-stream-in duplex-stream-out } get-slots ;
+    swap server-port-client ;
 
 ! Datagram sockets - UDP and Unix domain
 M: unix-io <datagram>

extra/io/windows/ce/ce.factor

@@ -3,4 +3,5 @@ io.windows.ce.files io.windows.ce.sockets io.windows.ce.launcher
 namespaces io.windows.mmap ;
 IN: io.windows.ce
 
+USE: io.windows.files
 T{ windows-ce-io } set-io-backend

extra/io/windows/files/files.factor

@@ -50,17 +50,20 @@ SYMBOL: +encrypted+
         { +encrypted+ FILE_ATTRIBUTE_ENCRYPTED }
     } get-flags ;
 
+: win32-file-type ( n -- symbol )
+    FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
+
 : WIN32_FIND_DATA>file-info
     {
-        [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ]
+        [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
         [
             [ WIN32_FIND_DATA-nFileSizeLow ]
             [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit
         ]
         [ WIN32_FIND_DATA-dwFileAttributes ]
-        [
+        ! [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp ]
-            WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp
+        [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp ]
-        ]
+        ! [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp ]
     } cleave
     \ file-info construct-boa ;
 
@@ -73,16 +76,15 @@ SYMBOL: +encrypted+
 
 : BY_HANDLE_FILE_INFORMATION>file-info
     {
-        [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes ]
+        [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type ]
         [
             [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
             [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit
         ]
         [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes ]
-        [
+        ! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ]
-            BY_HANDLE_FILE_INFORMATION-ftLastWriteTime
+        [ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ]
-            FILETIME>timestamp
+        ! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ]
-        ]
     } cleave
     \ file-info construct-boa ;
 

extra/io/windows/launcher/launcher.factor

@@ -5,7 +5,7 @@ io.windows io.windows.nt.pipes libc io.nonblocking
 io.streams.duplex windows.types math windows.kernel32 windows
 namespaces io.launcher kernel sequences windows.errors assocs
 splitting system threads init strings combinators
-io.backend ;
+io.backend new-slots accessors ;
 IN: io.windows.launcher
 
 TUPLE: CreateProcess-args
@@ -22,30 +22,25 @@ TUPLE: CreateProcess-args
        stdout-pipe stdin-pipe ;
 
 : default-CreateProcess-args ( -- obj )
-    0
+    CreateProcess-args construct-empty
+    0 >>dwCreateFlags
     "STARTUPINFO" <c-object>
-    "STARTUPINFO" heap-size over set-STARTUPINFO-cb
+    "STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
-    "PROCESS_INFORMATION" <c-object>
+    "PROCESS_INFORMATION" <c-object> >>lpProcessInformation
-    TRUE
+    TRUE >>bInheritHandles ;
-    {
-        set-CreateProcess-args-dwCreateFlags
-        set-CreateProcess-args-lpStartupInfo
-        set-CreateProcess-args-lpProcessInformation
-        set-CreateProcess-args-bInheritHandles
-    } \ CreateProcess-args construct ;
 
 : call-CreateProcess ( CreateProcess-args -- )
     {
-        CreateProcess-args-lpApplicationName
+        lpApplicationName>>
-        CreateProcess-args-lpCommandLine
+        lpCommandLine>>
-        CreateProcess-args-lpProcessAttributes
+        lpProcessAttributes>>
-        CreateProcess-args-lpThreadAttributes
+        lpThreadAttributes>>
-        CreateProcess-args-bInheritHandles
+        bInheritHandles>>
-        CreateProcess-args-dwCreateFlags
+        dwCreateFlags>>
-        CreateProcess-args-lpEnvironment
+        lpEnvironment>>
-        CreateProcess-args-lpCurrentDirectory
+        lpCurrentDirectory>>
-        CreateProcess-args-lpStartupInfo
+        lpStartupInfo>>
-        CreateProcess-args-lpProcessInformation
+        lpProcessInformation>>
     } get-slots CreateProcess win32-error=0/f ;
 
 : escape-argument ( str -- newstr )
@@ -54,66 +49,64 @@ TUPLE: CreateProcess-args
 : join-arguments ( args -- cmd-line )
     [ escape-argument ] map " " join ;
 
-: app-name/cmd-line ( -- app-name cmd-line )
+: app-name/cmd-line ( process -- app-name cmd-line )
-    +command+ get [
+    command>> dup string? [
         " " split1
     ] [
-        +arguments+ get unclip swap join-arguments
+        unclip swap join-arguments
-    ] if* ;
+    ] if ;
 
-: cmd-line ( -- cmd-line )
+: cmd-line ( process -- cmd-line )
-    +command+ get [ +arguments+ get join-arguments ] unless* ;
+    command>> dup string? [ join-arguments ] unless ;
 
-: fill-lpApplicationName
+: fill-lpApplicationName ( process args -- process args )
-    app-name/cmd-line
+    over app-name/cmd-line
-    pick set-CreateProcess-args-lpCommandLine
+    >r >>lpApplicationName
-    over set-CreateProcess-args-lpApplicationName ;
+    r> >>lpCommandLine ;
 
-: fill-lpCommandLine
+: fill-lpCommandLine ( process args -- process args )
-    cmd-line over set-CreateProcess-args-lpCommandLine ;
+    over cmd-line >>lpCommandLine ;
 
-: fill-dwCreateFlags
+: fill-dwCreateFlags ( process args -- process args )
     0
-    pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
+    pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
-    +detached+ get winnt? and [ DETACHED_PROCESS bitor ] when
+    pick detached>> winnt? and [ DETACHED_PROCESS bitor ] when
-    over set-CreateProcess-args-dwCreateFlags ;
+    >>dwCreateFlags ;
 
-: fill-lpEnvironment
+: fill-lpEnvironment ( process args -- process args )
-    pass-environment? [
+    over pass-environment? [
         [
-            get-environment
+            over get-environment
-            [ "=" swap 3append string>u16-alien % ] assoc-each
+            [ swap % "=" % % "\0" % ] assoc-each
             "\0" %
-        ] { } make >c-ushort-array
+        ] "" make >c-ushort-array
-        over set-CreateProcess-args-lpEnvironment
+        >>lpEnvironment
     ] when ;
 
-: fill-startup-info
+: fill-startup-info ( process args -- process args )
-    dup CreateProcess-args-lpStartupInfo
+    STARTF_USESTDHANDLES over lpStartupInfo>> set-STARTUPINFO-dwFlags ;
-    STARTF_USESTDHANDLES swap set-STARTUPINFO-dwFlags ;
 
-HOOK: fill-redirection io-backend ( args -- args )
+HOOK: fill-redirection io-backend ( process args -- )
 
-M: windows-ce-io fill-redirection ;
+M: windows-ce-io fill-redirection 2drop ;
 
-: make-CreateProcess-args ( -- args )
+: make-CreateProcess-args ( process -- args )
     default-CreateProcess-args
     wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
     fill-dwCreateFlags
     fill-lpEnvironment
-    fill-startup-info ;
+    fill-startup-info
+    nip ;
 
 M: windows-io current-process-handle ( -- handle )
     GetCurrentProcessId ;
 
-M: windows-io run-process* ( desc -- handle )
+M: windows-io run-process* ( process -- handle )
     [
-        [
+        dup make-CreateProcess-args
-            make-CreateProcess-args
+        tuck fill-redirection
-            fill-redirection
+        dup call-CreateProcess
-            dup call-CreateProcess
+        lpProcessInformation>>
-            CreateProcess-args-lpProcessInformation <process>
-        ] with-descriptor
     ] with-destructors ;
 
 M: windows-io kill-process* ( handle -- )
@@ -134,7 +127,7 @@ M: windows-io kill-process* ( handle -- )
 : process-exited ( process -- )
     dup process-handle exit-code
     over process-handle dispose-process
-    swap notify-exit ;
+    notify-exit ;
 
 : wait-for-processes ( processes -- ? )
     keys dup

extra/io/windows/nt/launcher/launcher-tests.factor

@@ -0,0 +1,131 @@
+IN: io.windows.launcher.nt.tests
+USING: io.launcher tools.test calendar accessors
+namespaces kernel system arrays io io.files io.encodings.ascii
+sequences parser assocs hashtables ;
+
+[ ] [
+    <process>
+        "notepad" >>command
+        1/2 seconds >>timeout
+    "notepad" set
+] unit-test
+
+[ f ] [ "notepad" get process-running? ] unit-test
+
+[ f ] [ "notepad" get process-started? ] unit-test
+
+[ ] [ "notepad" [ run-detached ] change ] unit-test
+
+[ "notepad" get wait-for-process ] must-fail
+
+[ t ] [ "notepad" get killed>> ] unit-test
+
+[ f ] [ "notepad" get process-running? ] unit-test
+
+[ ] [
+    <process>
+        vm "-quiet" "-run=hello-world" 3array >>command
+        "out.txt" temp-file >>stdout
+    try-process
+] unit-test
+
+[ "Hello world" ] [
+    "out.txt" temp-file ascii file-lines first
+] unit-test
+
+[ ] [
+    <process>
+        vm "-run=listener" 2array >>command
+        +closed+ >>stdin
+    try-process
+] unit-test
+
+[ ] [
+    "extra/io/windows/nt/launcher/test" resource-path [
+        <process>
+            vm "-script" "stderr.factor" 3array >>command
+            "out.txt" temp-file >>stdout
+            "err.txt" temp-file >>stderr
+        try-process
+    ] with-directory
+] unit-test
+
+[ "output" ] [
+    "out.txt" temp-file ascii file-lines first
+] unit-test
+
+[ "error" ] [
+    "err.txt" temp-file ascii file-lines first
+] unit-test
+
+[ ] [
+    "extra/io/windows/nt/launcher/test" resource-path [
+        <process>
+            vm "-script" "stderr.factor" 3array >>command
+            "out.txt" temp-file >>stdout
+            +stdout+ >>stderr
+        try-process
+    ] with-directory
+] unit-test
+
+[ "outputerror" ] [
+    "out.txt" temp-file ascii file-lines first
+] unit-test
+
+[ "output" ] [
+    "extra/io/windows/nt/launcher/test" resource-path [
+        <process>
+            vm "-script" "stderr.factor" 3array >>command
+            "err2.txt" temp-file >>stderr
+        ascii <process-stream> lines first
+    ] with-directory
+] unit-test
+
+[ "error" ] [
+    "err2.txt" temp-file ascii file-lines first
+] unit-test
+
+[ t ] [
+    "extra/io/windows/nt/launcher/test" resource-path [
+        <process>
+            vm "-script" "env.factor" 3array >>command
+        ascii <process-stream> contents
+    ] with-directory eval
+
+    os-envs =
+] unit-test
+
+[ t ] [
+    "extra/io/windows/nt/launcher/test" resource-path [
+        <process>
+            vm "-script" "env.factor" 3array >>command
+            +replace-environment+ >>environment-mode
+            os-envs >>environment
+        ascii <process-stream> contents
+    ] with-directory eval
+    
+    os-envs =
+] unit-test
+
+[ "B" ] [
+    "extra/io/windows/nt/launcher/test" resource-path [
+        <process>
+            vm "-script" "env.factor" 3array >>command
+            { { "A" "B" } } >>environment
+        ascii <process-stream> contents
+    ] with-directory eval
+
+    "A" swap at
+] unit-test
+
+[ f ] [
+    "extra/io/windows/nt/launcher/test" resource-path [
+        <process>
+            vm "-script" "env.factor" 3array >>command
+            { { "HOME" "XXX" } } >>environment
+            +prepend-environment+ >>environment-mode
+        ascii <process-stream> contents
+    ] with-directory eval
+
+    "HOME" swap at "XXX" =
+] unit-test

extra/io/windows/nt/launcher/launcher.factor

@@ -5,7 +5,7 @@ io.windows libc io.nonblocking io.streams.duplex windows.types
 math windows.kernel32 windows namespaces io.launcher kernel
 sequences windows.errors assocs splitting system strings
 io.windows.launcher io.windows.nt.pipes io.backend
-combinators shuffle ;
+combinators shuffle accessors locals ;
 IN: io.windows.nt.launcher
 
 : duplicate-handle ( handle -- handle' )
@@ -31,13 +31,12 @@ IN: io.windows.nt.launcher
 : redirect-closed ( default obj access-mode create-mode -- handle )
     drop 2nip null-pipe ;
 
-: redirect-file ( default path access-mode create-mode -- handle )
+:: redirect-file ( default path access-mode create-mode -- handle )
-    >r >r >r drop r>
+    path normalize-pathname
-    normalize-pathname
+    access-mode
-    r> ! access-mode
     share-mode
     security-attributes-inherit
-    r> ! create-mode
+    create-mode
     FILE_ATTRIBUTE_NORMAL ! flags and attributes
     f ! template file
     CreateFile dup invalid-handle? dup close-later ;
@@ -60,24 +59,25 @@ IN: io.windows.nt.launcher
     } cond ;
 
 : default-stdout ( args -- handle )
-    CreateProcess-args-stdout-pipe dup [ pipe-out ] when ;
+    stdout-pipe>> dup [ pipe-out ] when ;
 
-: redirect-stdout ( args -- handle )
+: redirect-stdout ( process args -- handle )
     default-stdout
-    +stdout+ get
+    swap stdout>>
     GENERIC_WRITE
     CREATE_ALWAYS
     redirect
     STD_OUTPUT_HANDLE GetStdHandle or ;
 
-: redirect-stderr ( args -- handle )
+: redirect-stderr ( process args -- handle )
-    +stderr+ get +stdout+ eq? [
+    over stderr>> +stdout+ eq? [
-        CreateProcess-args-lpStartupInfo
+        lpStartupInfo>>
         STARTUPINFO-hStdOutput
+        nip
     ] [
         drop
         f
-        +stderr+ get
+        swap stderr>>
         GENERIC_WRITE
         CREATE_ALWAYS
         redirect
@@ -85,11 +85,11 @@ IN: io.windows.nt.launcher
     ] if ;
 
 : default-stdin ( args -- handle )
-    CreateProcess-args-stdin-pipe dup [ pipe-in ] when ;
+    stdin-pipe>> dup [ pipe-in ] when ;
 
-: redirect-stdin ( args -- handle )
+: redirect-stdin ( process args -- handle )
     default-stdin
-    +stdin+ get
+    swap stdin>>
     GENERIC_READ
     OPEN_EXISTING
     redirect
@@ -97,48 +97,42 @@ IN: io.windows.nt.launcher
 
 : add-pipe-dtors ( pipe -- )
     dup
-    pipe-in close-later
+    in>> close-later
-    pipe-out close-later ;
+    out>> close-later ;
 
-: fill-stdout-pipe
+: fill-stdout-pipe ( args -- args )
     <unique-incoming-pipe>
     dup add-pipe-dtors
     dup pipe-in f set-inherit
-    over set-CreateProcess-args-stdout-pipe ;
+    >>stdout-pipe ;
 
-: fill-stdin-pipe
+: fill-stdin-pipe ( args -- args )
     <unique-outgoing-pipe>
     dup add-pipe-dtors
     dup pipe-out f set-inherit
-    over set-CreateProcess-args-stdin-pipe ;
+    >>stdin-pipe ;
 
-M: windows-nt-io fill-redirection
+M: windows-nt-io fill-redirection ( process args -- )
-    dup CreateProcess-args-lpStartupInfo
+    [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput
-    over redirect-stdout over set-STARTUPINFO-hStdOutput
+    [ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError
-    over redirect-stderr over set-STARTUPINFO-hStdError
+    [ 2dup redirect-stdin  ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput
-    over redirect-stdin over set-STARTUPINFO-hStdInput
+    2drop ;
-    drop ;
 
 M: windows-nt-io (process-stream)
     [
-        [
+        dup make-CreateProcess-args
-            make-CreateProcess-args
 
-            fill-stdout-pipe
+        fill-stdout-pipe
-            fill-stdin-pipe
+        fill-stdin-pipe
 
-            fill-redirection
+        tuck fill-redirection
 
-            dup call-CreateProcess
+        dup call-CreateProcess
 
-            dup CreateProcess-args-stdin-pipe pipe-in CloseHandle drop
+        dup stdin-pipe>> pipe-in CloseHandle drop
-            dup CreateProcess-args-stdout-pipe pipe-out CloseHandle drop
+        dup stdout-pipe>> pipe-out CloseHandle drop
 
-            dup CreateProcess-args-stdout-pipe pipe-in
+        dup lpProcessInformation>>
-            over CreateProcess-args-stdin-pipe pipe-out
+        over stdout-pipe>> in>> f <win32-file>
-
+        rot stdin-pipe>> out>> f <win32-file>
-            [ f <win32-file> ] 2apply <reader&writer>
+    ] with-destructors ;
-
-            rot CreateProcess-args-lpProcessInformation <process>
-        ] with-destructors
-    ] with-descriptor ;

extra/io/windows/nt/launcher/test/env.factor

@@ -0,0 +1,3 @@
+USE: system
+USE: prettyprint
+os-envs .

extra/io/windows/nt/launcher/test/stderr.factor

@@ -0,0 +1,5 @@
+USE: io
+USE: namespaces
+
+"output" write flush
+"error" stderr get stream-write stderr get stream-flush