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

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

db4
Eduardo Cavazos 2008-10-22 09:56:06 -05:00
parent b2ef848df4 1d750b26d2
commit 8c3ae91ef3
148 changed files with 2505 additions and 870 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
basis/calendar/unix/unix.factor
View File

@ -4,13 +4,19 @@ USING: alien alien.c-types alien.syntax arrays calendar
kernel math unix unix.time namespaces system ;
IN: calendar.unix
: timeval>unix-time ( timeval -- timestamp )
: timeval>seconds ( timeval -- seconds )
[ timeval-sec seconds ] [ timeval-usec microseconds ] bi
time+ since-1970 ;
time+ ;
: timespec>unix-time ( timeval -- timestamp )
: timeval>unix-time ( timeval -- timestamp )
timeval>seconds since-1970 ;
: timespec>seconds ( timespec -- seconds )
[ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi
time+ since-1970 ;
time+ ;
: timespec>unix-time ( timespec -- timestamp )
timespec>seconds since-1970 ;
: get-time ( -- alien )
f time <uint> localtime ;

24
basis/cpu/x86/assembler/assembler-tests.factor
View File

@ -4,9 +4,9 @@ IN: cpu.x86.assembler.tests
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test
! [ { HEX: 89 HEX: ca } ] [ [ EDX ECX MOV ] { } make ] unit-test
! [ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test
! [ { HEX: 49 HEX: 89 HEX: d4 } ] [ [ R12 RDX MOV ] { } make ] unit-test
[ { HEX: 89 HEX: ca } ] [ [ EDX ECX MOV ] { } make ] unit-test
[ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: d4 } ] [ [ R12 RDX MOV ] { } make ] unit-test
[ { HEX: f2 HEX: 0f HEX: 2c HEX: c0 } ] [ [ EAX XMM0 CVTTSD2SI ] { } make ] unit-test
[ { HEX: f2 HEX: 48 HEX: 0f HEX: 2c HEX: c0 } ] [ [ RAX XMM0 CVTTSD2SI ] { } make ] unit-test
@ -39,3 +39,21 @@ IN: cpu.x86.assembler.tests
[ { HEX: 80 HEX: 08 HEX: 05 } ] [ [ EAX [] 5 <byte> OR ] { } make ] unit-test
[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 <byte> MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1a } ] [ [ R10 RBX [+] RAX MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1b } ] [ [ R11 RBX [+] RAX MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1c } ] [ [ R12 RBX [+] RAX MOV ] { } make ] unit-test
[ { HEX: 48 HEX: 89 HEX: 04 HEX: 1c } ] [ [ RSP RBX [+] RAX MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ R13 RBX [+] RAX MOV ] { } make ] unit-test
[ { HEX: 48 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ RBP RBX [+] RAX MOV ] { } make ] unit-test
[ { HEX: 4a HEX: 89 HEX: 04 HEX: 23 } ] [ [ RBX R12 [+] RAX MOV ] { } make ] unit-test
[ { HEX: 4a HEX: 89 HEX: 04 HEX: 2b } ] [ [ RBX R13 [+] RAX MOV ] { } make ] unit-test
[ { HEX: 4b HEX: 89 HEX: 44 HEX: 25 HEX: 00 } ] [ [ R13 R12 [+] RAX MOV ] { } make ] unit-test
[ { HEX: 4b HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 R13 [+] RAX MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 RBP [+] RAX MOV ] { } make ] unit-test
[ [ R12 RSP [+] RAX MOV ] { } make ] must-fail

19
basis/cpu/x86/assembler/assembler.factor
View File

@ -64,18 +64,18 @@ M: indirect extended? base>> extended? ;
: canonicalize-EBP ( indirect -- indirect )
#! { EBP } ==> { EBP 0 }
dup base>> { EBP RBP R13 } member? [
dup displacement>> [ 0 >>displacement ] unless
] when ;
dup [ base>> { EBP RBP R13 } member? ] [ displacement>> not ] bi and
[ 0 >>displacement ] when ;
: canonicalize-ESP ( indirect -- indirect )
#! { ESP } ==> { ESP ESP }
dup base>> { ESP RSP R12 } member? [ ESP >>index ] when ;
ERROR: bad-index indirect ;
: check-ESP ( indirect -- indirect )
dup index>> { ESP RSP } memq? [ bad-index ] when ;
: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
#! quirks.
canonicalize-EBP canonicalize-ESP ;
canonicalize-EBP check-ESP ;
: <indirect> ( base index scale displacement -- indirect )
indirect boa canonicalize ;
@ -91,7 +91,7 @@ M: indirect extended? base>> extended? ;
GENERIC: sib-present? ( op -- ? )
M: indirect sib-present?
[ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri or or ;
[ base>> { ESP RSP R12 } member? ] [ index>> ] [ scale>> ] tri or or ;
M: register sib-present? drop f ;
@ -254,7 +254,8 @@ M: object operand-64? drop f ;
reg-code swap addressing ;
: direction-bit ( dst src op -- dst' src' op' )
pick register? [ BIN: 10 opcode-or swapd ] when ;
pick register? pick register? not and
[ BIN: 10 opcode-or swapd ] when ;
: operand-size-bit ( dst src op -- dst' src' op' )
over register-8? [ BIN: 1 opcode-or ] unless ;

6
basis/debugger/debugger-docs.factor
View File

@ -1,7 +1,6 @@
USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes
help generic.standard continuations system io.files.private
listener ;
help generic.standard continuations io.files.private listener ;
IN: debugger
ARTICLE: "debugger" "The debugger"
@ -144,5 +143,4 @@ HELP: memory-error.
{ $notes "This can be a result of incorrect usage of C library interface words, a bug in the compiler, or a bug in the VM." } ;
HELP: primitive-error.
{ $error-description "Thrown by the Factor VM if an unsupported primitive word is called." }
{ $notes "This word is only ever thrown on Windows CE, where the " { $link cwd } ", " { $link cd } ", and " { $link os-env } " primitives are unsupported." } ;
{ $error-description "Thrown by the Factor VM if an unsupported primitive word is called." } ;

1
basis/environment/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

68
basis/environment/environment-docs.factor Normal file
View File

@ -0,0 +1,68 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs help.markup help.syntax io.streams.string sequences strings ;
IN: environment
HELP: (os-envs)
{ $values
{ "seq" sequence } }
{ $description "" } ;
HELP: (set-os-envs)
{ $values
{ "seq" sequence } }
{ $description "" } ;
HELP: os-env ( key -- value )
{ $values { "key" string } { "value" string } }
{ $description "Looks up the value of a shell environment variable." }
{ $examples
"This is an operating system-specific feature. On Unix, you can do:"
{ $unchecked-example "\"USER\" os-env print" "jane" }
} ;
HELP: os-envs
{ $values { "assoc" "an association mapping strings to strings" } }
{ $description "Outputs the current set of environment variables." }
{ $notes
"Names and values of environment variables are operating system-specific."
} ;
HELP: set-os-envs
{ $values { "assoc" "an association mapping strings to strings" } }
{ $description "Replaces the current set of environment variables." }
{ $notes
"Names and values of environment variables are operating system-specific. Windows NT allows values up to 32766 characters in length."
} ;
HELP: set-os-env ( value key -- )
{ $values { "value" string } { "key" string } }
{ $description "Set an environment variable." }
{ $notes
"Names and values of environment variables are operating system-specific."
} ;
HELP: unset-os-env ( key -- )
{ $values { "key" string } }
{ $description "Unset an environment variable." }
{ $notes
"Names and values of environment variables are operating system-specific."
} ;
{ os-env os-envs set-os-env unset-os-env set-os-envs } related-words
ARTICLE: "environment" "Environment variables"
"The " { $vocab-link "environment" } " vocabulary interfaces to the platform-dependent mechanism for setting environment variables." $nl
"Windows CE has no concept of environment variables, so these words are undefined on that platform." $nl
"Reading environment variables:"
{ $subsection os-env }
{ $subsection os-envs }
"Writing environment variables:"
{ $subsection set-os-env }
{ $subsection unset-os-env }
{ $subsection set-os-envs } ;
ABOUT: "environment"

29
basis/environment/environment-tests.factor Normal file
View File

@ -0,0 +1,29 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces prettyprint system tools.test
environment strings sequences ;
IN: environment.tests
os wince? [
[ ] [ os-envs . ] unit-test
os 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
[ ] [ "factor-test-key-1" unset-os-env ] unit-test
[ ] [ "ps3" "factor-test-key-1" set-os-env ] unit-test
[ "ps3" ] [ "factor-test-key-1" os-env ] unit-test
[ ] [ "factor-test-key-1" unset-os-env ] unit-test
[ f ] [ "factor-test-key-1" os-env ] unit-test
[ ] [
32766 CHAR: a <string> "factor-test-key-long" set-os-env
] unit-test
[ 32766 ] [ "factor-test-key-long" os-env length ] unit-test
[ ] [ "factor-test-key-long" unset-os-env ] unit-test
] unless

27
basis/environment/environment.factor Normal file
View File

@ -0,0 +1,27 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs combinators kernel sequences splitting system
vocabs.loader ;
IN: environment
HOOK: os-env os ( key -- value )
HOOK: set-os-env os ( value key -- )
HOOK: unset-os-env os ( key -- )
HOOK: (os-envs) os ( -- seq )
HOOK: (set-os-envs) os ( seq -- )
: os-envs ( -- assoc )
(os-envs) [ "=" split1 ] H{ } map>assoc ;
: set-os-envs ( assoc -- )
[ "=" swap 3append ] { } assoc>map (set-os-envs) ;
{
{ [ os unix? ] [ "environment.unix" require ] }
{ [ os winnt? ] [ "environment.winnt" require ] }
{ [ os wince? ] [ ] }
} cond

1
basis/environment/summary.txt Normal file
View File

@ -0,0 +1 @@
Environment variables

1
basis/environment/unix/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/environment/unix/macosx/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

8
basis/environment/unix/macosx/macosx.factor Normal file
View File

@ -0,0 +1,8 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax system environment.unix ;
IN: environment.unix.macosx
FUNCTION: void* _NSGetEnviron ( ) ;
M: macosx environ _NSGetEnviron ;

1
basis/environment/unix/macosx/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

1
basis/environment/unix/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

29
basis/environment/unix/unix.factor Normal file
View File

@ -0,0 +1,29 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax kernel
layouts sequences system unix environment io.encodings.utf8
unix.utilities vocabs.loader combinators alien.accessors ;
IN: environment.unix
HOOK: environ os ( -- void* )
M: unix environ ( -- void* ) "environ" f dlsym ;
M: unix os-env ( key -- value ) getenv ;
M: unix set-os-env ( value key -- ) swap 1 setenv io-error ;
M: unix unset-os-env ( key -- ) unsetenv io-error ;
M: unix (os-envs) ( -- seq )
environ *void* utf8 alien>strings ;
: set-void* ( value alien -- ) 0 set-alien-cell ;
M: unix (set-os-envs) ( seq -- )
utf8 strings>alien malloc-byte-array environ set-void* ;
os {
{ macosx [ "environment.unix.macosx" require ] }
[ drop ]
} case

1
basis/environment/winnt/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/environment/winnt/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

33
basis/environment/winnt/winnt.factor Normal file
View File

@ -0,0 +1,33 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.strings fry io.encodings.utf16 kernel
splitting windows windows.kernel32 system environment
alien.c-types sequences windows.errors io.streams.memory
io.encodings io ;
IN: environment.winnt
M: winnt os-env ( key -- value )
MAX_UNICODE_PATH "TCHAR" <c-array>
[ dup length GetEnvironmentVariable ] keep over 0 = [
2drop f
] [
nip utf16n alien>string
] if ;
M: winnt set-os-env ( value key -- )
swap SetEnvironmentVariable win32-error=0/f ;
M: winnt unset-os-env ( key -- )
f SetEnvironmentVariable 0 = [
GetLastError ERROR_ENVVAR_NOT_FOUND =
[ win32-error ] unless
] when ;
M: winnt (os-envs) ( -- seq )
GetEnvironmentStrings [
<memory-stream> [
utf16n decode-input
[ "\0" read-until drop dup empty? not ]
[ ] [ drop ] produce
] with-input-stream*
] [ FreeEnvironmentStrings win32-error=0/f ] bi ;

159
basis/http/http-tests.factor
View File

@ -192,110 +192,104 @@ test-db [
init-furnace-tables
] with-db
: test-httpd ( -- )
#! Return as soon as server is running.
<http-server>
1237 >>insecure
f >>secure
start-server* ;
: test-httpd ( responder -- )
[
main-responder set
<http-server>
0 >>insecure
f >>secure
dup start-server*
sockets>> first addr>> port>>
] with-scope "port" set ;
[ ] [
[
<dispatcher>
add-quit-action
<dispatcher>
add-quit-action
<dispatcher>
"resource:basis/http/test" <static> >>default
"nested" add-responder
<action>
[ URL" redirect-loop" <temporary-redirect> ] >>display
"redirect-loop" add-responder
main-responder set
"resource:basis/http/test" <static> >>default
"nested" add-responder
<action>
[ URL" redirect-loop" <temporary-redirect> ] >>display
"redirect-loop" add-responder
test-httpd
] with-scope
test-httpd
] unit-test
: add-port ( url -- url' )
>url clone "port" get >>port ;
[ t ] [
"resource:basis/http/test/foo.html" ascii file-contents
"http://localhost:1237/nested/foo.html" http-get nip =
"http://localhost/nested/foo.html" add-port http-get nip =
] unit-test
[ "http://localhost:1237/redirect-loop" http-get nip ]
[ "http://localhost/redirect-loop" add-port http-get nip ]
[ too-many-redirects? ] must-fail-with
[ "Goodbye" ] [
"http://localhost:1237/quit" http-get nip
"http://localhost/quit" add-port http-get nip
] unit-test
! HTTP client redirect bug
[ ] [
[
<dispatcher>
add-quit-action
<action> [ "quit" <temporary-redirect> ] >>display
"redirect" add-responder
main-responder set
<dispatcher>
add-quit-action
<action> [ "quit" <temporary-redirect> ] >>display
"redirect" add-responder
test-httpd
] with-scope
test-httpd
] unit-test
[ "Goodbye" ] [
"http://localhost:1237/redirect" http-get nip
"http://localhost/redirect" add-port http-get nip
] unit-test
[ ] [
[ "http://localhost:1237/quit" http-get 2drop ] ignore-errors
[ "http://localhost/quit" add-port http-get 2drop ] ignore-errors
] unit-test
! Dispatcher bugs
[ ] [
[
<dispatcher>
<action> <protected>
"Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
<dispatcher>
<action> <protected>
"Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
<dispatcher>
<action> "" add-responder
"d" add-responder
test-db <db-persistence>
main-responder set
<action> "" add-responder
"d" add-responder
test-db <db-persistence>
test-httpd
] with-scope
test-httpd
] unit-test
: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
! This should give a 404 not an infinite redirect loop
[ "http://localhost:1237/d/blah" http-get nip ] [ 404? ] must-fail-with
[ "http://localhost/d/blah" add-port http-get nip ] [ 404? ] must-fail-with
! This should give a 404 not an infinite redirect loop
[ "http://localhost:1237/blah/" http-get nip ] [ 404? ] must-fail-with
[ "http://localhost/blah/" add-port http-get nip ] [ 404? ] must-fail-with
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
[ ] [
[
<dispatcher>
<action> [ [ "Hi" write ] "text/plain" <content> ] >>display
"Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
test-db <db-persistence>
main-responder set
<dispatcher>
<action> [ [ "Hi" write ] "text/plain" <content> ] >>display
"Test" <login-realm>
<sessions>
"" add-responder
add-quit-action
test-db <db-persistence>
test-httpd
] with-scope
test-httpd
] unit-test
[ "Hi" ] [ "http://localhost:1237/" http-get nip ] unit-test
[ "Hi" ] [ "http://localhost/" add-port http-get nip ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
USING: html.components html.elements html.forms
xml xml.utilities validators
@ -304,22 +298,19 @@ furnace furnace.conversations ;
SYMBOL: a
[ ] [
[
<dispatcher>
<action>
[ a get-global "a" set-value ] >>init
[ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
[ { { "a" [ v-integer ] } } validate-params ] >>validate
[ "a" value a set-global URL" " <redirect> ] >>submit
<conversations>
<sessions>
>>default
add-quit-action
test-db <db-persistence>
main-responder set
<dispatcher>
<action>
[ a get-global "a" set-value ] >>init
[ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
[ { { "a" [ v-integer ] } } validate-params ] >>validate
[ "a" value a set-global URL" " <redirect> ] >>submit
<conversations>
<sessions>
>>default
add-quit-action
test-db <db-persistence>
test-httpd
] with-scope
test-httpd
] unit-test
3 a set-global
@ -327,27 +318,35 @@ SYMBOL: a
: test-a string>xml "input" tag-named "value" swap at ;
[ "3" ] [
"http://localhost:1237/" http-get
"http://localhost/" add-port http-get
swap dup cookies>> "cookies" set session-id-key get-cookie
value>> "session-id" set test-a
] unit-test
[ "4" ] [
H{ { "a" "4" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
"http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
[
"4" "a" set
"http://localhost" add-port "__u" set
"session-id" get session-id-key set
] H{ } make-assoc
"http://localhost/" add-port <post-request> "cookies" get >>cookies http-request nip test-a
] unit-test
[ 4 ] [ a get-global ] unit-test
! Test flash scope
[ "xyz" ] [
H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
"http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
[
"xyz" "a" set
"http://localhost" add-port "__u" set
"session-id" get session-id-key set
] H{ } make-assoc
"http://localhost/" add-port <post-request> "cookies" get >>cookies http-request nip test-a
] unit-test
[ 4 ] [ a get-global ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
! Test cloning
[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test

7
basis/http/server/static/static.factor
View File

@ -59,8 +59,8 @@ TUPLE: file-responder root hook special allow-listings ;
\ serve-file NOTICE add-input-logging
: file. ( name dirp -- )
[ "/" append ] when
: file. ( name -- )
dup link-info directory? [ "/" append ] when
dup <a =href a> escape-string write </a> ;
: directory. ( path -- )
@ -68,8 +68,7 @@ TUPLE: file-responder root hook special allow-listings ;
[ <h1> file-name escape-string write </h1> ]
[
<ul>
directory sort-keys
[ <li> file. </li> ] assoc-each
directory-files [ <li> file. </li> ] each
</ul>
] bi
] simple-page ;

9
basis/io/launcher/launcher.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: system kernel namespaces strings hashtables sequences
assocs combinators vocabs.loader init threads continuations
math accessors concurrency.flags destructors
math accessors concurrency.flags destructors environment
io io.backend io.timeouts io.pipes io.pipes.private io.encodings
io.streams.duplex io.ports debugger prettyprint summary ;
IN: io.launcher
@ -58,8 +58,6 @@ SYMBOL: +realtime-priority+
! Non-blocking process exit notification facility
SYMBOL: processes
[ H{ } clone processes set-global ] "io.launcher" add-init-hook
HOOK: wait-for-processes io-backend ( -- ? )
SYMBOL: wait-flag
@ -73,7 +71,10 @@ SYMBOL: wait-flag
<flag> wait-flag set-global
[ wait-loop t ] "Process wait" spawn-server drop ;
[ start-wait-thread ] "io.launcher" add-init-hook
[
H{ } clone processes set-global
start-wait-thread
] "io.launcher" add-init-hook
: process-started ( process handle -- )
>>handle

7
basis/io/monitors/recursive/recursive.factor
View File

@ -19,11 +19,14 @@ DEFER: add-child-monitor
: add-child-monitors ( path -- )
#! We yield since this directory scan might take a while.
directory* [ first add-child-monitor ] each yield ;
dup [
[ append-path ] with map
[ add-child-monitor ] each yield
] with-directory-files ;
: add-child-monitor ( path -- )
notify? [ dup { +add-file+ } monitor tget queue-change ] when
qualify-path dup link-info type>> +directory+ eq? [
qualify-path dup link-info directory? [
[ add-child-monitors ]
[
[

19
basis/io/servers/connection/connection-tests.factor
View File

@ -27,25 +27,12 @@ concurrency.promises io.encodings.ascii io threads calendar ;
init-server semaphore>> count>>
] unit-test
[ ] [ <promise> "p" set ] unit-test
[ ] [
<threaded-server>
5 >>max-connections
1237 >>insecure
0 >>insecure
[ "Hello world." write stop-this-server ] >>handler
"server" set
dup start-server* sockets>> first addr>> port>> "port" set
] unit-test
[ ] [
[
"server" get start-server
t "p" get fulfill
] in-thread
] unit-test
[ ] [ "server" get wait-for-server ] unit-test
[ "Hello world." ] [ "localhost" 1237 <inet> ascii <client> drop contents ] unit-test
[ t ] [ "p" get 2 seconds ?promise-timeout ] unit-test
[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop contents ] unit-test

5
basis/io/unix/files/bsd/bsd.factor
View File

@ -13,5 +13,8 @@ M: bsd stat>file-info ( stat -- file-info )
{
[ stat-st_flags >>flags ]
[ stat-st_gen >>gen ]
[ stat-st_birthtimespec timespec>unix-time >>birth-time ]
[
stat-st_birthtimespec timespec>unix-time
>>birth-time
]
} cleave ;

48
basis/io/unix/files/files-docs.factor
View File

@ -36,39 +36,39 @@ HELP: file-user-id
HELP: group-execute?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "group execute" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "group execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: group-read?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "group read" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "group read" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: group-write?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "group write" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "group write" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: other-execute?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "other execute" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "other execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: other-read?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "other read" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "other read" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: other-write?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "other write" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "other write" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: set-file-access-time
{ $values
@ -124,9 +124,9 @@ HELP: set-gid
HELP: gid?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: set-group-execute
{ $values
@ -165,9 +165,9 @@ HELP: set-sticky
HELP: sticky?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "sticky" } " bit of a file is set." } ;
{ $description "Tests whether the " { $snippet "sticky" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: set-uid
{ $values
@ -176,9 +176,9 @@ HELP: set-uid
HELP: uid?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "uid" } " bit of a file is set." } ;
{ $description "Tests whether the " { $snippet "uid" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: set-user-execute
{ $values
@ -197,21 +197,21 @@ HELP: set-user-write
HELP: user-execute?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "user execute" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "user execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: user-read?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "user read" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "user read" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
HELP: user-write?
{ $values
{ "path" "a pathname string" }
{ "obj" "a pathname string, file-info object, or an integer" }
{ "?" "a boolean" } }
{ $description "Tests whether the " { $snippet "user write" } " bit is set on a file." } ;
{ $description "Tests whether the " { $snippet "user write" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
ARTICLE: "unix-file-permissions" "Unix file permissions"
"Reading all file permissions:"

62
basis/io/unix/files/files-tests.factor
View File

@ -55,32 +55,32 @@ prepare-test-file
[ t ] [ test-file other-write? ] unit-test
[ t ] [ test-file other-execute? ] unit-test
[ t ]
[ test-file f set-other-execute perms OCT: 776 = ] unit-test
[ t ] [ test-file f set-other-execute perms OCT: 776 = ] unit-test
[ f ] [ test-file file-info other-execute? ] unit-test
[ t ]
[ test-file f set-other-write perms OCT: 774 = ] unit-test
[ t ] [ test-file f set-other-write perms OCT: 774 = ] unit-test
[ f ] [ test-file file-info other-write? ] unit-test
[ t ]
[ test-file f set-other-read perms OCT: 770 = ] unit-test
[ t ] [ test-file f set-other-read perms OCT: 770 = ] unit-test
[ f ] [ test-file file-info other-read? ] unit-test
[ t ]
[ test-file f set-group-execute perms OCT: 760 = ] unit-test
[ t ] [ test-file f set-group-execute perms OCT: 760 = ] unit-test
[ f ] [ test-file file-info group-execute? ] unit-test
[ t ]
[ test-file f set-group-write perms OCT: 740 = ] unit-test
[ t ] [ test-file f set-group-write perms OCT: 740 = ] unit-test
[ f ] [ test-file file-info group-write? ] unit-test
[ t ]
[ test-file f set-group-read perms OCT: 700 = ] unit-test
[ t ] [ test-file f set-group-read perms OCT: 700 = ] unit-test
[ f ] [ test-file file-info group-read? ] unit-test
[ t ]
[ test-file f set-user-execute perms OCT: 600 = ] unit-test
[ t ] [ test-file f set-user-execute perms OCT: 600 = ] unit-test
[ f ] [ test-file file-info other-execute? ] unit-test
[ t ]
[ test-file f set-user-write perms OCT: 400 = ] unit-test
[ t ] [ test-file f set-user-write perms OCT: 400 = ] unit-test
[ f ] [ test-file file-info other-write? ] unit-test
[ t ]
[ test-file f set-user-read perms OCT: 000 = ] unit-test
[ t ] [ test-file f set-user-read perms OCT: 000 = ] unit-test
[ f ] [ test-file file-info other-read? ] unit-test
[ t ]
[ test-file { USER-ALL GROUP-ALL OTHER-EXECUTE } flags set-file-permissions perms OCT: 771 = ] unit-test
@ -135,3 +135,29 @@ prepare-test-file
[ ]
[ test-file f f set-file-ids ] unit-test
[ t ] [ OCT: 4000 uid? ] unit-test
[ t ] [ OCT: 2000 gid? ] unit-test
[ t ] [ OCT: 1000 sticky? ] unit-test
[ t ] [ OCT: 400 user-read? ] unit-test
[ t ] [ OCT: 200 user-write? ] unit-test
[ t ] [ OCT: 100 user-execute? ] unit-test
[ t ] [ OCT: 040 group-read? ] unit-test
[ t ] [ OCT: 020 group-write? ] unit-test
[ t ] [ OCT: 010 group-execute? ] unit-test
[ t ] [ OCT: 004 other-read? ] unit-test
[ t ] [ OCT: 002 other-write? ] unit-test
[ t ] [ OCT: 001 other-execute? ] unit-test
[ f ] [ 0 uid? ] unit-test
[ f ] [ 0 gid? ] unit-test
[ f ] [ 0 sticky? ] unit-test
[ f ] [ 0 user-read? ] unit-test
[ f ] [ 0 user-write? ] unit-test
[ f ] [ 0 user-execute? ] unit-test
[ f ] [ 0 group-read? ] unit-test
[ f ] [ 0 group-write? ] unit-test
[ f ] [ 0 group-execute? ] unit-test
[ f ] [ 0 other-read? ] unit-test
[ f ] [ 0 other-write? ] unit-test
[ f ] [ 0 other-execute? ] unit-test

89
basis/io/unix/files/files.factor
View File

@ -5,7 +5,8 @@ unix unix.stat unix.time kernel math continuations
math.bitwise byte-arrays alien combinators calendar
io.encodings.binary accessors sequences strings system
io.files.private destructors vocabs.loader calendar.unix
unix.stat alien.c-types arrays unix.users unix.groups ;
unix.stat alien.c-types arrays unix.users unix.groups
environment fry io.encodings.utf8 alien.strings unix.statfs ;
IN: io.unix.files
M: unix cwd ( -- path )
@ -137,6 +138,27 @@ os {
{ linux [ ] }
} case
: with-unix-directory ( path quot -- )
[ opendir dup [ (io-error) ] unless ] dip
dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline
: find-next-file ( DIR* -- byte-array )
"dirent" <c-object>
f <void*>
[ readdir_r 0 = [ (io-error) ] unless ] 2keep
*void* [ drop f ] unless ;
M: unix >directory-entry ( byte-array -- directory-entry )
[ dirent-d_name utf8 alien>string ]
[ dirent-d_type ] bi directory-entry boa ;
M: unix (directory-entries) ( path -- seq )
[
'[ _ find-next-file dup ]
[ >directory-entry ]
[ drop ] produce
] with-unix-directory ;
<PRIVATE
: stat-mode ( path -- mode )
@ -166,18 +188,57 @@ PRIVATE>
: OTHER-WRITE OCT: 0000002 ; inline
: OTHER-EXECUTE OCT: 0000001 ; inline
: uid? ( path -- ? ) UID file-mode? ;
: gid? ( path -- ? ) GID file-mode? ;
: sticky? ( path -- ? ) STICKY file-mode? ;
: user-read? ( path -- ? ) USER-READ file-mode? ;
: user-write? ( path -- ? ) USER-WRITE file-mode? ;
: user-execute? ( path -- ? ) USER-EXECUTE file-mode? ;
: group-read? ( path -- ? ) GROUP-READ file-mode? ;
: group-write? ( path -- ? ) GROUP-WRITE file-mode? ;
: group-execute? ( path -- ? ) GROUP-EXECUTE file-mode? ;
: other-read? ( path -- ? ) OTHER-READ file-mode? ;
: other-write? ( path -- ? ) OTHER-WRITE file-mode? ;
: other-execute? ( path -- ? ) OTHER-EXECUTE file-mode? ;
GENERIC: uid? ( obj -- ? )
GENERIC: gid? ( obj -- ? )
GENERIC: sticky? ( obj -- ? )
GENERIC: user-read? ( obj -- ? )
GENERIC: user-write? ( obj -- ? )
GENERIC: user-execute? ( obj -- ? )
GENERIC: group-read? ( obj -- ? )
GENERIC: group-write? ( obj -- ? )
GENERIC: group-execute? ( obj -- ? )
GENERIC: other-read? ( obj -- ? )
GENERIC: other-write? ( obj -- ? )
GENERIC: other-execute? ( obj -- ? )
M: integer uid? ( integer -- ? ) UID mask? ;
M: integer gid? ( integer -- ? ) GID mask? ;
M: integer sticky? ( integer -- ? ) STICKY mask? ;
M: integer user-read? ( integer -- ? ) USER-READ mask? ;
M: integer user-write? ( integer -- ? ) USER-WRITE mask? ;
M: integer user-execute? ( integer -- ? ) USER-EXECUTE mask? ;
M: integer group-read? ( integer -- ? ) GROUP-READ mask? ;
M: integer group-write? ( integer -- ? ) GROUP-WRITE mask? ;
M: integer group-execute? ( integer -- ? ) GROUP-EXECUTE mask? ;
M: integer other-read? ( integer -- ? ) OTHER-READ mask? ;
M: integer other-write? ( integer -- ? ) OTHER-WRITE mask? ;
M: integer other-execute? ( integer -- ? ) OTHER-EXECUTE mask? ;
M: file-info uid? ( file-info -- ? ) permissions>> uid? ;
M: file-info gid? ( file-info -- ? ) permissions>> gid? ;
M: file-info sticky? ( file-info -- ? ) permissions>> sticky? ;
M: file-info user-read? ( file-info -- ? ) permissions>> user-read? ;
M: file-info user-write? ( file-info -- ? ) permissions>> user-write? ;
M: file-info user-execute? ( file-info -- ? ) permissions>> user-execute? ;
M: file-info group-read? ( file-info -- ? ) permissions>> group-read? ;
M: file-info group-write? ( file-info -- ? ) permissions>> group-write? ;
M: file-info group-execute? ( file-info -- ? ) permissions>> group-execute? ;
M: file-info other-read? ( file-info -- ? ) permissions>> other-read? ;
M: file-info other-write? ( file-info -- ? ) permissions>> other-write? ;
M: file-info other-execute? ( file-info -- ? ) permissions>> other-execute? ;
M: string uid? ( path -- ? ) UID file-mode? ;
M: string gid? ( path -- ? ) GID file-mode? ;
M: string sticky? ( path -- ? ) STICKY file-mode? ;
M: string user-read? ( path -- ? ) USER-READ file-mode? ;
M: string user-write? ( path -- ? ) USER-WRITE file-mode? ;
M: string user-execute? ( path -- ? ) USER-EXECUTE file-mode? ;
M: string group-read? ( path -- ? ) GROUP-READ file-mode? ;
M: string group-write? ( path -- ? ) GROUP-WRITE file-mode? ;
M: string group-execute? ( path -- ? ) GROUP-EXECUTE file-mode? ;
M: string other-read? ( path -- ? ) OTHER-READ file-mode? ;
M: string other-write? ( path -- ? ) OTHER-WRITE file-mode? ;
M: string other-execute? ( path -- ? ) OTHER-EXECUTE file-mode? ;
: set-uid ( path ? -- ) UID swap chmod-set-bit ;
: set-gid ( path ? -- ) GID swap chmod-set-bit ;
@ -255,3 +316,5 @@ M: string set-file-group ( path string -- )
: file-group-name ( path -- string )
file-group-id group-name ;
M: unix home "HOME" os-env ;

2
basis/io/unix/launcher/launcher.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces math system sequences debugger
continuations arrays assocs combinators alien.c-types strings
threads accessors
threads accessors environment
io io.backend io.launcher io.ports io.files
io.files.private io.unix.files io.unix.backend
io.unix.launcher.parser

51
basis/io/windows/files/files.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io.binary io.backend io.files io.buffers
io.windows kernel math splitting
io.windows kernel math splitting fry alien.strings
windows windows.kernel32 windows.time calendar combinators
math.functions sequences namespaces make words symbols system
io.ports destructors accessors math.bitwise ;
io.ports destructors accessors math.bitwise continuations
windows.errors arrays ;
IN: io.windows.files
: open-file ( path access-mode create-mode flags -- handle )
@ -113,8 +114,35 @@ M: windows delete-directory ( path -- )
normalize-path
RemoveDirectory win32-error=0/f ;
M: windows normalize-directory ( string -- string )
normalize-path "\\" ?tail drop "\\*" append ;
M: windows >directory-entry ( byte-array -- directory-entry )
[ WIN32_FIND_DATA-cFileName utf16n alien>string ]
[ WIN32_FIND_DATA-dwFileAttributes ]
bi directory-entry boa ;
: find-first-file ( path -- WIN32_FIND_DATA handle )
"WIN32_FIND_DATA" <c-object> tuck
FindFirstFile
[ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep ;
: find-next-file ( path -- WIN32_FIND_DATA/f )
"WIN32_FIND_DATA" <c-object> tuck
FindNextFile 0 = [
GetLastError ERROR_NO_MORE_FILES = [
win32-error
] unless drop f
] when ;
M: windows (directory-entries) ( path -- seq )
"\\" ?tail drop "\\*" append
find-first-file [ >directory-entry ] dip
[
'[
[ _ find-next-file dup ]
[ >directory-entry ]
[ drop ] produce
over name>> "." = [ nip ] [ swap prefix ] if
]
] [ '[ _ FindClose win32-error=0/f ] ] bi [ ] cleanup ;
SYMBOLS: +read-only+ +hidden+ +system+
+archive+ +device+ +normal+ +temporary+
@ -218,6 +246,21 @@ M: winnt file-info ( path -- info )
M: winnt link-info ( path -- info )
file-info ;
TUPLE: winnt-file-system-info < file-system-info
total-bytes total-free-bytes ;
M: winnt file-system-info ( path -- file-system-info )
normalize-path
dup file-info directory? [ parent-directory ] unless
"ULARGE_INTEGER" <c-object>
"ULARGE_INTEGER" <c-object>
"ULARGE_INTEGER" <c-object>
[ GetDiskFreeSpaceEx win32-error=0/f ] 3keep
\ winnt-file-system-info new
swap *ulonglong >>total-free-bytes
swap *ulonglong >>total-bytes
swap *ulonglong >>free-space ;
: file-times ( path -- timestamp timestamp timestamp )
[
normalize-path open-existing &dispose handle>>

2
basis/io/windows/files/unique/unique.factor
View File

@ -1,6 +1,6 @@
USING: kernel system io.files.unique.backend
windows.kernel32 io.windows io.windows.files io.ports windows
destructors ;
destructors environment ;
IN: io.windows.files.unique
M: windows (make-unique-file) ( path -- )

4
basis/io/windows/nt/files/files.factor
View File

@ -1,7 +1,7 @@
USING: continuations destructors io.buffers io.files io.backend
io.timeouts io.ports io.windows io.windows.files
io.windows.nt.backend windows windows.kernel32
kernel libc math threads system
kernel libc math threads system environment
alien.c-types alien.arrays alien.strings sequences combinators
combinators.short-circuit ascii splitting alien strings
assocs namespaces make io.files.private accessors tr ;
@ -59,3 +59,5 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
M: winnt open-append
[ dup file-info size>> ] [ drop 0 ] recover
>r (open-append) r> >>ptr ;
M: winnt home "USERPROFILE" os-env ;

4
basis/io/windows/nt/launcher/launcher-tests.factor
View File

@ -1,7 +1,7 @@
IN: io.windows.launcher.nt.tests
USING: io.launcher tools.test calendar accessors
USING: io.launcher tools.test calendar accessors environment
namespaces kernel system arrays io io.files io.encodings.ascii
sequences parser assocs hashtables math continuations eval ;
IN: io.windows.launcher.nt.tests
[ ] [
<process>

7
basis/io/windows/nt/launcher/test/env.factor
View File

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

2
basis/logging/server/server.factor
View File

@ -83,7 +83,7 @@ SYMBOL: log-files
: (rotate-logs) ( -- )
(close-logs)
log-root directory [ drop rotate-log ] assoc-each ;
log-root directory-files [ rotate-log ] each ;
: log-server-loop ( -- )
receive unclip {

12
basis/stack-checker/known-words/known-words.factor
View File

@ -396,8 +396,6 @@ do-primitive alien-invoke alien-indirect alien-callback
\ (exists?) { string } { object } define-primitive
\ (directory) { string } { array } define-primitive
\ gc { } { } define-primitive
\ gc-stats { } { array } define-primitive
@ -412,8 +410,6 @@ do-primitive alien-invoke alien-indirect alien-callback
\ code-room { } { integer integer integer integer } define-primitive
\ code-room make-flushable
\ os-env { string } { object } define-primitive
\ millis { } { integer } define-primitive
\ millis make-flushable
@ -590,14 +586,6 @@ do-primitive alien-invoke alien-indirect alien-callback
\ set-innermost-frame-quot { quotation callstack } { } define-primitive
\ (os-envs) { } { array } define-primitive
\ set-os-env { string string } { } define-primitive
\ unset-os-env { string } { } define-primitive
\ (set-os-envs) { array } { } define-primitive
\ dll-valid? { object } { object } define-primitive
\ modify-code-heap { array object } { } define-primitive

38
basis/tools/deploy/deploy-tests.factor
View File

@ -1,7 +1,8 @@
IN: tools.deploy.tests
USING: tools.test system io.files kernel tools.deploy.config
tools.deploy.backend math sequences io.launcher arrays
namespaces continuations layouts accessors ;
namespaces continuations layouts accessors io.encodings.ascii
urls math.parser ;
: shake-and-bake ( vocab -- )
[ "test.image" temp-file delete-file ] ignore-errors
@ -38,7 +39,7 @@ namespaces continuations layouts accessors ;
! [ ] [ "tetris" shake-and-bake ] unit-test
!
! [ t ] [ 1500000 small-enough? ] unit-test
!
[ ] [ "bunny" shake-and-bake ] unit-test
[ t ] [ 2500000 small-enough? ] unit-test
@ -71,22 +72,24 @@ M: quit-responder call-responder*
: add-quot-responder ( responder -- responder )
quit-responder "quit" add-responder ;
: test-httpd ( -- )
#! Return as soon as server is running.
<http-server>
1237 >>insecure
f >>secure
start-server* ;
: test-httpd ( responder -- )
[
main-responder set
<http-server>
0 >>insecure
f >>secure
dup start-server*
sockets>> first addr>> port>>
dup number>string "resource:temp/port-number" ascii set-file-contents
] with-scope
"port" set ;
[ ] [
[
<dispatcher>
add-quot-responder
"resource:basis/http/test" <static> >>default
main-responder set
<dispatcher>
add-quot-responder
"resource:basis/http/test" <static> >>default
test-httpd
] with-scope
test-httpd
] unit-test
[ ] [
@ -94,7 +97,10 @@ M: quit-responder call-responder*
run-temp-image
] unit-test
[ ] [ "http://localhost:1237/quit" http-get 2drop ] unit-test
: add-port ( url -- url' )
>url clone "port" get >>port ;
[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
[ ] [
"tools.deploy.test.6" shake-and-bake

7
basis/tools/deploy/test/5/5.factor
View File

@ -1,7 +1,10 @@
IN: tools.deploy.test.5
USING: http.client kernel ;
USING: accessors urls io.encodings.ascii io.files math.parser
http.client kernel ;
: deploy-test-5 ( -- )
"http://localhost:1237/foo.html" http-get 2drop ;
URL" http://localhost/foo.html" clone
"resource:port-number" ascii file-contents string>number >>port
http-get 2drop ;
MAIN: deploy-test-5

25
basis/tools/scaffold/scaffold.factor
View File

@ -16,13 +16,18 @@ ERROR: vocab-name-contains-dot path ;
ERROR: no-vocab vocab ;
<PRIVATE
: root? ( string -- ? )
vocab-roots get member? ;
: root? ( string -- ? ) vocab-roots get member? ;
: length-changes? ( seq quot -- ? )
dupd call [ length ] bi@ = not ; inline
: check-vocab-name ( string -- string )
dup dup [ CHAR: . = ] trim [ length ] bi@ =
[ vocab-name-contains-dot ] unless
dup [ [ CHAR: . = ] trim ] length-changes?
[ vocab-name-contains-dot ] when
".." over subseq? [ vocab-name-contains-dot ] when
dup [ path-separator? ] contains?
[ vocab-name-contains-separator ] when ;
@ -43,8 +48,11 @@ ERROR: no-vocab vocab ;
: scaffolding ( path -- )
"Creating scaffolding for " write <pathname> . ;
: (scaffold-path) ( path string -- path )
dupd [ file-name ] dip append append-path ;
: scaffold-path ( path string -- path ? )
dupd [ file-name ] dip append append-path
(scaffold-path)
dup exists? [ dup not-scaffolding f ] [ dup scaffolding t ] if ;
: scaffold-copyright ( -- )
@ -205,14 +213,15 @@ ERROR: no-vocab vocab ;
: check-vocab ( vocab -- vocab )
dup find-vocab-root [ no-vocab ] unless ;
PRIVATE>
: link-vocab ( vocab -- )
check-vocab
"Edit documentation: " write
[ find-vocab-root ] keep
[ append-path ] keep "-docs.factor" append append-path
<pathname> . ;
[ find-vocab-root ]
[ vocab>scaffold-path ] bi
"-docs.factor" (scaffold-path) <pathname> . ;
: help. ( word -- )
[ (help.) ] [ nl vocabulary>> link-vocab ] bi ;

1
basis/tools/test/test.factor
View File

@ -12,6 +12,7 @@ SYMBOL: failures
error-continuation get 3array ;
: failure ( error what -- )
"--> test failed!" print
<failure> failures get push ;
SYMBOL: this-test

11
basis/tools/vocabs/vocabs.factor
View File

@ -14,8 +14,7 @@ IN: tools.vocabs
: vocab-tests-dir ( vocab -- paths )
dup vocab-dir "tests" append-path vocab-append-path dup [
dup exists? [
dup directory keys
[ ".factor" tail? ] filter
dup directory-files [ ".factor" tail? ] filter
[ append-path ] with map
] [ drop f ] if
] [ drop f ] if ;
@ -208,11 +207,15 @@ M: vocab-link summary vocab-summary ;
dup vocab-authors-path set-vocab-file-contents ;
: subdirs ( dir -- dirs )
directory [ second ] filter keys natural-sort ;
[
[ link-info directory? ] filter
] with-directory-files natural-sort ;
: (all-child-vocabs) ( root name -- vocabs )
[ vocab-dir append-path subdirs ] keep
[
vocab-dir append-path dup exists?
[ subdirs ] [ drop { } ] if
] keep [
swap [ "." swap 3append ] with map
] unless-empty ;

4
basis/ui/tools/listener/listener-tests.factor
View File

@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor
ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private
threads arrays generic threads accessors listener ;
threads arrays generic threads accessors listener math ;
IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map commands>> empty? ] unit-test
@ -51,3 +51,5 @@ IN: ui.tools.listener.tests
[ ] [ "listener" get com-end ] unit-test
] with-grafted-gadget
[ ] [ \ + <pane> <interactor> interactor-use use-if-necessary ] unit-test

11
basis/ui/tools/listener/listener.factor
View File

@ -101,8 +101,8 @@ M: engine-word word-completion-string
"engine-generic" word-prop word-completion-string ;
: use-if-necessary ( word seq -- )
over vocabulary>> [
2dup assoc-stack pick = [ 2drop ] [
over vocabulary>> over and [
2dup [ assoc-stack ] keep = [ 2drop ] [
>r vocabulary>> vocab-words r> push
] if
] [ 2drop ] if ;
@ -114,9 +114,10 @@ M: engine-word word-completion-string
2bi ;
: quot-action ( interactor -- lines )
dup control-value
dup "\n" join pick add-interactor-history
swap select-all ;
[ control-value ] keep
[ [ "\n" join ] dip add-interactor-history ]
[ select-all ]
2bi ;
TUPLE: stack-display < track ;

8
basis/ui/tools/tools.factor
View File

@ -40,11 +40,11 @@ IN: ui.tools
: resize-workspace ( workspace -- )
dup sizes>> over control-value zero? [
1/5 1 pick set-nth
4/5 2 rot set-nth
1/5 over set-second
4/5 swap set-third
] [
2/3 1 pick set-nth
1/3 2 rot set-nth
2/3 over set-second
1/3 swap set-third
] if relayout ;
M: workspace model-changed

6
basis/ui/x11/x11.factor
View File

@ -6,8 +6,8 @@ assocs kernel math namespaces opengl sequences strings x11.xlib
x11.events x11.xim x11.glx x11.clipboard x11.constants
x11.windows io.encodings.string io.encodings.ascii
io.encodings.utf8 combinators debugger command-line qualified
math.vectors classes.tuple opengl.gl threads math.geometry.rect ;
QUALIFIED: system
math.vectors classes.tuple opengl.gl threads math.geometry.rect
environment ;
IN: ui.x11
SINGLETON: x11-ui-backend
@ -262,5 +262,5 @@ M: x11-ui-backend beep ( -- )
x11-ui-backend ui-backend set-global
[ "DISPLAY" system:os-env "ui" "listener" ? ]
[ "DISPLAY" os-env "ui" "listener" ? ]
main-vocab-hook set-global

12
basis/unix/bsd/bsd.factor
View File

@ -3,8 +3,6 @@
USING: alien.syntax combinators system vocabs.loader ;
IN: unix
! FreeBSD
: MAXPATHLEN 1024 ; inline
: O_RDONLY HEX: 0000 ; inline
@ -85,6 +83,16 @@ C-STRUCT: passwd
: SEEK_CUR 1 ; inline
: SEEK_END 2 ; inline
: DT_UNKNOWN 0 ; inline
: DT_FIFO 1 ; inline
: DT_CHR 2 ; inline
: DT_DIR 4 ; inline
: DT_BLK 6 ; inline
: DT_REG 8 ; inline
: DT_LNK 10 ; inline
: DT_SOCK 12 ; inline
: DT_WHT 14 ; inline
os {
{ macosx [ "unix.bsd.macosx" require ] }
{ freebsd [ "unix.bsd.freebsd" require ] }

7
basis/unix/bsd/freebsd/freebsd.factor
View File

@ -13,6 +13,13 @@ C-STRUCT: addrinfo
{ "void*" "addr" }
{ "addrinfo*" "next" } ;
C-STRUCT: dirent
{ "u_int32_t" "d_fileno" }
{ "u_int16_t" "d_reclen" }
{ "u_int8_t" "d_type" }
{ "u_int8_t" "d_namlen" }
{ { "char" 256 } "d_name" } ;
: EPERM 1 ; inline
: ENOENT 2 ; inline
: ESRCH 3 ; inline

41
basis/unix/bsd/macosx/macosx.factor
View File

@ -13,6 +13,32 @@ C-STRUCT: addrinfo
{ "void*" "addr" }
{ "addrinfo*" "next" } ;
: _UTX_USERSIZE 256 ; inline
: _UTX_LINESIZE 32 ; inline
: _UTX_IDSIZE 4 ; inline
: _UTX_HOSTSIZE 256 ; inline
C-STRUCT: utmpx
{ { "char" _UTX_USERSIZE } "ut_user" }
{ { "char" _UTX_IDSIZE } "ut_id" }
{ { "char" _UTX_LINESIZE } "ut_line" }
{ "pid_t" "ut_pid" }
{ "short" "ut_type" }
{ "timeval" "ut_tv" }
{ { "char" _UTX_HOSTSIZE } "ut_host" }
{ { "uint" 16 } "ut_pad" } ;
: __DARWIN_MAXPATHLEN 1024 ; inline
: __DARWIN_MAXNAMELEN 255 ; inline
: __DARWIN_MAXNAMELEN+1 255 ; inline
C-STRUCT: dirent
{ "ino_t" "d_ino" }
{ "__uint16_t" "d_reclen" }
{ "__uint8_t" "d_type" }
{ "__uint8_t" "d_namlen" }
{ { "char" __DARWIN_MAXNAMELEN+1 } "d_name" } ;
: EPERM 1 ; inline
: ENOENT 2 ; inline
: ESRCH 3 ; inline
@ -117,18 +143,3 @@ C-STRUCT: addrinfo
: ETIME 101 ; inline
: EOPNOTSUPP 102 ; inline
: ENOPOLICY 103 ; inline
: _UTX_USERSIZE 256 ; inline
: _UTX_LINESIZE 32 ; inline
: _UTX_IDSIZE 4 ; inline
: _UTX_HOSTSIZE 256 ; inline
C-STRUCT: utmpx
{ { "char" _UTX_USERSIZE } "ut_user" }
{ { "char" _UTX_IDSIZE } "ut_id" }
{ { "char" _UTX_LINESIZE } "ut_line" }
{ "pid_t" "ut_pid" }
{ "short" "ut_type" }
{ "timeval" "ut_tv" }
{ { "char" _UTX_HOSTSIZE } "ut_host" }
{ { "uint" 16 } "ut_pad" } ;

7
basis/unix/bsd/netbsd/netbsd.factor
View File

@ -13,6 +13,13 @@ C-STRUCT: addrinfo
{ "void*" "addr" }
{ "addrinfo*" "next" } ;
C-STRUCT: dirent
{ "__uint32_t" "d_fileno" }
{ "__uint16_t" "d_reclen" }
{ "__uint8_t" "d_type" }
{ "__uint8_t" "d_namlen" }
{ { "char" 256 } "d_name" } ;
: EPERM 1 ; inline
: ENOENT 2 ; inline
: ESRCH 3 ; inline

7
basis/unix/bsd/openbsd/openbsd.factor
View File

@ -13,6 +13,13 @@ C-STRUCT: addrinfo
{ "char*" "canonname" }
{ "addrinfo*" "next" } ;
C-STRUCT: dirent
{ "__uint32_t" "d_fileno" }
{ "__uint16_t" "d_reclen" }
{ "__uint8_t" "d_type" }
{ "__uint8_t" "d_namlen" }
{ { "char" 256 } "d_name" } ;
: EPERM 1 ; inline
: ENOENT 2 ; inline
: ESRCH 3 ; inline

9
basis/unix/groups/groups.factor
View File

@ -4,7 +4,7 @@ USING: alien alien.c-types alien.strings io.encodings.utf8
io.unix.backend kernel math sequences splitting unix strings
combinators.short-circuit byte-arrays combinators qualified
accessors math.parser fry assocs namespaces continuations
unix.users ;
unix.users unix.utilities ;
IN: unix.groups
QUALIFIED: grouping
@ -18,12 +18,7 @@ GENERIC: group-struct ( obj -- group )
<PRIVATE
: group-members ( group-struct -- seq )
group-gr_mem
[ dup { [ ] [ *void* ] } 1&& ]
[
dup *void* utf8 alien>string
[ alien-address "char**" heap-size + <alien> ] dip
] [ ] produce nip ;
group-gr_mem utf8 alien>strings ;
: (group-struct) ( id -- group-struct id group-struct byte-array length void* )
"group" <c-object> tuck 4096

4
basis/unix/linux/fs/fs.factor
View File

@ -1,6 +1,4 @@
USING: alien.syntax ;
IN: unix.linux.fs
: MS_RDONLY 1 ; ! Mount read-only.
@ -22,4 +20,4 @@ FUNCTION: int mount
! FUNCTION: int umount2 ( char* file, int flags ) ;
FUNCTION: int umount ( char* file ) ;
FUNCTION: int umount ( char* file ) ;

7
basis/unix/linux/linux.factor
View File

@ -92,6 +92,13 @@ C-STRUCT: passwd
{ "char*" "pw_dir" }
{ "char*" "pw_shell" } ;
C-STRUCT: dirent
{ "__ino_t" "d_ino" }
{ "__off_t" "d_off" }
{ "ushort" "d_reclen" }
{ "uchar" "d_type" }
{ { "char" 256 } "d_name" } ;
: EPERM 1 ; inline
: ENOENT 2 ; inline
: ESRCH 3 ; inline

17
basis/unix/process/process.factor
View File

@ -1,6 +1,6 @@
USING: kernel alien.c-types alien.strings sequences math alien.syntax unix
vectors kernel namespaces continuations threads assocs vectors
io.unix.backend io.encodings.utf8 ;
vectors kernel namespaces continuations threads assocs vectors
io.unix.backend io.encodings.utf8 unix.utilities ;
IN: unix.process
! Low-level Unix process launching utilities. These are used
@ -15,17 +15,16 @@ FUNCTION: int execv ( char* path, char** argv ) ;
FUNCTION: int execvp ( char* path, char** argv ) ;
FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
: >argv ( seq -- alien )
[ utf8 malloc-string ] map f suffix >c-void*-array ;
: exec ( pathname argv -- int )
[ utf8 malloc-string ] [ >argv ] bi* execv ;
[ utf8 malloc-string ] [ utf8 strings>alien ] bi* execv ;
: exec-with-path ( filename argv -- int )
[ utf8 malloc-string ] [ >argv ] bi* execvp ;
[ utf8 malloc-string ] [ utf8 strings>alien ] bi* execvp ;
: exec-with-env ( filename argv envp -- int )
[ utf8 malloc-string ] [ >argv ] [ >argv ] tri* execve ;
[ utf8 malloc-string ]
[ utf8 strings>alien ]
[ utf8 strings>alien ] tri* execve ;
: exec-args ( seq -- int )
[ first ] [ ] bi exec ;
@ -99,4 +98,4 @@ FUNCTION: pid_t wait ( int* status ) ;
FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ;
: wait-for-pid ( pid -- status )
0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;
0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;

4
basis/unix/stat/linux/32/32.factor
View File

@ -1,6 +1,4 @@
USING: kernel alien.syntax math ;
IN: unix.stat
! Ubuntu 8.04 32-bit
@ -24,8 +22,6 @@ C-STRUCT: stat
{ "ulong" "unused4" }
{ "ulong" "unused5" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
FUNCTION: int __xstat ( int ver, char* pathname, stat* buf ) ;
FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;

5
basis/unix/stat/linux/64/64.factor
View File

@ -1,6 +1,5 @@
USING: kernel alien.syntax math ;
USING: kernel alien.syntax math sequences unix
alien.c-types arrays accessors combinators ;
IN: unix.stat
! Ubuntu 7.10 64-bit

9
basis/unix/stat/linux/linux.factor
View File

@ -1,11 +1,8 @@
USING: layouts combinators vocabs.loader ;
USING: alien.syntax layouts combinators vocabs.loader ;
IN: unix.stat
cell-bits
{
{
{ 32 [ "unix.stat.linux.32" require ] }
{ 64 [ "unix.stat.linux.64" require ] }
}
case
} case

3
basis/unix/stat/macosx/macosx.factor
View File

@ -1,4 +1,5 @@
USING: kernel alien.syntax math ;
USING: kernel alien.syntax math unix math.bitwise
alien.c-types alien sequences grouping accessors combinators ;
IN: unix.stat
! Mac OS X ppc

2
basis/unix/stat/netbsd/netbsd.factor
View File

@ -1,4 +1,4 @@
USING: layouts combinators vocabs.loader ;
USING: layouts combinators vocabs.loader alien.syntax ;
IN: unix.stat
cell-bits {

14
basis/unix/stat/stat.factor
View File

@ -18,6 +18,12 @@ FUNCTION: int chmod ( char* path, mode_t mode ) ;
FUNCTION: int fchmod ( int fd, mode_t mode ) ;
FUNCTION: int mkdir ( char* path, mode_t mode ) ;
C-STRUCT: fsid
{ { "int" 2 } "__val" } ;
TYPEDEF: fsid __fsid_t
TYPEDEF: fsid fsid_t
<< os {
{ linux [ "unix.stat.linux" require ] }
{ macosx [ "unix.stat.macosx" require ] }
@ -27,11 +33,7 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ;
} case >>
: file-status ( pathname -- stat )
"stat" <c-object> [
[ stat ] unix-system-call drop
] keep ;
"stat" <c-object> [ [ stat ] unix-system-call drop ] keep ;
: link-status ( pathname -- stat )
"stat" <c-object> [
[ lstat ] unix-system-call drop
] keep ;
"stat" <c-object> [ [ lstat ] unix-system-call drop ] keep ;

1
basis/unix/statfs/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/unix/statfs/freebsd/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

52
basis/unix/statfs/freebsd/freebsd.factor Normal file
View File

@ -0,0 +1,52 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel unix io.files math accessors
combinators system io.backend alien.c-types ;
IN: unix.statfs.freebsd
: ST_RDONLY 1 ; inline
: ST_NOSUID 2 ; inline
C-STRUCT: statvfs
{ "fsblkcnt_t" "f_bavail" }
{ "fsblkcnt_t" "f_bfree" }
{ "fsblkcnt_t" "f_blocks" }
{ "fsfilcnt_t" "f_favail" }
{ "fsfilcnt_t" "f_ffree" }
{ "fsfilcnt_t" "f_files" }
{ "ulong" "f_bsize" }
{ "ulong" "f_flag" }
{ "ulong" "f_frsize" }
{ "ulong" "f_fsid" }
{ "ulong" "f_namemax" } ;
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
TUPLE: freebsd-file-system-info < file-system-info
bavail bfree blocks favail ffree ffiles
bsize flag frsize fsid namemax ;
M: freebsd >file-system-info ( struct -- statfs )
[ \ freebsd-file-system-info new ] dip
{
[
[ statvfs-f_bsize ]
[ statvfs-f_bavail ] bi * >>free-space
]
[ statvfs-f_bavail >>bavail ]
[ statvfs-f_bfree >>bfree ]
[ statvfs-f_blocks >>blocks ]
[ statvfs-f_favail >>favail ]
[ statvfs-f_ffree >>ffree ]
[ statvfs-f_files >>files ]
[ statvfs-f_bsize >>bsize ]
[ statvfs-f_flag >>flag ]
[ statvfs-f_frsize >>frsize ]
[ statvfs-f_fsid >>fsid ]
[ statvfs-f_namemax >>namemax ]
} cleave ;
M: freebsd file-system-info ( path -- byte-array )
normalize-path
"statvfs" <c-object> tuck statvfs io-error
>file-system-info ;

1
basis/unix/statfs/freebsd/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

46
basis/unix/statfs/linux/32/32.factor Normal file
View File

@ -0,0 +1,46 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types combinators kernel io.files unix.stat
math accessors system unix io.backend layouts vocabs.loader
alien.syntax ;
IN: unix.statfs.linux
C-STRUCT: statfs
{ "long" "f_type" }
{ "long" "f_bsize" }
{ "long" "f_blocks" }
{ "long" "f_bfree" }
{ "long" "f_bavail" }
{ "long" "f_files" }
{ "long" "f_ffree" }
{ "fsid_t" "f_fsid" }
{ "long" "f_namelen" } ;
FUNCTION: int statfs ( char* path, statfs* buf ) ;
TUPLE: linux32-file-system-info < file-system-info
type bsize blocks bfree bavail files ffree fsid
namelen frsize spare ;
M: linux >file-system-info ( struct -- statfs )
[ \ linux32-file-system-info new ] dip
{
[
[ statfs-f_bsize ]
[ statfs-f_bavail ] bi * >>free-space
]
[ statfs-f_type >>type ]
[ statfs-f_bsize >>bsize ]
[ statfs-f_blocks >>blocks ]
[ statfs-f_bfree >>bfree ]
[ statfs-f_bavail >>bavail ]
[ statfs-f_files >>files ]
[ statfs-f_ffree >>ffree ]
[ statfs-f_fsid >>fsid ]
[ statfs-f_namelen >>namelen ]
} cleave ;
M: linux file-system-info ( path -- byte-array )
normalize-path
"statfs" <c-object> tuck statfs io-error
>file-system-info ;

1
basis/unix/statfs/linux/32/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/unix/statfs/linux/32/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

50
basis/unix/statfs/linux/64/64.factor Normal file
View File

@ -0,0 +1,50 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types combinators kernel io.files unix.stat
math accessors system unix io.backend layouts vocabs.loader
alien.syntax ;
IN: unix.statfs.linux
C-STRUCT: statfs64
{ "__SWORD_TYPE" "f_type" }
{ "__SWORD_TYPE" "f_bsize" }
{ "__fsblkcnt64_t" "f_blocks" }
{ "__fsblkcnt64_t" "f_bfree" }
{ "__fsblkcnt64_t" "f_bavail" }
{ "__fsfilcnt64_t" "f_files" }
{ "__fsfilcnt64_t" "f_ffree" }
{ "__fsid_t" "f_fsid" }
{ "__SWORD_TYPE" "f_namelen" }
{ "__SWORD_TYPE" "f_frsize" }
{ { "__SWORD_TYPE" 5 } "f_spare" } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
TUPLE: linux64-file-system-info < file-system-info
type bsize blocks bfree bavail files ffree fsid
namelen frsize spare ;
M: linux >file-system-info ( struct -- statfs )
[ \ linux64-file-system-info new ] dip
{
[
[ statfs64-f_bsize ]
[ statfs64-f_bavail ] bi * >>free-space
]
[ statfs64-f_type >>type ]
[ statfs64-f_bsize >>bsize ]
[ statfs64-f_blocks >>blocks ]
[ statfs64-f_bfree >>bfree ]
[ statfs64-f_bavail >>bavail ]
[ statfs64-f_files >>files ]
[ statfs64-f_ffree >>ffree ]
[ statfs64-f_fsid >>fsid ]
[ statfs64-f_namelen >>namelen ]
[ statfs64-f_frsize >>frsize ]
[ statfs64-f_spare >>spare ]
} cleave ;
M: linux file-system-info ( path -- byte-array )
normalize-path
"statfs64" <c-object> tuck statfs64 io-error
>file-system-info ;

1
basis/unix/statfs/linux/64/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/unix/statfs/linux/64/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

1
basis/unix/statfs/linux/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

10
basis/unix/statfs/linux/linux.factor Normal file
View File

@ -0,0 +1,10 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types combinators kernel io.files unix.stat
math accessors system unix io.backend layouts vocabs.loader ;
IN: unix.statfs.linux
cell-bits {
{ 32 [ "unix.statfs.linux.32" require ] }
{ 64 [ "unix.statfs.linux.64" require ] }
} case

1
basis/unix/statfs/linux/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

1
basis/unix/statfs/macosx/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

165
basis/unix/statfs/macosx/macosx.factor Normal file
View File

@ -0,0 +1,165 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io.encodings.utf8 io.encodings.string
kernel sequences unix.stat accessors unix combinators math
grouping system unix.statfs io.files io.backend alien.strings
math.bitwise alien.syntax ;
IN: unix.statfs.macosx
: MNT_RDONLY HEX: 00000001 ; inline
: MNT_SYNCHRONOUS HEX: 00000002 ; inline
: MNT_NOEXEC HEX: 00000004 ; inline
: MNT_NOSUID HEX: 00000008 ; inline
: MNT_NODEV HEX: 00000010 ; inline
: MNT_UNION HEX: 00000020 ; inline
: MNT_ASYNC HEX: 00000040 ; inline
: MNT_EXPORTED HEX: 00000100 ; inline
: MNT_QUARANTINE HEX: 00000400 ; inline
: MNT_LOCAL HEX: 00001000 ; inline
: MNT_QUOTA HEX: 00002000 ; inline
: MNT_ROOTFS HEX: 00004000 ; inline
: MNT_DOVOLFS HEX: 00008000 ; inline
: MNT_DONTBROWSE HEX: 00100000 ; inline
: MNT_IGNORE_OWNERSHIP HEX: 00200000 ; inline
: MNT_AUTOMOUNTED HEX: 00400000 ; inline
: MNT_JOURNALED HEX: 00800000 ; inline
: MNT_NOUSERXATTR HEX: 01000000 ; inline
: MNT_DEFWRITE HEX: 02000000 ; inline
: MNT_MULTILABEL HEX: 04000000 ; inline
: MNT_NOATIME HEX: 10000000 ; inline
: MNT_UNKNOWNPERMISSIONS MNT_IGNORE_OWNERSHIP ; inline
: MNT_VISFLAGMASK ( -- n )
{
MNT_RDONLY MNT_SYNCHRONOUS MNT_NOEXEC
MNT_NOSUID MNT_NODEV MNT_UNION
MNT_ASYNC MNT_EXPORTED MNT_QUARANTINE
MNT_LOCAL MNT_QUOTA
MNT_ROOTFS MNT_DOVOLFS MNT_DONTBROWSE
MNT_IGNORE_OWNERSHIP MNT_AUTOMOUNTED MNT_JOURNALED
MNT_NOUSERXATTR MNT_DEFWRITE MNT_MULTILABEL MNT_NOATIME
} flags ; inline
: MNT_UPDATE HEX: 00010000 ; inline
: MNT_RELOAD HEX: 00040000 ; inline
: MNT_FORCE HEX: 00080000 ; inline
: MNT_CMDFLAGS { MNT_UPDATE MNT_RELOAD MNT_FORCE } flags ; inline
: VFS_GENERIC 0 ; inline
: VFS_NUMMNTOPS 1 ; inline
: VFS_MAXTYPENUM 1 ; inline
: VFS_CONF 2 ; inline
: VFS_SET_PACKAGE_EXTS 3 ; inline
: MNT_WAIT 1 ; inline
: MNT_NOWAIT 2 ; inline
: VFS_CTL_VERS1 HEX: 01 ; inline
: VFS_CTL_STATFS HEX: 00010001 ; inline
: VFS_CTL_UMOUNT HEX: 00010002 ; inline
: VFS_CTL_QUERY HEX: 00010003 ; inline
: VFS_CTL_NEWADDR HEX: 00010004 ; inline
: VFS_CTL_TIMEO HEX: 00010005 ; inline
: VFS_CTL_NOLOCKS HEX: 00010006 ; inline
C-STRUCT: vfsquery
{ "uint32_t" "vq_flags" }
{ { "uint32_t" 31 } "vq_spare" } ;
: VQ_NOTRESP HEX: 0001 ; inline
: VQ_NEEDAUTH HEX: 0002 ; inline
: VQ_LOWDISK HEX: 0004 ; inline
: VQ_MOUNT HEX: 0008 ; inline
: VQ_UNMOUNT HEX: 0010 ; inline
: VQ_DEAD HEX: 0020 ; inline
: VQ_ASSIST HEX: 0040 ; inline
: VQ_NOTRESPLOCK HEX: 0080 ; inline
: VQ_UPDATE HEX: 0100 ; inline
: VQ_FLAG0200 HEX: 0200 ; inline
: VQ_FLAG0400 HEX: 0400 ; inline
: VQ_FLAG0800 HEX: 0800 ; inline
: VQ_FLAG1000 HEX: 1000 ; inline
: VQ_FLAG2000 HEX: 2000 ; inline
: VQ_FLAG4000 HEX: 4000 ; inline
: VQ_FLAG8000 HEX: 8000 ; inline
: NFSV4_MAX_FH_SIZE 128 ; inline
: NFSV3_MAX_FH_SIZE 64 ; inline
: NFSV2_MAX_FH_SIZE 32 ; inline
: NFS_MAX_FH_SIZE NFSV4_MAX_FH_SIZE ; inline
: MFSNAMELEN 15 ; inline
: MNAMELEN 90 ; inline
: MFSTYPENAMELEN 16 ; inline
C-STRUCT: fsid_t
{ { "int32_t" 2 } "val" } ;
C-STRUCT: statfs64
{ "uint32_t" "f_bsize" }
{ "int32_t" "f_iosize" }
{ "uint64_t" "f_blocks" }
{ "uint64_t" "f_bfree" }
{ "uint64_t" "f_bavail" }
{ "uint64_t" "f_files" }
{ "uint64_t" "f_ffree" }
{ "fsid_t" "f_fsid" }
{ "uid_t" "f_owner" }
{ "uint32_t" "f_type" }
{ "uint32_t" "f_flags" }
{ "uint32_t" "f_fssubtype" }
{ { "char" MFSTYPENAMELEN } "f_fstypename" }
{ { "char" MAXPATHLEN } "f_mntonname" }
{ { "char" MAXPATHLEN } "f_mntfromname" }
{ { "uint32_t" 8 } "f_reserved" } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
FUNCTION: int getmntinfo64 ( statfs64** mntbufp, int flags ) ;
TUPLE: macosx-file-system-info < file-system-info
block-size io-size blocks blocks-free blocks-available files
files-free file-system-id owner type flags filesystem-subtype
file-system-type-name mount-from ;
M: macosx mounted* ( -- array )
f <void*> dup 0 getmntinfo64 dup io-error
[ *void* ] dip
"statfs64" heap-size [ * memory>byte-array ] keep group ;
M: macosx >file-system-info ( byte-array -- file-system-info )
[ \ macosx-file-system-info new ] dip
{
[
[ statfs64-f_bavail ] [ statfs64-f_bsize ] bi *
>>free-space
]
[ statfs64-f_mntonname utf8 alien>string >>mount-on ]
[ statfs64-f_bsize >>block-size ]
[ statfs64-f_iosize >>io-size ]
[ statfs64-f_blocks >>blocks ]
[ statfs64-f_bfree >>blocks-free ]
[ statfs64-f_bavail >>blocks-available ]
[ statfs64-f_files >>files ]
[ statfs64-f_ffree >>files-free ]
[ statfs64-f_fsid >>file-system-id ]
[ statfs64-f_owner >>owner ]
[ statfs64-f_type >>type ]
[ statfs64-f_flags >>flags ]
[ statfs64-f_fssubtype >>filesystem-subtype ]
[
statfs64-f_fstypename utf8 alien>string
>>file-system-type-name
]
[
statfs64-f_mntfromname
utf8 alien>string >>mount-from
]
} cleave ;
M: macosx file-system-info ( path -- file-system-info )
normalize-path
"statfs64" <c-object> tuck statfs64 io-error
>file-system-info ;

1
basis/unix/statfs/macosx/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

1
basis/unix/statfs/netbsd/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

78
basis/unix/statfs/netbsd/netbsd.factor Normal file
View File

@ -0,0 +1,78 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel io.files unix.stat math unix
combinators system io.backend accessors alien.c-types
io.encodings.utf8 alien.strings unix.types ;
IN: unix.statfs.netbsd
: _VFS_NAMELEN 32 ; inline
: _VFS_MNAMELEN 1024 ; inline
C-STRUCT: statvfs
{ "ulong" "f_flag" }
{ "ulong" "f_bsize" }
{ "ulong" "f_frsize" }
{ "ulong" "f_iosize" }
{ "fsblkcnt_t" "f_blocks" }
{ "fsblkcnt_t" "f_bfree" }
{ "fsblkcnt_t" "f_bavail" }
{ "fsblkcnt_t" "f_bresvd" }
{ "fsfilcnt_t" "f_files" }
{ "fsfilcnt_t" "f_ffree" }
{ "fsfilcnt_t" "f_favail" }
{ "fsfilcnt_t" "f_fresvd" }
{ "uint64_t" "f_syncreads" }
{ "uint64_t" "f_syncwrites" }
{ "uint64_t" "f_asyncreads" }
{ "uint64_t" "f_asyncwrites" }
{ "fsid_t" "f_fsidx" }
{ "ulong" "f_fsid" }
{ "ulong" "f_namemax" }
{ "uid_t" "f_owner" }
{ { "uint32_t" 4 } "f_spare" }
{ { "char" _VFS_NAMELEN } "f_fstypename" }
{ { "char" _VFS_NAMELEN } "f_mntonname" }
{ { "char" _VFS_NAMELEN } "f_mntfromname" } ;
FUNCTION: int statvfs ( char* path, statvfs *buf ) ;
TUPLE: netbsd-file-system-info < file-system-info
flag bsize frsize io-size
blocks blocks-free blocks-available blocks-reserved
files ffree sync-reads sync-writes async-reads async-writes
fsidx fsid namemax owner spare fstype mnotonname mntfromname
file-system-type-name mount-from ;
M: netbsd >file-system-info ( byte-array -- netbsd-file-system-info )
[ \ netbsd-file-system-info new ] dip
{
[
[ statvfs-f_bsize ]
[ statvfs-f_bavail ] bi * >>free-space
]
[ statvfs-f_flag >>flag ]
[ statvfs-f_bsize >>bsize ]
[ statvfs-f_frsize >>frsize ]
[ statvfs-f_iosize >>io-size ]
[ statvfs-f_blocks >>blocks ]
[ statvfs-f_bfree >>blocks-free ]
[ statvfs-f_favail >>blocks-available ]
[ statvfs-f_fresvd >>blocks-reserved ]
[ statvfs-f_files >>files ]
[ statvfs-f_ffree >>ffree ]
[ statvfs-f_syncreads >>sync-reads ]
[ statvfs-f_syncwrites >>sync-writes ]
[ statvfs-f_asyncreads >>async-reads ]
[ statvfs-f_asyncwrites >>async-writes ]
[ statvfs-f_fsidx >>fsidx ]
[ statvfs-f_namemax >>namemax ]
[ statvfs-f_owner >>owner ]
[ statvfs-f_spare >>spare ]
[ statvfs-f_fstypename utf8 alien>string >>file-system-type-name ]
[ statvfs-f_mntonname utf8 alien>string >>mount-on ]
[ statvfs-f_mntfromname utf8 alien>string >>mount-from ]
} cleave ;
M: netbsd file-system-info
normalize-path "statvfs" <c-object> tuck statvfs io-error
>file-system-info ;

1
basis/unix/statfs/netbsd/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

26
basis/unix/statfs/openbsd/32/32.factor Normal file
View File

@ -0,0 +1,26 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel unix ;
IN: unix.statfs.openbsd.32
: MFSNAMELEN 16 ; inline
: MNAMELEN 90 ; inline
C-STRUCT: statfs
{ "u_int32_t" "f_flags" }
{ "int32_t" "f_bsize" }
{ "u_int32_t" "f_iosize" }
{ "u_int32_t" "f_blocks" }
{ "u_int32_t" "f_bfree" }
{ "int32_t" "f_bavail" }
{ "u_int32_t" "f_files" }
{ "u_int32_t" "f_ffree" }
{ "fsid_t" "f_fsid" }
{ "uid_t" "f_owner" }
{ "u_int32_t" "f_syncwrites" }
{ "u_int32_t" "f_asyncwrites" }
{ "u_int32_t" "f_ctime" }
{ { "u_int32_t" 3 } "f_spare" }
{ { "char" MFSNAMELEN } "f_fstypename" }
{ { "char" MNAMELEN } "f_mntonname" }
{ { "char" MNAMELEN } "f_mntfromname" } ;

1
basis/unix/statfs/openbsd/32/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/unix/statfs/openbsd/32/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

32
basis/unix/statfs/openbsd/64/64.factor Normal file
View File

@ -0,0 +1,32 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax unix ;
IN: unix.statfs.openbsd.64
: MFSNAMELEN 16 ; inline
: MNAMELEN 90 ; inline
C-STRUCT: statfss
{ "u_int32_t" "f_flags" }
{ "u_int32_t" "f_bsize" }
{ "u_int32_t" "f_iosize" }
{ "u_int64_t" "f_blocks" }
{ "u_int64_t" "f_bfree" }
{ "int64_t" "f_bavail" }
{ "u_int64_t" "f_files" }
{ "u_int64_t" "f_ffree" }
{ "int64_t" "f_favail" }
{ "u_int64_t" "f_syncwrites" }
{ "u_int64_t" "f_syncreads" }
{ "u_int64_t" "f_asyncwrites" }
{ "u_int64_t" "f_asyncreads" }
{ "fsid_t" "f_fsid" }
{ "u_int32_t" "f_namemax" }
{ "uid_t" "f_owner" }
{ "u_int32_t" "f_ctime" }
{ { "u_int32_t" 3 } " f_spare" }
{ { "char" MFSNAMELEN } "f_fstypename" }
{ { "char" MNAMELEN } "f_mntonname" }
{ { "char" MNAMELEN } "f_mntfromname" }
{ { "char" 512 } "mount_info" } ;
! { "mount_info" "mount_info" } ;

1
basis/unix/statfs/openbsd/64/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/unix/statfs/openbsd/64/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

1
basis/unix/statfs/openbsd/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

52
basis/unix/statfs/openbsd/openbsd.factor Normal file
View File

@ -0,0 +1,52 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax accessors combinators kernel io.files
unix.types math system io.backend alien.c-types unix ;
IN: unix.statfs.openbsd
C-STRUCT: statvfs
{ "ulong" "f_bsize" }
{ "ulong" "f_frsize" }
{ "fsblkcnt_t" "f_blocks" }
{ "fsblkcnt_t" "f_bfree" }
{ "fsblkcnt_t" "f_bavail" }
{ "fsfilcnt_t" "f_files" }
{ "fsfilcnt_t" "f_ffree" }
{ "fsfilcnt_t" "f_favail" }
{ "ulong" "f_fsid" }
{ "ulong" "f_flag" }
{ "ulong" "f_namemax" } ;
: ST_RDONLY 1 ; inline
: ST_NOSUID 2 ; inline
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
TUPLE: openbsd-file-system-info < file-system-info
bsize frsize blocks bfree bavail files ffree favail
fsid flag namemax ;
M: openbsd >file-system-info ( struct -- statfs )
[ \ openbsd-file-system-info new ] dip
{
[
[ statvfs-f_bsize ]
[ statvfs-f_bavail ] bi * >>free-space
]
[ statvfs-f_bsize >>bsize ]
[ statvfs-f_frsize >>frsize ]
[ statvfs-f_blocks >>blocks ]
[ statvfs-f_bfree >>bfree ]
[ statvfs-f_bavail >>bavail ]
[ statvfs-f_files >>files ]
[ statvfs-f_ffree >>ffree ]
[ statvfs-f_favail >>favail ]
[ statvfs-f_fsid >>fsid ]
[ statvfs-f_flag >>flag ]
[ statvfs-f_namemax >>namemax ]
} cleave ;
M: openbsd file-system-info ( path -- byte-array )
normalize-path
"statvfs" <c-object> tuck statvfs io-error
>file-system-info ;

1
basis/unix/statfs/openbsd/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

4
basis/unix/statfs/statfs-tests.factor Normal file
View File

@ -0,0 +1,4 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test unix.statfs ;
IN: unix.statfs.tests

33
basis/unix/statfs/statfs.factor Normal file
View File

@ -0,0 +1,33 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences system vocabs.loader combinators accessors
kernel math.order sorting ;
IN: unix.statfs
TUPLE: mounted block-size io-size blocks blocks-free
blocks-available files files-free file-system-id owner type
flags filesystem-subtype file-system-type-name mount-on
mount-from ;
HOOK: mounted* os ( -- array )
HOOK: mounted-struct>mounted os ( byte-array -- mounted )
TUPLE: file-system-info root-directory total-free-size total-size ;
HOOK: >file-system-info os ( struct -- statfs )
: mounted ( -- array )
mounted* [ mounted-struct>mounted ] map ;
: mounted-drive ( path -- mounted/f )
mounted
[ [ mount-on>> ] bi@ <=> ] sort <reversed>
[ mount-on>> head? ] with find nip ;
os {
{ linux [ "unix.statfs.linux" require ] }
{ macosx [ "unix.statfs.macosx" require ] }
{ freebsd [ "unix.statfs.freebsd" require ] }
{ netbsd [ "unix.statfs.netbsd" require ] }
{ openbsd [ "unix.statfs.openbsd" require ] }
} case

1
basis/unix/statfs/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

14
basis/unix/types/linux/linux.factor
View File

@ -1,10 +1,6 @@
USING: alien.syntax ;
IN: unix.types
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TYPEDEF: ulonglong __uquad_type
TYPEDEF: ulong __ulongword_type
TYPEDEF: long __sword_type
@ -13,17 +9,21 @@ TYPEDEF: long __slongword_type
TYPEDEF: uint __u32_type
TYPEDEF: int __s32_type
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TYPEDEF: __uquad_type dev_t
TYPEDEF: __ulongword_type ino_t
TYPEDEF: ino_t __ino_t
TYPEDEF: __u32_type mode_t
TYPEDEF: __uword_type nlink_t
TYPEDEF: __u32_type uid_t
TYPEDEF: __u32_type gid_t
TYPEDEF: __slongword_type off_t
TYPEDEF: off_t __off_t
TYPEDEF: __slongword_type blksize_t
TYPEDEF: __slongword_type blkcnt_t
TYPEDEF: __sword_type ssize_t
TYPEDEF: __s32_type pid_t
TYPEDEF: __slongword_type time_t
TYPEDEF: __slongword_type time_t
TYPEDEF: ssize_t __SWORD_TYPE
TYPEDEF: ulonglong __fsblkcnt64_t
TYPEDEF: ulonglong __fsfilcnt64_t

14
basis/unix/types/netbsd/netbsd.factor
View File

@ -3,24 +3,12 @@ IN: unix.types
! NetBSD 4.0
TYPEDEF: short __int16_t
TYPEDEF: ushort __uint16_t
TYPEDEF: int __int32_t
TYPEDEF: uint __uint32_t
TYPEDEF: longlong __int64_t
TYPEDEF: longlong __uint64_t
TYPEDEF: int int32_t
TYPEDEF: uint uint32_t
TYPEDEF: uint u_int32_t
TYPEDEF: longlong int64_t
TYPEDEF: ulonglong u_int64_t
TYPEDEF: __uint32_t __dev_t
TYPEDEF: __uint32_t dev_t
TYPEDEF: __uint32_t mode_t
TYPEDEF: __uint32_t nlink_t
TYPEDEF: __uint32_t uid_t
TYPEDEF: __uint32_t __uid_t
TYPEDEF: __uint32_t gid_t
TYPEDEF: __int64_t off_t
TYPEDEF: __int64_t blkcnt_t

13
basis/unix/types/openbsd/openbsd.factor
View File

@ -3,19 +3,6 @@ IN: unix.types
! OpenBSD 4.2
TYPEDEF: short __int16_t
TYPEDEF: ushort __uint16_t
TYPEDEF: int __int32_t
TYPEDEF: uint __uint32_t
TYPEDEF: longlong __int64_t
TYPEDEF: longlong __uint64_t
TYPEDEF: int int32_t
TYPEDEF: uint u_int32_t
TYPEDEF: uint uint32_t
TYPEDEF: longlong int64_t
TYPEDEF: ulonglong u_int64_t
TYPEDEF: __uint32_t __dev_t
TYPEDEF: __uint32_t dev_t
TYPEDEF: __uint32_t ino_t

10
basis/unix/types/types.factor
View File

@ -6,6 +6,11 @@ TYPEDEF: void* caddr_t
TYPEDEF: uint in_addr_t
TYPEDEF: uint socklen_t
TYPEDEF: __uint64_t fsblkcnt_t
TYPEDEF: fsblkcnt_t __fsblkcnt_t
TYPEDEF: __uint64_t fsfilcnt_t
TYPEDEF: fsfilcnt_t __fsfilcnt_t
TYPEDEF: char int8_t
TYPEDEF: short int16_t
TYPEDEF: int int32_t
@ -16,6 +21,11 @@ TYPEDEF: ushort uint16_t
TYPEDEF: uint uint32_t
TYPEDEF: ulonglong uint64_t
TYPEDEF: uchar u_int8_t
TYPEDEF: ushort u_int16_t
TYPEDEF: uint u_int32_t
TYPEDEF: ulonglong u_int64_t
TYPEDEF: char __int8_t
TYPEDEF: short __int16_t
TYPEDEF: int __int32_t

10
basis/unix/unix.factor
View File

@ -81,6 +81,7 @@ FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ;
FUNCTION: int chroot ( char* path ) ;
FUNCTION: int close ( int fd ) ;
FUNCTION: int closedir ( DIR* dirp ) ;
: close-file ( fd -- ) [ close ] unix-system-call drop ;
@ -105,6 +106,8 @@ FUNCTION: int getdtablesize ;
FUNCTION: gid_t getegid ;
FUNCTION: uid_t geteuid ;
FUNCTION: gid_t getgid ;
FUNCTION: char* getenv ( char* name ) ;
FUNCTION: int getgrgid_r ( gid_t gid, group* grp, char* buffer, size_t bufsize, group** result ) ;
FUNCTION: int getgrnam_r ( char* name, group* grp, char* buffer, size_t bufsize, group** result ) ;
FUNCTION: passwd* getpwent ( ) ;
@ -134,6 +137,8 @@ FUNCTION: int shutdown ( int fd, int how ) ;
FUNCTION: int open ( char* path, int flags, int prot ) ;
FUNCTION: DIR* opendir ( char* path ) ;
: open-file ( path flags mode -- fd ) [ open ] unix-system-call ;
C-STRUCT: utimbuf
@ -155,6 +160,9 @@ FUNCTION: int pipe ( int* filedes ) ;
FUNCTION: void* popen ( char* command, char* type ) ;
FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ;
FUNCTION: dirent* readdir ( DIR* dirp ) ;
FUNCTION: int readdir_r ( void* dirp, dirent* entry, dirent** result ) ;
FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ;
: PATH_MAX 1024 ; inline
@ -171,6 +179,8 @@ FUNCTION: int rename ( char* from, char* to ) ;
FUNCTION: int rmdir ( char* path ) ;
FUNCTION: int select ( int nfds, void* readfds, void* writefds, void* exceptfds, timeval* timeout ) ;
FUNCTION: ssize_t sendto ( int s, void* buf, size_t len, int flags, sockaddr-in* to, socklen_t tolen ) ;
FUNCTION: int setenv ( char* name, char* value, int overwrite ) ;
FUNCTION: int unsetenv ( char* name ) ;
FUNCTION: int setegid ( gid_t egid ) ;
FUNCTION: int seteuid ( uid_t euid ) ;
FUNCTION: int setgid ( gid_t gid ) ;

1
basis/unix/utilities/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

19
basis/unix/utilities/utilities.factor Normal file
View File

@ -0,0 +1,19 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings
combinators.short-circuit fry kernel layouts sequences ;
IN: unix.utilities
: more? ( alien -- ? )
{ [ ] [ *void* ] } 1&& ;
: advance ( void* -- void* )
cell swap <displaced-alien> ;
: alien>strings ( alien encoding -- strings )
[ [ dup more? ] ] dip
'[ [ advance ] [ *void* _ alien>string ] bi ]
[ ] produce nip ;
: strings>alien ( strings encoding -- alien )
'[ _ malloc-string ] map f suffix >c-void*-array ;

3
basis/windows/errors/errors.factor
View File

@ -2,8 +2,9 @@ USING: kernel ;
IN: windows.errors
: ERROR_SUCCESS 0 ; inline
: ERROR_NO_MORE_FILES 18 ; inline
: ERROR_HANDLE_EOF 38 ; inline
: ERROR_BROKEN_PIPE 109 ; inline
: ERROR_ENVVAR_NOT_FOUND 203 ; inline
: ERROR_IO_INCOMPLETE 996 ; inline
: ERROR_IO_PENDING 997 ; inline

16
basis/windows/kernel32/kernel32.factor
View File

@ -838,7 +838,8 @@ ALIAS: FindNextFile FindNextFileW
! FUNCTION: FormatMessageW
! FUNCTION: FreeConsole
! FUNCTION: FreeEnvironmentStringsA
! FUNCTION: FreeEnvironmentStringsW
FUNCTION: BOOL FreeEnvironmentStringsW ( LPTCH lpszEnvironmentBlock ) ;
ALIAS: FreeEnvironmentStrings FreeEnvironmentStringsW
! FUNCTION: FreeLibrary
! FUNCTION: FreeLibraryAndExitThread
! FUNCTION: FreeResource
@ -927,17 +928,19 @@ FUNCTION: HANDLE GetCurrentThread ( ) ;
! FUNCTION: GetDevicePowerState
! FUNCTION: GetDiskFreeSpaceA
! FUNCTION: GetDiskFreeSpaceExA
! FUNCTION: GetDiskFreeSpaceExW
FUNCTION: BOOL GetDiskFreeSpaceExW ( LPCTSTR lpDirectoryName, PULARGE_INTEGER pFreeBytesAvailable, PULARGE_INTEGER lpTotalNumberOfBytes, PULARGE_INTEGER lpTotalNumberOfFreeBytes ) ;
ALIAS: GetDiskFreeSpaceEx GetDiskFreeSpaceExW
! FUNCTION: GetDiskFreeSpaceW
! FUNCTION: GetDllDirectoryA
! FUNCTION: GetDllDirectoryW
! FUNCTION: GetDriveTypeA
! FUNCTION: GetDriveTypeW
! FUNCTION: GetEnvironmentStrings
FUNCTION: void* GetEnvironmentStringsW ( ) ;
! FUNCTION: GetEnvironmentStringsA
! FUNCTION: GetEnvironmentStringsW
ALIAS: GetEnvironmentStrings GetEnvironmentStringsW
! FUNCTION: GetEnvironmentVariableA
! FUNCTION: GetEnvironmentVariableW
FUNCTION: DWORD GetEnvironmentVariableW ( LPCTSTR lpName, LPTSTR lpBuffer, DWORD nSize ) ;
ALIAS: GetEnvironmentVariable GetEnvironmentVariableW
FUNCTION: BOOL GetExitCodeProcess ( HANDLE hProcess, LPDWORD lpExitCode ) ;
! FUNCTION: GetExitCodeThread
! FUNCTION: GetExpandedNameA
@ -1418,7 +1421,8 @@ ALIAS: SetCurrentDirectory SetCurrentDirectoryW
! FUNCTION: SetDllDirectoryW
FUNCTION: BOOL SetEndOfFile ( HANDLE hFile ) ;
! FUNCTION: SetEnvironmentVariableA
! FUNCTION: SetEnvironmentVariableW
FUNCTION: BOOL SetEnvironmentVariableW ( LPCTSTR key, LPCTSTR value ) ;
ALIAS: SetEnvironmentVariable SetEnvironmentVariableW
! FUNCTION: SetErrorMode
! FUNCTION: SetEvent
! FUNCTION: SetFileApisToANSI

12
basis/windows/types/types.factor
View File

@ -7,7 +7,7 @@ TYPEDEF: char CHAR
TYPEDEF: uchar UCHAR
TYPEDEF: uchar BYTE
TYPEDEF: ushort wchar_t
TYPEDEF: ushort wchar_t
TYPEDEF: wchar_t WCHAR
TYPEDEF: short SHORT
@ -62,14 +62,16 @@ TYPEDEF: ulonglong ULONGLONG
TYPEDEF: longlong LONG64
TYPEDEF: ulonglong DWORD64
TYPEDEF: longlong LARGE_INTEGER
TYPEDEF: ulonglong ULARGE_INTEGER
TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER
TYPEDEF: ULARGE_INTEGER* PULARGE_INTEGER
TYPEDEF: WCHAR TCHAR
TYPEDEF: TCHAR TBYTE
TYPEDEF: wchar_t* LPCSTR
TYPEDEF: wchar_t* LPWSTR
TYPEDEF: WCHAR TCHAR
TYPEDEF: LPWSTR LPTCH
TYPEDEF: LPWSTR PTCH
TYPEDEF: TCHAR TBYTE
TYPEDEF: WORD ATOM
TYPEDEF: BYTE BOOLEAN

Some files were not shown because too many files have changed in this diff Show More