steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Bruno Deferrari 2008-05-19 22:02:12 -03:00
parent 29d96bde8f fff3f601e3
commit 881dd3b8f9
55 changed files with 880 additions and 479 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/byte-arrays/byte-arrays-docs.factor
View File

@ -26,5 +26,6 @@ HELP: <byte-array> ( n -- byte-array )
HELP: >byte-array
{ $values { "seq" "a sequence" } { "byte-array" byte-array } }
{ $description "Outputs a freshly-allocated byte array whose elements have the same boolean values as a given sequence." }
{ $description
"Outputs a freshly-allocated byte array whose elements have the same signed byte values as a given sequence." }
{ $errors "Throws an error if the sequence contains elements other than integers." } ;

4
core/debugger/debugger.factor
View File

@ -7,7 +7,7 @@ splitting math.parser classes.tuple continuations
continuations.private combinators generic.math
classes.builtin classes compiler.units generic.standard vocabs
threads threads.private init kernel.private libc io.encodings
mirrors accessors math.order ;
mirrors accessors math.order destructors ;
IN: debugger
GENERIC: error. ( error -- )
@ -300,6 +300,8 @@ M: bad-create summary drop "Bad parameters to create" ;
M: attempt-all-error summary drop "Nothing to attempt" ;
M: already-disposed summary drop "Attempting to operate on disposed object" ;
<PRIVATE
: init-debugger ( -- )

2
core/io/files/files-tests.factor
View File

@ -105,6 +105,8 @@ strings accessors io.encodings.utf8 math destructors ;
[ f ] [ "test-bar.txt" temp-file exists? ] unit-test
[ "test-blah" temp-file delete-tree ] ignore-errors
[ ] [ "test-blah" temp-file make-directory ] unit-test
[ ] [

10
core/io/io-tests.factor
View File

@ -1,6 +1,6 @@
USING: arrays io io.files kernel math parser strings system
tools.test words namespaces io.encodings.8-bit
io.encodings.binary ;
io.encodings.binary sequences ;
IN: io.tests
[ f ] [
@ -47,3 +47,11 @@ IN: io.tests
10 [ 65536 read drop ] times
] with-file-reader
] unit-test
! Test EOF behavior
[ 10 ] [
image binary [
0 read drop
10 read length
] with-file-reader
] unit-test

6
core/io/streams/c/c.factor
View File

@ -10,12 +10,15 @@ TUPLE: c-writer handle disposed ;
: <c-writer> ( handle -- stream ) f c-writer boa ;
M: c-writer stream-write1
dup check-disposed
handle>> fputc ;
M: c-writer stream-write
dup check-disposed
handle>> fwrite ;
M: c-writer stream-flush
dup check-disposed
handle>> fflush ;
M: c-writer dispose*
@ -26,12 +29,14 @@ TUPLE: c-reader handle disposed ;
: <c-reader> ( handle -- stream ) f c-reader boa ;
M: c-reader stream-read
dup check-disposed
handle>> fread ;
M: c-reader stream-read-partial
stream-read ;
M: c-reader stream-read1
dup check-disposed
handle>> fgetc ;
: read-until-loop ( stream delim -- ch )
@ -42,6 +47,7 @@ M: c-reader stream-read1
] if ;
M: c-reader stream-read-until
dup check-disposed
[ swap read-until-loop ] B{ } make swap
over empty? over not and [ 2drop f f ] when ;

43
extra/builder/benchmark/benchmark.factor
View File

@ -1,43 +0,0 @@
USING: kernel continuations arrays assocs sequences sorting math
io io.styles prettyprint builder.util ;
IN: builder.benchmark
! : passing-benchmarks ( table -- table )
! [ second first2 number? swap number? and ] filter ;
: passing-benchmarks ( table -- table ) [ second number? ] filter ;
! : simplify-table ( table -- table ) [ first2 second 2array ] map ;
: benchmark-difference ( old-table benchmark-result -- result-diff )
first2 >r
tuck swap at
r>
swap -
2array ;
: compare-tables ( old new -- table )
[ passing-benchmarks ] bi@
[ benchmark-difference ] with map ;
: benchmark-deltas ( -- table )
"../benchmarks" "benchmarks" [ eval-file ] bi@
compare-tables
sort-values ;
: benchmark-deltas. ( deltas -- )
standard-table-style
[
[ [ "Benchmark" write ] with-cell [ "Delta (ms)" write ] with-cell ]
with-row
[ [ swap [ write ] with-cell pprint-cell ] with-row ]
assoc-each
]
tabular-output ;
: show-benchmark-deltas ( -- )
[ benchmark-deltas benchmark-deltas. ]
[ drop "Error generating benchmark deltas" . ]
recover ;

15
extra/builder/util/util.factor
View File

@ -41,12 +41,17 @@ DEFER: to-strings
: host-name* ( -- name ) host-name "." split first ;
! : datestamp ( -- string )
! now `{ ,[ dup timestamp-year ]
! ,[ dup timestamp-month ]
! ,[ dup timestamp-day ]
! ,[ dup timestamp-hour ]
! ,[ timestamp-minute ] }
! [ pad-00 ] map "-" join ;
: datestamp ( -- string )
now `{ ,[ dup timestamp-year ]
,[ dup timestamp-month ]
,[ dup timestamp-day ]
,[ dup timestamp-hour ]
,[ timestamp-minute ] }
now
{ year>> month>> day>> hour>> minute>> } <arr>
[ pad-00 ] map "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

4
extra/cocoa/application/application-docs.factor
View File

@ -27,8 +27,8 @@ HELP: with-cocoa
{ $description "Sets up an autorelease pool, initializes the " { $snippet "NSApplication" } " singleton, and calls the quotation." } ;
HELP: do-event
{ $values { "app" "an " { $snippet "NSApplication" } } }
{ $description "Processes any pending events in the queue. Does not block." } ;
{ $values { "app" "an " { $snippet "NSApplication" } } { "?" "a boolean" } }
{ $description "Processes a pending event in the queue, if any, returning a boolean indicating if there was one. Does not block." } ;
HELP: add-observer
{ $values { "observer" "an " { $snippet "NSObject" } } { "selector" string } { "name" "an " { $snippet "NSString" } } { "object" "an " { $snippet "NSObject" } } }

14
extra/cocoa/views/views.factor
View File

@ -74,3 +74,17 @@ PRIVATE>
-> locationInWindow f -> convertPoint:fromView:
dup NSPoint-x swap NSPoint-y
r> -> frame NSRect-h swap - 2array ;
USE: opengl.gl
USE: alien.syntax
: NSOpenGLCPSwapInterval 222 ;
LIBRARY: OpenGL
TYPEDEF: int CGLError
TYPEDEF: void* CGLContextObj
TYPEDEF: int CGLContextParameter
FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;

18
extra/ftp/client/client.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.singleton combinators
continuations io io.encodings.binary io.encodings.ascii
continuations io io.encodings.binary io.encodings.utf8
io.files io.sockets kernel io.streams.duplex math
math.parser sequences splitting namespaces strings fry ftp ;
IN: ftp.client
@ -56,15 +56,17 @@ IN: ftp.client
"|" split 2 tail* first string>number ;
TUPLE: remote-file
type permissions links owner group size month day time year name ;
type permissions links owner group size month day time year
name target ;
: <remote-file> ( -- remote-file ) remote-file new ;
: parse-permissions ( remote-file str -- remote-file )
[ first ch>type >>type ] [ rest >>permissions ] bi ;
: parse-list-9 ( lines -- seq )
: parse-list-11 ( lines -- seq )
[
11 f pad-right
<remote-file> swap {
[ 0 swap nth parse-permissions ]
[ 1 swap nth string>number >>links ]
@ -75,6 +77,7 @@ TUPLE: remote-file
[ 6 swap nth >>day ]
[ 7 swap nth >>time ]
[ 8 swap nth >>name ]
[ 10 swap nth >>target ]
} cleave
] map ;
@ -105,7 +108,8 @@ TUPLE: remote-file
dup strings>>
[ " " split harvest ] map
dup length {
{ 9 [ parse-list-9 ] }
{ 11 [ parse-list-11 ] }
{ 9 [ parse-list-11 ] }
{ 8 [ parse-list-8 ] }
{ 3 [ parse-list-3 ] }
[ drop ]
@ -129,7 +133,7 @@ ERROR: ftp-error got expected ;
[ 229 ftp-assert ] [ parse-epsv ] bi ;
: list ( ftp-client -- ftp-response )
host>> open-remote-port <inet> ascii <client>
host>> open-remote-port <inet> utf8 <client> drop
ftp-list 150 ftp-assert
lines
<ftp-response> swap >>strings
@ -137,14 +141,14 @@ ERROR: ftp-error got expected ;
parse-list ;
: ftp-get ( filename ftp-client -- ftp-response )
host>> open-remote-port <inet> binary <client>
host>> open-remote-port <inet> binary <client> drop
swap
[ ftp-retr 150 ftp-assert drop ]
[ binary <file-writer> stream-copy ] 2bi
read-response dup 226 ftp-assert ;
: ftp-connect ( ftp-client -- stream )
[ host>> ] [ port>> ] bi <inet> ascii <client> ;
[ host>> ] [ port>> ] bi <inet> utf8 <client> drop ;
GENERIC: ftp-download ( path obj -- )

3
extra/ftp/ftp.factor
View File

@ -7,7 +7,8 @@ IN: ftp
SINGLETON: active
SINGLETON: passive
TUPLE: ftp-client host port user password mode state ;
TUPLE: ftp-client host port user password mode state
command-promise ;
: <ftp-client> ( host -- ftp-client )
ftp-client new

250
extra/ftp/server/server.factor
View File

@ -1,19 +1,35 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io io.encodings.8-bit
io.files io.server io.sockets kernel math.parser
namespaces sequences ftp io.unix.launcher.parser
unicode.case splitting assocs ;
io.encodings io.encodings.binary io.encodings.utf8 io.files
io.server io.sockets kernel math.parser namespaces sequences
ftp io.unix.launcher.parser unicode.case splitting assocs
classes io.server destructors calendar io.timeouts
io.streams.duplex threads continuations
concurrency.promises byte-arrays ;
IN: ftp.server
SYMBOL: client
SYMBOL: stream
TUPLE: ftp-command raw tokenized ;
: <ftp-command> ( -- obj )
ftp-command new ;
TUPLE: ftp-get path ;
: <ftp-get> ( path -- obj )
ftp-get new swap >>path ;
TUPLE: ftp-put path ;
: <ftp-put> ( path -- obj )
ftp-put new swap >>path ;
TUPLE: ftp-list ;
C: <ftp-list> ftp-list
: read-command ( -- ftp-command )
<ftp-command> readln
[ >>raw ] [ tokenize-command >>tokenized ] bi ;
@ -32,77 +48,179 @@ TUPLE: ftp-command raw tokenized ;
swap >>n
send-response ;
: ftp-error ( string -- )
500 "Unrecognized command: " rot append server-response ;
: send-banner ( -- )
220 "Welcome to " host-name append server-response ;
: send-PASS-request ( -- )
331 "Please specify the password." server-response ;
: anonymous-only ( -- )
530 "This FTP server is anonymous only." server-response ;
: parse-USER ( ftp-command -- )
tokenized>> second client get swap >>user drop ;
: send-login-response ( -- )
! client get
230 "Login successful" server-response ;
: parse-PASS ( ftp-command -- )
tokenized>> second client get swap >>password drop ;
: send-quit-response ( ftp-command -- )
: handle-QUIT ( obj -- )
drop 221 "Goodbye." server-response ;
: ftp-error ( string -- )
500 "Unrecognized command: " rot append server-response ;
: handle-USER ( ftp-command -- )
[
tokenized>> second client get swap >>user drop
331 "Please specify the password." server-response
] [
2drop "bad USER" ftp-error
] recover ;
: send-type-error ( -- )
"TYPE is binary only" ftp-error ;
: handle-PASS ( ftp-command -- )
[
tokenized>> second client get swap >>password drop
230 "Login successful" server-response
] [
2drop "PASS error" ftp-error
] recover ;
: send-type-success ( string -- )
200 "Switching to " rot " mode" 3append server-response ;
ERROR: type-error type ;
: parse-TYPE ( obj -- )
tokenized>> second >upper {
{ "IMAGE" [ "Binary" send-type-success ] }
{ "I" [ "Binary" send-type-success ] }
[ drop send-type-error ]
} case ;
: handle-TYPE ( obj -- )
[
tokenized>> second >upper {
{ "IMAGE" [ "Binary" ] }
{ "I" [ "Binary" ] }
[ type-error ]
} case
200 "Switching to " rot " mode" 3append server-response
] [
2drop "TYPE is binary only" ftp-error
] recover ;
: pwd-response ( -- )
: handle-PWD ( obj -- )
drop
257 current-directory get "\"" swap "\"" 3append server-response ;
! : random-local-inet ( -- spec )
! remote-address get class new 0 >>port ;
! : handle-LIST ( -- )
! random-local-inet ascii <server> ;
: random-local-server ( -- server )
remote-address get class new 0 >>port binary <server> ;
: handle-STOR ( obj -- )
;
[
drop
] [
2drop
] recover ;
! EPRT |2|::1|62138|
! : handle-EPRT ( obj -- )
! tokenized>> second "|" split harvest ;
! : handle-EPSV ( obj -- )
! 229 "Entering Extended Passive Mode (|||"
! random-local-inet ! get port number>string
! "|)" 3append server-response ;
! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186
: handle-LPRT ( obj -- )
tokenized>> "," split ;
: start-directory ( -- )
150 "Here comes the directory listing." server-response ;
: finish-directory ( -- )
226 "Directory send OK." server-response ;
: send-directory-list ( stream -- )
[ directory-list write ] with-output-stream ;
GENERIC: service-command ( stream obj -- )
M: ftp-list service-command ( stream obj -- )
drop
start-directory
[
utf8 encode-output
directory-list [ ftp-send ] each
] with-output-stream
finish-directory ;
: start-file-transfer ( path -- )
150 "Opening BINARY mode data connection for "
rot
[ file-name ] [
" " swap file-info file-info-size number>string
"(" " bytes)." swapd 3append append
] bi 3append server-response ;
: finish-file-transfer ( -- )
226 "File send OK." server-response ;
M: ftp-get service-command ( stream obj -- )
[
path>>
[ start-file-transfer ]
[ binary <file-reader> swap stream-copy ] bi
finish-file-transfer
] [
3drop "File transfer failed" ftp-error
] recover ;
M: ftp-put service-command ( stream obj -- )
[
path>>
[ start-file-transfer ]
[ binary <file-reader> swap stream-copy ] bi
finish-file-transfer
] [
3drop "File transfer failed" ftp-error
] recover ;
: extended-passive-loop ( server -- )
[
[
|dispose
30 seconds over set-timeout
accept drop &dispose
client get command-promise>>
30 seconds ?promise-timeout
service-command
]
[ client get f >>command-promise drop ]
[ ] cleanup
] with-destructors ;
: if-command-promise ( quot -- )
>r client get command-promise>> r>
[ "Establish an active or passive connection first" ftp-error ] if* ;
: handle-LIST ( obj -- )
drop
[ <ftp-list> swap fulfill ] if-command-promise ;
: handle-SIZE ( obj -- )
[
tokenized>> second file-info size>>
213 swap number>string server-response
] [
2drop
550 "Could not get file size" server-response
] recover ;
: handle-RETR ( obj -- )
[ tokenized>> second <ftp-get> swap fulfill ]
curry if-command-promise ;
: handle-EPSV ( obj -- )
drop
client get command-promise>> [
"You already have a passive stream" ftp-error
] [
229 "Entering Extended Passive Mode (|||"
random-local-server
client get <promise> >>command-promise drop
[ [ B extended-passive-loop ] curry in-thread ]
[ addr>> port>> number>string ] bi
"|)" 3append server-response
] if ;
! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186
! : handle-LPRT ( obj -- ) tokenized>> "," split ;
ERROR: not-a-directory ;
: handle-CWD ( obj -- )
[
tokenized>> second dup directory? [
set-current-directory
250 "Directory successully changed." server-response
] [
not-a-directory throw
] if
] [
2drop
550 "Failed to change directory." server-response
] recover ;
: unrecognized-command ( obj -- ) raw>> ftp-error ;
@ -111,28 +229,30 @@ TUPLE: ftp-command raw tokenized ;
[ >>raw ]
[ tokenize-command >>tokenized ] bi
dup tokenized>> first >upper {
{ "USER" [ parse-USER send-PASS-request t ] }
{ "PASS" [ parse-PASS send-login-response t ] }
{ "USER" [ handle-USER t ] }
{ "PASS" [ handle-PASS t ] }
{ "ACCT" [ drop "ACCT unimplemented" ftp-error t ] }
! { "CWD" [ ] }
{ "CWD" [ handle-CWD t ] }
! { "XCWD" [ ] }
! { "CDUP" [ ] }
! { "SMNT" [ ] }
! { "REIN" [ drop client get reset-ftp-client t ] }
{ "QUIT" [ send-quit-response f ] }
{ "QUIT" [ handle-QUIT f ] }
! { "PORT" [ ] }
! { "PASV" [ ] }
! { "MODE" [ ] }
{ "TYPE" [ parse-TYPE t ] }
{ "TYPE" [ handle-TYPE t ] }
! { "STRU" [ ] }
! { "ALLO" [ ] }
! { "REST" [ ] }
! { "STOR" [ handle-STOR t ] }
! { "STOU" [ ] }
! { "RETR" [ ] }
! { "LIST" [ drop handle-LIST t ] }
{ "RETR" [ handle-RETR t ] }
{ "LIST" [ handle-LIST t ] }
{ "SIZE" [ handle-SIZE t ] }
! { "NLST" [ ] }
! { "APPE" [ ] }
! { "RNFR" [ ] }
@ -140,7 +260,7 @@ TUPLE: ftp-command raw tokenized ;
! { "DELE" [ ] }
! { "RMD" [ ] }
! { "MKD" [ ] }
{ "PWD" [ drop pwd-response t ] }
{ "PWD" [ handle-PWD t ] }
! { "ABOR" [ ] }
! { "SYST" [ drop ] }
@ -150,18 +270,20 @@ TUPLE: ftp-command raw tokenized ;
! { "SITE" [ ] }
! { "NOOP" [ ] }
! { "EPRT" [ handle-eprt ] }
! { "LPRT" [ handle-lprt ] }
! { "EPSV" [ drop handle-epsv t ] }
! { "LPSV" [ drop handle-lpsv t ] }
! { "EPRT" [ handle-EPRT ] }
! { "LPRT" [ handle-LPRT ] }
{ "EPSV" [ handle-EPSV t ] }
! { "LPSV" [ drop handle-LPSV t ] }
[ drop unrecognized-command t ]
} case [ handle-client-loop ] when ;
: handle-client ( -- )
"" [
host-name <ftp-client> client set
send-banner handle-client-loop
] with-directory ;
[
"" [
host-name <ftp-client> client set
send-banner handle-client-loop
] with-directory
] with-destructors ;
: ftpd ( port -- )
internet-server "ftp.server"

2
extra/globs/globs.factor
View File

@ -35,4 +35,4 @@ PRIVATE>
: <glob> 'glob' just parse-1 just ;
: glob-matches? ( input glob -- ? )
>r >lower r> <glob> parse nil? not ;
[ >lower ] [ <glob> ] bi* parse nil? not ;

98
extra/html/parser/analyzer/analyzer.factor
View File

@ -1,8 +1,11 @@
USING: assocs html.parser kernel math sequences strings ascii
arrays shuffle unicode.case namespaces splitting http
sequences.lib ;
sequences.lib accessors io combinators http.client ;
IN: html.parser.analyzer
: scrape-html ( url -- vector )
http-get parse-html ;
: (find-relative)
[ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ;
@ -41,8 +44,8 @@ IN: html.parser.analyzer
: remove-blank-text ( vector -- vector' )
[
dup tag-name text = [
tag-text [ blank? ] all? not
dup name>> text = [
text>> [ blank? ] all? not
] [
drop t
] if
@ -50,49 +53,50 @@ IN: html.parser.analyzer
: trim-text ( vector -- vector' )
[
dup tag-name text = [
[ tag-text [ blank? ] trim ] keep
dup name>> text = [
[ text>> [ blank? ] trim ] keep
[ set-tag-text ] keep
] when
] map ;
: find-by-id ( id vector -- vector )
[ tag-attributes "id" swap at = ] with filter ;
[ attributes>> "id" swap at = ] with filter ;
: find-by-class ( id vector -- vector )
[ tag-attributes "class" swap at = ] with filter ;
[ attributes>> "class" swap at = ] with filter ;
: find-by-name ( str vector -- vector )
>r >lower r>
[ tag-name = ] with filter ;
[ name>> = ] with filter ;
: find-first-name ( str vector -- i/f tag/f )
>r >lower r>
[ tag-name = ] with find ;
[ name>> = ] with find ;
: find-matching-close ( str vector -- i/f tag/f )
>r >lower r>
[ [ tag-name = ] keep tag-closing? and ] with find ;
[ [ name>> = ] keep closing?>> and ] with find ;
: find-by-attribute-key ( key vector -- vector )
>r >lower r>
[ tag-attributes at ] with filter
[ attributes>> at ] with filter
sift ;
: find-by-attribute-key-value ( value key vector -- vector )
>r >lower r>
[ tag-attributes at over = ] with filter nip
[ attributes>> at over = ] with filter nip
sift ;
: find-first-attribute-key-value ( value key vector -- i/f tag/f )
>r >lower r>
[ tag-attributes at over = ] with find rot drop ;
[ attributes>> at over = ] with find rot drop ;
: find-between* ( i/f tag/f vector -- vector )
pick integer? [
rot tail-slice
>r tag-name r>
[ find-matching-close drop 1+ ] keep swap head
>r name>> r>
[ find-matching-close drop dup [ 1+ ] when ] keep
swap [ head ] [ first ] if*
] [
3drop V{ } clone
] if ;
@ -105,31 +109,63 @@ IN: html.parser.analyzer
: find-between-first ( string vector -- vector' )
[ find-first-name ] keep find-between ;
: find-between-all ( vector quot -- seq )
[ [ [ closing?>> not ] bi and ] curry find-all ] curry
[ [ >r first2 r> find-between* ] curry map ] bi ;
: tag-link ( tag -- link/f )
tag-attributes [ "href" swap at ] [ f ] if* ;
attributes>> [ "href" swap at ] [ f ] if* ;
: find-links ( vector -- vector )
[ tag-name "a" = ] filter
[ tag-link ] filter ;
: find-links ( vector -- vector' )
[ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ]
find-between-all ;
: link. ( vector -- )
[ second text>> write bl ]
[ first tag-link write nl ] bi ;
: find-by-text ( seq quot -- tag )
[ dup tag-name text = ] prepose find drop ;
[ dup name>> text = ] prepose find drop ;
: find-opening-tags-by-name ( name seq -- seq )
[ [ tag-name = ] keep tag-closing? not and ] with find-all ;
[ [ name>> = ] keep closing?>> not and ] with find-all ;
: href-contains? ( str tag -- ? )
tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ;
attributes>> "href" swap at* [ subseq? ] [ 2drop f ] if ;
: find-forms ( vector -- vector' )
"form" over find-opening-tags-by-name
over [ >r first2 r> find-between* ] curry map
[ [ name>> { "form" "input" } member? ] filter ] map ;
: find-html-objects ( string vector -- vector' )
find-opening-tags-by-name
over [ >r first2 r> find-between* ] curry map ;
: form-action ( vector -- string )
[ name>> "form" = ] find nip
attributes>> "action" swap at ;
: hidden-form-values ( vector -- strings )
[ attributes>> "type" swap at "hidden" = ] filter ;
: input. ( tag -- )
dup name>> print
attributes>>
[ bl bl bl bl [ write "=" write ] [ write bl ] bi* nl ] assoc-each ;
: form. ( vector -- )
[ closing?>> not ] filter
[
{
{ [ dup name>> "form" = ]
[ "form action: " write attributes>> "action" swap at print
] }
{ [ dup name>> "input" = ] [ input. ] }
[ drop ]
} cond
] each ;
: query>assoc* ( str -- hash )
"?" split1 nip query>assoc ;
! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] filter [ "=" split peek ] map
! clear "http://www.sailwx.info/shiptrack/cruiseships.phtml" http-get parse-html remove-blank-text
! "a" over find-opening-tags-by-name
! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-filter
! first first 8 + over nth
! tag-attributes "href" swap at query>assoc*
! "lat" over at "lon" rot at

4
extra/html/parser/parser.factor
View File

@ -91,7 +91,7 @@ SYMBOL: tagstack
read-dtd
] if ;
: read-tag ( -- )
: read-tag ( -- string )
[ get-char CHAR: > = get-char CHAR: < = or ] take-until
get-char CHAR: < = [ next* ] unless ;
@ -135,7 +135,7 @@ SYMBOL: tagstack
(parse-tag) make-tag push-tag
] if ;
: (parse-html) ( tag -- )
: (parse-html) ( -- )
get-next [
parse-text
parse-tag

8
extra/http/http-tests.factor
View File

@ -176,11 +176,11 @@ test-db [
main-responder set
[ 1237 httpd ] "HTTPD test" spawn drop
yield
] with-scope
] unit-test
[ ] [ 100 sleep ] unit-test
[ t ] [
"resource:extra/http/test/foo.html" ascii file-contents
"http://localhost:1237/nested/foo.html" http-get =
@ -222,7 +222,7 @@ test-db [
] with-scope
] unit-test
[ ] [ 1000 sleep ] unit-test
[ ] [ 100 sleep ] unit-test
: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
@ -249,7 +249,7 @@ test-db [
] with-scope
] unit-test
[ ] [ 1000 sleep ] unit-test
[ ] [ 100 sleep ] unit-test
[ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test

2
extra/http/http.factor
View File

@ -386,7 +386,7 @@ M: object protocol-addr
drop [ host>> ] [ port>> ] bi <inet> ;
M: https protocol-addr
call-next-method <ssl> ;
call-next-method <secure> ;
: request-addr ( request -- addr )
dup protocol>> protocol-addr ;

5
extra/io/mmap/mmap-tests.factor
View File

@ -8,8 +8,3 @@ IN: io.mmap.tests
[ 5 ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ length ] with-mapped-file ] unit-test
[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
[ ] [ "a" "mmap-grow-test.txt" temp-file ascii set-file-contents ] unit-test
[ 1 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test
[ ] [ "mmap-grow-test.txt" temp-file 100 [ drop ] with-mapped-file ] unit-test
[ 100 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test

22
extra/io/monitors/monitors-tests.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
IN: io.monitors.tests
USING: io.monitors tools.test io.files system sequences
continuations namespaces concurrency.count-downs kernel io
threads calendar prettyprint destructors ;
threads calendar prettyprint destructors io.timeouts ;
os { winnt linux macosx } member? [
[
@ -89,5 +89,23 @@ os { winnt linux macosx } member? [
] with-monitors
! Out-of-scope disposal should not fail
[ "" resource-path t <monitor> ] with-monitors dispose
[ ] [ [ "" resource-path f <monitor> ] with-monitors dispose ] unit-test
[ ] [ [ "" resource-path t <monitor> ] with-monitors dispose ] unit-test
! Timeouts
[
[ ] [ "monitor-timeout-test" temp-file make-directories ] unit-test
! Non-recursive
[ ] [ "monitor-timeout-test" temp-file f <monitor> "m" set ] unit-test
[ ] [ 3 seconds "m" get set-timeout ] unit-test
[ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail
[ ] [ "m" get dispose ] unit-test
! Recursive
[ ] [ "monitor-timeout-test" temp-file t <monitor> "m" set ] unit-test
[ ] [ 3 seconds "m" get set-timeout ] unit-test
[ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail
[ ] [ "m" get dispose ] unit-test
] with-monitors
] when

22
extra/io/ports/ports-docs.factor
View File

@ -29,15 +29,7 @@ $nl
ABOUT: "io.ports"
HELP: port
{ $class-description "Instances of this class present a blocking stream interface on top of an underlying non-blocking I/O system, giving the illusion of blocking by yielding the thread which is waiting for input or output."
$nl
"Ports have the following slots:"
{ $list
{ { $snippet "handle" } " - a native handle identifying the underlying native resource used by the port" }
{ { $snippet "error" } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
{ { $snippet "type" } " - a symbol identifying the port's intended purpose" }
{ { $snippet "eof" } " - a flag indicating if the port has reached the end of file while reading" }
} } ;
{ $class-description "Instances of this class present a blocking stream interface on top of an underlying non-blocking I/O system, giving the illusion of blocking by yielding the thread which is waiting for input or output." } ;
HELP: input-port
{ $class-description "The class of ports implementing the input stream protocol." } ;
@ -65,21 +57,13 @@ HELP: <output-port>
{ $description "Creates a new " { $link output-port } " using the specified native handle and a default-sized input buffer." }
$low-level-note ;
HELP: pending-error
{ $values { "port" port } }
{ $description "If an error occurred while the I/O thread was performing input or output on this port, this error will be thrown to the caller." } ;
HELP: (wait-to-read)
{ $values { "port" input-port } }
{ $contract "Suspends the current thread until the port's buffer has data available for reading." } ;
HELP: wait-to-read
{ $values { "port" input-port } }
{ $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading." } ;
HELP: unless-eof
{ $values { "port" input-port } { "quot" "a quotation with stack effect " { $snippet "( port -- value )" } } { "value" object } }
{ $description "If the port has reached end of file, outputs " { $link f } ", otherwise applies the quotation to the port." } ;
{ $values { "port" input-port } { "eof?" "a boolean" } }
{ $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading. If the buffer was empty and no more data could be read, outputs " { $link t } " to indicate end-of-file; otherwise outputs " { $link f } "." } ;
HELP: can-write?
{ $values { "len" "a positive integer" } { "buffer" buffer } { "?" "a boolean" } }

31
extra/io/ports/ports.factor
View File

@ -10,7 +10,7 @@ IN: io.ports
SYMBOL: default-buffer-size
64 1024 * default-buffer-size set-global
TUPLE: port handle error timeout disposed ;
TUPLE: port handle timeout disposed ;
M: port timeout timeout>> ;
@ -19,36 +19,30 @@ M: port set-timeout (>>timeout) ;
: <port> ( handle class -- port )
new swap >>handle ; inline
: pending-error ( port -- )
[ f ] change-error drop [ throw ] when* ;
TUPLE: buffered-port < port buffer ;
: <buffered-port> ( handle class -- port )
<port>
default-buffer-size get <buffer> >>buffer ; inline
TUPLE: input-port < buffered-port eof ;
TUPLE: input-port < buffered-port ;
: <input-port> ( handle -- input-port )
input-port <buffered-port> ;
HOOK: (wait-to-read) io-backend ( port -- )
: wait-to-read ( port -- )
dup buffer>> buffer-empty? [ (wait-to-read) ] [ drop ] if ;
: unless-eof ( port quot -- value )
>r dup buffer>> buffer-empty? over eof>> and
[ f >>eof drop f ] r> if ; inline
: wait-to-read ( port -- eof? )
dup buffer>> buffer-empty? [
dup (wait-to-read) buffer>> buffer-empty?
] [ drop f ] if ;
M: input-port stream-read1
dup check-disposed
dup wait-to-read [ buffer>> buffer-pop ] unless-eof ;
dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ;
: read-step ( count port -- byte-array/f )
[ wait-to-read ] keep
[ dupd buffer>> buffer-read ] unless-eof nip ;
dup wait-to-read [ 2drop f ] [ buffer>> buffer-read ] if ;
M: input-port stream-read-partial ( max stream -- byte-array/f )
dup check-disposed
@ -106,14 +100,15 @@ M: output-port stream-write
HOOK: (wait-to-write) io-backend ( port -- )
: flush-port ( port -- )
dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ;
: port-flush ( port -- )
dup buffer>> buffer-empty?
[ drop ] [ dup (wait-to-write) port-flush ] if ;
M: output-port stream-flush ( port -- )
[ check-disposed ] [ flush-port ] bi ;
[ check-disposed ] [ port-flush ] bi ;
M: output-port dispose*
[ flush-port ] [ call-next-method ] bi ;
[ port-flush ] [ call-next-method ] bi ;
M: buffered-port dispose*
[ call-next-method ]

12
extra/io/server/server.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.sockets io.files io.streams.duplex logging
continuations destructors kernel math math.parser namespaces
parser sequences strings prettyprint debugger quotations
calendar threads concurrency.combinators assocs fry ;
USING: io io.sockets io.sockets.secure io.files
io.streams.duplex logging continuations destructors kernel math
math.parser namespaces parser sequences strings prettyprint
debugger quotations calendar threads concurrency.combinators
assocs fry ;
IN: io.server
SYMBOL: servers
@ -41,6 +42,9 @@ PRIVATE>
: internet-server ( port -- seq )
f swap t resolve-host ;
: secure-server ( port -- seq )
internet-server [ <secure> ] map ;
: with-server ( seq service encoding quot -- )
V{ } clone servers [
'[ , [ , , server-loop ] with-logging ] parallel-each

6
extra/io/sockets/secure/secure-tests.factor
View File

@ -1,5 +1 @@
IN: io.sockets.secure.tests
USING: io.sockets.secure tools.test ;
\ <ssl-config> must-infer
{ 1 0 } [ [ ] with-ssl-context ] must-infer-as
! No unit tests here, until Windows SSL is implemented

60
extra/io/sockets/secure/secure.factor
View File

@ -1,38 +1,68 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel symbols namespaces continuations
destructors io.sockets sequences ;
destructors io.sockets sequences inspector ;
IN: io.sockets.secure
SYMBOL: ssl-backend
SYMBOL: secure-socket-backend
SINGLETONS: SSLv2 SSLv23 SSLv3 TLSv1 ;
TUPLE: ssl-config method key-file ca-file ca-path password ;
TUPLE: secure-config
method
key-file password
ca-file ca-path
dh-file
ephemeral-key-bits ;
: <ssl-config> ( -- config )
ssl-config new
SSLv23 >>method ;
: <secure-config> ( -- config )
secure-config new
SSLv23 >>method
512 >>ephemeral-key-bits ;
TUPLE: ssl-context config handle ;
TUPLE: secure-context config handle disposed ;
HOOK: <ssl-context> ssl-backend ( config -- context )
HOOK: <secure-context> secure-socket-backend ( config -- context )
: with-ssl-context ( config quot -- )
: with-secure-context ( config quot -- )
[
[ <ssl-context> ] [ [ ssl-context set ] prepose ] bi*
[ <secure-context> ] [ [ secure-context set ] prepose ] bi*
with-disposal
] with-scope ; inline
TUPLE: ssl addrspec ;
TUPLE: secure addrspec ;
C: <ssl> ssl
C: <secure> secure
: resolve-secure-host ( host port passive? -- seq )
resolve-host [ <secure> ] map ;
HOOK: check-certificate secure-socket-backend ( host handle -- )
<PRIVATE
PREDICATE: ssl-inet < ssl addrspec>> inet? ;
PREDICATE: secure-inet < secure addrspec>> inet? ;
M: ssl-inet (client)
addrspec>> resolve-client-addr [ <ssl> ] map (client) ;
M: secure-inet (client)
[
addrspec>>
[ [ host>> ] [ port>> ] bi f resolve-secure-host (client) >r |dispose r> ] keep
host>> pick handle>> check-certificate
] with-destructors ;
PRIVATE>
ERROR: premature-close ;
M: premature-close summary
drop "Connection closed prematurely - potential truncation attack" ;
ERROR: certificate-verify-error result ;
M: certificate-verify-error summary
drop "Certificate verification failed" ;
ERROR: common-name-verify-error expected got ;
M: common-name-verify-error summary
drop "Common name verification failed" ;

4
extra/io/sockets/sockets-docs.factor
View File

@ -37,7 +37,7 @@ ARTICLE: "network-packet" "Packet-oriented networking"
{ $subsection receive }
"Packet-oriented sockets are closed by calling " { $link dispose } "."
$nl
"Address specifiers have the following interpretation with connection-oriented networking words:"
"Address specifiers have the following interpretation with packet-oriented networking words:"
{ $list
{ { $link local } " - Unix domain datagram sockets on Unix systems" }
{ { $link inet4 } " - a TCP/IP connection to an IPv4 address and port number; no name lookup is performed" }
@ -130,7 +130,7 @@ HELP: <server>
{ $errors "Throws an error if the address is already in use, or if it if the system forbids access." } ;
HELP: accept
{ $values { "server" "a handle" } { "client" "a bidirectional stream" } { "addrspec" "an address specifier" } }
{ $values { "server" "a handle" } { "client" "a bidirectional stream" } { "remote" "an address specifier" } }
{ $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor." }
{ $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ;

26
extra/io/sockets/sockets-tests.factor Normal file → Executable file
View File

@ -1,5 +1,6 @@
IN: io.sockets.tests
USING: io.sockets sequences math tools.test ;
USING: io.sockets sequences math tools.test namespaces accessors
kernel destructors calendar io.timeouts ;
[ B{ 1 2 3 4 } ]
[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
@ -44,3 +45,26 @@ USING: io.sockets sequences math tools.test ;
[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test
[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test
! Smoke-test UDP
[ ] [ "127.0.0.1" 0 <inet4> <datagram> "datagram1" set ] unit-test
[ ] [ "datagram1" get addr>> "addr1" set ] unit-test
[ f ] [ "addr1" get port>> 0 = ] unit-test
[ ] [ "127.0.0.1" 0 <inet4> <datagram> "datagram2" set ] unit-test
[ ] [ "datagram2" get addr>> "addr2" set ] unit-test
[ f ] [ "addr2" get port>> 0 = ] unit-test
[ ] [ B{ 1 2 3 4 } "addr2" get "datagram1" get send ] unit-test
[ B{ 1 2 3 4 } ] [ "datagram2" get receive "from" set ] unit-test
[ ] [ B{ 4 3 2 1 } "from" get "datagram2" get send ] unit-test
[ B{ 4 3 2 1 } t ] [ "datagram1" get receive "addr2" get = ] unit-test
[ ] [ "datagram1" get dispose ] unit-test
[ ] [ "datagram2" get dispose ] unit-test
! Test timeouts
[ ] [ "127.0.0.1" 0 <inet4> <datagram> "datagram3" set ] unit-test
[ ] [ 1 seconds "datagram3" get set-timeout ] unit-test
[ "datagram3" get receive ] must-fail

28
extra/io/sockets/sockets.factor
View File

@ -156,6 +156,11 @@ GENERIC: (get-local-address) ( handle remote -- sockaddr )
: get-local-address ( handle remote -- local )
[ (get-local-address) ] keep parse-sockaddr ;
GENERIC: (get-remote-address) ( handle remote -- sockaddr )
: get-remote-address ( handle local -- remote )
[ (get-remote-address) ] keep parse-sockaddr ;
GENERIC: establish-connection ( client-out remote -- )
GENERIC: ((client)) ( remote -- handle )
@ -180,7 +185,7 @@ M: object (client) ( remote -- client-in client-out local )
SYMBOL: local-address
: with-client ( addrspec encoding quot -- )
: with-client ( remote encoding quot -- )
>r <client> [ local-address set ] curry
r> compose with-stream ; inline
@ -198,22 +203,26 @@ GENERIC: (server) ( addrspec -- handle )
[ drop server-port <port> ] [ get-local-address ] 2bi
>>addr r> >>encoding ;
GENERIC: (accept) ( server addrspec -- handle )
GENERIC: (accept) ( server addrspec -- handle sockaddr )
: accept ( server -- client remote )
[
dup addr>>
[ (accept) ] keep
[ drop dup <ports> ] [ get-local-address ] 2bi
-rot
parse-sockaddr swap
dup <ports>
] keep encoding>> <encoder-duplex> swap ;
TUPLE: datagram-port < port addr ;
HOOK: (datagram) io-backend ( addr -- datagram )
: <datagram> ( addr -- datagram )
dup (datagram) datagram-port <port> swap >>addr ;
: <datagram> ( addrspec -- datagram )
[
[ (datagram) |dispose ] keep
[ drop datagram-port <port> ] [ get-local-address ] 2bi
>>addr
] with-destructors ;
: check-datagram-port ( port -- port )
dup check-disposed
@ -221,7 +230,7 @@ HOOK: (datagram) io-backend ( addr -- datagram )
HOOK: (receive) io-backend ( datagram -- packet addrspec )
: receive ( datagram -- packet sockaddr )
: receive ( datagram -- packet addrspec )
check-datagram-port
[ (receive) ] [ addr>> ] bi parse-sockaddr ;
@ -278,11 +287,8 @@ TUPLE: inet host port ;
C: <inet> inet
: resolve-client-addr ( inet -- seq )
[ host>> ] [ port>> ] bi f resolve-host ;
M: inet (client)
resolve-client-addr (client) ;
[ host>> ] [ port>> ] bi f resolve-host (client) ;
ERROR: invalid-inet-server addrspec ;

37
extra/io/unix/backend/backend.factor Normal file → Executable file
View File

@ -62,21 +62,18 @@ GENERIC: wait-for-events ( ms mx -- )
: output-available ( fd mx -- )
remove-output-callbacks [ resume ] each ;
TUPLE: io-timeout ;
M: io-timeout summary drop "I/O operation timed out" ;
M: unix cancel-io ( port -- )
io-timeout new >>error
handle>> handle-fd mx get-global
[ input-available ] [ output-available ] 2bi ;
[ remove-input-callbacks [ t swap resume-with ] each ]
[ remove-output-callbacks [ t swap resume-with ] each ]
2bi ;
SYMBOL: +retry+ ! just try the operation again without blocking
SYMBOL: +input+
SYMBOL: +output+
: wait-for-fd ( handle event -- )
dup +retry+ eq? [ 2drop ] [
: wait-for-fd ( handle event -- timeout? )
dup +retry+ eq? [ 2drop f ] [
[
>r
swap handle-fd
@ -85,12 +82,18 @@ SYMBOL: +output+
{ +input+ [ add-input-callback ] }
{ +output+ [ add-output-callback ] }
} case
] curry "I/O" suspend 2drop
] curry "I/O" suspend nip
] if ;
ERROR: io-timeout ;
M: io-timeout summary drop "I/O operation timed out" ;
: wait-for-port ( port event -- )
[ >r dup handle>> r> wait-for-fd ] curry
with-timeout pending-error ;
[
>r handle>> r> wait-for-fd
[ io-timeout ] when
] curry with-timeout ;
! Some general stuff
: file-mode OCT: 0666 ;
@ -105,9 +108,6 @@ SYMBOL: +output+
: io-error ( n -- ) 0 < [ (io-error) ] when ;
! Readers
: eof ( reader -- )
dup buffer>> buffer-empty? [ t >>eof ] when drop ;
: (refill) ( port -- n )
[ handle>> ]
[ buffer>> buffer-end ]
@ -120,8 +120,7 @@ GENERIC: refill ( port handle -- event/f )
M: fd refill
fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read
{
{ [ dup 0 = ] [ drop eof f ] }
{ [ dup 0 > ] [ swap buffer>> n>buffer f ] }
{ [ dup 0 >= ] [ swap buffer>> n>buffer f ] }
{ [ err_no EINTR = ] [ 2drop +retry+ ] }
{ [ err_no EAGAIN = ] [ 2drop +input+ ] }
[ (io-error) ]
@ -147,8 +146,7 @@ M: fd drain
} cond ;
M: unix (wait-to-write) ( port -- )
dup dup handle>> drain dup
[ dupd wait-for-port (wait-to-write) ] [ 2drop ] if ;
dup dup handle>> drain dup [ wait-for-port ] [ 2drop ] if ;
M: unix io-multiplex ( ms/f -- )
mx get-global wait-for-events ;
@ -166,7 +164,8 @@ TUPLE: mx-port < port mx ;
: multiplexer-error ( n -- )
0 < [
err_no [ EAGAIN = ] [ EINTR = ] bi or [ (io-error) ] unless
err_no [ EAGAIN = ] [ EINTR = ] bi or
[ (io-error) ] unless
] when ;
: ?flag ( n mask symbol -- n )

15
extra/io/unix/linux/monitors/monitors.factor
View File

@ -5,7 +5,7 @@ io.files io.buffers io.monitors io.ports io.timeouts
io.unix.backend io.unix.select io.encodings.utf8
unix.linux.inotify assocs namespaces threads continuations init
math math.bitfields sets alien alien.strings alien.c-types
vocabs.loader accessors system hashtables ;
vocabs.loader accessors system hashtables destructors ;
IN: io.unix.linux.monitors
SYMBOL: watches
@ -23,9 +23,9 @@ TUPLE: linux-monitor < monitor wd inotify watches disposed ;
: wd>monitor ( wd -- monitor ) watches get at ;
: <inotify> ( -- port/f )
inotify_init dup 0 < [ drop f ] [ <input-port> ] if ;
inotify_init dup 0 < [ drop f ] [ <fd> <input-port> ] if ;
: inotify-fd inotify get handle>> ;
: inotify-fd inotify get handle>> handle-fd ;
: check-existing ( wd -- )
watches get key? [
@ -57,8 +57,10 @@ M: linux (monitor) ( path recursive? mailbox -- monitor )
M: linux-monitor dispose* ( monitor -- )
[ [ wd>> ] [ watches>> ] bi delete-at ]
[
[ inotify>> handle>> ] [ wd>> ] bi
inotify_rm_watch io-error
dup inotify>> disposed>> [ drop ] [
[ inotify>> handle>> handle-fd ] [ wd>> ] bi
inotify_rm_watch io-error
] if
] bi ;
: ignore-flags? ( mask -- ? )
@ -108,7 +110,8 @@ M: linux-monitor dispose* ( monitor -- )
] if ;
: inotify-read-loop ( port -- )
dup wait-to-read
dup check-disposed
dup wait-to-read drop
0 over buffer>> parse-file-notifications
0 over buffer>> buffer-reset
inotify-read-loop ;

90
extra/io/unix/sockets/secure/secure-tests.factor Normal file
View File

@ -0,0 +1,90 @@
IN: io.sockets.secure.tests
USING: accessors kernel namespaces io io.sockets
io.sockets.secure io.encodings.ascii io.streams.duplex
classes words destructors threads tools.test
concurrency.promises byte-arrays ;
\ <secure-config> must-infer
{ 1 0 } [ [ ] with-secure-context ] must-infer-as
[ ] [ <promise> "port" set ] unit-test
[ ] [
[
<secure-config>
"resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/root.pem" >>ca-file
"resource:extra/openssl/test/dh1024.pem" >>dh-file
"password" >byte-array >>password
[
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
dup addr>> addrspec>> port>> "port" get fulfill
accept [
class word-name write
] curry with-stream
] with-disposal
] with-secure-context
] "SSL server test" spawn drop
] unit-test
[ "secure" ] [
<secure-config> [
"127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
] with-secure-context
] unit-test
! Now, see what happens if the server closes the connection prematurely
! [ ] [ <promise> "port" set ] unit-test
!
! [ ] [
! [
! <secure-config>
! "resource:extra/openssl/test/server.pem" >>key-file
! "resource:extra/openssl/test/root.pem" >>ca-file
! "resource:extra/openssl/test/dh1024.pem" >>dh-file
! "password" >byte-array >>password
! [
! "127.0.0.1" 0 <inet4> <secure> ascii <server> [
! dup addr>> addrspec>> port>> "port" get fulfill
! accept drop
! [
! dup in>> stream>> handle>> f >>connected drop
! "hello" over stream-write dup stream-flush
! ] with-disposal
! ] with-disposal
! ] with-secure-context
! ] "SSL server test" spawn drop
! ] unit-test
! [
! <secure-config> [
! "127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
! ] with-secure-context
! ] [ \ premature-close = ] must-fail-with
! Now, try validating the certificate. This should fail because its
! actually an invalid certificate
[ ] [ <promise> "port" set ] unit-test
[ ] [
[
<secure-config>
"resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/root.pem" >>ca-file
"resource:extra/openssl/test/dh1024.pem" >>dh-file
"password" >>password
[
"127.0.0.1" 0 <inet4> <secure> ascii <server> [
dup addr>> addrspec>> port>> "port" get fulfill
accept drop dispose
] with-disposal
] with-secure-context
] "SSL server test" spawn drop
] unit-test
[
<secure-config> [
"localhost" "port" get ?promise <inet> <secure> ascii
<client> drop dispose
] with-secure-context
] [ certificate-verify-error? ] must-fail-with

36
extra/io/unix/sockets/secure/secure.factor Normal file → Executable file
View File

@ -6,7 +6,7 @@ continuations destructors
openssl openssl.libcrypto openssl.libssl
io.files io.ports io.unix.backend io.unix.sockets
io.encodings.ascii io.buffers io.sockets io.sockets.secure
unix system ;
unix system inspector ;
IN: io.unix.sockets.secure
M: ssl-handle handle-fd file>> handle-fd ;
@ -16,7 +16,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
drop
{
{ -1 [ (io-error) ] }
{ 0 [ "Premature EOF" throw ] }
{ 0 [ premature-close ] }
} case
] [
nip (ssl-error)
@ -30,7 +30,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
check-response
{
{ SSL_ERROR_NONE [ swap buffer>> n>buffer f ] }
{ SSL_ERROR_ZERO_RETURN [ drop eof f ] }
{ SSL_ERROR_ZERO_RETURN [ 2drop f ] }
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
{ SSL_ERROR_SYSCALL [ syscall-error ] }
@ -69,12 +69,12 @@ M: ssl-handle drain
[ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep <ssl-handle>
[ handle>> swap dup SSL_set_bio ] keep ;
M: ssl ((client)) ( addrspec -- handle )
M: secure ((client)) ( addrspec -- handle )
addrspec>> ((client)) <ssl-socket> ;
M: ssl parse-sockaddr addrspec>> parse-sockaddr <ssl> ;
M: secure parse-sockaddr addrspec>> parse-sockaddr <secure> ;
M: ssl (get-local-address) addrspec>> (get-local-address) ;
M: secure (get-local-address) addrspec>> (get-local-address) ;
: check-connect-response ( port r -- event )
check-response
@ -91,13 +91,13 @@ M: ssl (get-local-address) addrspec>> (get-local-address) ;
check-connect-response dup
[ dupd wait-for-port do-ssl-connect ] [ 2drop ] if ;
M: ssl establish-connection ( client-out remote -- )
M: secure establish-connection ( client-out remote -- )
[ addrspec>> establish-connection ]
[ drop do-ssl-connect ]
[ drop handle>> t >>connected drop ]
2tri ;
M: ssl (server) addrspec>> (server) ;
M: secure (server) addrspec>> (server) ;
: check-accept-response ( handle r -- event )
over handle>> over SSL_get_error
@ -111,12 +111,13 @@ M: ssl (server) addrspec>> (server) ;
: do-ssl-accept ( ssl-handle -- )
dup dup handle>> SSL_accept check-accept-response dup
[ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ;
[ >r dup file>> r> wait-for-fd drop do-ssl-accept ] [ 2drop ] if ;
M: ssl (accept)
M: secure (accept)
[
addrspec>> (accept) |dispose <ssl-socket> |dispose
dup do-ssl-accept
addrspec>> (accept) >r
|dispose <ssl-socket> t >>connected |dispose
dup do-ssl-accept r>
] with-destructors ;
: check-shutdown-response ( handle r -- event )
@ -124,14 +125,15 @@ M: ssl (accept)
{
{ 1 [ drop f ] }
{ 0 [
dup SSL_want {
{ SSL_NOTHING [ dup SSL_shutdown check-shutdown-response ] }
dup handle>> SSL_want
{
{ SSL_NOTHING [ dup handle>> SSL_shutdown check-shutdown-response ] }
{ SSL_READING [ drop +input+ ] }
{ SSL_WRITING [ drop +output+ ] }
} case
] }
{ -1 [
-1 SSL_get_error
handle>> -1 SSL_get_error
{
{ SSL_ERROR_WANT_READ [ +input+ ] }
{ SSL_ERROR_WANT_WRITE [ +output+ ] }
@ -143,6 +145,6 @@ M: ssl (accept)
M: unix ssl-shutdown
dup connected>> [
dup handle>> dup SSL_shutdown check-shutdown-response
dup [ dupd wait-for-fd ssl-shutdown ] [ 2drop ] if
dup dup handle>> SSL_shutdown check-shutdown-response
dup [ dupd wait-for-fd drop ssl-shutdown ] [ 2drop ] if
] [ drop ] if ;

17
extra/io/unix/sockets/sockets.factor
View File

@ -26,6 +26,10 @@ M: object (get-local-address) ( handle remote -- sockaddr )
>r handle-fd r> empty-sockaddr/size <int>
[ getsockname io-error ] 2keep drop ;
M: object (get-remote-address) ( handle local -- sockaddr )
>r handle-fd r> empty-sockaddr/size <int>
[ getpeername io-error ] 2keep drop ;
: init-client-socket ( fd -- )
SOL_SOCKET SO_OOBINLINE set-socket-option ;
@ -66,16 +70,17 @@ M: object (server) ( addrspec -- handle )
dup handle-fd 10 listen io-error
] with-destructors ;
: do-accept ( server addrspec -- fd )
[ handle>> handle-fd ] [ empty-sockaddr/size <int> ] bi* accept ; inline
: do-accept ( server addrspec -- fd sockaddr )
[ handle>> handle-fd ] [ empty-sockaddr/size <int> ] bi*
[ accept ] 2keep drop ; inline
M: object (accept) ( server addrspec -- fd )
M: object (accept) ( server addrspec -- fd sockaddr )
2dup do-accept
{
{ [ dup 0 >= ] [ 2nip <fd> ] }
{ [ err_no EINTR = ] [ drop (accept) ] }
{ [ over 0 >= ] [ >r 2nip <fd> r> ] }
{ [ err_no EINTR = ] [ 2drop (accept) ] }
{ [ err_no EAGAIN = ] [
drop
2drop
[ drop +input+ wait-for-port ]
[ (accept) ]
2bi

8
extra/io/windows/mmap/mmap-tests.factor Normal file
View File

@ -0,0 +1,8 @@
USING: io io.mmap io.files kernel tools.test continuations
sequences io.encodings.ascii accessors ;
IN: io.windows.mmap.tests
[ ] [ "a" "mmap-grow-test.txt" temp-file ascii set-file-contents ] unit-test
[ 1 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test
[ ] [ "mmap-grow-test.txt" temp-file 100 [ [ ] change-each ] with-mapped-file ] unit-test
[ 100 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test

135
extra/io/windows/nt/backend/backend.factor
View File

@ -8,7 +8,8 @@ accessors locals ;
QUALIFIED: windows.winsock
IN: io.windows.nt.backend
SYMBOL: io-hash
! Global variable with assoc mapping overlapped to threads
SYMBOL: pending-overlapped
TUPLE: io-callback port thread ;
@ -33,62 +34,41 @@ M: winnt add-completion ( win32-handle -- )
handle>> master-completion-port get-global <completion-port> drop ;
: eof? ( error -- ? )
dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ;
: overlapped-error? ( port n -- ? )
zero? [
GetLastError {
{ [ dup expected-io-error? ] [ 2drop t ] }
{ [ dup eof? ] [ drop t >>eof drop f ] }
[ (win32-error-string) throw ]
} cond
] [
drop t
] if ;
: get-overlapped-result ( overlapped port -- bytes-transferred )
dup handle>> handle>> rot 0 <uint>
[ 0 GetOverlappedResult overlapped-error? drop ] keep *uint ;
: save-callback ( overlapped port -- )
[
<io-callback> swap
dup alien? [ "bad overlapped in save-callback" throw ] unless
io-hash get-global set-at
] "I/O" suspend 3drop ;
[ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] bi or ;
: twiddle-thumbs ( overlapped port -- bytes-transferred )
[ save-callback ]
[ get-overlapped-result ]
[ nip pending-error ]
2tri ;
:: wait-for-overlapped ( ms -- overlapped ? )
master-completion-port get-global
0 <int> ! bytes
f <void*> ! key
f <void*> ! overlapped
[
ms INFINITE or ! timeout
GetQueuedCompletionStatus
] keep *void* swap zero? ;
drop
[ pending-overlapped get-global set-at ] curry "I/O" suspend
{
{ [ dup integer? ] [ ] }
{ [ dup array? ] [
first dup eof?
[ drop 0 ] [ (win32-error-string) throw ] if
] }
} cond
] with-timeout ;
: lookup-callback ( overlapped -- callback )
io-hash get-global delete-at* drop
dup io-callback? [ "no callback in io-hash" throw ] unless ;
:: wait-for-overlapped ( ms -- bytes-transferred overlapped error? )
master-completion-port get-global
0 <int> [ ! bytes
f <void*> ! key
f <void*> [ ! overlapped
ms INFINITE or ! timeout
GetQueuedCompletionStatus zero?
] keep *void*
] keep *int spin ;
: resume-callback ( result overlapped -- )
pending-overlapped get-global delete-at* drop resume-with ;
: handle-overlapped ( timeout -- ? )
wait-for-overlapped [
GetLastError dup expected-io-error? [ 2drop f ] [
>r lookup-callback [ thread>> ] [ port>> ] bi r>
dup eof?
[ drop t >>eof ]
[ (win32-error-string) >>error ] if drop
resume t
] if
>r drop GetLastError
[ 1array ] [ expected-io-error? ] bi
[ r> 2drop f ] [ r> resume-callback t ] if
] [
lookup-callback
thread>> resume t
resume-callback t
] if ;
M: winnt cancel-io
@ -99,44 +79,43 @@ M: winnt io-multiplex ( ms -- )
M: winnt init-io ( -- )
<master-completion-port> master-completion-port set-global
H{ } clone io-hash set-global
H{ } clone pending-overlapped set-global
windows.winsock:init-winsock ;
: file-error? ( n -- eof? )
zero? [
GetLastError {
{ [ dup expected-io-error? ] [ drop f ] }
{ [ dup eof? ] [ drop t ] }
[ (win32-error-string) throw ]
} cond
] [ f ] if ;
: wait-for-file ( FileArgs n port -- n )
swap file-error?
[ 2drop 0 ] [ >r lpOverlapped>> r> twiddle-thumbs ] if ;
: update-file-ptr ( n port -- )
handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
: finish-flush ( n port -- )
: finish-write ( n port -- )
[ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
: ((wait-to-write)) ( port -- )
dup make-FileArgs
tuck setup-write WriteFile
dupd overlapped-error? [
>r lpOverlapped>> r>
[ twiddle-thumbs ] keep
[ finish-flush ] keep
dup buffer>> buffer-empty? [ drop ] [ ((wait-to-write)) ] if
] [
2drop
] if ;
M: winnt (wait-to-write)
[ [ ((wait-to-write)) ] with-timeout ] with-destructors ;
[
[ make-FileArgs dup setup-write WriteFile ]
[ wait-for-file ]
[ finish-write ]
tri
] with-destructors ;
: finish-read ( n port -- )
over zero? [
t >>eof 2drop
] [
[ buffer>> n>buffer ] [ update-file-ptr ] 2bi
] if ;
: ((wait-to-read)) ( port -- )
dup make-FileArgs
tuck setup-read ReadFile
dupd overlapped-error? [
>r lpOverlapped>> r>
[ twiddle-thumbs ] [ finish-read ] bi
] [ 2drop ] if ;
[ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
M: winnt (wait-to-read) ( port -- )
[ [ ((wait-to-read)) ] with-timeout ] with-destructors ;
[
[ make-FileArgs dup setup-read ReadFile ]
[ wait-for-file ]
[ finish-read ]
tri
] with-destructors ;

2
extra/io/windows/nt/monitors/monitors.factor
View File

@ -35,7 +35,7 @@ TUPLE: win32-monitor < monitor port ;
(make-overlapped)
[ f ReadDirectoryChangesW win32-error=0/f ] keep ;
: read-changes ( port -- bytes )
: read-changes ( port -- bytes-transferred )
[
[ begin-reading-changes ] [ twiddle-thumbs ] bi
] with-destructors ;

27
extra/io/windows/nt/sockets/sockets.factor
View File

@ -82,15 +82,27 @@ TUPLE: AcceptEx-args port
AcceptEx-args >tuple*< AcceptEx drop
winsock-error-string [ throw ] when* ;
M: object (accept) ( server addr -- handle )
: extract-remote-address ( AcceptEx -- sockaddr )
{
[ lpOutputBuffer*>> ]
[ dwReceiveDataLength*>> ]
[ dwLocalAddressLength*>> ]
[ dwRemoteAddressLength*>> ]
} cleave
f <void*>
0 <int>
f <void*>
[ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
M: object (accept) ( server addr -- handle sockaddr )
[
[
<AcceptEx-args>
<AcceptEx-args>
{
[ call-AcceptEx ]
[ wait-for-socket drop ]
[ sAcceptSocket*>> opened-socket ]
tri
] curry with-timeout
[ sAcceptSocket*>> <win32-socket> ]
[ extract-remote-address ]
} cleave
] with-destructors ;
TUPLE: WSARecvFrom-args port
@ -119,7 +131,8 @@ TUPLE: WSARecvFrom-args port
WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ;
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
[ lpBuffers*>> WSABUF-buf swap memory>byte-array ] [ lpFrom*>> ] bi ;
[ lpBuffers*>> WSABUF-buf swap memory>byte-array ]
[ [ lpFrom*>> ] [ lpFromLen*>> *int ] bi memory>byte-array ] bi ;
M: winnt (receive) ( datagram -- packet addrspec )
[

4
extra/io/windows/sockets/sockets.factor
View File

@ -30,6 +30,10 @@ M: object (get-local-address) ( socket addrspec -- sockaddr )
>r handle>> r> empty-sockaddr/size <int>
[ getsockname socket-error ] 2keep drop ;
M: object (get-remote-address) ( socket addrspec -- sockaddr )
>r handle>> r> empty-sockaddr/size <int>
[ getpeername socket-error ] 2keep drop ;
: bind-socket ( win32-socket sockaddr len -- )
>r >r handle>> r> r> bind socket-error ;

11
extra/jamshred/game/game.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math.vectors ;
USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ;
IN: jamshred.game
TUPLE: jamshred sounds tunnel players running quit ;
@ -29,3 +29,12 @@ TUPLE: jamshred sounds tunnel players running quit ;
: mouse-moved ( x-radians y-radians jamshred -- )
jamshred-player -rot turn-player ;
: units-per-full-roll ( -- n ) 50 ;
: jamshred-roll ( jamshred n -- )
[ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;
: mouse-scroll-x ( jamshred x -- ) jamshred-roll ;
: mouse-scroll-y ( jamshred y -- )
neg swap jamshred-player change-player-speed ;

12
extra/jamshred/gl/gl.factor
View File

@ -51,18 +51,18 @@ IN: jamshred.gl
GL_LIGHT0 glEnable
GL_FOG glEnable
GL_FOG_DENSITY 0.09 glFogf
GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
GL_COLOR_MATERIAL glEnable
GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial
GL_LIGHT0 GL_POSITION F{ 0.0 0.0 -3.0 1.0 } >c-float-array glLightfv
GL_LIGHT0 GL_POSITION F{ 0.0 0.0 0.0 1.0 } >c-float-array glLightfv
GL_LIGHT0 GL_AMBIENT F{ 0.2 0.2 0.2 1.0 } >c-float-array glLightfv
GL_LIGHT0 GL_DIFFUSE F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv
GL_LIGHT0 GL_SPECULAR F{ 1.0 1.0 1.0 1.0 } >c-float-array glLightfv ;
: player-view ( player -- )
[ location>> first3 ]
[ [ location>> ] [ forward>> ] bi v+ first3 ]
[ up>> first3 ] tri gluLookAt ;
[ location>> ]
[ [ location>> ] [ forward>> ] bi v+ ]
[ up>> ] tri gl-look-at ;
: draw-jamshred ( jamshred width height -- )
init-graphics jamshred-player dup player-view draw-tunnel ;
init-graphics jamshred-player [ player-view ] [ draw-tunnel ] bi ;

17
extra/jamshred/jamshred.factor
View File

@ -21,9 +21,9 @@ M: jamshred-gadget draw-gadget* ( gadget -- )
dup jamshred>> quit>> [
drop
] [
dup [ jamshred>> jamshred-update ]
[ relayout-1 ] bi
yield jamshred-loop
[ jamshred>> jamshred-update ]
[ relayout-1 ]
[ yield jamshred-loop ] tri
] if ;
: fullscreen ( gadget -- )
@ -45,7 +45,7 @@ M: jamshred-gadget ungraft* ( gadget -- )
<jamshred> >>jamshred drop ;
: pix>radians ( n m -- theta )
2 / / pi 2 * * ;
/ pi 4 * * ; ! 2 / / pi 2 * * ;
: x>radians ( x gadget -- theta )
#! translate motion of x pixels to an angle
@ -68,8 +68,9 @@ M: jamshred-gadget ungraft* ( gadget -- )
] 2keep >>last-hand-loc drop ;
: handle-mouse-scroll ( jamshred-gadget -- )
jamshred>> jamshred-player scroll-direction get
second neg swap change-player-speed ;
jamshred>> scroll-direction get
[ first mouse-scroll-x ]
[ second mouse-scroll-y ] 2bi ;
: quit ( gadget -- )
[ no-fullscreen ] [ close-window ] bi ;
@ -78,6 +79,10 @@ jamshred-gadget H{
{ T{ key-down f f "r" } [ jamshred-restart ] }
{ T{ key-down f f " " } [ jamshred>> toggle-running ] }
{ T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
{ T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] }
{ T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] }
{ T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] }
{ T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] }
{ T{ key-down f f "q" } [ quit ] }
{ T{ motion } [ handle-mouse-motion ] }
{ T{ mouse-scroll } [ handle-mouse-scroll ] }

3
extra/jamshred/oint/oint.factor
View File

@ -29,6 +29,9 @@ C: <oint> oint
: up-pivot ( oint theta -- )
over up>> rotate-oint ;
: forward-pivot ( oint theta -- )
over forward>> rotate-oint ;
: random-float+- ( n -- m )
#! find a random float between -n/2 and n/2
dup 10000 * >fixnum random 10000 / swap 2 / - ;

16
extra/jamshred/player/player.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors colors jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ;
USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ;
IN: jamshred.player
TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
@ -16,6 +16,9 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
: turn-player ( player x-radians y-radians -- )
>r over r> left-pivot up-pivot ;
: roll-player ( player z-radians -- )
forward-pivot ;
: to-tunnel-start ( player -- )
[ tunnel>> first dup location>> ]
[ tuck (>>location) (>>nearest-segment) ] bi ;
@ -35,6 +38,9 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
: change-player-speed ( inc player -- )
[ + speed-range clamp-to-range ] change-speed drop ;
: multiply-player-speed ( n player -- )
[ * speed-range clamp-to-range ] change-speed drop ;
: distance-to-move ( player -- distance )
[ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ]
[ (>>last-move) ] tri ;
@ -43,8 +49,12 @@ DEFER: (move-player)
: ?bounce ( distance-remaining player -- )
over 0 > [
[ dup nearest-segment>> bounce ] [ sounds>> bang ]
[ (move-player) ] tri
{
[ dup nearest-segment>> bounce ]
[ sounds>> bang ]
[ 3/4 swap multiply-player-speed ]
[ (move-player) ]
} cleave
] [
2drop
] if ;

4
extra/openal/openal.factor
View File

@ -235,13 +235,13 @@ SYMBOL: init
: init-openal ( -- )
init get-global expired? [
f f alutInit drop
f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
1337 <alien> init set-global
] when ;
: exit-openal ( -- )
init get-global expired? [
alutExit drop
alutExit 0 = [ "Could not close OpenAL" throw ] when
f init set-global
] unless ;

2
extra/opengl/opengl.factor
View File

@ -154,7 +154,7 @@ MACRO: set-draw-buffers ( buffers -- )
swap glPushAttrib call glPopAttrib ; inline
: gl-look-at ( eye focus up -- )
>r >r first3 r> first3 r> first3 gluLookAt ;
[ first3 ] tri@ gluLookAt ;
TUPLE: sprite loc dim dim2 dlist texture ;

107
extra/openssl/libssl/libssl.factor
View File

@ -5,7 +5,8 @@
!
! export LD_LIBRARY_PATH=/opt/local/lib
USING: alien alien.syntax combinators kernel system ;
USING: alien alien.syntax combinators kernel system namespaces
assocs parser sequences words quotations ;
IN: openssl.libssl
@ -176,6 +177,12 @@ FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( ssl-ctx ctx, void* rsa ) ;
FUNCTION: void* BIO_f_ssl ( ) ;
: SSL_CTX_set_tmp_rsa ( ctx rsa -- n )
>r SSL_CTRL_SET_TMP_RSA 0 r> SSL_CTX_ctrl ;
: SSL_CTX_set_tmp_dh ( ctx dh -- n )
>r SSL_CTRL_SET_TMP_DH 0 r> SSL_CTX_ctrl ;
! ===============================================
! x509.h
! ===============================================
@ -191,47 +198,63 @@ FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ;
! x509_vfy.h
! ===============================================
: X509_V_OK 0 ; inline
: X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT 2 ; inline
: X509_V_ERR_UNABLE_TO_GET_CRL 3 ; inline
: X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE 4 ; inline
: X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE 5 ; inline
: X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY 6 ; inline
: X509_V_ERR_CERT_SIGNATURE_FAILURE 7 ; inline
: X509_V_ERR_CRL_SIGNATURE_FAILURE 8 ; inline
: X509_V_ERR_CERT_NOT_YET_VALID 9 ; inline
: X509_V_ERR_CERT_HAS_EXPIRED 10 ; inline
: X509_V_ERR_CRL_NOT_YET_VALID 11 ; inline
: X509_V_ERR_CRL_HAS_EXPIRED 12 ; inline
: X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD 13 ; inline
: X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD 14 ; inline
: X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD 15 ; inline
: X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD 16 ; inline
: X509_V_ERR_OUT_OF_MEM 17 ; inline
: X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT 18 ; inline
: X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN 19 ; inline
: X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY 20 ; inline
: X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE 21 ; inline
: X509_V_ERR_CERT_CHAIN_TOO_LONG 22 ; inline
: X509_V_ERR_CERT_REVOKED 23 ; inline
: X509_V_ERR_INVALID_CA 24 ; inline
: X509_V_ERR_PATH_LENGTH_EXCEEDED 25 ; inline
: X509_V_ERR_INVALID_PURPOSE 26 ; inline
: X509_V_ERR_CERT_UNTRUSTED 27 ; inline
: X509_V_ERR_CERT_REJECTED 28 ; inline
: X509_V_ERR_SUBJECT_ISSUER_MISMATCH 29 ; inline
: X509_V_ERR_AKID_SKID_MISMATCH 30 ; inline
: X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH 31 ; inline
: X509_V_ERR_KEYUSAGE_NO_CERTSIGN 32 ; inline
: X509_V_ERR_UNABLE_TO_GET_CRL_ISSUER 33 ; inline
: X509_V_ERR_UNHANDLED_CRITICAL_EXTENSION 34 ; inline
: X509_V_ERR_KEYUSAGE_NO_CRL_SIGN 35 ; inline
: X509_V_ERR_UNHANDLED_CRITICAL_CRL_EXTENSION 36 ; inline
: X509_V_ERR_INVALID_NON_CA 37 ; inline
: X509_V_ERR_PROXY_PATH_LENGTH_EXCEEDED 38 ; inline
: X509_V_ERR_KEYUSAGE_NO_DIGITAL_SIGNATURE 39 ; inline
: X509_V_ERR_PROXY_CERTIFICATES_NOT_ALLOWED 40 ; inline
: X509_V_ERR_APPLICATION_VERIFICATION 50 ; inline
<<
SYMBOL: verify-messages
H{ } clone verify-messages set-global
: verify-message ( n -- word ) verify-messages get-global at ;
: X509_V_:
scan "X509_V_" prepend create-in
scan-word
[ 1quotation define-inline ]
[ verify-messages get set-at ] 2bi ; parsing
>>
X509_V_: OK 0
X509_V_: ERR_UNABLE_TO_GET_ISSUER_CERT 2
X509_V_: ERR_UNABLE_TO_GET_CRL 3
X509_V_: ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE 4
X509_V_: ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE 5
X509_V_: ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY 6
X509_V_: ERR_CERT_SIGNATURE_FAILURE 7
X509_V_: ERR_CRL_SIGNATURE_FAILURE 8
X509_V_: ERR_CERT_NOT_YET_VALID 9
X509_V_: ERR_CERT_HAS_EXPIRED 10
X509_V_: ERR_CRL_NOT_YET_VALID 11
X509_V_: ERR_CRL_HAS_EXPIRED 12
X509_V_: ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD 13
X509_V_: ERR_ERROR_IN_CERT_NOT_AFTER_FIELD 14
X509_V_: ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD 15
X509_V_: ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD 16
X509_V_: ERR_OUT_OF_MEM 17
X509_V_: ERR_DEPTH_ZERO_SELF_SIGNED_CERT 18
X509_V_: ERR_SELF_SIGNED_CERT_IN_CHAIN 19
X509_V_: ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY 20
X509_V_: ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE 21
X509_V_: ERR_CERT_CHAIN_TOO_LONG 22
X509_V_: ERR_CERT_REVOKED 23
X509_V_: ERR_INVALID_CA 24
X509_V_: ERR_PATH_LENGTH_EXCEEDED 25
X509_V_: ERR_INVALID_PURPOSE 26
X509_V_: ERR_CERT_UNTRUSTED 27
X509_V_: ERR_CERT_REJECTED 28
X509_V_: ERR_SUBJECT_ISSUER_MISMATCH 29
X509_V_: ERR_AKID_SKID_MISMATCH 30
X509_V_: ERR_AKID_ISSUER_SERIAL_MISMATCH 31
X509_V_: ERR_KEYUSAGE_NO_CERTSIGN 32
X509_V_: ERR_UNABLE_TO_GET_CRL_ISSUER 33
X509_V_: ERR_UNHANDLED_CRITICAL_EXTENSION 34
X509_V_: ERR_KEYUSAGE_NO_CRL_SIGN 35
X509_V_: ERR_UNHANDLED_CRITICAL_CRL_EXTENSION 36
X509_V_: ERR_INVALID_NON_CA 37
X509_V_: ERR_PROXY_PATH_LENGTH_EXCEEDED 38
X509_V_: ERR_KEYUSAGE_NO_DIGITAL_SIGNATURE 39
X509_V_: ERR_PROXY_CERTIFICATES_NOT_ALLOWED 40
X509_V_: ERR_APPLICATION_VERIFICATION 50
! ===============================================
! obj_mac.h

15
extra/openssl/openssl-tests.factor
View File

@ -1,20 +1,21 @@
USING: io.sockets.secure io.encodings.ascii alien.strings
openssl namespaces accessors tools.test continuations kernel ;
openssl ssl-backend [
openssl secure-socket-backend [
[ ] [
<ssl-config>
<secure-config>
"resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/root.pem" >>ca-file
"password" ascii string>alien >>password
[ ] with-ssl-context
"resource:extra/openssl/test/dh1024.pem" >>dh-file
"password" >>password
[ ] with-secure-context
] unit-test
[
<ssl-config>
<secure-config>
"resource:extra/openssl/test/server.pem" >>key-file
"resource:extra/openssl/test/root.pem" >>ca-file
"wrong password" ascii string>alien >>password
[ ] with-ssl-context
"wrong password" >>password
[ ] with-secure-context
] must-fail
] with-variable

64
extra/openssl/openssl.factor
View File

@ -5,7 +5,7 @@ math.order combinators init alien alien.c-types alien.strings libc
continuations destructors debugger inspector
locals unicode.case
openssl.libcrypto openssl.libssl
io.backend io.ports io.files io.encodings.ascii io.sockets.secure ;
io.backend io.ports io.files io.encodings.8-bit io.sockets.secure ;
IN: openssl
! This code is based on http://www.rtfm.com/openssl-examples/
@ -47,7 +47,7 @@ SYMBOL: ssl-initiazed?
[ f ssl-initiazed? set-global ] "openssl" add-init-hook
TUPLE: openssl-context < ssl-context aliens ;
TUPLE: openssl-context < secure-context aliens ;
: load-certificate-chain ( ctx -- )
dup config>> key-file>> [
@ -68,7 +68,7 @@ TUPLE: openssl-context < ssl-context aliens ;
] alien-callback ;
: default-pasword ( ctx -- alien )
[ config>> password>> malloc-byte-array ] [ aliens>> ] bi
[ config>> password>> latin1 malloc-string ] [ aliens>> ] bi
[ push ] [ drop ] 2bi ;
: set-default-password ( ctx -- )
@ -99,25 +99,57 @@ TUPLE: openssl-context < ssl-context aliens ;
: set-verify-depth ( ctx -- )
handle>> 1 SSL_CTX_set_verify_depth ;
M: openssl <ssl-context> ( config -- context )
TUPLE: bio handle disposed ;
: <bio> f bio boa ;
M: bio dispose* handle>> BIO_free ssl-error ;
: <file-bio> ( path -- bio )
normalize-path "r" BIO_new_file dup ssl-error <bio> ;
: load-dh-params ( ctx -- )
dup config>> dh-file>> [
[ handle>> ] [ config>> dh-file>> ] bi <file-bio> &dispose
handle>> f f f PEM_read_bio_DHparams dup ssl-error
SSL_CTX_set_tmp_dh ssl-error
] [ drop ] if ;
TUPLE: rsa handle disposed ;
: <rsa> f rsa boa ;
M: rsa dispose* handle>> RSA_free ;
: generate-eph-rsa-key ( ctx -- )
[ handle>> ]
[
config>> ephemeral-key-bits>> RSA_F4 f f RSA_generate_key
dup ssl-error <rsa> &dispose handle>>
] bi
SSL_CTX_set_tmp_rsa ssl-error ;
M: openssl <secure-context> ( config -- context )
maybe-init-ssl
[
dup method>> ssl-method SSL_CTX_new
dup ssl-error V{ } clone openssl-context boa |dispose
dup ssl-error f V{ } clone openssl-context boa |dispose
{
[ load-certificate-chain ]
[ set-default-password ]
[ use-private-key-file ]
[ load-verify-locations ]
[ set-verify-depth ]
[ load-dh-params ]
[ generate-eph-rsa-key ]
[ ]
} cleave
] with-destructors ;
M: openssl-context dispose
dup aliens>> [ free ] each f >>aliens
dup handle>> [ SSL_CTX_free ] when* f >>handle
drop ;
M: openssl-context dispose*
[ aliens>> [ free ] each ]
[ handle>> SSL_CTX_free ]
bi ;
TUPLE: ssl-handle file handle connected disposed ;
@ -127,7 +159,7 @@ M: no-ssl-context summary
drop "SSL operations must be wrapped in calls to with-ssl-context" ;
: current-ssl-context ( -- ctx )
ssl-context get [ no-ssl-context ] unless* ;
secure-context get [ no-ssl-context ] unless* ;
: <ssl-handle> ( fd -- ssl )
current-ssl-context handle>> SSL_new dup ssl-error
@ -141,28 +173,24 @@ M: ssl-handle dispose*
[ file>> dispose ]
tri ;
ERROR: certificate-verify-error result ;
: check-verify-result ( ssl-handle -- )
SSL_get_verify_result dup X509_V_OK =
[ certificate-verify-error ] [ drop ] if ;
[ drop ] [ verify-message certificate-verify-error ] if ;
: common-name ( certificate -- host )
X509_get_subject_name
NID_commonName 256 <byte-array>
[ 256 X509_NAME_get_text_by_NID ] keep
swap -1 = [ drop f ] [ ascii alien>string ] if ;
ERROR: common-name-verify-error expected got ;
swap -1 = [ drop f ] [ latin1 alien>string ] if ;
: check-common-name ( host ssl-handle -- )
SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ =
[ 2drop ] [ common-name-verify-error ] if ;
: check-certificate ( host ssl -- )
M: openssl check-certificate ( host ssl -- )
handle>>
[ nip check-verify-result ]
[ check-common-name ]
2bi ;
openssl ssl-backend set-global
openssl secure-socket-backend set-global

4
extra/shell/parser/parser.factor
View File

@ -23,8 +23,8 @@ TUPLE: factor-expr expr ;
pipeline-expr new
over [ 1st ] [ 4th [ 1st ] map ] [ 5th ] tri suffix prefix-on >>commands
over 2nd >>stdin
over 5th >>stdout
swap 6th >>background ;
over 6th >>stdout
swap 7th >>background ;
: ast>single-quoted-expr ( ast -- obj )
2nd >string single-quoted-expr boa ;

5
extra/shell/shell.factor
View File

@ -1,7 +1,7 @@
USING: kernel parser words continuations namespaces debugger
sequences combinators splitting prettyprint
system io io.files io.launcher io.encodings.utf8 sequences.deep
system io io.files io.launcher io.encodings.utf8 io.pipes sequences.deep
accessors multi-methods newfx shell.parser ;
IN: shell
@ -95,8 +95,7 @@ METHOD: expand { object } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: pipeline-chant ( pipeline-chant -- )
drop "ix: pipelines not supported" print ;
: pipeline-chant ( pipeline-chant -- ) commands>> run-pipeline drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

15
extra/ui/cocoa/views/views.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays assocs cocoa kernel math cocoa.messages
USING: alien alien.c-types arrays assocs cocoa kernel math cocoa.messages
cocoa.subclassing cocoa.classes cocoa.views cocoa.application
cocoa.pasteboard cocoa.types cocoa.windows sequences ui
ui.gadgets ui.gadgets.worlds ui.gestures core-foundation
threads combinators ;
cocoa.pasteboard cocoa.types cocoa.windows sequences ui ui.gadgets
ui.gadgets.worlds ui.gestures core-foundation threads combinators ;
IN: ui.cocoa.views
: send-mouse-moved ( view event -- )
@ -360,8 +359,14 @@ CLASS: {
]
} ;
: sync-refresh-to-screen ( GLView -- )
-> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
CGLSetParameter drop ;
: <FactorView> ( world -- view )
FactorView over rect-dim <GLView> [ register-window ] keep ;
FactorView over rect-dim <GLView>
[ sync-refresh-to-screen ] keep
[ register-window ] keep ;
CLASS: {
{ +superclass+ "NSObject" }

3
extra/unix/unix.factor
View File

@ -26,6 +26,8 @@ TYPEDEF: uint socklen_t
: ESRCH 3 ; inline
: EEXIST 17 ; inline
: NGROUPS_MAX 16 ; inline
C-STRUCT: group
{ "char*" "gr_name" }
{ "char*" "gr_passwd" }
@ -120,6 +122,7 @@ FUNCTION: void* mmap ( void* addr, size_t len, int prot, int flags, int fd, off_
FUNCTION: int munmap ( void* addr, size_t len ) ;
FUNCTION: uint ntohl ( uint n ) ;
FUNCTION: ushort ntohs ( ushort n ) ;
FUNCTION: int shutdown ( int fd, int how ) ;
FUNCTION: int open ( char* path, int flags, int prot ) ;

2
extra/windows/com/com-tests.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
USING: kernel windows.com windows.com.syntax windows.ole32
alien alien.syntax tools.test libc alien.c-types arrays.lib
namespaces arrays continuations accessors math windows.com.wrapper
windows.com.wrapper.private ;
windows.com.wrapper.private destructors ;
IN: windows.com.tests
COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}

3
extra/windows/com/wrapper/wrapper-docs.factor Normal file → Executable file
View File

@ -1,5 +1,6 @@
USING: help.markup help.syntax io kernel math quotations
multiline alien windows.com windows.com.syntax continuations ;
multiline alien windows.com windows.com.syntax continuations
destructors ;
IN: windows.com.wrapper
HELP: <com-wrapper>

2
extra/windows/com/wrapper/wrapper.factor
View File

@ -2,7 +2,7 @@ USING: alien alien.c-types windows.com.syntax
windows.com.syntax.private windows.com continuations kernel
sequences.lib namespaces windows.ole32 libc
assocs accessors arrays sequences quotations combinators
math combinators.lib words compiler.units ;
math combinators.lib words compiler.units destructors ;
IN: windows.com.wrapper
TUPLE: com-wrapper vtbls freed? ;

1
extra/windows/winsock/winsock.factor
View File

@ -168,6 +168,7 @@ FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ;
FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ;
FUNCTION: int getsockname ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
FUNCTION: int getpeername ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
TYPEDEF: uint SERVICETYPE
TYPEDEF: OVERLAPPED WSAOVERLAPPED