Merge branch 'master' of git://factorcode.org/git/factor into unicode
Daniel Ehrenberg
commit
191a61a024
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -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? [
|
||||
2drop probe (key@)
|
||||
] [
|
||||
dup ((empty)) eq? [
|
||||
3drop nip f f
|
||||
] [
|
||||
= [ rot drop t ] [ probe (key@) ] if
|
||||
] if
|
||||
] if ; inline
|
||||
3dup swap array-nth
|
||||
dup ((empty)) eq?
|
||||
[ 3drop nip f f ]
|
||||
[
|
||||
=
|
||||
[ rot drop t ]
|
||||
[ probe (key@) ]
|
||||
if
|
||||
]
|
||||
if ; inline
|
||||
|
||||
: key@ ( key hash -- array n ? )
|
||||
hash-array 2dup hash@ (key@) ; inline
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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+
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
[
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
io.backend io.streams.duplex io.files continuations
|
||||
io.encodings.utf8 ;
|
||||
sequences math generic threads.private classes io.backend
|
||||
io.streams.duplex io.files continuations byte-arrays ;
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
dup [ slot-spec-offset slot t ] [ 2drop f f ] if ;
|
||||
mirror@ 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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) ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
[ ] [
|
||||
|
|
|
|||
|
|
@ -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? ;
|
||||
|
|
|
|||
|
|
@ -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*>
|
||||
{ "make" } >>arguments
|
||||
<process>
|
||||
{ "make" } >>command
|
||||
"../compile-log" >>stdout
|
||||
+stdout+ >>stderr
|
||||
>desc ;
|
||||
+stdout+ >>stderr ;
|
||||
|
||||
: 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*>
|
||||
bootstrap-cmd >>arguments
|
||||
<process>
|
||||
bootstrap-cmd >>command
|
||||
+closed+ >>stdin
|
||||
"../boot-log" >>stdout
|
||||
+stdout+ >>stderr
|
||||
20 minutes >>timeout
|
||||
>desc ;
|
||||
20 minutes >>timeout ;
|
||||
|
||||
: 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*>
|
||||
builder-test-cmd >>arguments
|
||||
<process>
|
||||
builder-test-cmd >>command
|
||||
+closed+ >>stdin
|
||||
"../test-log" >>stdout
|
||||
+stdout+ >>stderr
|
||||
45 minutes >>timeout
|
||||
>desc ;
|
||||
45 minutes >>timeout ;
|
||||
|
||||
: 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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[ do-load ] runtime "../load-time" [ . ] with-file-writer
|
||||
[ do-tests ] runtime "../test-time" [ . ] with-file-writer
|
||||
bootstrap-time get "../boot-time" utf8 [ . ] with-file-writer
|
||||
[ do-load ] runtime "../load-time" utf8 [ . ] with-file-writer
|
||||
[ do-tests ] runtime "../test-time" utf8 [ . ] with-file-writer
|
||||
do-benchmarks ;
|
||||
|
||||
MAIN: do-all
|
||||
|
|
@ -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 )
|
||||
H{ } clone
|
||||
over arguments>> [ +arguments+ swap put-at ] when*
|
||||
over stdin>> [ +stdin+ swap put-at ] when*
|
||||
over stdout>> [ +stdout+ swap put-at ] when*
|
||||
over stderr>> [ +stderr+ swap put-at ] when*
|
||||
over timeout>> [ +timeout+ swap put-at ] when*
|
||||
nip ;
|
||||
! : >desc ( process* -- desc )
|
||||
! H{ } clone
|
||||
! over arguments>> [ +arguments+ swap put-at ] when*
|
||||
! over stdin>> [ +stdin+ swap put-at ] when*
|
||||
! over stdout>> [ +stdout+ swap put-at ] when*
|
||||
! over stderr>> [ +stderr+ swap put-at ] when*
|
||||
! over timeout>> [ +timeout+ swap put-at ] when*
|
||||
! 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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
"-" expect
|
||||
read-00 ! month
|
||||
"-" expect
|
||||
read-00 ! day
|
||||
read-ymd
|
||||
"Tt" expect
|
||||
read-00 ! hour
|
||||
":" expect
|
||||
read-00 ! minute
|
||||
":" expect
|
||||
read-00 ! second
|
||||
read-hms
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
{ (>>sql) (>>params) (>>handle) } result-set
|
||||
>r >r { sql>> in-params>> out-params>> } get-slots r>
|
||||
{ (>>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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
>r result-set-handle r> sqlite-column-typed ;
|
||||
M: sqlite-result-set row-column-typed ( result-set n -- obj )
|
||||
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? [
|
||||
drop
|
||||
] [
|
||||
" where " 0%
|
||||
[ ", " 0% ]
|
||||
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
|
||||
] if
|
||||
";" 0%
|
||||
dup empty? [ drop ] [ where-clause ] 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
|
||||
|
|
|
|||
Binary file not shown.
|
|
@ -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
|
||||
prettyprint tools.walker db.sqlite ;
|
||||
db.types continuations namespaces math
|
||||
prettyprint tools.walker db.sqlite calendar
|
||||
math.intervals ;
|
||||
IN: db.tuples.tests
|
||||
|
||||
TUPLE: person the-id the-name the-number the-real ;
|
||||
: <person> ( name age real -- person )
|
||||
TUPLE: person the-id the-name the-number the-real ts date time blob ;
|
||||
: <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: the-person2
|
||||
SYMBOL: person1
|
||||
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
|
||||
"johnny" 10 3.14 <person> the-person2 set ;
|
||||
"billy" 10 3.14 f f f f <person> person1 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
|
||||
2 "johnny" 10 3.14 <assigned-person> the-person2 set ;
|
||||
|
||||
1 "billy" 10 3.14 f f f f <assigned-person> person1 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 ( -- )
|
||||
>r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ;
|
||||
! : test-postgresql ( -- )
|
||||
! >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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
sql-spec-slot-name r> set-slot-named
|
||||
>r 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
|
||||
sql-spec-slot-name r> set-slot-named
|
||||
>r sql-spec-slot-name r> set-slot-named
|
||||
] curry 2each ;
|
||||
|
||||
: sql-props ( class -- columns table )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
math.parser io.encodings.ascii ;
|
||||
editors io.files io.sockets io.streams.byte-array io.binary
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
Slava Pestov
|
||||
Doug Coleman
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Action-based web framework
|
||||
|
|
@ -1 +0,0 @@
|
|||
enterprise
|
||||
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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
|
||||
|
|
@ -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* ;
|
||||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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{
|
||||
|
|
|
|||
|
|
@ -1,8 +1,44 @@
|
|||
USING: assocs html.parser kernel math sequences strings ascii
|
||||
arrays shuffle unicode.case namespaces splitting
|
||||
http.server.responders ;
|
||||
arrays shuffle unicode.case namespaces splitting http
|
||||
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
|
||||
[ ] subset ;
|
||||
[ tag-link ] 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 )
|
||||
[ 0 -rot (find-all) ] { } make ;
|
||||
: find-by-text ( seq quot -- tag )
|
||||
[ 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 )
|
||||
"?" split1 nip query>hash ;
|
||||
: query>assoc* ( str -- 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
|
||||
|
|
|
|||
|
|
@ -23,6 +23,5 @@ tuple-syntax namespaces ;
|
|||
[
|
||||
"http://www.apple.com/index.html"
|
||||
<get-request>
|
||||
request-with-url
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
dup host>> over port>> <inet> <client> stdio set
|
||||
dup "r" set-global write-request flush read-response
|
||||
do-redirect ;
|
||||
: request-addr ( request -- addr )
|
||||
dup host>> swap port>> <inet> ;
|
||||
|
||||
: close-on-error ( stream quot -- )
|
||||
[ with-stream* ] curry [ ] pick [ dispose ] curry cleanup ;
|
||||
inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: http-request ( url request -- response stream )
|
||||
[
|
||||
request-with-url
|
||||
: http-request ( request -- response stream )
|
||||
dup request [
|
||||
dup request-addr latin1 <client>
|
||||
1 minutes over set-timeout
|
||||
[
|
||||
(http-request)
|
||||
1 minutes over set-timeout
|
||||
] [ ] [ stdio get dispose ] cleanup
|
||||
] with-scope ;
|
||||
write-request flush
|
||||
read-response
|
||||
do-redirect
|
||||
] close-on-error
|
||||
] with-variable ;
|
||||
|
||||
: <get-request> ( -- request )
|
||||
<request> "GET" >>method ;
|
||||
: <get-request> ( url -- request )
|
||||
<request> request-with-url "GET" >>method ;
|
||||
|
||||
: http-get-stream ( url -- response stream )
|
||||
<get-request> http-request ;
|
||||
|
||||
: success? ( code -- ? ) 200 = ;
|
||||
|
||||
: check-response ( response stream -- stream )
|
||||
swap code>> success?
|
||||
[ dispose "HTTP download failed" throw ] unless ;
|
||||
: check-response ( response -- )
|
||||
code>> success?
|
||||
[ "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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
[ + ]
|
||||
{ { "a" [ string>number ] } { "b" [ string>number ] } }
|
||||
"GET" <action> "action-1" set
|
||||
<action>
|
||||
[ "a" get "b" get + ] >>get
|
||||
{ { "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 ]
|
||||
{ { +path+ [ ] } { "xxx" [ string>number ] } }
|
||||
"POST" <action> "action-2" set
|
||||
<action>
|
||||
[ +path+ get "xxx" get "X" <repetition> concat append ] >>post
|
||||
{ { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params
|
||||
"action-2" set
|
||||
|
||||
STRING: action-request-test-2
|
||||
POST http://foo/bar/baz HTTP/1.1
|
||||
|
|
|
|||
|
|
@ -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 -- ... )
|
||||
params>> [ first2 >r swap at r> call ] with each ;
|
||||
: action-params ( request path param -- error? )
|
||||
-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
|
||||
pick method>> over method>> = [
|
||||
>r extract-params r>
|
||||
[ push-params ] keep
|
||||
quot>> call
|
||||
] [
|
||||
3drop <400>
|
||||
] if ;
|
||||
action set
|
||||
over request set
|
||||
over method>>
|
||||
{
|
||||
{ "GET" [ get-action ] }
|
||||
{ "POST" [ post-action ] }
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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> ;
|
||||
|
|
@ -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>
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -41,18 +41,17 @@ IN: http.server.cgi
|
|||
] when
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: cgi-descriptor ( name -- desc )
|
||||
[
|
||||
dup 1array +arguments+ set
|
||||
cgi-variables +environment+ set
|
||||
] H{ } make-assoc ;
|
||||
: <cgi-process> ( name -- desc )
|
||||
<process>
|
||||
over 1array >>command
|
||||
swap cgi-variables >>environment ;
|
||||
|
||||
: 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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 [
|
||||
db set responder>> call-responder
|
||||
] with-disposal ;
|
||||
dup connect-db responder>> call-responder ;
|
||||
|
|
|
|||
|
|
@ -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 ( -- )
|
||||
default-timeout
|
||||
: ?refresh-all ( -- )
|
||||
development-mode get-global
|
||||
[ global [ refresh-all ] bind ] when
|
||||
read-request
|
||||
dup log-request
|
||||
do-request do-response ;
|
||||
[ global [ refresh-all ] bind ] when ;
|
||||
|
||||
: handle-client ( -- )
|
||||
[
|
||||
default-timeout
|
||||
?refresh-all
|
||||
read-request
|
||||
dup log-request
|
||||
do-request do-response
|
||||
] with-destructors ;
|
||||
|
||||
: httpd ( port -- )
|
||||
internet-server "http.server"
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
[ 0 "x" sset ] >>init
|
||||
<foo> <url-sessions>
|
||||
"manager" set
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -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' )
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
8
extra/http/server/templating/templating-tests.factor → extra/http/server/templating/fhtml/fhtml-tests.factor
Normal file → Executable file
8
extra/http/server/templating/templating-tests.factor → extra/http/server/templating/fhtml/fhtml-tests.factor
Normal file → Executable file
|
|
@ -1,9 +1,9 @@
|
|||
USING: io io.files io.streams.string http.server.templating kernel tools.test
|
||||
sequences io.encodings.utf8 ;
|
||||
IN: http.server.templating.tests
|
||||
USING: io io.files io.streams.string io.encodings.utf8
|
||||
http.server.templating.fhtml kernel tools.test sequences ;
|
||||
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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
<html><head><title>Hello</title></head><body>HTTPd test</body></html>
|
||||
|
|
@ -1 +1,2 @@
|
|||
Doug Coleman
|
||||
Slava Pestov
|
||||
|
|
|
|||
|
|
@ -4,102 +4,71 @@ USING: help.markup help.syntax quotations kernel io math
|
|||
calendar ;
|
||||
IN: io.launcher
|
||||
|
||||
HELP: +command+
|
||||
{ $description "Launch descriptor key. A command line string, to be processed by the system's shell." } ;
|
||||
ARTICLE: "io.launcher.command" "Specifying a command"
|
||||
"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+
|
||||
{ $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." } ;
|
||||
ARTICLE: "io.launcher.detached" "Running processes in the background"
|
||||
"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+
|
||||
{ $description "Launch descriptor key. A boolean indicating whether " { $link run-process } " will return immediately, rather than wait for the program to complete."
|
||||
ARTICLE: "io.launcher.environment" "Setting environment variables"
|
||||
"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 } "." }
|
||||
{ $notes "Cannot be used with " { $link <process-stream> } "." }
|
||||
{ $see-also run-detached } ;
|
||||
"The " { $snippet "environment-mode" } " slot controls how the environment of the current Factor instance is composed with the value of the " { $snippet "environment" } " slot:"
|
||||
{ $subsection +prepend-environment+ }
|
||||
{ $subsection +replace-environment+ }
|
||||
{ $subsection +append-environment+ }
|
||||
"The default value is " { $link +append-environment+ } "." ;
|
||||
|
||||
HELP: +environment+
|
||||
{ $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."
|
||||
ARTICLE: "io.launcher.redirection" "Input/output redirection"
|
||||
"On all operating systems except for Windows CE, the default input/output/error streams can be redirected."
|
||||
$nl
|
||||
"Default value is an empty association." } ;
|
||||
|
||||
HELP: +environment-mode+
|
||||
{ $description "Launch descriptor key. Must equal of the following:"
|
||||
{ $list
|
||||
{ $link +prepend-environment+ }
|
||||
{ $link +replace-environment+ }
|
||||
{ $link +append-environment+ }
|
||||
}
|
||||
"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" }
|
||||
}
|
||||
"To specify redirection, set the " { $snippet "stdin" } ", " { $snippet "stdout" } " and " { $snippet "stderr" } " slots of a " { $link process } " to one of the following values:"
|
||||
{ $list
|
||||
{ { $link f } " - default value; the stream is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
|
||||
{ { $link +inherit+ } " - the stream is inherited from the current process, overriding a " { $link <process-stream> } " pipe" }
|
||||
{ { $link +closed+ } " - the stream is closed; reads will return end of file and writes will fails" }
|
||||
{ { $link +stdout+ } " - a special value for the " { $snippet "stderr" } " slot only, indicating that the standard output and standard error streams should be merged" }
|
||||
{ "a path name - the stream is sent to the given file, which must exist for input and is created automatically on output" }
|
||||
{ "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" }
|
||||
} ;
|
||||
|
||||
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+
|
||||
{ $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." } ;
|
||||
|
||||
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 } "." } ;
|
||||
ARTICLE: "io.launcher.timeouts" "Process run-time timeouts"
|
||||
"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: get-environment
|
||||
{ $values { "env" "an association" } }
|
||||
{ $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ;
|
||||
{ $values { "process" process } { "env" "an association" } }
|
||||
{ $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."
|
||||
$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."
|
||||
$nl
|
||||
"Processes can be passed to " { $link wait-for-process } "." } ;
|
||||
{ $class-description "A class representing a process. Instances are created by calling " { $link <process> } "." } ;
|
||||
|
||||
HELP: <process>
|
||||
{ $values { "process" 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." }
|
||||
{ $notes "Closing the stream will block until the process exits." } ;
|
||||
{ $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." } ;
|
||||
|
||||
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:"
|
||||
{ $list
|
||||
{ "strings are wrapped in an assoc with a single " { $link +command+ } " key" }
|
||||
{ "sequences of strings are wrapped in an assoc with a single " { $link +arguments+ } " key" }
|
||||
{ "associations can be passed in, which allows finer control over launch parameters" }
|
||||
}
|
||||
"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+ } ;
|
||||
"Words which launch processes can take either a command line string, a sequence of command line arguments, or a " { $link process } "."
|
||||
$nl
|
||||
"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."
|
||||
$nl
|
||||
"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." ;
|
||||
|
||||
ARTICLE: "io.launcher" "Launching OS processes"
|
||||
"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
|
||||
{ $subsection "io.launcher.descriptors" }
|
||||
"The following words are used to launch processes:"
|
||||
ARTICLE: "io.launcher.lifecycle" "The process lifecycle"
|
||||
"A freshly instantiated " { $link process } " represents a set of launch parameters."
|
||||
{ $subsection process }
|
||||
{ $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 }
|
||||
"A class representing an active or finished process:"
|
||||
{ $subsection process }
|
||||
"Waiting for a process to end, or getting the exit code of a finished process:"
|
||||
{ $subsection wait-for-process }
|
||||
"Processes support the " { $link "io.timeouts" } "; the timeout specifies an upper bound on the running time of the process." ;
|
||||
{ $subsection with-process-stream } ;
|
||||
|
||||
ARTICLE: "io.launcher.examples" "Launcher examples"
|
||||
"Starting a command and waiting for it to finish:"
|
||||
{ $code
|
||||
"\"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"
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
f f f process construct-boa
|
||||
: process-started ( process handle -- )
|
||||
>>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+
|
||||
SYMBOL: +arguments+
|
||||
SYMBOL: +detached+
|
||||
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 {
|
||||
: get-environment ( process -- env )
|
||||
dup environment>>
|
||||
swap environment-mode>> {
|
||||
{ +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 )
|
||||
{
|
||||
{ [ dup string? ] [ +command+ associate ] }
|
||||
{ [ dup string-array? ] [ +arguments+ associate ] }
|
||||
{ [ dup assoc? ] [ >hashtable ] }
|
||||
} cond ;
|
||||
GENERIC: >process ( obj -- process )
|
||||
|
||||
M: process >process
|
||||
dup process-started? [
|
||||
"Process has already been started once" throw
|
||||
] 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?
|
||||
[ "Process was killed" throw ] [ process-status ] if
|
||||
dup killed>>
|
||||
[ "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?
|
||||
process-handle [ kill-process* ] when* ;
|
||||
t >>killed
|
||||
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
|
||||
[ (process-stream) >r rot <encoder-duplex> r> ] keep
|
||||
+timeout+ swap at [ over set-timeout ] when*
|
||||
{ set-delegate set-process-stream-process }
|
||||
process-stream construct ;
|
||||
>r >process dup dup (process-stream)
|
||||
>r >r process-started process-stream construct-boa
|
||||
r> r> <reader&writer> r> <encoder-duplex>
|
||||
over set-delegate ;
|
||||
|
||||
: 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 -- )
|
||||
[ set-process-status ] keep
|
||||
: notify-exit ( process status -- )
|
||||
>>status
|
||||
[ processes get delete-at* drop [ resume ] each ] keep
|
||||
f swap set-process-handle ;
|
||||
f >>handle
|
||||
drop ;
|
||||
|
||||
GENERIC: underlying-handle ( stream -- handle )
|
||||
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -40,11 +40,11 @@ PRIVATE>
|
|||
f swap t resolve-host ;
|
||||
|
||||
: with-server ( seq service encoding quot -- )
|
||||
V{ } clone [
|
||||
swap servers [
|
||||
V{ } clone servers [
|
||||
[
|
||||
[ server-loop ] 2curry with-logging
|
||||
] with-variable
|
||||
] 3curry curry parallel-each ; inline
|
||||
] 3curry parallel-each
|
||||
] with-variable ; inline
|
||||
|
||||
: stop-server ( -- )
|
||||
servers get [ dispose ] each ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 {
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"echo Hello" +command+ set
|
||||
"launcher-test-1" temp-file +stdout+ set
|
||||
] { } make-assoc try-process
|
||||
<process>
|
||||
"echo Hello" >>command
|
||||
"launcher-test-1" temp-file >>stdout
|
||||
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
|
||||
+inherit+ +stdout+ set
|
||||
] { } make-assoc ascii <process-stream> contents
|
||||
2array >>command
|
||||
+inherit+ >>stdout
|
||||
ascii <process-stream> contents
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
|
@ -47,11 +48,11 @@ continuations math io.encodings.ascii ;
|
|||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"cat" +command+ set
|
||||
+closed+ +stdin+ set
|
||||
"launcher-test-1" temp-file +stdout+ set
|
||||
] { } make-assoc try-process
|
||||
<process>
|
||||
"cat" >>command
|
||||
+closed+ >>stdin
|
||||
"launcher-test-1" temp-file >>stdout
|
||||
try-process
|
||||
] unit-test
|
||||
|
||||
[ "" ] [
|
||||
|
|
@ -64,10 +65,10 @@ continuations math io.encodings.ascii ;
|
|||
[ ] [
|
||||
2 [
|
||||
"launcher-test-1" temp-file ascii <file-appender> [
|
||||
[
|
||||
+stdout+ set
|
||||
"echo Hello" +command+ set
|
||||
] { } make-assoc try-process
|
||||
<process>
|
||||
swap >>stdout
|
||||
"echo Hello" >>command
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
+command+ get [ tokenize-command ] [ +arguments+ get ] if* ;
|
||||
: get-arguments ( process -- seq )
|
||||
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 ( -- )
|
||||
+stdin+ get ?closed read-flags 0 redirect
|
||||
+stdout+ get ?closed write-flags 1 redirect
|
||||
+stderr+ get dup +stdout+ eq?
|
||||
: setup-redirection ( process -- process )
|
||||
dup stdin>> ?closed read-flags 0 redirect
|
||||
dup stdout>> ?closed write-flags 1 redirect
|
||||
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
|
||||
pass-environment?
|
||||
[ get-environment assoc>env exec-args-with-env ]
|
||||
[ exec-args-with-path ] if
|
||||
io-error
|
||||
] [ error. :c flush ] recover 1 exit ;
|
||||
dup pass-environment? [
|
||||
dup get-environment set-os-envs
|
||||
] when
|
||||
|
||||
get-arguments exec-args-with-path
|
||||
(io-error)
|
||||
] [ 255 exit ] recover ;
|
||||
|
||||
M: unix-io current-process-handle ( -- handle ) getpid ;
|
||||
|
||||
M: unix-io run-process* ( desc -- pid )
|
||||
[
|
||||
[ spawn-process ] [ ] with-fork <process>
|
||||
] with-descriptor ;
|
||||
M: unix-io run-process* ( process -- pid )
|
||||
[ spawn-process ] curry [ ] with-fork ;
|
||||
|
||||
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)
|
||||
[
|
||||
spawn-process-stream >r <reader&writer> r>
|
||||
] with-descriptor ;
|
||||
>r open-pipe open-pipe r>
|
||||
[ >r setup-stdio-pipe r> spawn-process ] curry
|
||||
[ -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
|
||||
|
|
|
|||
|
|
@ -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 [
|
||||
server-port-addr parse-sockaddr
|
||||
swap dup <reader&writer> <duplex-stream> <client-stream>
|
||||
] keep set-server-port-client ;
|
||||
rot
|
||||
[ server-port-addr parse-sockaddr ] keep
|
||||
[ set-server-port-client-addr ] keep
|
||||
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
|
||||
{ duplex-stream-in duplex-stream-out } get-slots ;
|
||||
dup server-port-client-addr
|
||||
swap server-port-client ;
|
||||
|
||||
! Datagram sockets - UDP and Unix domain
|
||||
M: unix-io <datagram>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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-ftLastWriteTime FILETIME>timestamp
|
||||
]
|
||||
! [ WIN32_FIND_DATA-ftCreationTime 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-ftLastWriteTime
|
||||
FILETIME>timestamp
|
||||
]
|
||||
! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ]
|
||||
[ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ]
|
||||
! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ]
|
||||
} cleave
|
||||
\ file-info construct-boa ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
"PROCESS_INFORMATION" <c-object>
|
||||
TRUE
|
||||
{
|
||||
set-CreateProcess-args-dwCreateFlags
|
||||
set-CreateProcess-args-lpStartupInfo
|
||||
set-CreateProcess-args-lpProcessInformation
|
||||
set-CreateProcess-args-bInheritHandles
|
||||
} \ CreateProcess-args construct ;
|
||||
"STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
|
||||
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
|
||||
TRUE >>bInheritHandles ;
|
||||
|
||||
: call-CreateProcess ( CreateProcess-args -- )
|
||||
{
|
||||
CreateProcess-args-lpApplicationName
|
||||
CreateProcess-args-lpCommandLine
|
||||
CreateProcess-args-lpProcessAttributes
|
||||
CreateProcess-args-lpThreadAttributes
|
||||
CreateProcess-args-bInheritHandles
|
||||
CreateProcess-args-dwCreateFlags
|
||||
CreateProcess-args-lpEnvironment
|
||||
CreateProcess-args-lpCurrentDirectory
|
||||
CreateProcess-args-lpStartupInfo
|
||||
CreateProcess-args-lpProcessInformation
|
||||
lpApplicationName>>
|
||||
lpCommandLine>>
|
||||
lpProcessAttributes>>
|
||||
lpThreadAttributes>>
|
||||
bInheritHandles>>
|
||||
dwCreateFlags>>
|
||||
lpEnvironment>>
|
||||
lpCurrentDirectory>>
|
||||
lpStartupInfo>>
|
||||
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 )
|
||||
+command+ get [
|
||||
: app-name/cmd-line ( process -- app-name cmd-line )
|
||||
command>> dup string? [
|
||||
" " split1
|
||||
] [
|
||||
+arguments+ get unclip swap join-arguments
|
||||
] if* ;
|
||||
unclip swap join-arguments
|
||||
] if ;
|
||||
|
||||
: cmd-line ( -- cmd-line )
|
||||
+command+ get [ +arguments+ get join-arguments ] unless* ;
|
||||
: cmd-line ( process -- cmd-line )
|
||||
command>> dup string? [ join-arguments ] unless ;
|
||||
|
||||
: fill-lpApplicationName
|
||||
app-name/cmd-line
|
||||
pick set-CreateProcess-args-lpCommandLine
|
||||
over set-CreateProcess-args-lpApplicationName ;
|
||||
: fill-lpApplicationName ( process args -- process args )
|
||||
over app-name/cmd-line
|
||||
>r >>lpApplicationName
|
||||
r> >>lpCommandLine ;
|
||||
|
||||
: fill-lpCommandLine
|
||||
cmd-line over set-CreateProcess-args-lpCommandLine ;
|
||||
: fill-lpCommandLine ( process args -- process args )
|
||||
over cmd-line >>lpCommandLine ;
|
||||
|
||||
: fill-dwCreateFlags
|
||||
: fill-dwCreateFlags ( process args -- process args )
|
||||
0
|
||||
pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
|
||||
+detached+ get winnt? and [ DETACHED_PROCESS bitor ] when
|
||||
over set-CreateProcess-args-dwCreateFlags ;
|
||||
pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
|
||||
pick detached>> winnt? and [ DETACHED_PROCESS bitor ] when
|
||||
>>dwCreateFlags ;
|
||||
|
||||
: fill-lpEnvironment
|
||||
pass-environment? [
|
||||
: fill-lpEnvironment ( process args -- process args )
|
||||
over pass-environment? [
|
||||
[
|
||||
get-environment
|
||||
[ "=" swap 3append string>u16-alien % ] assoc-each
|
||||
over get-environment
|
||||
[ swap % "=" % % "\0" % ] assoc-each
|
||||
"\0" %
|
||||
] { } make >c-ushort-array
|
||||
over set-CreateProcess-args-lpEnvironment
|
||||
] "" make >c-ushort-array
|
||||
>>lpEnvironment
|
||||
] when ;
|
||||
|
||||
: fill-startup-info
|
||||
dup CreateProcess-args-lpStartupInfo
|
||||
STARTF_USESTDHANDLES swap set-STARTUPINFO-dwFlags ;
|
||||
: fill-startup-info ( process args -- process args )
|
||||
STARTF_USESTDHANDLES over lpStartupInfo>> 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 )
|
||||
[
|
||||
[
|
||||
make-CreateProcess-args
|
||||
fill-redirection
|
||||
dup call-CreateProcess
|
||||
CreateProcess-args-lpProcessInformation <process>
|
||||
] with-descriptor
|
||||
dup make-CreateProcess-args
|
||||
tuck fill-redirection
|
||||
dup call-CreateProcess
|
||||
lpProcessInformation>>
|
||||
] 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 )
|
||||
>r >r >r drop r>
|
||||
normalize-pathname
|
||||
r> ! access-mode
|
||||
:: redirect-file ( default path access-mode create-mode -- handle )
|
||||
path normalize-pathname
|
||||
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 )
|
||||
+stderr+ get +stdout+ eq? [
|
||||
CreateProcess-args-lpStartupInfo
|
||||
: redirect-stderr ( process args -- handle )
|
||||
over stderr>> +stdout+ eq? [
|
||||
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
|
||||
pipe-out close-later ;
|
||||
in>> 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
|
||||
dup CreateProcess-args-lpStartupInfo
|
||||
over redirect-stdout over set-STARTUPINFO-hStdOutput
|
||||
over redirect-stderr over set-STARTUPINFO-hStdError
|
||||
over redirect-stdin over set-STARTUPINFO-hStdInput
|
||||
drop ;
|
||||
M: windows-nt-io fill-redirection ( process args -- )
|
||||
[ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput
|
||||
[ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError
|
||||
[ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput
|
||||
2drop ;
|
||||
|
||||
M: windows-nt-io (process-stream)
|
||||
[
|
||||
[
|
||||
make-CreateProcess-args
|
||||
dup make-CreateProcess-args
|
||||
|
||||
fill-stdout-pipe
|
||||
fill-stdin-pipe
|
||||
fill-stdout-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 CreateProcess-args-stdout-pipe pipe-out CloseHandle drop
|
||||
dup stdin-pipe>> pipe-in CloseHandle drop
|
||||
dup stdout-pipe>> pipe-out CloseHandle drop
|
||||
|
||||
dup CreateProcess-args-stdout-pipe pipe-in
|
||||
over CreateProcess-args-stdin-pipe pipe-out
|
||||
|
||||
[ f <win32-file> ] 2apply <reader&writer>
|
||||
|
||||
rot CreateProcess-args-lpProcessInformation <process>
|
||||
] with-destructors
|
||||
] with-descriptor ;
|
||||
dup lpProcessInformation>>
|
||||
over stdout-pipe>> in>> f <win32-file>
|
||||
rot stdin-pipe>> out>> f <win32-file>
|
||||
] with-destructors ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,3 @@
|
|||
USE: system
|
||||
USE: prettyprint
|
||||
os-envs .
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
USE: io
|
||||
USE: namespaces
|
||||
|
||||
"output" write flush
|
||||
"error" stderr get stream-write stderr get stream-flush
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue