From: John Benediktsson Date: Mon, 15 Dec 2008 18:00:44 +0000 (-0800) Subject: Merge branch 'master' of git://factorcode.org/git/factor X-Git-Tag: 0.94~2229^2~5 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=ceb78e417fde7c26d73dfbe1311e10d56e90e375;hp=8509daf843f5a1cbdb0dcf978e3212c7ade13234 Merge branch 'master' of git://factorcode.org/git/factor --- diff --git a/basis/alien/strings/windows/tags.txt b/basis/alien/strings/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/alien/strings/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/bootstrap/image/image-docs.factor b/basis/bootstrap/image/image-docs.factor index 91aa22b738..3856382ffb 100644 --- a/basis/bootstrap/image/image-docs.factor +++ b/basis/bootstrap/image/image-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io io.files ; +USING: help.markup help.syntax io io.files io.pathnames ; IN: bootstrap.image ARTICLE: "bootstrap.image" "Bootstrapping new images" diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index c7d87776a1..d9ecdf22eb 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -1,14 +1,15 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays byte-arrays generic assocs hashtables assocs -hashtables.private io kernel kernel.private math namespaces make -parser prettyprint sequences sequences.private strings sbufs +hashtables.private io io.binary io.files io.encodings.binary +io.pathnames kernel kernel.private math namespaces make parser +prettyprint sequences sequences.private strings sbufs vectors words quotations assocs system layouts splitting grouping growable classes classes.builtin classes.tuple -classes.tuple.private words.private io.binary io.files vocabs +classes.tuple.private words.private vocabs vocabs.loader source-files definitions debugger quotations.private sequences.private combinators -io.encodings.binary math.order math.private accessors +math.order math.private accessors slots.private compiler.units ; IN: bootstrap.image diff --git a/basis/bootstrap/image/upload/upload.factor b/basis/bootstrap/image/upload/upload.factor index f0edf85e65..d70a253e5f 100644 --- a/basis/bootstrap/image/upload/upload.factor +++ b/basis/bootstrap/image/upload/upload.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: checksums checksums.openssl splitting assocs kernel io.files bootstrap.image sequences io namespaces make -io.launcher math io.encodings.ascii ; +io.launcher math io.encodings.ascii io.files.temp io.pathnames +io.directories ; IN: bootstrap.image.upload SYMBOL: upload-images-destination diff --git a/basis/bootstrap/io/io.factor b/basis/bootstrap/io/io.factor index a38107fbab..b9a49b48b8 100644 --- a/basis/bootstrap/io/io.factor +++ b/basis/bootstrap/io/io.factor @@ -1,12 +1,11 @@ USING: system vocabs vocabs.loader kernel combinators -namespaces sequences io.backend ; +namespaces sequences io.backend accessors ; IN: bootstrap.io "bootstrap.compiler" vocab [ - "io." { + "io.backend." { { [ "io-backend" get ] [ "io-backend" get ] } - { [ os unix? ] [ "unix" ] } + { [ os unix? ] [ "unix." os name>> append ] } { [ os winnt? ] [ "windows.nt" ] } - { [ os wince? ] [ "windows.ce" ] } } cond append require ] when diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 45a6c354a6..d2b522581d 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors init namespaces words io -kernel.private math memory continuations kernel io.files -io.backend system parser vocabs sequences -vocabs.loader combinators splitting source-files strings -definitions assocs compiler.errors compiler.units -math.parser generic sets command-line ; +USING: accessors init namespaces words io kernel.private math +memory continuations kernel io.files io.pathnames io.backend +system parser vocabs sequences vocabs.loader combinators +splitting source-files strings definitions assocs +compiler.errors compiler.units math.parser generic sets +command-line ; IN: bootstrap.stage2 SYMBOL: core-bootstrap-time diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor index 7d5a041951..38d40d8482 100644 --- a/basis/command-line/command-line.factor +++ b/basis/command-line/command-line.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: init continuations hashtables io io.encodings.utf8 -io.files kernel kernel.private namespaces parser sequences -strings system splitting vocabs.loader ; +io.files io.pathnames kernel kernel.private namespaces parser +sequences strings system splitting vocabs.loader ; IN: command-line SYMBOL: script diff --git a/basis/concurrency/distributed/distributed-tests.factor b/basis/concurrency/distributed/distributed-tests.factor index 1087823aa0..996e3db4c0 100644 --- a/basis/concurrency/distributed/distributed-tests.factor +++ b/basis/concurrency/distributed/distributed-tests.factor @@ -1,7 +1,8 @@ IN: concurrency.distributed.tests USING: tools.test concurrency.distributed kernel io.files -arrays io.sockets system combinators threads math sequences -concurrency.messaging continuations accessors prettyprint ; +io.files.temp io.directories arrays io.sockets system +combinators threads math sequences concurrency.messaging +continuations accessors prettyprint ; : test-node ( -- addrspec ) { diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor index 6b7d81c862..ec83ba7a8b 100644 --- a/basis/core-foundation/core-foundation.factor +++ b/basis/core-foundation/core-foundation.factor @@ -14,6 +14,7 @@ TYPEDEF: int SInt32 TYPEDEF: uint UInt32 TYPEDEF: ulong CFTypeID TYPEDEF: UInt32 CFOptionFlags +TYPEDEF: void* CFUUIDRef FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ; diff --git a/basis/core-foundation/data/data.factor b/basis/core-foundation/data/data.factor index 043fb905ad..f4d2babca7 100644 --- a/basis/core-foundation/data/data.factor +++ b/basis/core-foundation/data/data.factor @@ -8,7 +8,6 @@ TYPEDEF: void* CFDictionaryRef TYPEDEF: void* CFMutableDictionaryRef TYPEDEF: void* CFNumberRef TYPEDEF: void* CFSetRef -TYPEDEF: void* CFUUIDRef TYPEDEF: int CFNumberType : kCFNumberSInt8Type 1 ; inline diff --git a/basis/db/pools/pools-tests.factor b/basis/db/pools/pools-tests.factor index 0a68db501b..7ff2a33d92 100644 --- a/basis/db/pools/pools-tests.factor +++ b/basis/db/pools/pools-tests.factor @@ -1,6 +1,6 @@ IN: db.pools.tests -USING: db.pools tools.test continuations io.files namespaces -accessors kernel math destructors ; +USING: db.pools tools.test continuations io.files io.files.temp +io.directories namespaces accessors kernel math destructors ; \ must-infer diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index fe95980bcf..b816e414ba 100644 --- a/basis/db/sqlite/sqlite-tests.factor +++ b/basis/db/sqlite/sqlite-tests.factor @@ -1,5 +1,5 @@ -USING: io io.files io.launcher kernel namespaces -prettyprint tools.test db.sqlite db sequences +USING: io io.files io.files.temp io.directories io.launcher +kernel namespaces prettyprint tools.test db.sqlite db sequences continuations db.types db.tuples unicode.case ; IN: db.sqlite.tests diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 0432f38683..b834c2c990 100644 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files kernel tools.test db db.tuples classes +USING: io.files io.files.temp kernel tools.test db db.tuples classes db.types continuations namespaces math math.ranges prettyprint calendar sequences db.sqlite math.intervals db.postgresql accessors random math.bitwise system diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 4e0c4e8840..885e2e303c 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -2,10 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: slots arrays definitions generic hashtables summary io kernel math namespaces make prettyprint prettyprint.config -sequences assocs sequences.private strings io.styles io.files -vectors words system splitting math.parser classes.mixin -classes.tuple continuations continuations.private combinators -generic.math classes.builtin classes compiler.units +sequences assocs sequences.private strings io.styles +io.pathnames vectors words system splitting math.parser +classes.mixin classes.tuple continuations continuations.private +combinators generic.math classes.builtin classes compiler.units generic.standard vocabs init kernel.private io.encodings accessors math.order destructors source-files parser classes.tuple.parser effects.parser lexer compiler.errors diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index 6b49c939c3..53887bd353 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser lexer kernel namespaces sequences definitions -io.files summary continuations tools.crossref tools.vocabs io -prettyprint source-files assocs vocabs vocabs.loader io.backend -splitting accessors ; +io.files io.backend io.pathnames io summary continuations +tools.crossref tools.vocabs prettyprint source-files assocs +vocabs vocabs.loader splitting accessors ; IN: editors TUPLE: no-edit-hook ; diff --git a/basis/editors/gvim/unix/unix.factor b/basis/editors/gvim/unix/unix.factor index 82b6bf199d..3e2a42e6e5 100644 --- a/basis/editors/gvim/unix/unix.factor +++ b/basis/editors/gvim/unix/unix.factor @@ -1,5 +1,4 @@ -USING: io.unix.backend kernel namespaces editors.gvim -system ; +USING: kernel namespaces editors.gvim system ; IN: editors.gvim.unix M: unix gvim-path diff --git a/basis/editors/gvim/windows/windows.factor b/basis/editors/gvim/windows/windows.factor index 2f733f3c2f..1a6f8e902c 100644 --- a/basis/editors/gvim/windows/windows.factor +++ b/basis/editors/gvim/windows/windows.factor @@ -1,5 +1,5 @@ -USING: editors.gvim io.files io.windows kernel namespaces -sequences windows.shell32 io.paths.windows system ; +USING: editors.gvim io.files kernel namespaces sequences +windows.shell32 io.paths.windows system ; IN: editors.gvim.windows M: windows gvim-path diff --git a/basis/editors/jedit/jedit.factor b/basis/editors/jedit/jedit.factor index fe9abc0e76..e34f0ce175 100644 --- a/basis/editors/jedit/jedit.factor +++ b/basis/editors/jedit/jedit.factor @@ -4,7 +4,7 @@ USING: arrays definitions io kernel math namespaces parser prettyprint sequences strings words editors io.files io.sockets io.streams.byte-array io.binary math.parser io.encodings.ascii io.encodings.binary -io.encodings.utf8 io.files.private ; +io.encodings.utf8 io.files.private io.pathnames ; IN: editors.jedit : jedit-server-info ( -- port auth ) diff --git a/basis/ftp/client/client.factor b/basis/ftp/client/client.factor index 9c82cdbb50..ac21bb8f78 100644 --- a/basis/ftp/client/client.factor +++ b/basis/ftp/client/client.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays classes.singleton combinators continuations io io.encodings.binary io.encodings.utf8 -io.files io.sockets kernel io.streams.duplex math +io.files io.pathnames io.sockets kernel io.streams.duplex math math.parser sequences splitting namespaces strings fry ftp ftp.client.listing-parser urls ; IN: ftp.client @@ -104,7 +104,3 @@ ERROR: ftp-error got expected ; [ nip parent-directory ftp-cwd drop ] [ file-name (ftp-get) ] 2bi ] with-ftp-client ; - - - - diff --git a/basis/ftp/client/listing-parser/listing-parser.factor b/basis/ftp/client/listing-parser/listing-parser.factor index 04e96ed77a..6183165b3a 100644 --- a/basis/ftp/client/listing-parser/listing-parser.factor +++ b/basis/ftp/client/listing-parser/listing-parser.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators io.files kernel math.parser +USING: accessors combinators io.files.types kernel math.parser sequences splitting ; IN: ftp.client.listing-parser diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index b0ec340202..d71179d599 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -2,12 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: combinators.short-circuit accessors combinators io io.encodings.8-bit io.encodings io.encodings.binary -io.encodings.utf8 io.files io.sockets kernel math.parser -namespaces make sequences ftp io.unix.launcher.parser -unicode.case splitting assocs classes io.servers.connection -destructors calendar io.timeouts io.streams.duplex threads -continuations math concurrency.promises byte-arrays -io.backend tools.hexdump tools.files io.streams.string ; +io.encodings.utf8 io.files io.files.info io.directories +io.pathnames io.sockets kernel math.parser namespaces make +sequences ftp io.launcher.unix.parser unicode.case splitting +assocs classes io.servers.connection destructors calendar +io.timeouts io.streams.duplex threads continuations math +concurrency.promises byte-arrays io.backend tools.hexdump +tools.files io.streams.string ; IN: ftp.server TUPLE: ftp-client url mode state command-promise user password ; diff --git a/basis/furnace/auth/providers/db/db-tests.factor b/basis/furnace/auth/providers/db/db-tests.factor index 3bcd82a15d..de7650d9ef 100644 --- a/basis/furnace/auth/providers/db/db-tests.factor +++ b/basis/furnace/auth/providers/db/db-tests.factor @@ -5,7 +5,7 @@ furnace.auth.login furnace.auth.providers furnace.auth.providers.db tools.test namespaces db db.sqlite db.tuples continuations -io.files accessors kernel ; +io.files io.files.temp io.directories accessors kernel ; "test" realm set diff --git a/basis/furnace/sessions/sessions-tests.factor b/basis/furnace/sessions/sessions-tests.factor index 907e657125..14cdce3811 100644 --- a/basis/furnace/sessions/sessions-tests.factor +++ b/basis/furnace/sessions/sessions-tests.factor @@ -2,9 +2,9 @@ IN: furnace.sessions.tests USING: tools.test http furnace.sessions furnace.actions http.server http.server.responses math namespaces make kernel accessors io.sockets io.servers.connection prettyprint -io.streams.string io.files splitting destructors sequences db -db.tuples db.sqlite continuations urls math.parser furnace -furnace.utilities ; +io.streams.string io.files io.files.temp io.directories +splitting destructors sequences db db.tuples db.sqlite +continuations urls math.parser furnace furnace.utilities ; : with-session [ diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index cc36e9faab..69c2046834 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -168,6 +168,11 @@ ARTICLE: "io" "Input and output" { $heading "Streams" } { $subsection "streams" } { $subsection "io.files" } +{ $heading "The file system" } +{ $subsection "io.pathnames" } +{ $subsection "io.files.info" } +{ $subsection "io.files.links" } +{ $subsection "io.directories" } { $heading "Encodings" } { $subsection "encodings-introduction" } { $subsection "io.encodings" } diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index a9df0bea81..ec52264643 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary -io.files html.streams html.elements help kernel +io.files io.files.temp io.directories html.streams html.elements help kernel assocs sequences make words accessors arrays help.topics vocabs tools.vocabs tools.vocabs.browser namespaces prettyprint io vocabs.loader serialize fry memoize unicode.case math.order diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index 73cc239a56..c3c1ec2b9e 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel sequences combinators kernel fry namespaces make classes.tuple assocs splitting words arrays io -io.files io.encodings.utf8 io.streams.string unicode.case -mirrors math urls present multiline quotations xml logging -continuations +io.files io.files.info io.encodings.utf8 io.streams.string +unicode.case mirrors math urls present multiline quotations xml +logging continuations xml.data html.forms html.elements diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index 7a35ba812b..7031f5d16c 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -1,4 +1,4 @@ -USING: http help.markup help.syntax io.files io.streams.string +USING: http help.markup help.syntax io.pathnames io.streams.string io.encodings.8-bit io.encodings.binary kernel strings urls urls.encoding byte-arrays strings assocs sequences ; IN: http.client diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 108ae5ecc4..fc6e296a4f 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -1,17 +1,12 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel math math.parser namespaces make -sequences io io.sockets io.streams.string io.files io.timeouts -strings splitting calendar continuations accessors vectors +sequences strings splitting calendar continuations accessors vectors math.order hashtables byte-arrays destructors -io.encodings -io.encodings.string -io.encodings.ascii -io.encodings.utf8 -io.encodings.8-bit -io.encodings.binary -io.streams.duplex -fry ascii urls urls.encoding present +io io.sockets io.streams.string io.files io.timeouts +io.pathnames io.encodings io.encodings.string io.encodings.ascii +io.encodings.utf8 io.encodings.8-bit io.encodings.binary +io.streams.duplex fry ascii urls urls.encoding present http http.parsers ; IN: http.client diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 6e93d5ee3a..92a296c2d3 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -179,7 +179,7 @@ Set-Cookie: oo="bar; a=b"; comment="your mom"; httponly=yes ! Live-fire exercise USING: http.server http.server.static furnace.sessions furnace.alloy furnace.actions furnace.auth furnace.auth.login furnace.db http.client -io.servers.connection io.files io io.encodings.ascii +io.servers.connection io.files io.files.temp io.directories io io.encodings.ascii accessors namespaces threads http.server.responses http.server.redirection furnace.redirection http.server.dispatchers db.tuples ; diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 0bc644d019..b19bf2ae55 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -1,14 +1,11 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: calendar io io.files kernel math math.order -math.parser namespaces parser sequences strings -assocs hashtables debugger mime.types sorting logging -calendar.format accessors splitting -io.encodings.binary fry xml.entities destructors urls -html.elements html.templates.fhtml -http -http.server -http.server.responses +USING: calendar kernel math math.order math.parser namespaces +parser sequences strings assocs hashtables debugger mime.types +sorting logging calendar.format accessors splitting io io.files +io.files.info io.directories io.pathnames io.encodings.binary +fry xml.entities destructors urls html.elements +html.templates.fhtml http http.server http.server.responses http.server.redirection ; IN: http.server.static diff --git a/basis/io/backend/unix/authors.txt b/basis/io/backend/unix/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/io/backend/unix/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/io/backend/unix/bsd/authors.txt b/basis/io/backend/unix/bsd/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/io/backend/unix/bsd/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/io/backend/unix/bsd/bsd.factor b/basis/io/backend/unix/bsd/bsd.factor new file mode 100644 index 0000000000..e0a675a8fc --- /dev/null +++ b/basis/io/backend/unix/bsd/bsd.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces system kernel accessors assocs continuations +unix io.backend io.backend.unix io.backend.unix.multiplexers +io.backend.unix.multiplexers.kqueue io.files.unix ; +IN: io.backend.unix.bsd + +M: bsd init-io ( -- ) + mx set-global ; + +! M: bsd (monitor) ( path recursive? mailbox -- ) +! swap [ "Recursive kqueue monitors not supported" throw ] when +! ; diff --git a/basis/io/backend/unix/bsd/tags.txt b/basis/io/backend/unix/bsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/backend/unix/bsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/backend/unix/freebsd/freebsd.factor b/basis/io/backend/unix/freebsd/freebsd.factor new file mode 100644 index 0000000000..1c0471b330 --- /dev/null +++ b/basis/io/backend/unix/freebsd/freebsd.factor @@ -0,0 +1,3 @@ +USING: io.backend.unix.bsd io.backend system ; + +freebsd set-io-backend diff --git a/basis/io/backend/unix/freebsd/tags.txt b/basis/io/backend/unix/freebsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/backend/unix/freebsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/backend/unix/linux/authors.txt b/basis/io/backend/unix/linux/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/io/backend/unix/linux/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/io/backend/unix/linux/linux.factor b/basis/io/backend/unix/linux/linux.factor new file mode 100644 index 0000000000..54b20d1b44 --- /dev/null +++ b/basis/io/backend/unix/linux/linux.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel system namespaces io.files.unix io.backend +io.backend.unix io.backend.unix.multiplexers +io.backend.unix.multiplexers.epoll ; +IN: io.backend.unix.linux + +M: linux init-io ( -- ) + mx set-global ; + +linux set-io-backend diff --git a/basis/io/backend/unix/linux/tags.txt b/basis/io/backend/unix/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/backend/unix/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/backend/unix/macosx/macosx.factor b/basis/io/backend/unix/macosx/macosx.factor new file mode 100644 index 0000000000..e669875448 --- /dev/null +++ b/basis/io/backend/unix/macosx/macosx.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.backend system namespaces io.backend.unix.bsd +io.backend.unix.multiplexers io.backend.unix.multiplexers.run-loop ; +IN: io.backend.macosx + +M: macosx init-io ( -- ) + mx set-global ; + +macosx set-io-backend diff --git a/basis/io/backend/unix/macosx/tags.txt b/basis/io/backend/unix/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/backend/unix/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/backend/unix/multiplexers/epoll/authors.txt b/basis/io/backend/unix/multiplexers/epoll/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/io/backend/unix/multiplexers/epoll/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/io/backend/unix/multiplexers/epoll/epoll.factor b/basis/io/backend/unix/multiplexers/epoll/epoll.factor new file mode 100644 index 0000000000..a91f62f1df --- /dev/null +++ b/basis/io/backend/unix/multiplexers/epoll/epoll.factor @@ -0,0 +1,66 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types kernel destructors bit-arrays +sequences assocs struct-arrays math namespaces locals fry unix +unix.linux.epoll unix.time io.ports io.backend.unix +io.backend.unix.multiplexers ; +IN: io.backend.unix.multiplexers.epoll + +TUPLE: epoll-mx < mx events ; + +: max-events ( -- n ) + #! We read up to 256 events at a time. This is an arbitrary + #! constant... + 256 ; inline + +: ( -- mx ) + epoll-mx new-mx + max-events epoll_create dup io-error >>fd + max-events "epoll-event" >>events ; + +M: epoll-mx dispose fd>> close-file ; + +: make-event ( fd events -- event ) + "epoll-event" + [ set-epoll-event-events ] keep + [ set-epoll-event-fd ] keep ; + +:: do-epoll-ctl ( fd mx what events -- ) + mx fd>> what fd fd events make-event epoll_ctl io-error ; + +: do-epoll-add ( fd mx events -- ) + EPOLL_CTL_ADD swap EPOLLONESHOT bitor do-epoll-ctl ; + +: do-epoll-del ( fd mx events -- ) + EPOLL_CTL_DEL swap do-epoll-ctl ; + +M: epoll-mx add-input-callback ( thread fd mx -- ) + [ EPOLLIN do-epoll-add ] [ call-next-method ] 2bi ; + +M: epoll-mx add-output-callback ( thread fd mx -- ) + [ EPOLLOUT do-epoll-add ] [ call-next-method ] 2bi ; + +M: epoll-mx remove-input-callbacks ( fd mx -- seq ) + 2dup reads>> key? [ + [ call-next-method ] [ EPOLLIN do-epoll-del ] 2bi + ] [ 2drop f ] if ; + +M: epoll-mx remove-output-callbacks ( fd mx -- seq ) + 2dup writes>> key? [ + [ EPOLLOUT do-epoll-del ] [ call-next-method ] 2bi + ] [ 2drop f ] if ; + +: wait-event ( mx us -- n ) + [ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi* + epoll_wait multiplexer-error ; + +: handle-event ( event mx -- ) + [ epoll-event-fd ] dip + [ EPOLLIN EPOLLOUT bitor do-epoll-del ] + [ input-available ] [ output-available ] 2tri ; + +: handle-events ( mx n -- ) + [ dup events>> ] dip head-slice swap '[ _ handle-event ] each ; + +M: epoll-mx wait-for-events ( us mx -- ) + swap 60000000 or dupd wait-event handle-events ; diff --git a/basis/io/backend/unix/multiplexers/epoll/tags.txt b/basis/io/backend/unix/multiplexers/epoll/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/backend/unix/multiplexers/epoll/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/backend/unix/multiplexers/kqueue/authors.txt b/basis/io/backend/unix/multiplexers/kqueue/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/io/backend/unix/multiplexers/kqueue/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor new file mode 100644 index 0000000000..2a6648981b --- /dev/null +++ b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor @@ -0,0 +1,76 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types combinators destructors +io.backend.unix kernel math.bitwise sequences struct-arrays unix +unix.kqueue unix.time assocs io.backend.unix.multiplexers ; +IN: io.backend.unix.multiplexers.kqueue + +TUPLE: kqueue-mx < mx events ; + +: max-events ( -- n ) + #! We read up to 256 events at a time. This is an arbitrary + #! constant... + 256 ; inline + +: ( -- mx ) + kqueue-mx new-mx + kqueue dup io-error >>fd + max-events "kevent" >>events ; + +M: kqueue-mx dispose fd>> close-file ; + +: make-kevent ( fd filter flags -- event ) + "kevent" + [ set-kevent-flags ] keep + [ set-kevent-filter ] keep + [ set-kevent-ident ] keep ; + +: register-kevent ( kevent mx -- ) + fd>> swap 1 f 0 f kevent io-error ; + +M: kqueue-mx add-input-callback ( thread fd mx -- ) + [ call-next-method ] [ + [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip + register-kevent + ] 2bi ; + +M: kqueue-mx add-output-callback ( thread fd mx -- ) + [ call-next-method ] [ + [ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip + register-kevent + ] 2bi ; + +M: kqueue-mx remove-input-callbacks ( fd mx -- seq ) + 2dup reads>> key? [ + [ call-next-method ] [ + [ EVFILT_READ EV_DELETE make-kevent ] dip + register-kevent + ] 2bi + ] [ 2drop f ] if ; + +M: kqueue-mx remove-output-callbacks ( fd mx -- seq ) + 2dup writes>> key? [ + [ + [ EVFILT_WRITE EV_DELETE make-kevent ] dip + register-kevent + ] [ call-next-method ] 2bi + ] [ 2drop f ] if ; + +: wait-kevent ( mx timespec -- n ) + [ + [ fd>> f 0 ] + [ events>> [ underlying>> ] [ length ] bi ] bi + ] dip kevent multiplexer-error ; + +: handle-kevent ( mx kevent -- ) + [ kevent-ident swap ] [ kevent-filter ] bi { + { EVFILT_READ [ input-available ] } + { EVFILT_WRITE [ output-available ] } + } case ; + +: handle-kevents ( mx n -- ) + [ dup events>> ] dip head-slice [ handle-kevent ] with each ; + +M: kqueue-mx wait-for-events ( us mx -- ) + swap dup [ make-timespec ] when + dupd wait-kevent handle-kevents ; diff --git a/basis/io/backend/unix/multiplexers/kqueue/tags.txt b/basis/io/backend/unix/multiplexers/kqueue/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/backend/unix/multiplexers/kqueue/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/backend/unix/multiplexers/multiplexers.factor b/basis/io/backend/unix/multiplexers/multiplexers.factor new file mode 100644 index 0000000000..844670d635 --- /dev/null +++ b/basis/io/backend/unix/multiplexers/multiplexers.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors assocs sequences threads ; +IN: io.backend.unix.multiplexers + +TUPLE: mx fd reads writes ; + +: new-mx ( class -- obj ) + new + H{ } clone >>reads + H{ } clone >>writes ; inline + +GENERIC: add-input-callback ( thread fd mx -- ) + +M: mx add-input-callback reads>> push-at ; + +GENERIC: add-output-callback ( thread fd mx -- ) + +M: mx add-output-callback writes>> push-at ; + +GENERIC: remove-input-callbacks ( fd mx -- callbacks ) + +M: mx remove-input-callbacks reads>> delete-at* drop ; + +GENERIC: remove-output-callbacks ( fd mx -- callbacks ) + +M: mx remove-output-callbacks writes>> delete-at* drop ; + +GENERIC: wait-for-events ( ms mx -- ) + +: input-available ( fd mx -- ) + reads>> delete-at* drop [ resume ] each ; + +: output-available ( fd mx -- ) + writes>> delete-at* drop [ resume ] each ; diff --git a/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor b/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor new file mode 100644 index 0000000000..84a609643a --- /dev/null +++ b/basis/io/backend/unix/multiplexers/run-loop/run-loop.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel arrays namespaces math accessors alien locals +destructors system threads io.backend.unix.multiplexers +io.backend.unix.multiplexers.kqueue core-foundation +core-foundation.run-loop ; +IN: io.backend.unix.multiplexers.run-loop + +TUPLE: run-loop-mx kqueue-mx ; + +: file-descriptor-callback ( -- callback ) + "void" { "CFFileDescriptorRef" "CFOptionFlags" "void*" } + "cdecl" [ + 3drop + 0 mx get kqueue-mx>> wait-for-events + reset-run-loop + yield + ] alien-callback ; + +: ( -- mx ) + [ + |dispose + dup fd>> file-descriptor-callback add-fd-to-run-loop + run-loop-mx boa + ] with-destructors ; + +M: run-loop-mx add-input-callback kqueue-mx>> add-input-callback ; +M: run-loop-mx add-output-callback kqueue-mx>> add-output-callback ; +M: run-loop-mx remove-input-callbacks kqueue-mx>> remove-input-callbacks ; +M: run-loop-mx remove-output-callbacks kqueue-mx>> remove-output-callbacks ; + +M: run-loop-mx wait-for-events ( us mx -- ) + swap run-one-iteration [ 0 swap wait-for-events ] [ drop ] if ; diff --git a/basis/io/backend/unix/multiplexers/run-loop/tags.txt b/basis/io/backend/unix/multiplexers/run-loop/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/backend/unix/multiplexers/run-loop/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/backend/unix/multiplexers/select/authors.txt b/basis/io/backend/unix/multiplexers/select/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/io/backend/unix/multiplexers/select/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/io/backend/unix/multiplexers/select/select.factor b/basis/io/backend/unix/multiplexers/select/select.factor new file mode 100644 index 0000000000..c62101e478 --- /dev/null +++ b/basis/io/backend/unix/multiplexers/select/select.factor @@ -0,0 +1,56 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types kernel bit-arrays sequences assocs unix +math namespaces accessors math.order locals unix.time fry +io.ports io.backend.unix io.backend.unix.multiplexers ; +IN: io.backend.unix.multiplexers.select + +TUPLE: select-mx < mx read-fdset write-fdset ; + +! Factor's bit-arrays are an array of bytes, OS X expects +! FD_SET to be an array of cells, so we have to account for +! byte order differences on big endian platforms +: munge ( i -- i' ) + little-endian? [ BIN: 11000 bitxor ] unless ; inline + +: ( -- mx ) + select-mx new-mx + FD_SETSIZE 8 * >>read-fdset + FD_SETSIZE 8 * >>write-fdset ; + +: clear-nth ( n seq -- ? ) + [ nth ] [ [ f ] 2dip set-nth ] 2bi ; + +:: check-fd ( fd fdset mx quot -- ) + fd munge fdset clear-nth [ fd mx quot call ] when ; inline + +: check-fdset ( fds fdset mx quot -- ) + [ check-fd ] 3curry each ; inline + +: init-fdset ( fds fdset -- ) + '[ t swap munge _ set-nth ] each ; + +: read-fdset/tasks ( mx -- seq fdset ) + [ reads>> keys ] [ read-fdset>> ] bi ; + +: write-fdset/tasks ( mx -- seq fdset ) + [ writes>> keys ] [ write-fdset>> ] bi ; + +: max-fd ( assoc -- n ) + dup assoc-empty? [ drop 0 ] [ keys supremum ] if ; + +: num-fds ( mx -- n ) + [ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ; + +: init-fdsets ( mx -- nfds read write except ) + [ num-fds ] + [ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] + [ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri + f ; + +M:: select-mx wait-for-events ( us mx -- ) + mx + [ init-fdsets us dup [ make-timeval ] when select multiplexer-error drop ] + [ [ read-fdset/tasks ] keep [ input-available ] check-fdset ] + [ [ write-fdset/tasks ] keep [ output-available ] check-fdset ] + tri ; diff --git a/basis/io/backend/unix/multiplexers/select/tags.txt b/basis/io/backend/unix/multiplexers/select/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/backend/unix/multiplexers/select/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/backend/unix/netbsd/netbsd.factor b/basis/io/backend/unix/netbsd/netbsd.factor new file mode 100644 index 0000000000..a47be300f8 --- /dev/null +++ b/basis/io/backend/unix/netbsd/netbsd.factor @@ -0,0 +1,3 @@ +USING: io.backend.unix.bsd io.backend system ; + +netbsd set-io-backend diff --git a/basis/io/backend/unix/netbsd/tags.txt b/basis/io/backend/unix/netbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/backend/unix/netbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/backend/unix/openbsd/openbsd.factor b/basis/io/backend/unix/openbsd/openbsd.factor new file mode 100644 index 0000000000..a9e25134de --- /dev/null +++ b/basis/io/backend/unix/openbsd/openbsd.factor @@ -0,0 +1,3 @@ +USING: io.backend.unix.bsd io.backend system ; + +openbsd set-io-backend diff --git a/basis/io/backend/unix/openbsd/tags.txt b/basis/io/backend/unix/openbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/backend/unix/openbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/backend/unix/summary.txt b/basis/io/backend/unix/summary.txt new file mode 100644 index 0000000000..8f66d889cc --- /dev/null +++ b/basis/io/backend/unix/summary.txt @@ -0,0 +1 @@ +Non-blocking I/O and sockets on Unix-like systems diff --git a/basis/io/backend/unix/tags.txt b/basis/io/backend/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/backend/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/backend/unix/unix-tests.factor b/basis/io/backend/unix/unix-tests.factor new file mode 100644 index 0000000000..5417b9b178 --- /dev/null +++ b/basis/io/backend/unix/unix-tests.factor @@ -0,0 +1,140 @@ +USING: io.files io.files.temp io.directories io.sockets io kernel threads +namespaces tools.test continuations strings byte-arrays +sequences prettyprint system io.encodings.binary io.encodings.ascii +io.streams.duplex destructors make ; +IN: io.backend.unix.tests + +! Unix domain stream sockets +: socket-server "unix-domain-socket-test" temp-file ; + +[ + [ socket-server delete-file ] ignore-errors + + socket-server + ascii [ + accept drop [ + "Hello world" print flush + readln "XYZ" = "FOO" "BAR" ? print flush + ] with-stream + ] with-disposal + + socket-server delete-file +] "Test" spawn drop + +yield + +[ { "Hello world" "FOO" } ] [ + [ + socket-server ascii [ + readln , + "XYZ" print flush + readln , + ] with-client + ] { } make +] unit-test + +: datagram-server "unix-domain-datagram-test" temp-file ; +: datagram-client "unix-domain-datagram-test-2" temp-file ; + +! Unix domain datagram sockets +[ datagram-server delete-file ] ignore-errors +[ datagram-client delete-file ] ignore-errors + +[ + [ + datagram-server "d" set + + "Receive 1" print + + "d" get receive [ reverse ] dip + + "Send 1" print + dup . + + "d" get send + + "Receive 2" print + + "d" get receive [ " world" append ] dip + + "Send 1" print + dup . + + "d" get send + + "d" get dispose + + "Done" print + + datagram-server delete-file + ] with-scope +] "Test" spawn drop + +yield + +[ datagram-client delete-file ] ignore-errors + +datagram-client +"d" set + +[ ] [ + "hello" >byte-array + datagram-server + "d" get send +] unit-test + +[ "olleh" t ] [ + "d" get receive + datagram-server = + [ >string ] dip +] unit-test + +[ ] [ + "hello" >byte-array + datagram-server + "d" get send +] unit-test + +[ "hello world" t ] [ + "d" get receive + datagram-server = + [ >string ] dip +] unit-test + +[ ] [ "d" get dispose ] unit-test + +! Test error behavior +: another-datagram "unix-domain-datagram-test-3" temp-file ; + +[ another-datagram delete-file ] ignore-errors + +datagram-client delete-file + +[ ] [ datagram-client "d" set ] unit-test + +[ B{ 1 2 3 } another-datagram "d" get send ] must-fail + +[ ] [ "d" get dispose ] unit-test + +! See what happens on send/receive after close + +[ "d" get receive ] must-fail + +[ B{ 1 2 } datagram-server "d" get send ] must-fail + +! Invalid parameter tests + +[ + image binary [ input-stream get accept ] with-file-reader +] must-fail + +[ + image binary [ input-stream get receive ] with-file-reader +] must-fail + +[ + image binary [ + B{ 1 2 } datagram-server + input-stream get send + ] with-file-reader +] must-fail diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor new file mode 100644 index 0000000000..e8ace90d73 --- /dev/null +++ b/basis/io/backend/unix/unix.factor @@ -0,0 +1,185 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types alien.syntax generic assocs kernel +kernel.private math io.ports sequences strings sbufs threads +unix vectors io.buffers io.backend io.encodings math.parser +continuations system libc qualified namespaces make io.timeouts +io.encodings.utf8 destructors accessors summary combinators +locals unix.time fry io.backend.unix.multiplexers ; +QUALIFIED: io +IN: io.backend.unix + +GENERIC: handle-fd ( handle -- fd ) + +TUPLE: fd fd disposed ; + +: init-fd ( fd -- fd ) + [ + |dispose + dup fd>> F_SETFL O_NONBLOCK fcntl io-error + dup fd>> F_SETFD FD_CLOEXEC fcntl io-error + ] with-destructors ; + +: ( n -- fd ) + #! We drop the error code rather than calling io-error, + #! since on OS X 10.3, this operation fails from init-io + #! when running the Factor.app (presumably because fd 0 and + #! 1 are closed). + f fd boa ; + +M: fd dispose + dup disposed>> [ drop ] [ + [ cancel-operation ] + [ t >>disposed drop ] + [ fd>> close-file ] + tri + ] if ; + +M: fd handle-fd dup check-disposed fd>> ; + +M: fd cancel-operation ( fd -- ) + dup disposed>> [ drop ] [ + fd>> + mx get-global + [ remove-input-callbacks [ t swap resume-with ] each ] + [ remove-output-callbacks [ t swap resume-with ] each ] + 2bi + ] if ; + +SYMBOL: +retry+ ! just try the operation again without blocking +SYMBOL: +input+ +SYMBOL: +output+ + +ERROR: io-timeout ; + +M: io-timeout summary drop "I/O operation timed out" ; + +: wait-for-fd ( handle event -- ) + dup +retry+ eq? [ 2drop ] [ + '[ + swap handle-fd mx get-global _ { + { +input+ [ add-input-callback ] } + { +output+ [ add-output-callback ] } + } case + ] "I/O" suspend nip [ io-timeout ] when + ] if ; + +: wait-for-port ( port event -- ) + '[ handle>> _ wait-for-fd ] with-timeout ; + +! Some general stuff +: file-mode OCT: 0666 ; + +! Readers +: (refill) ( port -- n ) + [ handle>> ] + [ buffer>> buffer-end ] + [ buffer>> buffer-capacity ] tri read ; + +! Returns an event to wait for which will ensure completion of +! this request +GENERIC: refill ( port handle -- event/f ) + +M: fd refill + fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read + { + { [ dup 0 >= ] [ swap buffer>> n>buffer f ] } + { [ err_no EINTR = ] [ 2drop +retry+ ] } + { [ err_no EAGAIN = ] [ 2drop +input+ ] } + [ (io-error) ] + } cond ; + +M: unix (wait-to-read) ( port -- ) + dup + dup handle>> dup check-disposed refill dup + [ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ; + +! Writers +GENERIC: drain ( port handle -- event/f ) + +M: fd drain + fd>> over buffer>> [ buffer@ ] [ buffer-length ] bi write + { + { [ dup 0 >= ] [ + over buffer>> buffer-consume + buffer>> buffer-empty? f +output+ ? + ] } + { [ err_no EINTR = ] [ 2drop +retry+ ] } + { [ err_no EAGAIN = ] [ 2drop +output+ ] } + [ (io-error) ] + } cond ; + +M: unix (wait-to-write) ( port -- ) + dup + dup handle>> dup check-disposed drain + dup [ wait-for-port ] [ 2drop ] if ; + +M: unix io-multiplex ( ms/f -- ) + mx get-global wait-for-events ; + +! On Unix, you're not supposed to set stdin to non-blocking +! because the fd might be shared with another process (either +! parent or child). So what we do is have the VM start a thread +! which pumps data from the real stdin to a pipe. We set the +! pipe to non-blocking, and read from it instead of the real +! stdin. Very crufty, but it will suffice until we get native +! threading support at the language level. +TUPLE: stdin control size data disposed ; + +M: stdin dispose* + [ + [ control>> &dispose drop ] + [ size>> &dispose drop ] + [ data>> &dispose drop ] + tri + ] with-destructors ; + +: wait-for-stdin ( stdin -- n ) + [ control>> CHAR: X over io:stream-write1 io:stream-flush ] + [ size>> "ssize_t" heap-size swap io:stream-read *int ] + bi ; + +:: refill-stdin ( buffer stdin size -- ) + stdin data>> handle-fd buffer buffer-end size read + dup 0 < [ + drop + err_no EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if + ] [ + size = [ "Error reading stdin pipe" throw ] unless + size buffer n>buffer + ] if ; + +M: stdin refill + [ buffer>> ] [ dup wait-for-stdin ] bi* refill-stdin f ; + +: control-write-fd ( -- fd ) &: control_write *uint ; + +: size-read-fd ( -- fd ) &: size_read *uint ; + +: data-read-fd ( -- fd ) &: stdin_read *uint ; + +: ( -- stdin ) + stdin new + control-write-fd >>control + size-read-fd init-fd >>size + data-read-fd >>data ; + +M: unix (init-stdio) ( -- ) + + 1 + 2 ; + +! mx io-task for embedding an fd-based mx inside another mx +TUPLE: mx-port < port mx ; + +: ( mx -- port ) + dup fd>> mx-port swap >>mx ; + +: multiplexer-error ( n -- n ) + dup 0 < [ + err_no [ EAGAIN = ] [ EINTR = ] bi or + [ drop 0 ] [ (io-error) ] if + ] when ; + +: ?flag ( n mask symbol -- n ) + pick rot bitand 0 > [ , ] [ drop ] if ; diff --git a/basis/io/backend/windows/authors.txt b/basis/io/backend/windows/authors.txt new file mode 100644 index 0000000000..781acc2b62 --- /dev/null +++ b/basis/io/backend/windows/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Mackenzie Straight diff --git a/basis/io/backend/windows/nt/authors.txt b/basis/io/backend/windows/nt/authors.txt new file mode 100755 index 0000000000..026f4cd0de --- /dev/null +++ b/basis/io/backend/windows/nt/authors.txt @@ -0,0 +1,3 @@ +Doug Coleman +Slava Pestov +Mackenzie Straight diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor new file mode 100755 index 0000000000..bb8175b35c --- /dev/null +++ b/basis/io/backend/windows/nt/nt.factor @@ -0,0 +1,122 @@ +USING: alien alien.c-types arrays assocs combinators +continuations destructors io io.backend io.ports io.timeouts +io.backend.windows io.files.windows io.files.windows.nt io.files +io.pathnames io.buffers io.streams.c libc kernel math namespaces +sequences threads windows windows.errors windows.kernel32 +strings splitting qualified ascii system accessors locals ; +QUALIFIED: windows.winsock +IN: io.backend.windows.nt + +! Global variable with assoc mapping overlapped to threads +SYMBOL: pending-overlapped + +TUPLE: io-callback port thread ; + +C: io-callback + +: (make-overlapped) ( -- overlapped-ext ) + "OVERLAPPED" malloc-object &free ; + +: make-overlapped ( port -- overlapped-ext ) + [ (make-overlapped) ] dip + handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ; + +: ( handle existing -- handle ) + f 1 CreateIoCompletionPort dup win32-error=0/f ; + +SYMBOL: master-completion-port + +: ( -- handle ) + INVALID_HANDLE_VALUE f ; + +M: winnt add-completion ( win32-handle -- ) + handle>> master-completion-port get-global drop ; + +: eof? ( error -- ? ) + [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] bi or ; + +: twiddle-thumbs ( overlapped port -- bytes-transferred ) + [ + 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 ; + +:: wait-for-overlapped ( us -- bytes-transferred overlapped error? ) + master-completion-port get-global + 0 [ ! bytes + f ! key + f [ ! overlapped + us [ 1000 /i ] [ INFINITE ] if* ! timeout + GetQueuedCompletionStatus zero? + ] keep *void* + ] keep *int spin ; + +: resume-callback ( result overlapped -- ) + pending-overlapped get-global delete-at* drop resume-with ; + +: handle-overlapped ( us -- ? ) + wait-for-overlapped [ + dup [ + [ drop GetLastError 1array ] dip resume-callback t + ] [ 2drop f ] if + ] [ resume-callback t ] if ; + +M: win32-handle cancel-operation + [ check-disposed ] [ handle>> CancelIo drop ] bi ; + +M: winnt io-multiplex ( us -- ) + handle-overlapped [ 0 io-multiplex ] when ; + +M: winnt init-io ( -- ) + master-completion-port 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 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ; + +: update-file-ptr ( n port -- ) + handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ; + +: finish-write ( n port -- ) + [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ; + +M: winnt (wait-to-write) + [ + [ make-FileArgs dup setup-write WriteFile ] + [ wait-for-file ] + [ finish-write ] + tri + ] with-destructors ; + +: finish-read ( n port -- ) + [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ; + +M: winnt (wait-to-read) ( port -- ) + [ + [ make-FileArgs dup setup-read ReadFile ] + [ wait-for-file ] + [ finish-read ] + tri + ] with-destructors ; + +M: winnt (init-stdio) init-c-stdio ; + +winnt set-io-backend diff --git a/basis/io/backend/windows/nt/privileges/privileges.factor b/basis/io/backend/windows/nt/privileges/privileges.factor new file mode 100755 index 0000000000..64218f75b0 --- /dev/null +++ b/basis/io/backend/windows/nt/privileges/privileges.factor @@ -0,0 +1,52 @@ +USING: alien alien.c-types alien.syntax arrays continuations +destructors generic io.mmap io.ports io.backend.windows io.files.windows +kernel libc math math.bitwise namespaces quotations sequences windows +windows.advapi32 windows.kernel32 io.backend system accessors +io.backend.windows.privileges ; +IN: io.backend.windows.nt.privileges + +TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES + +! Security tokens +! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/ + +: (open-process-token) ( handle -- handle ) + { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" + [ OpenProcessToken win32-error=0/f ] keep *void* ; + +: open-process-token ( -- handle ) + #! remember to CloseHandle + GetCurrentProcess (open-process-token) ; + +: with-process-token ( quot -- ) + #! quot: ( token-handle -- token-handle ) + [ open-process-token ] dip + [ keep ] curry + [ CloseHandle drop ] [ ] cleanup ; inline + +: lookup-privilege ( string -- luid ) + [ f ] dip "LUID" + [ LookupPrivilegeValue win32-error=0/f ] keep ; + +: make-token-privileges ( name ? -- obj ) + "TOKEN_PRIVILEGES" + 1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep + "LUID_AND_ATTRIBUTES" malloc-array &free + over set-TOKEN_PRIVILEGES-Privileges + + swap [ + SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges + set-LUID_AND_ATTRIBUTES-Attributes + ] when + + [ lookup-privilege ] dip + [ + TOKEN_PRIVILEGES-Privileges + set-LUID_AND_ATTRIBUTES-Luid + ] keep ; + +M: winnt set-privilege ( name ? -- ) + [ + -rot 0 -rot make-token-privileges + dup length f f AdjustTokenPrivileges win32-error=0/f + ] with-process-token ; diff --git a/basis/io/backend/windows/nt/privileges/tags.txt b/basis/io/backend/windows/nt/privileges/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/backend/windows/nt/privileges/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/backend/windows/nt/tags.txt b/basis/io/backend/windows/nt/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/backend/windows/nt/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/backend/windows/privileges/privileges.factor b/basis/io/backend/windows/privileges/privileges.factor new file mode 100644 index 0000000000..8661ba99d9 --- /dev/null +++ b/basis/io/backend/windows/privileges/privileges.factor @@ -0,0 +1,14 @@ +USING: io.backend kernel continuations sequences +system vocabs.loader combinators ; +IN: io.backend.windows.privileges + +HOOK: set-privilege io-backend ( name ? -- ) inline + +: with-privileges ( seq quot -- ) + over [ [ t set-privilege ] each ] curry compose + swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline + +{ + { [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] } + { [ os wince? ] [ "io.backend.windows.ce.privileges" require ] } +} cond diff --git a/basis/io/backend/windows/privileges/tags.txt b/basis/io/backend/windows/privileges/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/backend/windows/privileges/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/backend/windows/summary.txt b/basis/io/backend/windows/summary.txt new file mode 100644 index 0000000000..2a2d5443b2 --- /dev/null +++ b/basis/io/backend/windows/summary.txt @@ -0,0 +1 @@ +Microsoft Windows native I/O implementation diff --git a/basis/io/backend/windows/tags.txt b/basis/io/backend/windows/tags.txt new file mode 100755 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/backend/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor new file mode 100755 index 0000000000..e7c72edfd0 --- /dev/null +++ b/basis/io/backend/windows/windows.factor @@ -0,0 +1,54 @@ +! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types arrays destructors io io.backend +io.buffers io.files io.ports io.binary io.timeouts +windows.errors strings kernel math namespaces sequences windows +windows.kernel32 windows.shell32 windows.types windows.winsock +splitting continuations math.bitwise system accessors ; +IN: io.backend.windows + +: set-inherit ( handle ? -- ) + [ HANDLE_FLAG_INHERIT ] dip + >BOOLEAN SetHandleInformation win32-error=0/f ; + +TUPLE: win32-handle handle disposed ; + +: new-win32-handle ( handle class -- win32-handle ) + new swap [ >>handle ] [ f set-inherit ] bi ; + +: ( handle -- win32-handle ) + win32-handle new-win32-handle ; + +M: win32-handle dispose* ( handle -- ) + handle>> CloseHandle drop ; + +TUPLE: win32-file < win32-handle ptr ; + +: ( handle -- win32-file ) + win32-file new-win32-handle ; + +M: win32-file dispose + dup disposed>> [ drop ] [ + [ cancel-operation ] [ call-next-method ] bi + ] if ; + +HOOK: CreateFile-flags io-backend ( DWORD -- DWORD ) +HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) +HOOK: add-completion io-backend ( port -- ) + +: opened-file ( handle -- win32-file ) + dup invalid-handle? + |dispose + dup add-completion ; + +: share-mode ( -- fixnum ) + { + FILE_SHARE_READ + FILE_SHARE_WRITE + FILE_SHARE_DELETE + } flags ; foldable + +: default-security-attributes ( -- obj ) + "SECURITY_ATTRIBUTES" + "SECURITY_ATTRIBUTES" heap-size + over set-SECURITY_ATTRIBUTES-nLength ; diff --git a/basis/io/directories/authors.txt b/basis/io/directories/authors.txt new file mode 100644 index 0000000000..f372b574ae --- /dev/null +++ b/basis/io/directories/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Doug Coleman diff --git a/basis/io/directories/directories-docs.factor b/basis/io/directories/directories-docs.factor new file mode 100644 index 0000000000..edfcf480b0 --- /dev/null +++ b/basis/io/directories/directories-docs.factor @@ -0,0 +1,166 @@ +USING: help.markup help.syntax io.files.private io.pathnames +quotations ; +IN: io.directories + +HELP: cwd +{ $values { "path" "a pathname string" } } +{ $description "Outputs the current working directory of the Factor process." } +{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } +{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ; + +HELP: cd +{ $values { "path" "a pathname string" } } +{ $description "Changes the current working directory of the Factor process." } +{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } +{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ; + +{ cd cwd current-directory set-current-directory with-directory } related-words + +HELP: current-directory +{ $description "A variable holding the current directory as an absolute path. Words that use the filesystem do so in relation to this variable." +$nl +"This variable should never be set directly; instead, use " { $link set-current-directory } " or " { $link with-directory } ". This preserves the invariant that the value of this variable is an absolute path." } ; + +HELP: set-current-directory +{ $values { "path" "a pathname string" } } +{ $description "Changes the " { $link current-directory } " variable." +$nl +"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ; + +HELP: with-directory +{ $values { "path" "a pathname string" } { "quot" quotation } } +{ $description "Calls the quotation in a new dynamic scope with the " { $link current-directory } " variable rebound." +$nl +"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ; + +HELP: (directory-entries) +{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } } +{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } +{ $notes "This is a low-level word, and user code should call one of the related words instead." } ; + +HELP: directory-entries +{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $link directory-entry } " objects" } } +{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ; + +HELP: directory-files +{ $values { "path" "a pathname string" } { "seq" "a sequence of filenames" } } +{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ; + +HELP: with-directory-files +{ $values { "path" "a pathname string" } { "quot" quotation } } +{ $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ; + +HELP: delete-file +{ $values { "path" "a pathname string" } } +{ $description "Deletes a file." } +{ $errors "Throws an error if the file could not be deleted." } ; + +HELP: make-directory +{ $values { "path" "a pathname string" } } +{ $description "Creates a directory." } +{ $errors "Throws an error if the directory could not be created." } ; + +HELP: make-directories +{ $values { "path" "a pathname string" } } +{ $description "Creates a directory and any parent directories which do not yet exist." } +{ $errors "Throws an error if the directories could not be created." } ; + +HELP: delete-directory +{ $values { "path" "a pathname string" } } +{ $description "Deletes a directory. The directory must be empty." } +{ $errors "Throws an error if the directory could not be deleted." } ; + +HELP: touch-file +{ $values { "path" "a pathname string" } } +{ $description "Updates the modification time of a file or directory. If the file does not exist, creates a new, empty file." } +{ $errors "Throws an error if the file could not be touched." } ; + +HELP: move-file +{ $values { "from" "a pathname string" } { "to" "a pathname string" } } +{ $description "Moves or renames a file." } +{ $errors "Throws an error if the file does not exist or if the move operation fails." } ; + +HELP: move-file-into +{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } } +{ $description "Moves a file to another directory without renaming it." } +{ $errors "Throws an error if the file does not exist or if the move operation fails." } ; + +HELP: move-files-into +{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } } +{ $description "Moves a set of files to another directory." } +{ $errors "Throws an error if the file does not exist or if the move operation fails." } ; + +HELP: copy-file +{ $values { "from" "a pathname string" } { "to" "a pathname string" } } +{ $description "Copies a file." } +{ $notes "This operation attempts to preserve the original file's attributes, however not all attributes may be preserved." } +{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ; + +HELP: copy-file-into +{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } } +{ $description "Copies a file to another directory." } +{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ; + +HELP: copy-files-into +{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } } +{ $description "Copies a set of files to another directory." } +{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ; + +ARTICLE: "current-directory" "Current working directory" +"File system I/O operations use the value of a variable to resolve relative pathnames:" +{ $subsection current-directory } +"This variable can be changed with a pair of words:" +{ $subsection set-current-directory } +{ $subsection with-directory } +"This variable is independent of the operating system notion of ``current working directory''. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:" +{ $subsection (normalize-path) } +"The second is to change the working directory of the current process:" +{ $subsection cd } +{ $subsection cwd } ; + +ARTICLE: "io.directories.listing" "Directory listing" +"Directory listing:" +{ $subsection directory-entries } +{ $subsection directory-files } +{ $subsection with-directory-files } ; + +ARTICLE: "io.directories.create" "Creating directories" +{ $subsection make-directory } +{ $subsection make-directories } ; + +ARTICLE: "delete-move-copy" "Deleting, moving, and copying files" +"Operations for deleting and copying files come in two forms:" +{ $list + { "Words named " { $snippet { $emphasis "operation" } "-file" } " which work on regular files only." } + { "Words named " { $snippet { $emphasis "operation" } "-tree" } " works on directory trees recursively, and also accepts regular files." } +} +"The operations for moving and copying files come in three flavors:" +{ $list + { "A word named " { $snippet { $emphasis "operation" } } " which takes a source and destination path." } + { "A word named " { $snippet { $emphasis "operation" } "-into" } " which takes a source path and destination directory. The destination file will be stored in the destination directory and will have the same file name as the source path." } + { "A word named " { $snippet { $emphasis "operation" } "s-into" } " which takes a sequence of source paths and destination directory." } +} +"Since both of the above lists apply to copying files, that this means that there are a total of six variations on copying a file." +$nl +"Deleting files:" +{ $subsection delete-file } +{ $subsection delete-directory } +"Moving files:" +{ $subsection move-file } +{ $subsection move-file-into } +{ $subsection move-files-into } +"Copying files:" +{ $subsection copy-file } +{ $subsection copy-file-into } +{ $subsection copy-files-into } +"On most operating systems, files can only be moved within the same file system. To move files between file systems, use " { $link copy-file } " followed by " { $link delete-file } " on the old name." ; + +ARTICLE: "io.directories" "Directory manipulation" +"The " { $vocab-link "io.directories" } " vocabulary defines words for inspecting and manipulating directory trees." +{ $subsection home } +{ $subsection "current-directory" } +{ $subsection "io.directories.listing" } +{ $subsection "io.directories.create" } +{ $subsection "delete-move-copy" } ; + +ABOUT: "io.directories" diff --git a/basis/io/directories/directories-tests.factor b/basis/io/directories/directories-tests.factor new file mode 100644 index 0000000000..b703421b45 --- /dev/null +++ b/basis/io/directories/directories-tests.factor @@ -0,0 +1,189 @@ +USING: continuations destructors io io.directories +io.directories.hierarchy io.encodings.ascii io.encodings.utf8 +io.files io.files.info io.files.temp io.pathnames kernel +sequences tools.test ; +IN: io.directories.tests + +[ { "kernel" } ] [ + "core" resource-path [ + "." directory-files [ "kernel" = ] filter + ] with-directory +] unit-test + +[ { "kernel" } ] [ + "resource:core" [ + "." directory-files [ "kernel" = ] filter + ] with-directory +] unit-test + +[ { "kernel" } ] [ + "resource:core" [ + [ "kernel" = ] filter + ] with-directory-files +] unit-test + +[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test +[ ] [ "blahblah" temp-file make-directory ] unit-test +[ t ] [ "blahblah" temp-file file-info directory? ] unit-test + +[ t ] [ + [ temp-directory "loldir" append-path delete-directory ] ignore-errors + temp-directory [ + "loldir" make-directory + ] with-directory + temp-directory "loldir" append-path exists? +] unit-test + +[ ] [ + [ temp-directory "loldir" append-path delete-directory ] ignore-errors + temp-directory [ + "loldir" make-directory + "loldir" delete-directory + ] with-directory +] unit-test + +[ "file1 contents" ] [ + [ temp-directory "loldir" append-path delete-directory ] ignore-errors + temp-directory [ + "file1 contents" "file1" utf8 set-file-contents + "file1" "file2" copy-file + "file2" utf8 file-contents + ] with-directory + "file1" temp-file delete-file + "file2" temp-file delete-file +] unit-test + +[ "file3 contents" ] [ + temp-directory [ + "file3 contents" "file3" utf8 set-file-contents + "file3" "file4" move-file + "file4" utf8 file-contents + ] with-directory + "file4" temp-file delete-file +] unit-test + +[ "file5" temp-file delete-file ] ignore-errors + +[ ] [ + temp-directory [ + "file5" touch-file + "file5" delete-file + ] with-directory +] unit-test + +[ "file6" temp-file delete-file ] ignore-errors + +[ ] [ + temp-directory [ + "file6" touch-file + "file6" link-info drop + ] with-directory +] unit-test + +[ ] [ + { "Hello world." } + "test-foo.txt" temp-file ascii set-file-lines +] unit-test + +[ ] [ + "test-foo.txt" temp-file ascii [ + "Hello appender." print + ] with-file-appender +] unit-test + +[ ] [ + "test-bar.txt" temp-file ascii [ + "Hello appender." print + ] with-file-appender +] unit-test + +[ "Hello world.\nHello appender.\n" ] [ + "test-foo.txt" temp-file ascii file-contents +] unit-test + +[ "Hello appender.\n" ] [ + "test-bar.txt" temp-file ascii file-contents +] unit-test + +[ ] [ "test-foo.txt" temp-file delete-file ] unit-test + +[ ] [ "test-bar.txt" temp-file delete-file ] unit-test + +[ f ] [ "test-foo.txt" temp-file exists? ] unit-test + +[ 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 + +[ ] [ + "test-blah/fooz" temp-file ascii dispose +] unit-test + +[ t ] [ + "test-blah/fooz" temp-file exists? +] unit-test + +[ ] [ "test-blah/fooz" temp-file delete-file ] unit-test + +[ ] [ "test-blah" temp-file delete-directory ] unit-test + +[ f ] [ "test-blah" temp-file exists? ] unit-test + +[ ] [ "delete-tree-test/a/b/c" temp-file make-directories ] unit-test + +[ ] [ + { "Hi" } + "delete-tree-test/a/b/c/d" temp-file ascii set-file-lines +] unit-test + +[ ] [ + "delete-tree-test" temp-file delete-tree +] unit-test + +[ ] [ + "copy-tree-test/a/b/c" temp-file make-directories +] unit-test + +[ ] [ + "Foobar" + "copy-tree-test/a/b/c/d" temp-file + ascii set-file-contents +] unit-test + +[ ] [ + "copy-tree-test" temp-file + "copy-destination" temp-file copy-tree +] unit-test + +[ "Foobar" ] [ + "copy-destination/a/b/c/d" temp-file ascii file-contents +] unit-test + +[ ] [ + "copy-destination" temp-file delete-tree +] unit-test + +[ ] [ + "copy-tree-test" temp-file + "copy-destination" temp-file copy-tree-into +] unit-test + +[ "Foobar" ] [ + "copy-destination/copy-tree-test/a/b/c/d" temp-file ascii file-contents +] unit-test + +[ ] [ + "copy-destination/copy-tree-test/a/b/c/d" temp-file "" temp-file copy-file-into +] unit-test + +[ "Foobar" ] [ + "d" temp-file ascii file-contents +] unit-test + +[ ] [ "d" temp-file delete-file ] unit-test + +[ ] [ "copy-destination" temp-file delete-tree ] unit-test + +[ ] [ "copy-tree-test" temp-file delete-tree ] unit-test diff --git a/basis/io/directories/directories.factor b/basis/io/directories/directories.factor new file mode 100755 index 0000000000..2630be8ce2 --- /dev/null +++ b/basis/io/directories/directories.factor @@ -0,0 +1,87 @@ +! Copyright (C) 2004, 2008 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators destructors io io.backend +io.encodings.binary io.files io.pathnames kernel namespaces +sequences system vocabs.loader fry ; +IN: io.directories + +: set-current-directory ( path -- ) + (normalize-path) current-directory set ; + +: with-directory ( path quot -- ) + [ (normalize-path) current-directory ] dip with-variable ; inline + +! Creating directories +HOOK: make-directory io-backend ( path -- ) + +: make-directories ( path -- ) + normalize-path trim-right-separators { + { [ dup "." = ] [ ] } + { [ dup root-directory? ] [ ] } + { [ dup empty? ] [ ] } + { [ dup exists? ] [ ] } + [ + dup parent-directory make-directories + dup make-directory + ] + } cond drop ; + +! Listing directories +TUPLE: directory-entry name type ; + +HOOK: >directory-entry os ( byte-array -- directory-entry ) + +HOOK: (directory-entries) os ( path -- seq ) + +: directory-entries ( path -- seq ) + normalize-path + (directory-entries) + [ name>> { "." ".." } member? not ] filter ; + +: directory-files ( path -- seq ) + directory-entries [ name>> ] map ; + +: with-directory-files ( path quot -- ) + '[ "" directory-files @ ] with-directory ; inline + +! Touching files +HOOK: touch-file io-backend ( path -- ) + +! Deleting files +HOOK: delete-file io-backend ( path -- ) + +HOOK: delete-directory io-backend ( path -- ) + +: to-directory ( from to -- from to' ) + over file-name append-path ; + +! Moving and renaming files +HOOK: move-file io-backend ( from to -- ) + +: move-file-into ( from to -- ) + to-directory move-file ; + +: move-files-into ( files to -- ) + '[ _ move-file-into ] each ; + +! Copying files +HOOK: copy-file io-backend ( from to -- ) + +M: object copy-file + dup parent-directory make-directories + binary [ + swap binary [ + swap stream-copy + ] with-disposal + ] with-disposal ; + +: copy-file-into ( from to -- ) + to-directory copy-file ; + +: copy-files-into ( files to -- ) + '[ _ copy-file-into ] each ; + +{ + { [ os unix? ] [ "io.directories.unix" require ] } + { [ os windows? ] [ "io.directories.windows" require ] } +} cond \ No newline at end of file diff --git a/basis/io/directories/hierarchy/authors.txt b/basis/io/directories/hierarchy/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/io/directories/hierarchy/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/io/directories/hierarchy/hierarchy-docs.factor b/basis/io/directories/hierarchy/hierarchy-docs.factor new file mode 100644 index 0000000000..8b3ca7391d --- /dev/null +++ b/basis/io/directories/hierarchy/hierarchy-docs.factor @@ -0,0 +1,36 @@ +USING: help.markup help.syntax ; +IN: io.directories.hierarchy + +HELP: delete-tree +{ $values { "path" "a pathname string" } } +{ $description "Deletes a file or directory, recursing into subdirectories." } +{ $errors "Throws an error if the deletion fails." } +{ $warning "Misuse of this word can lead to catastrophic data loss." } ; + +HELP: copy-tree +{ $values { "from" "a pathname string" } { "to" "a pathname string" } } +{ $description "Copies a directory tree recursively." } +{ $notes "This operation attempts to preserve original file attributes, however not all attributes may be preserved." } +{ $errors "Throws an error if the copy operation fails." } ; + +HELP: copy-tree-into +{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } } +{ $description "Copies a directory tree to another directory, recursively." } +{ $errors "Throws an error if the copy operation fails." } ; + +HELP: copy-trees-into +{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } } +{ $description "Copies a set of directory trees to another directory, recursively." } +{ $errors "Throws an error if the copy operation fails." } ; + +ARTICLE: "io.directories.hierarchy" "Directory hierarchy manipulation" +"The " { $vocab-link "io.directories.hierarchy" } " vocabulary defines words for operating on directory hierarchies recursively." +$nl +"Deleting directory trees recursively:" +{ $subsection delete-tree } +"Copying directory trees recursively:" +{ $subsection copy-tree } +{ $subsection copy-tree-into } +{ $subsection copy-trees-into } ; + +ABOUT: "io.directories.hierarchy" diff --git a/basis/io/directories/hierarchy/hierarchy.factor b/basis/io/directories/hierarchy/hierarchy.factor new file mode 100644 index 0000000000..555f001bfc --- /dev/null +++ b/basis/io/directories/hierarchy/hierarchy.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2004, 2008 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences combinators fry io.directories +io.pathnames io.files.info io.files.types io.files.links +io.backend ; +IN: io.directories.hierarchy + +: delete-tree ( path -- ) + dup link-info directory? [ + [ [ [ delete-tree ] each ] with-directory-files ] + [ delete-directory ] + bi + ] [ delete-file ] if ; + +DEFER: copy-tree-into + +: copy-tree ( from to -- ) + normalize-path + over link-info type>> + { + { +symbolic-link+ [ copy-link ] } + { +directory+ [ '[ [ _ copy-tree-into ] each ] with-directory-files ] } + [ drop copy-file ] + } case ; + +: copy-tree-into ( from to -- ) + to-directory copy-tree ; + +: copy-trees-into ( files to -- ) + '[ _ copy-tree-into ] each ; + diff --git a/basis/io/directories/hierarchy/summary.txt b/basis/io/directories/hierarchy/summary.txt new file mode 100644 index 0000000000..3480f88d49 --- /dev/null +++ b/basis/io/directories/hierarchy/summary.txt @@ -0,0 +1 @@ +Deleting and copying directory hierarchies diff --git a/basis/io/directories/search/authors.txt b/basis/io/directories/search/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/io/directories/search/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/io/directories/search/search-tests.factor b/basis/io/directories/search/search-tests.factor new file mode 100644 index 0000000000..63c9483331 --- /dev/null +++ b/basis/io/directories/search/search-tests.factor @@ -0,0 +1,11 @@ +USING: io.directories.search io.files io.files.unique +io.pathnames kernel namespaces sequences sorting tools.test ; +IN: io.directories.search.tests + +[ t ] [ + [ + 10 [ "io.paths.test" "gogogo" make-unique-file* ] replicate + current-directory get t [ ] find-all-files + ] with-unique-directory + [ natural-sort ] bi@ = +] unit-test diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor new file mode 100755 index 0000000000..17f8552c2b --- /dev/null +++ b/basis/io/directories/search/search.factor @@ -0,0 +1,59 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays continuations deques dlists fry +io.directories io.files io.files.info io.pathnames kernel +sequences system vocabs.loader ; +IN: io.directories.search + +TUPLE: directory-iterator path bfs queue ; + +> swap bfs>> + [ push-front ] [ push-back ] if + ] curry each ; + +: ( path bfs? -- iterator ) + directory-iterator boa + dup path>> over push-directory ; + +: next-file ( iter -- file/f ) + dup queue>> deque-empty? [ drop f ] [ + dup queue>> pop-back dup link-info directory? + [ over push-directory next-file ] [ nip ] if + ] if ; + +: iterate-directory ( iter quot: ( obj -- ? ) -- obj ) + over next-file [ + over call + [ 2nip ] [ iterate-directory ] if* + ] [ + 2drop f + ] if* ; inline recursive + +PRIVATE> + +: find-file ( path bfs? quot: ( obj -- ? ) -- path/f ) + [ ] dip + [ keep and ] curry iterate-directory ; inline + +: each-file ( path bfs? quot: ( obj -- ? ) -- ) + [ ] dip + [ f ] compose iterate-directory drop ; inline + +: find-all-files ( path bfs? quot: ( obj -- ? ) -- paths ) + [ ] dip + pusher [ [ f ] compose iterate-directory drop ] dip ; inline + +: recursive-directory ( path bfs? -- paths ) + [ ] accumulator [ each-file ] dip ; + +: find-in-directories ( directories bfs? quot -- path' ) + '[ _ _ find-file ] attempt-all ; inline + +os windows? [ "io.paths.windows" require ] when diff --git a/basis/io/directories/search/windows/authors.txt b/basis/io/directories/search/windows/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/io/directories/search/windows/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/io/directories/search/windows/tags.txt b/basis/io/directories/search/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/directories/search/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/directories/search/windows/windows.factor b/basis/io/directories/search/windows/windows.factor new file mode 100644 index 0000000000..b9ef53f4f5 --- /dev/null +++ b/basis/io/directories/search/windows/windows.factor @@ -0,0 +1,12 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays fry io.pathnames kernel sequences windows.shell32 ; +IN: io.paths + +: program-files-directories ( -- array ) + program-files program-files-x86 2array ; inline + +: find-in-program-files ( base-directory bfs? quot -- path ) + [ + [ program-files-directories ] dip '[ _ append-path ] map + ] 2dip find-in-directories ; inline diff --git a/basis/io/directories/summary.txt b/basis/io/directories/summary.txt new file mode 100644 index 0000000000..b77012207b --- /dev/null +++ b/basis/io/directories/summary.txt @@ -0,0 +1 @@ +Listing directories, moving, copying and deleting files diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor new file mode 100644 index 0000000000..1ef80b3438 --- /dev/null +++ b/basis/io/directories/unix/unix.factor @@ -0,0 +1,73 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types alien.strings combinators +continuations destructors fry io io.backend io.backend.unix +io.directories io.encodings.binary io.encodings.utf8 io.files +io.pathnames io.files.types kernel math.bitwise sequences system +unix unix.stat ; +IN: io.directories.unix + +: touch-mode ( -- n ) + { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable + +M: unix touch-file ( path -- ) + normalize-path + dup exists? [ touch ] [ + touch-mode file-mode open-file close-file + ] if ; + +M: unix move-file ( from to -- ) + [ normalize-path ] bi@ rename io-error ; + +M: unix delete-file ( path -- ) normalize-path unlink-file ; + +M: unix make-directory ( path -- ) + normalize-path OCT: 777 mkdir io-error ; + +M: unix delete-directory ( path -- ) + normalize-path rmdir io-error ; + +: (copy-file) ( from to -- ) + dup parent-directory make-directories + binary [ + swap binary [ + swap stream-copy + ] with-disposal + ] with-disposal ; + +M: unix copy-file ( from to -- ) + [ normalize-path ] bi@ (copy-file) ; + +: 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" + f + [ readdir_r 0 = [ (io-error) ] unless ] 2keep + *void* [ drop f ] unless ; + +: dirent-type>file-type ( ch -- type ) + { + { DT_BLK [ +block-device+ ] } + { DT_CHR [ +character-device+ ] } + { DT_DIR [ +directory+ ] } + { DT_LNK [ +symbolic-link+ ] } + { DT_SOCK [ +socket+ ] } + { DT_FIFO [ +fifo+ ] } + { DT_REG [ +regular-file+ ] } + { DT_WHT [ +whiteout+ ] } + [ drop +unknown+ ] + } case ; + +M: unix >directory-entry ( byte-array -- directory-entry ) + [ dirent-d_name utf8 alien>string ] + [ dirent-d_type dirent-type>file-type ] bi directory-entry boa ; + +M: unix (directory-entries) ( path -- seq ) + [ + '[ _ find-next-file dup ] + [ >directory-entry ] + [ drop ] produce + ] with-unix-directory ; diff --git a/basis/io/directories/windows/tags.txt b/basis/io/directories/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/directories/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/directories/windows/windows.factor b/basis/io/directories/windows/windows.factor new file mode 100755 index 0000000000..c2955d3977 --- /dev/null +++ b/basis/io/directories/windows/windows.factor @@ -0,0 +1,68 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: system io.directories io.encodings.utf16n alien.strings +io.pathnames io.backend io.files.windows destructors +kernel accessors calendar windows windows.errors +windows.kernel32 alien.c-types sequences splitting +fry continuations ; +IN: io.directories.windows + +M: windows touch-file ( path -- ) + [ + normalize-path + maybe-create-file [ &dispose ] dip + [ drop ] [ handle>> f now dup (set-file-times) ] if + ] with-destructors ; + +M: windows move-file ( from to -- ) + [ normalize-path ] bi@ MoveFile win32-error=0/f ; + +M: windows delete-file ( path -- ) + normalize-path DeleteFile win32-error=0/f ; + +M: windows copy-file ( from to -- ) + dup parent-directory make-directories + [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ; + +M: windows make-directory ( path -- ) + normalize-path + f CreateDirectory win32-error=0/f ; + +M: windows delete-directory ( path -- ) + normalize-path + RemoveDirectory win32-error=0/f ; + +: find-first-file ( path -- WIN32_FIND_DATA handle ) + "WIN32_FIND_DATA" tuck + FindFirstFile + [ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ; + +: find-next-file ( path -- WIN32_FIND_DATA/f ) + "WIN32_FIND_DATA" tuck + FindNextFile 0 = [ + GetLastError ERROR_NO_MORE_FILES = [ + win32-error + ] unless drop f + ] when ; + +TUPLE: windows-directory-entry < directory-entry attributes ; + +M: windows >directory-entry ( byte-array -- directory-entry ) + [ WIN32_FIND_DATA-cFileName utf16n alien>string ] + [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ] + [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ] + tri + dupd remove windows-directory-entry boa ; + +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 ; + diff --git a/basis/io/encodings/binary/authors.txt b/basis/io/encodings/binary/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/basis/io/encodings/binary/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/basis/io/encodings/binary/binary-docs.factor b/basis/io/encodings/binary/binary-docs.factor new file mode 100644 index 0000000000..4da1e0811f --- /dev/null +++ b/basis/io/encodings/binary/binary-docs.factor @@ -0,0 +1,11 @@ +USING: help.syntax help.markup ; +IN: io.encodings.binary + +HELP: binary +{ $class-description "Encoding descriptor for binary I/O." } ; + +ARTICLE: "io.encodings.binary" "Binary encoding" +"Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." +{ $subsection binary } ; + +ABOUT: "io.encodings.binary" diff --git a/basis/io/encodings/binary/binary.factor b/basis/io/encodings/binary/binary.factor new file mode 100644 index 0000000000..e54163f632 --- /dev/null +++ b/basis/io/encodings/binary/binary.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings kernel ; +IN: io.encodings.binary + +SINGLETON: binary +M: binary drop ; +M: binary drop ; diff --git a/basis/io/encodings/binary/summary.txt b/basis/io/encodings/binary/summary.txt new file mode 100644 index 0000000000..a1eb4bc664 --- /dev/null +++ b/basis/io/encodings/binary/summary.txt @@ -0,0 +1 @@ +Dummy encoding for binary I/O diff --git a/basis/io/encodings/binary/tags.txt b/basis/io/encodings/binary/tags.txt new file mode 100644 index 0000000000..8e27be7d61 --- /dev/null +++ b/basis/io/encodings/binary/tags.txt @@ -0,0 +1 @@ +text diff --git a/basis/io/files/info/authors.txt b/basis/io/files/info/authors.txt new file mode 100644 index 0000000000..f372b574ae --- /dev/null +++ b/basis/io/files/info/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Doug Coleman diff --git a/basis/io/files/info/info-docs.factor b/basis/io/files/info/info-docs.factor new file mode 100644 index 0000000000..8db780f976 --- /dev/null +++ b/basis/io/files/info/info-docs.factor @@ -0,0 +1,41 @@ +USING: help.markup help.syntax arrays io.files ; +IN: io.files.info + +HELP: file-info +{ $values { "path" "a pathname string" } { "info" file-info } } +{ $description "Queries the file system for metadata. If " { $snippet "path" } " refers to a symbolic link, it is followed. See the article " { $link "file-types" } " for a list of metadata symbols." } +{ $errors "Throws an error if the file does not exist." } ; + +HELP: link-info +{ $values { "path" "a pathname string" } { "info" "a file-info tuple" } } +{ $description "Queries the file system for metadata. If path refers to a symbolic link, information about the symbolic link itself is returned. If the file does not exist, an exception is thrown." } ; + +{ file-info link-info } related-words + +HELP: directory? +{ $values { "file-info" file-info } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "file-info" } " is a directory." } ; + +HELP: file-systems +{ $values { "array" array } } +{ $description "Returns an array of " { $link file-system-info } " objects returned by iterating the mount points and calling " { $link file-system-info } " on each." } ; + +HELP: file-system-info +{ $values +{ "path" "a pathname string" } +{ "file-system-info" file-system-info } } +{ $description "Returns a platform-specific object describing the file-system that contains the path. The cross-platform slot is " { $slot "free-space" } "." } ; + +ARTICLE: "io.files.info" "File system meta-data" +"File meta-data:" +{ $subsection file-info } +{ $subsection link-info } +{ $subsection exists? } +{ $subsection directory? } +"File types:" +{ $subsection "file-types" } +"File system meta-data:" +{ $subsection file-system-info } +{ $subsection file-systems } ; + +ABOUT: "io.files.info" diff --git a/basis/io/files/info/info-tests.factor b/basis/io/files/info/info-tests.factor new file mode 100644 index 0000000000..b94bc0635c --- /dev/null +++ b/basis/io/files/info/info-tests.factor @@ -0,0 +1,19 @@ +USING: io.files.info io.pathnames io.encodings.utf8 io.files +io.directories kernel io.pathnames accessors tools.test +sequences io.files.temp ; +IN: io.files.info.tests + +\ file-info must-infer +\ link-info must-infer + +[ t ] [ + temp-directory [ "hi41" "test41" utf8 set-file-contents ] with-directory + temp-directory "test41" append-path utf8 file-contents "hi41" = +] unit-test + +[ t ] [ + temp-directory [ "test41" file-info size>> ] with-directory 4 = +] unit-test + +[ t ] [ "/" file-system-info file-system-info? ] unit-test +[ t ] [ file-systems [ file-system-info? ] all? ] unit-test diff --git a/basis/io/files/info/info.factor b/basis/io/files/info/info.factor new file mode 100644 index 0000000000..fd21850612 --- /dev/null +++ b/basis/io/files/info/info.factor @@ -0,0 +1,28 @@ +! Copyright (C) 2008 Doug Coleman, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel system sequences combinators +vocabs.loader io.files.types ; +IN: io.files.info + +! File info +TUPLE: file-info type size permissions created modified +accessed ; + +HOOK: file-info os ( path -- info ) + +HOOK: link-info os ( path -- info ) + +: directory? ( file-info -- ? ) type>> +directory+ = ; + +! File systems +HOOK: file-systems os ( -- array ) + +TUPLE: file-system-info device-name mount-point type +available-space free-space used-space total-space ; + +HOOK: file-system-info os ( path -- file-system-info ) + +{ + { [ os unix? ] [ "io.files.info.unix." os name>> append ] } + { [ os windows? ] [ "io.files.info.windows" ] } +} cond require \ No newline at end of file diff --git a/basis/io/files/info/summary.txt b/basis/io/files/info/summary.txt new file mode 100644 index 0000000000..5d354fb573 --- /dev/null +++ b/basis/io/files/info/summary.txt @@ -0,0 +1 @@ +File and file system meta-data diff --git a/basis/io/files/info/unix/bsd/bsd.factor b/basis/io/files/info/unix/bsd/bsd.factor new file mode 100644 index 0000000000..6d0f3e7161 --- /dev/null +++ b/basis/io/files/info/unix/bsd/bsd.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel alien.syntax math io.files.unix system +unix.stat accessors combinators calendar.unix +io.files.info.unix ; +IN: io.files.info.unix.bsd + +TUPLE: bsd-file-info < unix-file-info birth-time flags gen ; + +M: bsd new-file-info ( -- class ) bsd-file-info new ; + +M: bsd stat>file-info ( stat -- file-info ) + [ call-next-method ] keep + { + [ stat-st_flags >>flags ] + [ stat-st_gen >>gen ] + [ + stat-st_birthtimespec timespec>unix-time + >>birth-time + ] + } cleave ; diff --git a/basis/io/files/info/unix/bsd/tags.txt b/basis/io/files/info/unix/bsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/files/info/unix/bsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/files/info/unix/freebsd/freebsd.factor b/basis/io/files/info/unix/freebsd/freebsd.factor new file mode 100644 index 0000000000..398e4ff968 --- /dev/null +++ b/basis/io/files/info/unix/freebsd/freebsd.factor @@ -0,0 +1,55 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types alien.syntax combinators +io.backend io.files io.files.info io.files.unix kernel math system unix +unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd +sequences grouping alien.strings io.encodings.utf8 +specialized-arrays.direct.uint arrays io.files.info.unix ; +IN: io.files.info.unix.freebsd + +TUPLE: freebsd-file-system-info < unix-file-system-info +version io-size owner syncreads syncwrites asyncreads asyncwrites ; + +M: freebsd new-file-system-info freebsd-file-system-info new ; + +M: freebsd file-system-statfs ( path -- byte-array ) + "statfs" tuck statfs io-error ; + +M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-info ) + { + [ statfs-f_version >>version ] + [ statfs-f_type >>type ] + [ statfs-f_flags >>flags ] + [ statfs-f_bsize >>block-size ] + [ statfs-f_iosize >>io-size ] + [ statfs-f_blocks >>blocks ] + [ statfs-f_bfree >>blocks-free ] + [ statfs-f_bavail >>blocks-available ] + [ statfs-f_files >>files ] + [ statfs-f_ffree >>files-free ] + [ statfs-f_syncwrites >>syncwrites ] + [ statfs-f_asyncwrites >>asyncwrites ] + [ statfs-f_syncreads >>syncreads ] + [ statfs-f_asyncreads >>asyncreads ] + [ statfs-f_namemax >>name-max ] + [ statfs-f_owner >>owner ] + [ statfs-f_fsid 2 >array >>id ] + [ statfs-f_fstypename utf8 alien>string >>type ] + [ statfs-f_mntfromname utf8 alien>string >>device-name ] + [ statfs-f_mntonname utf8 alien>string >>mount-point ] + } cleave ; + +M: freebsd file-system-statvfs ( path -- byte-array ) + "statvfs" tuck statvfs io-error ; + +M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info ) + { + [ statvfs-f_favail >>files-available ] + [ statvfs-f_frsize >>preferred-block-size ] + } cleave ; + +M: freebsd file-systems ( -- array ) + f 0 0 getfsstat dup io-error + "statfs" dup dup length 0 getfsstat io-error + "statfs" heap-size group + [ statfs-f_mntonname alien>native-string file-system-info ] map ; diff --git a/basis/io/files/info/unix/freebsd/tags.txt b/basis/io/files/info/unix/freebsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/files/info/unix/freebsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor new file mode 100644 index 0000000000..ee4a1ed91f --- /dev/null +++ b/basis/io/files/info/unix/linux/linux.factor @@ -0,0 +1,90 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types alien.syntax combinators csv +io.backend io.encodings.utf8 io.files io.files.info io.streams.string +io.files.unix kernel math.order namespaces sequences sorting +system unix unix.statfs.linux unix.statvfs.linux +specialized-arrays.direct.uint arrays io.files.info.unix ; +IN: io.files.info.unix.linux + +TUPLE: linux-file-system-info < unix-file-system-info +namelen ; + +M: linux new-file-system-info linux-file-system-info new ; + +M: linux file-system-statfs ( path -- byte-array ) + "statfs64" tuck statfs64 io-error ; + +M: linux statfs>file-system-info ( struct -- statfs ) + { + [ statfs64-f_type >>type ] + [ statfs64-f_bsize >>block-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 2 >array >>id ] + [ statfs64-f_namelen >>namelen ] + [ statfs64-f_frsize >>preferred-block-size ] + ! [ statfs64-f_spare >>spare ] + } cleave ; + +M: linux file-system-statvfs ( path -- byte-array ) + "statvfs64" tuck statvfs64 io-error ; + +M: linux statvfs>file-system-info ( struct -- statfs ) + { + [ statvfs64-f_flag >>flags ] + [ statvfs64-f_namemax >>name-max ] + } cleave ; + +TUPLE: mtab-entry file-system-name mount-point type options +frequency pass-number ; + +: mtab-csv>mtab-entry ( csv -- mtab-entry ) + [ mtab-entry new ] dip + { + [ first >>file-system-name ] + [ second >>mount-point ] + [ third >>type ] + [ fourth csv first >>options ] + [ 4 swap nth >>frequency ] + [ 5 swap nth >>pass-number ] + } cleave ; + +: parse-mtab ( -- array ) + [ + "/etc/mtab" utf8 + CHAR: \s delimiter set csv + ] with-scope + [ mtab-csv>mtab-entry ] map ; + +M: linux file-systems + parse-mtab [ + [ mount-point>> file-system-info ] keep + { + [ file-system-name>> >>device-name ] + [ mount-point>> >>mount-point ] + [ type>> >>type ] + } cleave + ] map ; + +ERROR: file-system-not-found ; + +M: linux file-system-info ( path -- ) + normalize-path + [ + [ new-file-system-info ] dip + [ file-system-statfs statfs>file-system-info ] + [ file-system-statvfs statvfs>file-system-info ] bi + file-system-calculations + ] keep + + parse-mtab [ [ mount-point>> ] bi@ <=> invert-comparison ] sort + [ mount-point>> head? ] with find nip [ file-system-not-found ] unless* + { + [ file-system-name>> >>device-name drop ] + [ mount-point>> >>mount-point drop ] + [ type>> >>type ] + } 2cleave ; diff --git a/basis/io/files/info/unix/linux/tags.txt b/basis/io/files/info/unix/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/files/info/unix/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/files/info/unix/macosx/macosx.factor b/basis/io/files/info/unix/macosx/macosx.factor new file mode 100644 index 0000000000..53992bcb95 --- /dev/null +++ b/basis/io/files/info/unix/macosx/macosx.factor @@ -0,0 +1,52 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types alien.strings combinators +grouping io.encodings.utf8 io.files kernel math sequences +system unix io.files.unix specialized-arrays.direct.uint arrays +unix.statfs.macosx unix.statvfs.macosx unix.getfsstat.macosx +io.files.info.unix io.files.info ; +IN: io.files.info.unix.macosx + +TUPLE: macosx-file-system-info < unix-file-system-info +io-size owner type-id filesystem-subtype ; + +M: macosx file-systems ( -- array ) + f dup 0 getmntinfo64 dup io-error + [ *void* ] dip + "statfs64" heap-size [ * memory>byte-array ] keep group + [ statfs64-f_mntonname utf8 alien>string file-system-info ] map ; + ! [ [ new-file-system-info ] dip statfs>file-system-info ] map ; + +M: macosx new-file-system-info macosx-file-system-info new ; + +M: macosx file-system-statfs ( normalized-path -- statfs ) + "statfs64" tuck statfs64 io-error ; + +M: macosx file-system-statvfs ( normalized-path -- statvfs ) + "statvfs" tuck statvfs io-error ; + +M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' ) + { + [ 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 2 >array >>id ] + [ statfs64-f_owner >>owner ] + [ statfs64-f_type >>type-id ] + [ statfs64-f_flags >>flags ] + [ statfs64-f_fssubtype >>filesystem-subtype ] + [ statfs64-f_fstypename utf8 alien>string >>type ] + [ statfs64-f_mntonname utf8 alien>string >>mount-point ] + [ statfs64-f_mntfromname utf8 alien>string >>device-name ] + } cleave ; + +M: macosx statvfs>file-system-info ( file-system-info byte-array -- file-system-info' ) + { + [ statvfs-f_frsize >>preferred-block-size ] + [ statvfs-f_favail >>files-available ] + [ statvfs-f_namemax >>name-max ] + } cleave ; diff --git a/basis/io/files/info/unix/macosx/tags.txt b/basis/io/files/info/unix/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/files/info/unix/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/files/info/unix/netbsd/netbsd.factor b/basis/io/files/info/unix/netbsd/netbsd.factor new file mode 100644 index 0000000000..6dc0bb3f87 --- /dev/null +++ b/basis/io/files/info/unix/netbsd/netbsd.factor @@ -0,0 +1,53 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel unix.stat math unix +combinators system io.backend accessors alien.c-types +io.encodings.utf8 alien.strings unix.types io.files.unix +io.files io.files.info unix.statvfs.netbsd unix.getfsstat.netbsd arrays +grouping sequences io.encodings.utf8 +specialized-arrays.direct.uint io.files.info.unix ; +IN: io.files.info.unix.netbsd + +TUPLE: netbsd-file-system-info < unix-file-system-info +blocks-reserved files-reserved +owner io-size sync-reads sync-writes async-reads async-writes +idx mount-from ; + +M: netbsd new-file-system-info netbsd-file-system-info new ; + +M: netbsd file-system-statvfs + "statvfs" tuck statvfs io-error ; + +M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' ) + { + [ statvfs-f_flag >>flags ] + [ statvfs-f_bsize >>block-size ] + [ statvfs-f_frsize >>preferred-block-size ] + [ statvfs-f_iosize >>io-size ] + [ statvfs-f_blocks >>blocks ] + [ statvfs-f_bfree >>blocks-free ] + [ statvfs-f_bavail >>blocks-available ] + [ statvfs-f_bresvd >>blocks-reserved ] + [ statvfs-f_files >>files ] + [ statvfs-f_ffree >>files-free ] + [ statvfs-f_favail >>files-available ] + [ statvfs-f_fresvd >>files-reserved ] + [ statvfs-f_syncreads >>sync-reads ] + [ statvfs-f_syncwrites >>sync-writes ] + [ statvfs-f_asyncreads >>async-reads ] + [ statvfs-f_asyncwrites >>async-writes ] + [ statvfs-f_fsidx 2 >array >>idx ] + [ statvfs-f_fsid >>id ] + [ statvfs-f_namemax >>name-max ] + [ statvfs-f_owner >>owner ] + ! [ statvfs-f_spare >>spare ] + [ statvfs-f_fstypename utf8 alien>string >>type ] + [ statvfs-f_mntonname utf8 alien>string >>mount-point ] + [ statvfs-f_mntfromname utf8 alien>string >>device-name ] + } cleave ; + +M: netbsd file-systems ( -- array ) + f 0 0 getvfsstat dup io-error + "statvfs" dup dup length 0 getvfsstat io-error + "statvfs" heap-size group + [ statvfs-f_mntonname utf8 alien>string file-system-info ] map ; diff --git a/basis/io/files/info/unix/netbsd/tags.txt b/basis/io/files/info/unix/netbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/files/info/unix/netbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/files/info/unix/openbsd/openbsd.factor b/basis/io/files/info/unix/openbsd/openbsd.factor new file mode 100644 index 0000000000..62783a968b --- /dev/null +++ b/basis/io/files/info/unix/openbsd/openbsd.factor @@ -0,0 +1,55 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types alien.strings alien.syntax +combinators io.backend io.files io.files.info io.files.unix kernel math +sequences system unix unix.getfsstat.openbsd grouping +unix.statfs.openbsd unix.statvfs.openbsd unix.types +specialized-arrays.direct.uint arrays io.files.info.unix ; +IN: io.files.unix.openbsd + +TUPLE: freebsd-file-system-info < unix-file-system-info +io-size sync-writes sync-reads async-writes async-reads +owner ; + +M: openbsd new-file-system-info freebsd-file-system-info new ; + +M: openbsd file-system-statfs + "statfs" tuck statfs io-error ; + +M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info' ) + { + [ statfs-f_flags >>flags ] + [ statfs-f_bsize >>block-size ] + [ statfs-f_iosize >>io-size ] + [ statfs-f_blocks >>blocks ] + [ statfs-f_bfree >>blocks-free ] + [ statfs-f_bavail >>blocks-available ] + [ statfs-f_files >>files ] + [ statfs-f_ffree >>files-free ] + [ statfs-f_favail >>files-available ] + [ statfs-f_syncwrites >>sync-writes ] + [ statfs-f_syncreads >>sync-reads ] + [ statfs-f_asyncwrites >>async-writes ] + [ statfs-f_asyncreads >>async-reads ] + [ statfs-f_fsid 2 >array >>id ] + [ statfs-f_namemax >>name-max ] + [ statfs-f_owner >>owner ] + ! [ statfs-f_spare >>spare ] + [ statfs-f_fstypename alien>native-string >>type ] + [ statfs-f_mntonname alien>native-string >>mount-point ] + [ statfs-f_mntfromname alien>native-string >>device-name ] + } cleave ; + +M: openbsd file-system-statvfs ( normalized-path -- statvfs ) + "statvfs" tuck statvfs io-error ; + +M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' ) + { + [ statvfs-f_frsize >>preferred-block-size ] + } cleave ; + +M: openbsd file-systems ( -- seq ) + f 0 0 getfsstat dup io-error + "statfs" dup dup length 0 getfsstat io-error + "statfs" heap-size group + [ statfs-f_mntonname alien>native-string file-system-info ] map ; diff --git a/basis/io/files/info/unix/openbsd/tags.txt b/basis/io/files/info/unix/openbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/files/info/unix/openbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/files/info/unix/unix-docs.factor b/basis/io/files/info/unix/unix-docs.factor new file mode 100644 index 0000000000..0dff2e4419 --- /dev/null +++ b/basis/io/files/info/unix/unix-docs.factor @@ -0,0 +1,277 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: classes help.markup help.syntax io.streams.string +strings math calendar io.files.info io.files.info.unix ; +IN: io.files.unix + +HELP: file-group-id +{ $values + { "path" "a pathname string" } + { "gid" integer } } +{ $description "Returns the group id for a given file." } ; + +HELP: file-group-name +{ $values + { "path" "a pathname string" } + { "string" string } } +{ $description "Returns the group name for a given file." } ; + +HELP: file-permissions +{ $values + { "path" "a pathname string" } + { "n" integer } } +{ $description "Returns the Unix file permissions for a given file." } ; + +HELP: file-username +{ $values + { "path" "a pathname string" } + { "string" string } } +{ $description "Returns the username for a given file." } ; + +HELP: file-user-id +{ $values + { "path" "a pathname string" } + { "uid" integer } } +{ $description "Returns the user id for a given file." } ; + +HELP: group-execute? +{ $values + { "obj" "a pathname string or an integer" } + { "?" "a boolean" } } +{ $description "Tests whether the " { $snippet "group execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ; + +HELP: group-read? +{ $values + { "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, " { $link file-info } ", or an integer." } ; + +HELP: group-write? +{ $values + { "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, " { $link file-info } ", or an integer." } ; + +HELP: other-execute? +{ $values + { "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, " { $link file-info } ", or an integer." } ; + +HELP: other-read? +{ $values + { "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, " { $link file-info } ", or an integer." } ; + +HELP: other-write? +{ $values + { "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, " { $link file-info } ", or an integer." } ; + +HELP: set-file-access-time +{ $values + { "path" "a pathname string" } { "timestamp" timestamp } } +{ $description "Sets a file's last access timestamp." } ; + +HELP: set-file-group +{ $values + { "path" "a pathname string" } { "string/id" "a string or a group id" } } +{ $description "Sets a file's group id from the given group id or group name." } ; + +HELP: set-file-ids +{ $values + { "path" "a pathname string" } { "uid" integer } { "gid" integer } } +{ $description "Sets the user id and group id of a file with a single library call." } ; + +HELP: set-file-permissions +{ $values + { "path" "a pathname string" } { "n" "an integer, interepreted as a string of bits" } } +{ $description "Sets the file permissions for a given file with the supplied Unix permissions integer. Supplying an octal number with " { $link POSTPONE: OCT: } " is recommended." } +{ $examples "Using the tradidional octal value:" + { $unchecked-example "USING: io.files.unix kernel ;" + "\"resource:license.txt\" OCT: 755 set-file-permissions" + "" + } + "Higher-level, setting named bits:" + { $unchecked-example "USING: io.files.unix kernel math.bitwise ;" + "\"resource:license.txt\"" + "{ USER-ALL GROUP-READ GROUP-EXECUTE OTHER-READ OTHER-EXECUTE }" + "flags set-file-permissions" + "" } +} ; + +HELP: set-file-times +{ $values + { "path" "a pathname string" } { "timestamps" "an array of two timestamps" } } +{ $description "Sets the access and write timestamps for a file as provided in the input array. A value of " { $link f } " provided for either of the timestamps will not change that timestamp." } ; + +HELP: set-file-user +{ $values + { "path" "a pathname string" } { "string/id" "a string or a user id" } } +{ $description "Sets a file's user id from the given user id or username." } ; + +HELP: set-file-modified-time +{ $values + { "path" "a pathname string" } { "timestamp" timestamp } } +{ $description "Sets a file's last modified timestamp, or write timestamp." } ; + +HELP: set-gid +{ $values + { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Sets the " { $snippet "gid" } " bit of a file to true or false." } ; + +HELP: gid? +{ $values + { "obj" "a pathname string, file-info object, or an integer" } + { "?" "a boolean" } } +{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file, " { $link file-info } ", or an integer." } ; + +HELP: set-group-execute +{ $values + { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Sets the " { $snippet "group execute" } " bit of a file to true or false." } ; + +HELP: set-group-read +{ $values + { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Sets the " { $snippet "group read" } " bit of a file to true or false." } ; + +HELP: set-group-write +{ $values + { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Sets the " { $snippet "group write" } " bit of a file to true or false." } ; + +HELP: set-other-execute +{ $values + { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Sets the " { $snippet "other execute" } " bit of a file to true or false." } ; + +HELP: set-other-read +{ $values + { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Sets the " { $snippet "other read" } " bit of a file to true or false." } ; + +HELP: set-other-write +{ $values + { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Sets the " { $snippet "other execute" } " bit of a file to true or false." } ; + +HELP: set-sticky +{ $values + { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Sets the " { $snippet "sticky" } " bit of a file to true or false." } ; + +HELP: sticky? +{ $values + { "obj" "a pathname string, file-info object, or an integer" } + { "?" "a boolean" } } +{ $description "Tests whether the " { $snippet "sticky" } " bit is set on a file, " { $link file-info } ", or an integer." } ; + +HELP: set-uid +{ $values + { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Sets the " { $snippet "uid" } " bit of a file to true or false." } ; + +HELP: uid? +{ $values + { "obj" "a pathname string, file-info object, or an integer" } + { "?" "a boolean" } } +{ $description "Tests whether the " { $snippet "uid" } " bit is set on a file, " { $link file-info } ", or an integer." } ; + +HELP: set-user-execute +{ $values + { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Sets the " { $snippet "user execute" } " bit of a file to true or false." } ; + +HELP: set-user-read +{ $values + { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Sets the " { $snippet "user read" } " bit of a file to true or false." } ; + +HELP: set-user-write +{ $values + { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Sets the " { $snippet "user write" } " bit of a file to true or false." } ; + +HELP: user-execute? +{ $values + { "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, " { $link file-info } ", or an integer." } ; + +HELP: user-read? +{ $values + { "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, " { $link file-info } ", or an integer." } ; + +HELP: user-write? +{ $values + { "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, " { $link file-info } ", or an integer." } ; + +ARTICLE: "unix-file-permissions" "Unix file permissions" +"Reading all file permissions:" +{ $subsection file-permissions } +"Reading individual file permissions:" +{ $subsection uid? } +{ $subsection gid? } +{ $subsection sticky? } +{ $subsection user-read? } +{ $subsection user-write? } +{ $subsection user-execute? } +{ $subsection group-read? } +{ $subsection group-write? } +{ $subsection group-execute? } +{ $subsection other-read? } +{ $subsection other-write? } +{ $subsection other-execute? } +"Writing all file permissions:" +{ $subsection set-file-permissions } +"Writing individual file permissions:" +{ $subsection set-uid } +{ $subsection set-gid } +{ $subsection set-sticky } +{ $subsection set-user-read } +{ $subsection set-user-write } +{ $subsection set-user-execute } +{ $subsection set-group-read } +{ $subsection set-group-write } +{ $subsection set-group-execute } +{ $subsection set-other-read } +{ $subsection set-other-write } +{ $subsection set-other-execute } ; + +ARTICLE: "unix-file-timestamps" "Unix file timestamps" +"To read file times, use the accessors on the object returned by the " { $link file-info } " word." $nl +"Setting multiple file times:" +{ $subsection set-file-times } +"Setting just the last access time:" +{ $subsection set-file-access-time } +"Setting just the last modified time:" +{ $subsection set-file-modified-time } ; + + +ARTICLE: "unix-file-ids" "Unix file user and group ids" +"Reading file user data:" +{ $subsection file-user-id } +{ $subsection file-username } +"Setting file user data:" +{ $subsection set-file-user } +"Reading file group data:" +{ $subsection file-group-id } +{ $subsection file-group-name } +"Setting file group data:" +{ $subsection set-file-group } ; + + +ARTICLE: "io.files.info.unix" "Unix file attributes" +"The " { $vocab-link "io.files.info.unix" } " vocabulary implements a high-level way to set Unix-specific permissions, timestamps, and user and group IDs for files." +{ $subsection "unix-file-permissions" } +{ $subsection "unix-file-timestamps" } +{ $subsection "unix-file-ids" } ; + +ABOUT: "io.files.info.unix" diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor new file mode 100644 index 0000000000..66b95db144 --- /dev/null +++ b/basis/io/files/info/unix/unix.factor @@ -0,0 +1,253 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel system math math.bitwise strings arrays +sequences combinators combinators.short-circuit alien.c-types +vocabs.loader calendar calendar.unix io.files.info +io.files.types io.backend unix unix.stat unix.time unix.users +unix.groups ; +IN: io.files.info.unix + +TUPLE: unix-file-system-info < file-system-info +block-size preferred-block-size +blocks blocks-free blocks-available +files files-free files-available +name-max flags id ; + +HOOK: new-file-system-info os ( -- file-system-info ) + +M: unix new-file-system-info ( -- ) unix-file-system-info new ; + +HOOK: file-system-statfs os ( path -- statfs ) + +M: unix file-system-statfs drop f ; + +HOOK: file-system-statvfs os ( path -- statvfs ) + +M: unix file-system-statvfs drop f ; + +HOOK: statfs>file-system-info os ( file-system-info statfs -- file-system-info' ) + +M: unix statfs>file-system-info drop ; + +HOOK: statvfs>file-system-info os ( file-system-info statvfs -- file-system-info' ) + +M: unix statvfs>file-system-info drop ; + +: file-system-calculations ( file-system-info -- file-system-info' ) + dup [ blocks-available>> ] [ block-size>> ] bi * >>available-space + dup [ blocks-free>> ] [ block-size>> ] bi * >>free-space + dup [ blocks>> ] [ block-size>> ] bi * >>total-space + dup [ total-space>> ] [ free-space>> ] bi - >>used-space ; + +M: unix file-system-info + normalize-path + [ new-file-system-info ] dip + [ file-system-statfs statfs>file-system-info ] + [ file-system-statvfs statvfs>file-system-info ] bi + file-system-calculations ; + +TUPLE: unix-file-info < file-info uid gid dev ino +nlink rdev blocks blocksize ; + +HOOK: new-file-info os ( -- file-info ) + +HOOK: stat>file-info os ( stat -- file-info ) + +HOOK: stat>type os ( stat -- file-info ) + +M: unix file-info ( path -- info ) + normalize-path file-status stat>file-info ; + +M: unix link-info ( path -- info ) + normalize-path link-status stat>file-info ; + +M: unix new-file-info ( -- class ) unix-file-info new ; + +M: unix stat>file-info ( stat -- file-info ) + [ new-file-info ] dip + { + [ stat>type >>type ] + [ stat-st_size >>size ] + [ stat-st_mode >>permissions ] + [ stat-st_ctimespec timespec>unix-time >>created ] + [ stat-st_mtimespec timespec>unix-time >>modified ] + [ stat-st_atimespec timespec>unix-time >>accessed ] + [ stat-st_uid >>uid ] + [ stat-st_gid >>gid ] + [ stat-st_dev >>dev ] + [ stat-st_ino >>ino ] + [ stat-st_nlink >>nlink ] + [ stat-st_rdev >>rdev ] + [ stat-st_blocks >>blocks ] + [ stat-st_blksize >>blocksize ] + } cleave ; + +: n>file-type ( n -- type ) + S_IFMT bitand { + { S_IFREG [ +regular-file+ ] } + { S_IFDIR [ +directory+ ] } + { S_IFCHR [ +character-device+ ] } + { S_IFBLK [ +block-device+ ] } + { S_IFIFO [ +fifo+ ] } + { S_IFLNK [ +symbolic-link+ ] } + { S_IFSOCK [ +socket+ ] } + [ drop +unknown+ ] + } case ; + +M: unix stat>type ( stat -- type ) + stat-st_mode n>file-type ; + +> ] dip mask? ; + +PRIVATE> + +: ch>file-type ( ch -- type ) + { + { CHAR: b [ +block-device+ ] } + { CHAR: c [ +character-device+ ] } + { CHAR: d [ +directory+ ] } + { CHAR: l [ +symbolic-link+ ] } + { CHAR: s [ +socket+ ] } + { CHAR: p [ +fifo+ ] } + { CHAR: - [ +regular-file+ ] } + [ drop +unknown+ ] + } case ; + +: file-type>ch ( type -- string ) + { + { +block-device+ [ CHAR: b ] } + { +character-device+ [ CHAR: c ] } + { +directory+ [ CHAR: d ] } + { +symbolic-link+ [ CHAR: l ] } + { +socket+ [ CHAR: s ] } + { +fifo+ [ CHAR: p ] } + { +regular-file+ [ CHAR: - ] } + [ drop CHAR: - ] + } case ; + +: UID OCT: 0004000 ; inline +: GID OCT: 0002000 ; inline +: STICKY OCT: 0001000 ; inline +: USER-ALL OCT: 0000700 ; inline +: USER-READ OCT: 0000400 ; inline +: USER-WRITE OCT: 0000200 ; inline +: USER-EXECUTE OCT: 0000100 ; inline +: GROUP-ALL OCT: 0000070 ; inline +: GROUP-READ OCT: 0000040 ; inline +: GROUP-WRITE OCT: 0000020 ; inline +: GROUP-EXECUTE OCT: 0000010 ; inline +: OTHER-ALL OCT: 0000007 ; inline +: OTHER-READ OCT: 0000004 ; inline +: OTHER-WRITE OCT: 0000002 ; inline +: OTHER-EXECUTE OCT: 0000001 ; inline + +: uid? ( obj -- ? ) UID file-mode? ; +: gid? ( obj -- ? ) GID file-mode? ; +: sticky? ( obj -- ? ) STICKY file-mode? ; +: user-read? ( obj -- ? ) USER-READ file-mode? ; +: user-write? ( obj -- ? ) USER-WRITE file-mode? ; +: user-execute? ( obj -- ? ) USER-EXECUTE file-mode? ; +: group-read? ( obj -- ? ) GROUP-READ file-mode? ; +: group-write? ( obj -- ? ) GROUP-WRITE file-mode? ; +: group-execute? ( obj -- ? ) GROUP-EXECUTE file-mode? ; +: other-read? ( obj -- ? ) OTHER-READ file-mode? ; +: other-write? ( obj -- ? ) OTHER-WRITE file-mode? ; +: other-execute? ( obj -- ? ) OTHER-EXECUTE file-mode? ; + +: any-read? ( obj -- ? ) + { [ user-read? ] [ group-read? ] [ other-read? ] } 1|| ; + +: any-write? ( obj -- ? ) + { [ user-write? ] [ group-write? ] [ other-write? ] } 1|| ; + +: any-execute? ( obj -- ? ) + { [ user-execute? ] [ group-execute? ] [ other-execute? ] } 1|| ; + +: set-uid ( path ? -- ) UID swap chmod-set-bit ; +: set-gid ( path ? -- ) GID swap chmod-set-bit ; +: set-sticky ( path ? -- ) STICKY swap chmod-set-bit ; +: set-user-read ( path ? -- ) USER-READ swap chmod-set-bit ; +: set-user-write ( path ? -- ) USER-WRITE swap chmod-set-bit ; +: set-user-execute ( path ? -- ) USER-EXECUTE swap chmod-set-bit ; +: set-group-read ( path ? -- ) GROUP-READ swap chmod-set-bit ; +: set-group-write ( path ? -- ) GROUP-WRITE swap chmod-set-bit ; +: set-group-execute ( path ? -- ) GROUP-EXECUTE swap chmod-set-bit ; +: set-other-read ( path ? -- ) OTHER-READ swap chmod-set-bit ; +: set-other-write ( path ? -- ) OTHER-WRITE swap chmod-set-bit ; +: set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ; + +: set-file-permissions ( path n -- ) + [ normalize-path ] dip chmod io-error ; + +: file-permissions ( path -- n ) + normalize-path file-info permissions>> ; + + ] unless* ] map concat ; + +: timestamp>timeval ( timestamp -- timeval ) + unix-1970 time- duration>microseconds make-timeval ; + +: timestamps>byte-array ( timestamps -- byte-array ) + [ dup [ timestamp>timeval ] when ] map make-timeval-array ; + +PRIVATE> + +: set-file-times ( path timestamps -- ) + #! set access, write + [ normalize-path ] dip + timestamps>byte-array utimes io-error ; + +: set-file-access-time ( path timestamp -- ) + f 2array set-file-times ; + +: set-file-modified-time ( path timestamp -- ) + f swap 2array set-file-times ; + +: set-file-ids ( path uid gid -- ) + [ normalize-path ] 2dip + [ [ -1 ] unless* ] bi@ chown io-error ; + +GENERIC: set-file-user ( path string/id -- ) + +GENERIC: set-file-group ( path string/id -- ) + +M: integer set-file-user ( path uid -- ) + f set-file-ids ; + +M: string set-file-user ( path string -- ) + user-id f set-file-ids ; + +M: integer set-file-group ( path gid -- ) + f swap set-file-ids ; + +M: string set-file-group ( path string -- ) + group-id + f swap set-file-ids ; + +: file-user-id ( path -- uid ) + normalize-path file-info uid>> ; + +: file-username ( path -- string ) + file-user-id username ; + +: file-group-id ( path -- gid ) + normalize-path file-info gid>> ; + +: file-group-name ( path -- string ) + file-group-id group-name ; diff --git a/basis/io/files/info/windows/tags.txt b/basis/io/files/info/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/files/info/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor new file mode 100755 index 0000000000..aecf42d9a2 --- /dev/null +++ b/basis/io/files/info/windows/windows.factor @@ -0,0 +1,204 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: byte-arrays math io.backend io.files.info +io.files.windows io.files.windows.nt kernel windows.kernel32 +windows.time windows accessors alien.c-types combinators +generalizations system alien.strings io.encodings.utf16n +sequences splitting windows.errors fry continuations destructors +calendar ascii combinators.short-circuit ; +IN: io.files.info.windows + +TUPLE: windows-file-info < file-info attributes ; + +: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info ) + [ \ windows-file-info new ] dip + { + [ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ] + [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes >>attributes ] + [ + [ WIN32_FIND_DATA-nFileSizeLow ] + [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size + ] + [ WIN32_FIND_DATA-dwFileAttributes >>permissions ] + [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp >>created ] + [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp >>modified ] + [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp >>accessed ] + } cleave ; + +: find-first-file-stat ( path -- WIN32_FIND_DATA ) + "WIN32_FIND_DATA" [ + FindFirstFile + [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep + FindClose win32-error=0/f + ] keep ; + +: BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info ) + [ \ windows-file-info new ] dip + { + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ] + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes >>attributes ] + [ + [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ] + [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size + ] + [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes >>permissions ] + [ + BY_HANDLE_FILE_INFORMATION-ftCreationTime + FILETIME>timestamp >>created + ] + [ + BY_HANDLE_FILE_INFORMATION-ftLastWriteTime + FILETIME>timestamp >>modified + ] + [ + BY_HANDLE_FILE_INFORMATION-ftLastAccessTime + FILETIME>timestamp >>accessed + ] + ! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ] + ! [ + ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ] + ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit + ! ] + } cleave ; + +: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION ) + [ + "BY_HANDLE_FILE_INFORMATION" + [ GetFileInformationByHandle win32-error=0/f ] keep + ] keep CloseHandle win32-error=0/f ; + +: get-file-information-stat ( path -- BY_HANDLE_FILE_INFORMATION ) + dup + GENERIC_READ FILE_SHARE_READ f + OPEN_EXISTING FILE_FLAG_BACKUP_SEMANTICS f + CreateFileW dup INVALID_HANDLE_VALUE = [ + drop find-first-file-stat WIN32_FIND_DATA>file-info + ] [ + nip + get-file-information BY_HANDLE_FILE_INFORMATION>file-info + ] if ; + +M: windows file-info ( path -- info ) + normalize-path get-file-information-stat ; + +M: windows link-info ( path -- info ) + file-info ; + +: volume-information ( normalized-path -- volume-name volume-serial max-component flags type ) + MAX_PATH 1+ [ ] keep + "DWORD" + "DWORD" + "DWORD" + MAX_PATH 1+ [ ] keep + [ GetVolumeInformation win32-error=0/f ] 7 nkeep + drop 5 nrot drop + [ utf16n alien>string ] 4 ndip + utf16n alien>string ; + +: file-system-space ( normalized-path -- available-space total-space free-space ) + "ULARGE_INTEGER" + "ULARGE_INTEGER" + "ULARGE_INTEGER" + [ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ; + +: calculate-file-system-info ( file-system-info -- file-system-info' ) + { + [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ] + [ ] + } cleave ; + +TUPLE: win32-file-system-info < file-system-info max-component flags device-serial ; + +ERROR: not-absolute-path ; + +: root-directory ( string -- string' ) + unicode-prefix ?head drop + dup { + [ length 2 >= ] + [ second CHAR: : = ] + [ first Letter? ] + } 1&& [ 2 head "\\" append ] [ not-absolute-path ] if ; + +M: winnt file-system-info ( path -- file-system-info ) + normalize-path root-directory + dup [ volume-information ] [ file-system-space ] bi + \ win32-file-system-info new + swap *ulonglong >>free-space + swap *ulonglong >>total-space + swap *ulonglong >>available-space + swap >>type + swap *uint >>flags + swap *uint >>max-component + swap *uint >>device-serial + swap >>device-name + swap >>mount-point + calculate-file-system-info ; + +: volume>paths ( string -- array ) + 16384 "ushort" tuck dup length + 0 dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [ + win32-error-string throw + ] [ + *uint "ushort" heap-size * head + utf16n alien>string CHAR: \0 split + ] if ; + +: find-first-volume ( -- string handle ) + MAX_PATH 1+ [ ] keep + dupd + FindFirstVolume dup win32-error=0/f + [ utf16n alien>string ] dip ; + +: find-next-volume ( handle -- string/f ) + MAX_PATH 1+ [ tuck ] keep + FindNextVolume 0 = [ + GetLastError ERROR_NO_MORE_FILES = + [ drop f ] [ win32-error-string throw ] if + ] [ + utf16n alien>string + ] if ; + +: find-volumes ( -- array ) + find-first-volume + [ + '[ + [ _ find-next-volume dup ] + [ ] + [ drop ] produce + swap prefix + ] + ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ; + +M: winnt file-systems ( -- array ) + find-volumes [ volume>paths ] map + concat [ + [ file-system-info ] + [ drop \ file-system-info new swap >>mount-point ] recover + ] map ; + +: file-times ( path -- timestamp timestamp timestamp ) + [ + normalize-path open-existing &dispose handle>> + "FILETIME" + "FILETIME" + "FILETIME" + [ GetFileTime win32-error=0/f ] 3keep + [ FILETIME>timestamp >local-time ] tri@ + ] with-destructors ; + +: set-file-times ( path timestamp/f timestamp/f timestamp/f -- ) + #! timestamp order: creation access write + [ + [ + normalize-path open-existing &dispose handle>> + ] 3dip (set-file-times) + ] with-destructors ; + +: set-file-create-time ( path timestamp -- ) + f f set-file-times ; + +: set-file-access-time ( path timestamp -- ) + [ f ] dip f set-file-times ; + +: set-file-write-time ( path timestamp -- ) + [ f f ] dip set-file-times ; diff --git a/basis/io/files/links/authors.txt b/basis/io/files/links/authors.txt new file mode 100644 index 0000000000..f372b574ae --- /dev/null +++ b/basis/io/files/links/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Doug Coleman diff --git a/basis/io/files/links/links-docs.factor b/basis/io/files/links/links-docs.factor new file mode 100644 index 0000000000..0e9a375da3 --- /dev/null +++ b/basis/io/files/links/links-docs.factor @@ -0,0 +1,27 @@ +USING: help.markup help.syntax io.files.info ; +IN: io.files.links + +HELP: make-link +{ $values { "target" "a path to the symbolic link's target" } { "symlink" "a path to new symbolic link" } } +{ $description "Creates a symbolic link." } ; + +HELP: read-link +{ $values { "symlink" "a path to an existing symbolic link" } { "path" "the path pointed to by the symbolic link" } } +{ $description "Reads the symbolic link and returns its target path." } ; + +HELP: copy-link +{ $values { "target" "a path to an existing symlink" } { "symlink" "a path to a new symbolic link" } } +{ $description "Copies a symbolic link without following the link." } ; + +{ make-link read-link copy-link } related-words + +ARTICLE: "io.files.links" "Symbolic links" +"Reading and creating links:" +{ $subsection read-link } +{ $subsection make-link } +"Copying links:" +{ $subsection copy-link } +"Not all operating systems support symbolic links." +{ $see-also link-info } ; + +ABOUT: "io.files.links" diff --git a/basis/io/files/links/links.factor b/basis/io/files/links/links.factor new file mode 100644 index 0000000000..02e1a1b078 --- /dev/null +++ b/basis/io/files/links/links.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: system kernel vocabs.loader ; +IN: io.files.links + +HOOK: make-link os ( target symlink -- ) + +HOOK: read-link os ( symlink -- path ) + +: copy-link ( target symlink -- ) + [ read-link ] dip make-link ; + +os unix? [ "io.files.links.unix" require ] when \ No newline at end of file diff --git a/basis/io/files/links/summary.txt b/basis/io/files/links/summary.txt new file mode 100644 index 0000000000..6f5e4598db --- /dev/null +++ b/basis/io/files/links/summary.txt @@ -0,0 +1 @@ +Working with symbolic links diff --git a/basis/io/files/links/unix/unix.factor b/basis/io/files/links/unix/unix.factor new file mode 100644 index 0000000000..69b31c6874 --- /dev/null +++ b/basis/io/files/links/unix/unix.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.backend io.files.links system unix ; +IN: io.files.links.unix + +M: unix make-link ( path1 path2 -- ) + normalize-path symlink io-error ; + +M: unix read-link ( path -- path' ) + normalize-path read-symbolic-link ; diff --git a/basis/io/files/temp/temp-docs.factor b/basis/io/files/temp/temp-docs.factor new file mode 100644 index 0000000000..e9f49283de --- /dev/null +++ b/basis/io/files/temp/temp-docs.factor @@ -0,0 +1,9 @@ +USING: help.markup help.syntax ; +IN: io.files.temp + +ARTICLE: "io.files.temp" "Temporary files" +"Pathnames relative to Factor's temporary files directory:" +{ $subsection temp-directory } +{ $subsection temp-file } ; + +ABOUT: "io.files.temp" diff --git a/basis/io/files/temp/temp.factor b/basis/io/files/temp/temp.factor new file mode 100644 index 0000000000..7ace21932a --- /dev/null +++ b/basis/io/files/temp/temp.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2008 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel io.pathnames io.directories ; +IN: io.files.temp + +: temp-directory ( -- path ) + "temp" resource-path dup make-directories ; + +: temp-file ( name -- path ) + temp-directory prepend-path ; \ No newline at end of file diff --git a/basis/io/files/types/types-docs.factor b/basis/io/files/types/types-docs.factor new file mode 100644 index 0000000000..a6402851ea --- /dev/null +++ b/basis/io/files/types/types-docs.factor @@ -0,0 +1,40 @@ +USING: help.markup help.syntax ; +IN: io.files.types + +HELP: +regular-file+ +{ $description "A regular file. This type exists on all platforms. See " { $link "io.files" } " for words operating on files." } ; + +HELP: +directory+ +{ $description "A directory. This type exists on all platforms. See " { $link "io.directories" } " for words operating on directories." } ; + +HELP: +symbolic-link+ +{ $description "A symbolic link file. This type is currently implemented on Unix platforms only. See " { $link "io.files.links" } " for words operating on symbolic links." } ; + +HELP: +character-device+ +{ $description "A Unix character device file. This type exists on Unix platforms only." } ; + +HELP: +block-device+ +{ $description "A Unix block device file. This type exists on Unix platforms only." } ; + +HELP: +fifo+ +{ $description "A Unix fifo file. This type exists on Unix platforms only." } ; + +HELP: +socket+ +{ $description "A Unix socket file. This type exists on Unix platforms only." } ; + +HELP: +unknown+ +{ $description "A unknown file type." } ; + +ARTICLE: "file-types" "File types" +"Platform-independent types:" +{ $subsection +regular-file+ } +{ $subsection +directory+ } +"Platform-specific types:" +{ $subsection +character-device+ } +{ $subsection +block-device+ } +{ $subsection +fifo+ } +{ $subsection +symbolic-link+ } +{ $subsection +socket+ } +{ $subsection +unknown+ } ; + +ABOUT: "file-types" diff --git a/basis/io/files/types/types.factor b/basis/io/files/types/types.factor new file mode 100644 index 0000000000..bf8be9ec9b --- /dev/null +++ b/basis/io/files/types/types.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: io.files.types + +SYMBOL: +regular-file+ +SYMBOL: +directory+ +SYMBOL: +symbolic-link+ +SYMBOL: +character-device+ +SYMBOL: +block-device+ +SYMBOL: +fifo+ +SYMBOL: +socket+ +SYMBOL: +whiteout+ +SYMBOL: +unknown+ diff --git a/basis/io/files/unique/unique-docs.factor b/basis/io/files/unique/unique-docs.factor index bfde09dc48..681cd94a38 100644 --- a/basis/io/files/unique/unique-docs.factor +++ b/basis/io/files/unique/unique-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io io.ports kernel math -io.files.unique.private math.parser io.files ; +io.pathnames io.directories math.parser io.files ; IN: io.files.unique HELP: temporary-path diff --git a/basis/io/files/unique/unique-tests.factor b/basis/io/files/unique/unique-tests.factor index 178e4572d0..8f2e32cea2 100644 --- a/basis/io/files/unique/unique-tests.factor +++ b/basis/io/files/unique/unique-tests.factor @@ -1,5 +1,6 @@ USING: io.encodings.ascii sequences strings io io.files accessors -tools.test kernel io.files.unique namespaces continuations ; +tools.test kernel io.files.unique namespaces continuations +io.files.info io.pathnames ; IN: io.files.unique.tests [ 123 ] [ diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor index 66540fb48e..02f4d6080c 100644 --- a/basis/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.bitwise math.parser random sequences -continuations namespaces io.files io arrays system -combinators vocabs.loader fry io.backend ; +USING: arrays combinators continuations fry io io.backend +io.directories io.directories.hierarchy io.files io.pathnames +kernel math math.bitwise math.parser namespaces random +sequences system vocabs.loader ; IN: io.files.unique HOOK: touch-unique-file io-backend ( path -- ) @@ -54,6 +55,6 @@ PRIVATE> '[ _ with-directory ] [ delete-tree ] bi ; inline { - { [ os unix? ] [ "io.unix.files.unique" ] } - { [ os windows? ] [ "io.windows.files.unique" ] } + { [ os unix? ] [ "io.files.unique.unix" ] } + { [ os windows? ] [ "io.files.unique.windows" ] } } cond require diff --git a/basis/io/files/unique/unix/tags.txt b/basis/io/files/unique/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/files/unique/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/files/unique/unix/unix.factor b/basis/io/files/unique/unix/unix.factor new file mode 100644 index 0000000000..ed4e120b79 --- /dev/null +++ b/basis/io/files/unique/unix/unix.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel io.ports io.backend.unix math.bitwise +unix system io.files.unique ; +IN: io.files.unique.unix + +: open-unique-flags ( -- flags ) + { O_RDWR O_CREAT O_EXCL } flags ; + +M: unix touch-unique-file ( path -- ) + open-unique-flags file-mode open-file close-file ; + +M: unix temporary-path ( -- path ) "/tmp" ; diff --git a/basis/io/files/unique/windows/tags.txt b/basis/io/files/unique/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/files/unique/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/files/unique/windows/windows.factor b/basis/io/files/unique/windows/windows.factor new file mode 100644 index 0000000000..47f30999c3 --- /dev/null +++ b/basis/io/files/unique/windows/windows.factor @@ -0,0 +1,10 @@ +USING: kernel system windows.kernel32 io.backend.windows +io.files.windows io.ports windows destructors environment +io.files.unique ; +IN: io.files.unique.windows + +M: windows touch-unique-file ( path -- ) + GENERIC_WRITE CREATE_NEW 0 open-file dispose ; + +M: windows temporary-path ( -- path ) + "TEMP" os-env ; diff --git a/basis/io/files/unix/authors.txt b/basis/io/files/unix/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/io/files/unix/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/io/files/unix/summary.txt b/basis/io/files/unix/summary.txt new file mode 100644 index 0000000000..57527bef70 --- /dev/null +++ b/basis/io/files/unix/summary.txt @@ -0,0 +1 @@ +Implementation of reading and writing files on Unix-like systems diff --git a/basis/io/files/unix/tags.txt b/basis/io/files/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/files/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/files/unix/unix-tests.factor b/basis/io/files/unix/unix-tests.factor new file mode 100644 index 0000000000..48a128d862 --- /dev/null +++ b/basis/io/files/unix/unix-tests.factor @@ -0,0 +1,164 @@ +USING: tools.test io.files io.files.temp io.pathnames +io.directories io.files.info io.files.info.unix continuations +kernel io.files.unix math.bitwise calendar accessors +math.functions math unix.users unix.groups arrays sequences ; +IN: io.files.unix.tests + +[ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test +[ "/etc/" ] [ "/etc/passwd" parent-directory ] unit-test +[ "/" ] [ "/etc/" parent-directory ] unit-test +[ "/" ] [ "/etc" parent-directory ] unit-test +[ "/" ] [ "/" parent-directory ] unit-test + +[ f ] [ "" root-directory? ] unit-test +[ t ] [ "/" root-directory? ] unit-test +[ t ] [ "//" root-directory? ] unit-test +[ t ] [ "///////" root-directory? ] unit-test + +[ "/" ] [ "/" file-name ] unit-test +[ "///" ] [ "///" file-name ] unit-test + +[ "/" ] [ "/" "../.." append-path ] unit-test +[ "/" ] [ "/" "../../" append-path ] unit-test +[ "/lib" ] [ "/" "../lib" append-path ] unit-test +[ "/lib/" ] [ "/" "../lib/" append-path ] unit-test +[ "/lib" ] [ "/" "../../lib" append-path ] unit-test +[ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test + +[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test +[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test +[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test +[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test +[ t ] [ "/foo" absolute-path? ] unit-test + +: test-file ( -- path ) + "permissions" temp-file ; + +: prepare-test-file ( -- ) + [ test-file delete-file ] ignore-errors + test-file touch-file ; + +: perms ( -- n ) + test-file file-permissions OCT: 7777 mask ; + +prepare-test-file + +[ t ] +[ test-file { USER-ALL GROUP-ALL OTHER-ALL } flags set-file-permissions perms OCT: 777 = ] unit-test + +[ t ] [ test-file user-read? ] unit-test +[ t ] [ test-file user-write? ] unit-test +[ t ] [ test-file user-execute? ] unit-test +[ t ] [ test-file group-read? ] unit-test +[ t ] [ test-file group-write? ] unit-test +[ t ] [ test-file group-execute? ] unit-test +[ t ] [ test-file other-read? ] unit-test +[ 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 +[ f ] [ test-file file-info other-execute? ] 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 +[ f ] [ test-file file-info other-read? ] 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 +[ f ] [ test-file file-info group-write? ] 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 +[ f ] [ test-file file-info other-execute? ] 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 +[ 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 + +prepare-test-file + +[ t ] +[ + test-file now + [ set-file-access-time ] 2keep + [ file-info accessed>> ] + [ [ [ truncate >integer ] change-second ] bi@ ] bi* = +] unit-test + +[ t ] +[ + test-file now + [ set-file-modified-time ] 2keep + [ file-info modified>> ] + [ [ [ truncate >integer ] change-second ] bi@ ] bi* = +] unit-test + +[ t ] +[ + test-file now [ dup 2array set-file-times ] 2keep + [ file-info [ modified>> ] [ accessed>> ] bi ] dip + 3array + [ [ truncate >integer ] change-second ] map all-equal? +] unit-test + +[ ] [ test-file f now 2array set-file-times ] unit-test +[ ] [ test-file now f 2array set-file-times ] unit-test +[ ] [ test-file f f 2array set-file-times ] unit-test + + +[ ] [ test-file real-username set-file-user ] unit-test +[ ] [ test-file real-user-id set-file-user ] unit-test +[ ] [ test-file real-group-name set-file-group ] unit-test +[ ] [ test-file real-group-id set-file-group ] unit-test + +[ t ] [ test-file file-username real-username = ] unit-test +[ t ] [ test-file file-group-name real-group-name = ] unit-test + +[ ] +[ test-file real-user-id real-group-id set-file-ids ] unit-test + +[ ] +[ test-file f real-group-id set-file-ids ] unit-test + +[ ] +[ test-file real-user-id f set-file-ids ] unit-test + +[ ] +[ 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 diff --git a/basis/io/files/unix/unix.factor b/basis/io/files/unix/unix.factor new file mode 100644 index 0000000000..ac78cdff0c --- /dev/null +++ b/basis/io/files/unix/unix.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: unix byte-arrays kernel io.backend.unix math.bitwise +io.ports io.files io.files.private io.pathnames environment +destructors system ; +IN: io.files.unix + +M: unix cwd ( -- path ) + MAXPATHLEN [ ] keep getcwd + [ (io-error) ] unless* ; + +M: unix cd ( path -- ) [ chdir ] unix-system-call drop ; + +: read-flags O_RDONLY ; inline + +: open-read ( path -- fd ) O_RDONLY file-mode open-file ; + +M: unix (file-reader) ( path -- stream ) + open-read init-fd ; + +: write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline + +: open-write ( path -- fd ) + write-flags file-mode open-file ; + +M: unix (file-writer) ( path -- stream ) + open-write init-fd ; + +: append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline + +: open-append ( path -- fd ) + [ + append-flags file-mode open-file |dispose + dup 0 SEEK_END lseek io-error + ] with-destructors ; + +M: unix (file-appender) ( path -- stream ) + open-append init-fd ; + +M: unix home "HOME" os-env ; diff --git a/basis/io/files/windows/nt/authors.txt b/basis/io/files/windows/nt/authors.txt new file mode 100755 index 0000000000..026f4cd0de --- /dev/null +++ b/basis/io/files/windows/nt/authors.txt @@ -0,0 +1,3 @@ +Doug Coleman +Slava Pestov +Mackenzie Straight diff --git a/basis/io/files/windows/nt/nt-tests.factor b/basis/io/files/windows/nt/nt-tests.factor new file mode 100644 index 0000000000..727f72c808 --- /dev/null +++ b/basis/io/files/windows/nt/nt-tests.factor @@ -0,0 +1,55 @@ +USING: io.files kernel tools.test io.backend +io.files.windows.nt splitting sequences ; +IN: io.files.windows.nt.tests + +[ f ] [ "\\foo" absolute-path? ] unit-test +[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test +[ t ] [ "\\\\?\\c:\\" absolute-path? ] unit-test +[ t ] [ "\\\\?\\c:" absolute-path? ] unit-test +[ t ] [ "c:\\foo" absolute-path? ] unit-test +[ t ] [ "c:" absolute-path? ] unit-test +[ t ] [ "c:\\" absolute-path? ] unit-test +[ f ] [ "/cygdrive/c/builds" absolute-path? ] unit-test + +[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test +[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test +[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test +! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing +[ "c:\\" ] [ "c:\\" parent-directory ] unit-test +[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test +[ "c:" ] [ "c:" parent-directory ] unit-test +[ "Z:" ] [ "Z:" parent-directory ] unit-test + +[ f ] [ "" root-directory? ] unit-test +[ t ] [ "\\" root-directory? ] unit-test +[ t ] [ "\\\\" root-directory? ] unit-test +[ t ] [ "/" root-directory? ] unit-test +[ t ] [ "//" root-directory? ] unit-test +[ t ] [ "c:\\" trim-right-separators root-directory? ] unit-test +[ t ] [ "Z:\\" trim-right-separators root-directory? ] unit-test +[ f ] [ "c:\\foo" root-directory? ] unit-test +[ f ] [ "." root-directory? ] unit-test +[ f ] [ ".." root-directory? ] unit-test +[ t ] [ "\\\\?\\c:\\" root-directory? ] unit-test +[ t ] [ "\\\\?\\c:" root-directory? ] unit-test +[ f ] [ "\\\\?\\c:\\bar" root-directory? ] unit-test + +[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test + +[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [ + "C:\\builds\\factor\\12345\\" + "..\\log.txt" append-path normalize-path +] unit-test + +[ "\\\\?\\C:\\builds\\" ] [ + "C:\\builds\\factor\\12345\\" + "..\\.." append-path normalize-path +] unit-test + +[ "\\\\?\\C:\\builds\\" ] [ + "C:\\builds\\factor\\12345\\" + "..\\.." append-path normalize-path +] unit-test + +[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test +[ t ] [ "" resource-path 2 tail exists? ] unit-test diff --git a/basis/io/files/windows/nt/nt.factor b/basis/io/files/windows/nt/nt.factor new file mode 100755 index 0000000000..37c6e3190a --- /dev/null +++ b/basis/io/files/windows/nt/nt.factor @@ -0,0 +1,54 @@ +USING: continuations destructors io.buffers io.files io.backend +io.timeouts io.ports io.pathnames io.files.private io.backend.windows +io.files.windows io.backend.windows.nt io.encodings.utf16n +windows windows.kernel32 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 accessors tr ; +IN: io.files.windows.nt + +M: winnt cwd + MAX_UNICODE_PATH dup "ushort" + [ GetCurrentDirectory win32-error=0/f ] keep + utf16n alien>string ; + +M: winnt cd + SetCurrentDirectory win32-error=0/f ; + +: unicode-prefix ( -- seq ) + "\\\\?\\" ; inline + +M: winnt root-directory? ( path -- ? ) + { + { [ dup empty? ] [ drop f ] } + { [ dup [ path-separator? ] all? ] [ drop t ] } + { [ dup trim-right-separators { [ length 2 = ] + [ second CHAR: : = ] } 1&& ] [ drop t ] } + { [ dup unicode-prefix head? ] + [ trim-right-separators length unicode-prefix length 2 + = ] } + [ drop f ] + } cond ; + +: prepend-prefix ( string -- string' ) + dup unicode-prefix head? [ + unicode-prefix prepend + ] unless ; + +TR: normalize-separators "/" "\\" ; + +M: winnt normalize-path ( string -- string' ) + (normalize-path) + normalize-separators + prepend-prefix ; + +M: winnt CreateFile-flags ( DWORD -- DWORD ) + FILE_FLAG_OVERLAPPED bitor ; + +M: winnt FileArgs-overlapped ( port -- overlapped ) + make-overlapped ; + +M: winnt open-append + 0 ! [ dup file-info size>> ] [ drop 0 ] recover + [ (open-append) ] dip >>ptr ; + +M: winnt home "USERPROFILE" os-env ; diff --git a/basis/io/files/windows/nt/tags.txt b/basis/io/files/windows/nt/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/files/windows/nt/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/files/windows/tags.txt b/basis/io/files/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/files/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/files/windows/windows.factor b/basis/io/files/windows/windows.factor new file mode 100755 index 0000000000..1a1ffe0dc7 --- /dev/null +++ b/basis/io/files/windows/windows.factor @@ -0,0 +1,133 @@ +! 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.files.types io.buffers io.encodings.utf16n io.ports +io.backend.windows kernel math splitting fry alien.strings +windows windows.kernel32 windows.time calendar combinators +math.functions sequences namespaces make words symbols system +destructors accessors math.bitwise continuations windows.errors +arrays byte-arrays generalizations ; +IN: io.files.windows + +: open-file ( path access-mode create-mode flags -- handle ) + [ + [ share-mode default-security-attributes ] 2dip + CreateFile-flags f CreateFile opened-file + ] with-destructors ; + +: open-pipe-r/w ( path -- win32-file ) + { GENERIC_READ GENERIC_WRITE } flags + OPEN_EXISTING 0 open-file ; + +: open-read ( path -- win32-file ) + GENERIC_READ OPEN_EXISTING 0 open-file 0 >>ptr ; + +: open-write ( path -- win32-file ) + GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 >>ptr ; + +: (open-append) ( path -- win32-file ) + GENERIC_WRITE OPEN_ALWAYS 0 open-file ; + +: open-existing ( path -- win32-file ) + { GENERIC_READ GENERIC_WRITE } flags + share-mode + f + OPEN_EXISTING + FILE_FLAG_BACKUP_SEMANTICS + f CreateFileW dup win32-error=0/f ; + +: maybe-create-file ( path -- win32-file ? ) + #! return true if file was just created + { GENERIC_READ GENERIC_WRITE } flags + share-mode + f + OPEN_ALWAYS + 0 CreateFile-flags + f CreateFileW dup win32-error=0/f + GetLastError ERROR_ALREADY_EXISTS = not ; + +: set-file-pointer ( handle length method -- ) + [ dupd d>w/w ] dip SetFilePointer + INVALID_SET_FILE_POINTER = [ + CloseHandle "SetFilePointer failed" throw + ] when drop ; + +HOOK: open-append os ( path -- win32-file ) + +TUPLE: FileArgs + hFile lpBuffer nNumberOfBytesToRead + lpNumberOfBytesRet lpOverlapped ; + +C: FileArgs + +: make-FileArgs ( port -- ) + { + [ handle>> check-disposed ] + [ handle>> handle>> ] + [ buffer>> ] + [ buffer>> buffer-length ] + [ drop "DWORD" ] + [ FileArgs-overlapped ] + } cleave ; + +: setup-read ( -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped ) + { + [ hFile>> ] + [ lpBuffer>> buffer-end ] + [ lpBuffer>> buffer-capacity ] + [ lpNumberOfBytesRet>> ] + [ lpOverlapped>> ] + } cleave ; + +: setup-write ( -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped ) + { + [ hFile>> ] + [ lpBuffer>> buffer@ ] + [ lpBuffer>> buffer-length ] + [ lpNumberOfBytesRet>> ] + [ lpOverlapped>> ] + } cleave ; + +M: windows (file-reader) ( path -- stream ) + open-read ; + +M: windows (file-writer) ( path -- stream ) + open-write ; + +M: windows (file-appender) ( path -- stream ) + open-append ; + +SYMBOLS: +read-only+ +hidden+ +system+ ++archive+ +device+ +normal+ +temporary+ ++sparse-file+ +reparse-point+ +compressed+ +offline+ ++not-content-indexed+ +encrypted+ ; + +: win32-file-attribute ( n attr symbol -- ) + rot mask? [ , ] [ drop ] if ; + +: win32-file-attributes ( n -- seq ) + [ + { + [ +read-only+ FILE_ATTRIBUTE_READONLY win32-file-attribute ] + [ +hidden+ FILE_ATTRIBUTE_HIDDEN win32-file-attribute ] + [ +system+ FILE_ATTRIBUTE_SYSTEM win32-file-attribute ] + [ +directory+ FILE_ATTRIBUTE_DIRECTORY win32-file-attribute ] + [ +archive+ FILE_ATTRIBUTE_ARCHIVE win32-file-attribute ] + [ +device+ FILE_ATTRIBUTE_DEVICE win32-file-attribute ] + [ +normal+ FILE_ATTRIBUTE_NORMAL win32-file-attribute ] + [ +temporary+ FILE_ATTRIBUTE_TEMPORARY win32-file-attribute ] + [ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE win32-file-attribute ] + [ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT win32-file-attribute ] + [ +compressed+ FILE_ATTRIBUTE_COMPRESSED win32-file-attribute ] + [ +offline+ FILE_ATTRIBUTE_OFFLINE win32-file-attribute ] + [ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED win32-file-attribute ] + [ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED win32-file-attribute ] + } cleave + ] { } make ; + +: win32-file-type ( n -- symbol ) + FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ; + +: (set-file-times) ( handle timestamp/f timestamp/f timestamp/f -- ) + [ timestamp>FILETIME ] tri@ + SetFileTime win32-error=0/f ; diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor old mode 100644 new mode 100755 index 7bafb95376..f5809223fc --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -261,8 +261,7 @@ M: object run-pipeline-element drop ; { - { [ os unix? ] [ "io.unix.launcher" require ] } - { [ os winnt? ] [ "io.windows.nt.launcher" require ] } - { [ os wince? ] [ "io.windows.launcher" require ] } + { [ os unix? ] [ "io.launcher.unix" require ] } + { [ os winnt? ] [ "io.launcher.windows.nt" require ] } [ ] } cond diff --git a/basis/io/launcher/unix/authors.txt b/basis/io/launcher/unix/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/io/launcher/unix/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/io/launcher/unix/parser/parser-tests.factor b/basis/io/launcher/unix/parser/parser-tests.factor new file mode 100644 index 0000000000..07502e87a4 --- /dev/null +++ b/basis/io/launcher/unix/parser/parser-tests.factor @@ -0,0 +1,33 @@ +IN: io.launcher.unix.parser.tests +USING: io.launcher.unix.parser tools.test ; + +[ "" tokenize-command ] must-fail +[ " " tokenize-command ] must-fail +[ V{ "a" } ] [ "a" tokenize-command ] unit-test +[ V{ "abc" } ] [ "abc" tokenize-command ] unit-test +[ V{ "abc" } ] [ "abc " tokenize-command ] unit-test +[ V{ "abc" } ] [ " abc" tokenize-command ] unit-test +[ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test +[ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test +[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test +[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test +[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test +[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test +[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test +[ "'abc def' \"hey" tokenize-command ] must-fail +[ "'abc def" tokenize-command ] must-fail +[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test + +[ + V{ + "Hello world.app/Contents/MacOS/hello-ui" + "-i=boot.macosx-ppc.image" + "-include= math compiler ui" + "-deploy-vocab=hello-ui" + "-output-image=Hello world.app/Contents/Resources/hello-ui.image" + "-no-stack-traces" + "-no-user-init" + } +] [ + "\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize-command +] unit-test diff --git a/basis/io/launcher/unix/parser/parser.factor b/basis/io/launcher/unix/parser/parser.factor new file mode 100644 index 0000000000..97e6dee95f --- /dev/null +++ b/basis/io/launcher/unix/parser/parser.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: peg peg.parsers kernel sequences strings words ; +IN: io.launcher.unix.parser + +! Our command line parser. Supported syntax: +! foo bar baz -- simple tokens +! foo\ bar -- escaping the space +! 'foo bar' -- quotation +! "foo bar" -- quotation +: 'escaped-char' ( -- parser ) + "\\" token any-char 2seq [ second ] action ; + +: 'quoted-char' ( delimiter -- parser' ) + 'escaped-char' + swap [ member? not ] curry satisfy + 2choice ; inline + +: 'quoted' ( delimiter -- parser ) + dup 'quoted-char' repeat0 swap dup surrounded-by ; + +: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ; + +: 'argument' ( -- parser ) + "\"" 'quoted' + "'" 'quoted' + 'unquoted' 3choice + [ >string ] action ; + +PEG: tokenize-command ( command -- ast/f ) + 'argument' " " token repeat1 list-of + " " token repeat0 tuck pack + just ; diff --git a/basis/io/launcher/unix/parser/tags.txt b/basis/io/launcher/unix/parser/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/launcher/unix/parser/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/launcher/unix/tags.txt b/basis/io/launcher/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/launcher/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/launcher/unix/unix-tests.factor b/basis/io/launcher/unix/unix-tests.factor new file mode 100644 index 0000000000..f375bb41e8 --- /dev/null +++ b/basis/io/launcher/unix/unix-tests.factor @@ -0,0 +1,138 @@ +IN: io.launcher.unix.tests +USING: io.files io.files.temp io.directories io.pathnames +tools.test io.launcher arrays io namespaces continuations math +io.encodings.binary io.encodings.ascii accessors kernel +sequences io.encodings.utf8 destructors io.streams.duplex locals +concurrency.promises threads unix.process ; + +[ ] [ + [ "launcher-test-1" temp-file delete-file ] ignore-errors +] unit-test + +[ ] [ + "touch" + "launcher-test-1" temp-file + 2array + try-process +] unit-test + +[ t ] [ "launcher-test-1" temp-file exists? ] unit-test + +[ ] [ + [ "launcher-test-1" temp-file delete-file ] ignore-errors +] unit-test + +[ ] [ + + "echo Hello" >>command + "launcher-test-1" temp-file >>stdout + try-process +] unit-test + +[ "Hello\n" ] [ + "cat" + "launcher-test-1" temp-file + 2array + ascii contents +] unit-test + +[ ] [ + [ "launcher-test-1" temp-file delete-file ] ignore-errors +] unit-test + +[ ] [ + + "cat" >>command + +closed+ >>stdin + "launcher-test-1" temp-file >>stdout + try-process +] unit-test + +[ f ] [ + "cat" + "launcher-test-1" temp-file + 2array + ascii contents +] unit-test + +[ ] [ + 2 [ + "launcher-test-1" temp-file binary [ + + swap >>stdout + "echo Hello" >>command + try-process + ] with-disposal + ] times +] unit-test + +[ "Hello\nHello\n" ] [ + "cat" + "launcher-test-1" temp-file + 2array + ascii contents +] unit-test + +[ t ] [ + + "env" >>command + { { "A" "B" } } >>environment + ascii lines + "A=B" swap member? +] unit-test + +[ { "A=B" } ] [ + + "env" >>command + { { "A" "B" } } >>environment + +replace-environment+ >>environment-mode + ascii lines +] unit-test + +[ "hi\n" ] [ + temp-directory [ + [ "aloha" delete-file ] ignore-errors + + { "echo" "hi" } >>command + "aloha" >>stdout + try-process + ] with-directory + temp-directory "aloha" append-path + utf8 file-contents +] unit-test + +[ "append-test" temp-file delete-file ] ignore-errors + +[ "hi\nhi\n" ] [ + 2 [ + + "echo hi" >>command + "append-test" temp-file >>stdout + try-process + ] times + "append-test" temp-file utf8 file-contents +] unit-test + +[ t ] [ "ls" utf8 contents >boolean ] unit-test + +[ "Hello world.\n" ] [ + "cat" utf8 [ + "Hello world.\n" write + output-stream get dispose + input-stream get contents + ] with-stream +] unit-test + +! Killed processes were exiting with code 0 on FreeBSD +[ f ] [ + [let | p [ ] + s [ ] | + [ + "sleep 1000" run-detached + [ p fulfill ] [ wait-for-process s fulfill ] bi + ] in-thread + + p ?promise handle>> 9 kill drop + s ?promise 0 = + ] +] unit-test diff --git a/basis/io/launcher/unix/unix.factor b/basis/io/launcher/unix/unix.factor new file mode 100644 index 0000000000..ac25e4ec2f --- /dev/null +++ b/basis/io/launcher/unix/unix.factor @@ -0,0 +1,106 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alien.c-types arrays assocs combinators +continuations environment io io.backend io.backend.unix +io.files io.files.private io.files.unix io.launcher +io.launcher.unix.parser io.pathnames io.ports kernel math +namespaces sequences strings system threads unix unix +unix.process ; +IN: io.launcher.unix + +! Search unix first +USE: unix + +: get-arguments ( process -- seq ) + command>> dup string? [ tokenize-command ] when ; + +: assoc>env ( assoc -- env ) + [ "=" glue ] { } assoc>map ; + +: setup-priority ( process -- process ) + dup priority>> [ + H{ + { +lowest-priority+ 20 } + { +low-priority+ 10 } + { +normal-priority+ 0 } + { +high-priority+ -10 } + { +highest-priority+ -20 } + { +realtime-priority+ -20 } + } at set-priority + ] when* ; + +: reset-fd ( fd -- ) + [ F_SETFL 0 fcntl io-error ] [ F_SETFD 0 fcntl io-error ] bi ; + +: redirect-fd ( oldfd fd -- ) + 2dup = [ 2drop ] [ dup2 io-error ] if ; + +: redirect-file ( obj mode fd -- ) + [ [ normalize-path ] dip file-mode open-file ] dip redirect-fd ; + +: redirect-file-append ( obj mode fd -- ) + [ drop path>> normalize-path open-append ] dip redirect-fd ; + +: redirect-closed ( obj mode fd -- ) + [ drop "/dev/null" ] 2dip redirect-file ; + +: redirect ( obj mode fd -- ) + { + { [ pick not ] [ 3drop ] } + { [ pick string? ] [ redirect-file ] } + { [ pick appender? ] [ redirect-file-append ] } + { [ pick +closed+ eq? ] [ redirect-closed ] } + { [ pick fd? ] [ [ drop fd>> dup reset-fd ] dip redirect-fd ] } + [ [ underlying-handle ] 2dip redirect ] + } cond ; + +: ?closed ( obj -- obj' ) + dup +closed+ eq? [ drop "/dev/null" ] when ; + +: setup-redirection ( process -- process ) + dup stdin>> ?closed read-flags 0 redirect + dup stdout>> ?closed write-flags 1 redirect + dup stderr>> dup +stdout+ eq? [ + drop 1 2 dup2 io-error + ] [ + ?closed write-flags 2 redirect + ] if ; + +: setup-environment ( process -- process ) + dup pass-environment? [ + dup get-environment set-os-envs + ] when ; + +: spawn-process ( process -- * ) + [ setup-priority ] [ 250 _exit ] recover + [ setup-redirection ] [ 251 _exit ] recover + [ current-directory get (normalize-path) cd ] [ 252 _exit ] recover + [ setup-environment ] [ 253 _exit ] recover + [ get-arguments exec-args-with-path ] [ 254 _exit ] recover + 255 _exit ; + +M: unix current-process-handle ( -- handle ) getpid ; + +M: unix run-process* ( process -- pid ) + [ spawn-process ] curry [ ] with-fork ; + +M: unix kill-process* ( pid -- ) + SIGTERM kill io-error ; + +: find-process ( handle -- process ) + processes get swap [ nip swap handle>> = ] curry + assoc-find 2drop ; + +TUPLE: signal n ; + +: code>status ( code -- obj ) + dup WIFEXITED [ WEXITSTATUS ] [ WTERMSIG signal boa ] if ; + +M: unix wait-for-processes ( -- ? ) + -1 0 tuck WNOHANG waitpid + dup 0 <= [ + 2drop t + ] [ + find-process dup + [ swap *int code>status notify-exit f ] [ 2drop f ] if + ] if ; diff --git a/basis/io/launcher/windows/authors.txt b/basis/io/launcher/windows/authors.txt new file mode 100755 index 0000000000..5674120196 --- /dev/null +++ b/basis/io/launcher/windows/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Slava Pestov diff --git a/basis/io/launcher/windows/nt/authors.txt b/basis/io/launcher/windows/nt/authors.txt new file mode 100755 index 0000000000..026f4cd0de --- /dev/null +++ b/basis/io/launcher/windows/nt/authors.txt @@ -0,0 +1,3 @@ +Doug Coleman +Slava Pestov +Mackenzie Straight diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor new file mode 100644 index 0000000000..2cdb7d5f89 --- /dev/null +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -0,0 +1,157 @@ +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.launcher.windows.nt.tests + +[ ] [ + + "notepad" >>command + 1/2 seconds >>timeout + "notepad" set +] unit-test + +[ f ] [ "notepad" get process-running? ] unit-test + +[ f ] [ "notepad" get process-started? ] unit-test + +[ ] [ "notepad" [ run-detached ] change ] unit-test + +[ "notepad" get wait-for-process ] must-fail + +[ t ] [ "notepad" get killed>> ] unit-test + +[ f ] [ "notepad" get process-running? ] unit-test + +[ ] [ + + vm "-quiet" "-run=hello-world" 3array >>command + "out.txt" temp-file >>stdout + try-process +] unit-test + +[ "Hello world" ] [ + "out.txt" temp-file ascii file-lines first +] unit-test + +[ ] [ + + vm "-run=listener" 2array >>command + +closed+ >>stdin + try-process +] unit-test + +[ ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "stderr.factor" 3array >>command + "out.txt" temp-file >>stdout + "err.txt" temp-file >>stderr + try-process + ] with-directory +] unit-test + +[ "output" ] [ + "out.txt" temp-file ascii file-lines first +] unit-test + +[ "error" ] [ + "err.txt" temp-file ascii file-lines first +] unit-test + +[ ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "stderr.factor" 3array >>command + "out.txt" temp-file >>stdout + +stdout+ >>stderr + try-process + ] with-directory +] unit-test + +[ "outputerror" ] [ + "out.txt" temp-file ascii file-lines first +] unit-test + +[ "output" ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "stderr.factor" 3array >>command + "err2.txt" temp-file >>stderr + ascii lines first + ] with-directory +] unit-test + +[ "error" ] [ + "err2.txt" temp-file ascii file-lines first +] unit-test + +[ t ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "env.factor" 3array >>command + ascii contents + ] with-directory eval + + os-envs = +] unit-test + +[ t ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "env.factor" 3array >>command + +replace-environment+ >>environment-mode + os-envs >>environment + ascii contents + ] with-directory eval + + os-envs = +] unit-test + +[ "B" ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "env.factor" 3array >>command + { { "A" "B" } } >>environment + ascii contents + ] with-directory eval + + "A" swap at +] unit-test + +[ f ] [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "env.factor" 3array >>command + { { "USERPROFILE" "XXX" } } >>environment + +prepend-environment+ >>environment-mode + ascii contents + ] with-directory eval + + "USERPROFILE" swap at "XXX" = +] unit-test + +2 [ + [ ] [ + + "cmd.exe /c dir" >>command + "dir.txt" temp-file >>stdout + try-process + ] unit-test + + [ ] [ "dir.txt" temp-file delete-file ] unit-test +] times + +[ "append-test" temp-file delete-file ] ignore-errors + +[ "Hello appender\r\nHello appender\r\n" ] [ + 2 [ + "resource:basis/io/windows/nt/launcher/test" [ + + vm "-script" "append.factor" 3array >>command + "append-test" temp-file >>stdout + try-process + ] with-directory + ] times + + "append-test" temp-file ascii file-contents +] unit-test diff --git a/basis/io/launcher/windows/nt/nt.factor b/basis/io/launcher/windows/nt/nt.factor new file mode 100755 index 0000000000..5ebb38abc2 --- /dev/null +++ b/basis/io/launcher/windows/nt/nt.factor @@ -0,0 +1,110 @@ +! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types arrays continuations destructors io +io.backend.windows libc io.ports io.pipes windows.types math +windows.kernel32 windows namespaces make io.launcher kernel +sequences windows.errors assocs splitting system strings +io.launcher.windows io.files.windows io.backend io.files +io.files.private combinators shuffle accessors locals ; +IN: io.launcher.windows.nt + +: duplicate-handle ( handle -- handle' ) + GetCurrentProcess ! source process + swap ! handle + GetCurrentProcess ! target process + f [ ! target handle + DUPLICATE_SAME_ACCESS ! desired access + TRUE ! inherit handle + DUPLICATE_CLOSE_SOURCE ! options + DuplicateHandle win32-error=0/f + ] keep *void* ; + +! /dev/null simulation +: null-input ( -- pipe ) + (pipe) [ in>> handle>> ] [ out>> dispose ] bi ; + +: null-output ( -- pipe ) + (pipe) [ in>> dispose ] [ out>> handle>> ] bi ; + +: null-pipe ( mode -- pipe ) + { + { GENERIC_READ [ null-input ] } + { GENERIC_WRITE [ null-output ] } + } case ; + +! The below code is based on the example given in +! http://msdn2.microsoft.com/en-us/library/ms682499.aspx + +: redirect-default ( obj access-mode create-mode -- handle ) + 3drop f ; + +: redirect-closed ( obj access-mode create-mode -- handle ) + drop nip null-pipe ; + +:: redirect-file ( path access-mode create-mode -- handle ) + path normalize-path + access-mode + share-mode + default-security-attributes + create-mode + FILE_ATTRIBUTE_NORMAL ! flags and attributes + f ! template file + CreateFile dup invalid-handle? &dispose handle>> ; + +: redirect-append ( path access-mode create-mode -- handle ) + [ path>> ] 2dip + drop OPEN_ALWAYS + redirect-file + dup 0 FILE_END set-file-pointer ; + +: redirect-handle ( handle access-mode create-mode -- handle ) + 2drop handle>> duplicate-handle ; + +: redirect-stream ( stream access-mode create-mode -- handle ) + [ underlying-handle handle>> ] 2dip redirect-handle ; + +: redirect ( obj access-mode create-mode -- handle ) + { + { [ pick not ] [ redirect-default ] } + { [ pick +closed+ eq? ] [ redirect-closed ] } + { [ pick string? ] [ redirect-file ] } + { [ pick appender? ] [ redirect-append ] } + { [ pick win32-file? ] [ redirect-handle ] } + [ redirect-stream ] + } cond + dup [ dup t set-inherit ] when ; + +: redirect-stdout ( process args -- handle ) + drop + stdout>> + GENERIC_WRITE + CREATE_ALWAYS + redirect + STD_OUTPUT_HANDLE GetStdHandle or ; + +: redirect-stderr ( process args -- handle ) + over stderr>> +stdout+ eq? [ + nip + lpStartupInfo>> STARTUPINFO-hStdOutput + ] [ + drop + stderr>> + GENERIC_WRITE + CREATE_ALWAYS + redirect + STD_ERROR_HANDLE GetStdHandle or + ] if ; + +: redirect-stdin ( process args -- handle ) + drop + stdin>> + GENERIC_READ + OPEN_EXISTING + redirect + STD_INPUT_HANDLE GetStdHandle or ; + +M: winnt fill-redirection ( process args -- ) + [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput + [ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError + [ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput + 2drop ; diff --git a/basis/io/launcher/windows/nt/tags.txt b/basis/io/launcher/windows/nt/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/launcher/windows/nt/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/launcher/windows/nt/test/append.factor b/basis/io/launcher/windows/nt/test/append.factor new file mode 100644 index 0000000000..4c1de0c5f9 --- /dev/null +++ b/basis/io/launcher/windows/nt/test/append.factor @@ -0,0 +1,2 @@ +USE: io +"Hello appender" print diff --git a/basis/io/launcher/windows/nt/test/env.factor b/basis/io/launcher/windows/nt/test/env.factor new file mode 100644 index 0000000000..503ca7d018 --- /dev/null +++ b/basis/io/launcher/windows/nt/test/env.factor @@ -0,0 +1,4 @@ +USE: system +USE: prettyprint +USE: environment +os-envs . diff --git a/basis/io/launcher/windows/nt/test/stderr.factor b/basis/io/launcher/windows/nt/test/stderr.factor new file mode 100644 index 0000000000..f22f50e406 --- /dev/null +++ b/basis/io/launcher/windows/nt/test/stderr.factor @@ -0,0 +1,5 @@ +USE: io +USE: namespaces + +"output" write flush +"error" error-stream get stream-write error-stream get stream-flush diff --git a/basis/io/launcher/windows/tags.txt b/basis/io/launcher/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/launcher/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/launcher/windows/windows-tests.factor b/basis/io/launcher/windows/windows-tests.factor new file mode 100644 index 0000000000..1a3fe823a5 --- /dev/null +++ b/basis/io/launcher/windows/windows-tests.factor @@ -0,0 +1,10 @@ +IN: io.launcher.windows.tests +USING: tools.test io.launcher.windows ; + +[ "hello world" ] [ { "hello" "world" } join-arguments ] unit-test + +[ "bob \"mac arthur\"" ] [ { "bob" "mac arthur" } join-arguments ] unit-test + +[ "bob mac\\\\arthur" ] [ { "bob" "mac\\\\arthur" } join-arguments ] unit-test + +[ "bob \"mac arthur\\\\\"" ] [ { "bob" "mac arthur\\" } join-arguments ] unit-test diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor new file mode 100755 index 0000000000..0497754aa2 --- /dev/null +++ b/basis/io/launcher/windows/windows.factor @@ -0,0 +1,164 @@ +! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types arrays continuations io +io.backend.windows io.pipes.windows.nt io.pathnames libc io.ports +windows.types math windows.kernel32 +namespaces make io.launcher kernel sequences windows.errors +splitting system threads init strings combinators +io.backend accessors concurrency.flags io.files assocs +io.files.private windows destructors specialized-arrays.ushort +specialized-arrays.alien ; +IN: io.launcher.windows + +TUPLE: CreateProcess-args + lpApplicationName + lpCommandLine + lpProcessAttributes + lpThreadAttributes + bInheritHandles + dwCreateFlags + lpEnvironment + lpCurrentDirectory + lpStartupInfo + lpProcessInformation ; + +: default-CreateProcess-args ( -- obj ) + CreateProcess-args new + "STARTUPINFO" + "STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo + "PROCESS_INFORMATION" >>lpProcessInformation + TRUE >>bInheritHandles + 0 >>dwCreateFlags ; + +: call-CreateProcess ( CreateProcess-args -- ) + { + [ lpApplicationName>> ] + [ lpCommandLine>> ] + [ lpProcessAttributes>> ] + [ lpThreadAttributes>> ] + [ bInheritHandles>> ] + [ dwCreateFlags>> ] + [ lpEnvironment>> ] + [ lpCurrentDirectory>> ] + [ lpStartupInfo>> ] + [ lpProcessInformation>> ] + } cleave + CreateProcess win32-error=0/f ; + +: count-trailing-backslashes ( str n -- str n ) + [ "\\" ?tail ] dip swap [ + 1+ count-trailing-backslashes + ] when ; + +: fix-trailing-backslashes ( str -- str' ) + 0 count-trailing-backslashes + 2 * CHAR: \\ append ; + +: escape-argument ( str -- newstr ) + CHAR: \s over member? [ + fix-trailing-backslashes "\"" dup surround + ] when ; + +: join-arguments ( args -- cmd-line ) + [ escape-argument ] map " " join ; + +: lookup-priority ( process -- n ) + priority>> { + { +lowest-priority+ [ IDLE_PRIORITY_CLASS ] } + { +low-priority+ [ BELOW_NORMAL_PRIORITY_CLASS ] } + { +normal-priority+ [ NORMAL_PRIORITY_CLASS ] } + { +high-priority+ [ ABOVE_NORMAL_PRIORITY_CLASS ] } + { +highest-priority+ [ HIGH_PRIORITY_CLASS ] } + { +realtime-priority+ [ REALTIME_PRIORITY_CLASS ] } + [ drop f ] + } case ; + +: app-name/cmd-line ( process -- app-name cmd-line ) + command>> dup string? [ + " " split1 + ] [ + unclip swap join-arguments + ] if ; + +: cmd-line ( process -- cmd-line ) + command>> dup string? [ join-arguments ] unless ; + +: fill-lpApplicationName ( process args -- process args ) + over app-name/cmd-line + [ >>lpApplicationName ] [ >>lpCommandLine ] bi* ; + +: fill-lpCommandLine ( process args -- process args ) + over cmd-line >>lpCommandLine ; + +: fill-dwCreateFlags ( process args -- process args ) + 0 + pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when + pick detached>> os winnt? and [ DETACHED_PROCESS bitor ] when + pick lookup-priority [ bitor ] when* + >>dwCreateFlags ; + +: fill-lpEnvironment ( process args -- process args ) + over pass-environment? [ + [ + over get-environment + [ swap % "=" % % "\0" % ] assoc-each + "\0" % + ] ushort-array{ } make underlying>> + >>lpEnvironment + ] when ; + +: fill-startup-info ( process args -- process args ) + STARTF_USESTDHANDLES over lpStartupInfo>> set-STARTUPINFO-dwFlags ; + +HOOK: fill-redirection io-backend ( process args -- ) + +M: wince fill-redirection 2drop ; + +: make-CreateProcess-args ( process -- args ) + default-CreateProcess-args + os wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if + fill-dwCreateFlags + fill-lpEnvironment + fill-startup-info + nip ; + +M: windows current-process-handle ( -- handle ) + GetCurrentProcessId ; + +M: windows run-process* ( process -- handle ) + [ + current-directory get (normalize-path) cd + + dup make-CreateProcess-args + tuck fill-redirection + dup call-CreateProcess + lpProcessInformation>> + ] with-destructors ; + +M: windows kill-process* ( handle -- ) + PROCESS_INFORMATION-hProcess + 255 TerminateProcess win32-error=0/f ; + +: dispose-process ( process-information -- ) + #! From MSDN: "Handles in PROCESS_INFORMATION must be closed + #! with CloseHandle when they are no longer needed." + dup PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when* + PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ; + +: exit-code ( process -- n ) + PROCESS_INFORMATION-hProcess + 0 [ GetExitCodeProcess ] keep *ulong + swap win32-error=0/f ; + +: process-exited ( process -- ) + dup handle>> exit-code + over handle>> dispose-process + notify-exit ; + +M: windows wait-for-processes ( -- ? ) + processes get keys dup + [ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as + [ length ] [ underlying>> ] bi 0 0 + WaitForMultipleObjects + dup HEX: ffffffff = [ win32-error ] when + dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ; diff --git a/basis/io/mmap/mmap-tests.factor b/basis/io/mmap/mmap-tests.factor index dc2f0b4687..166167a7e7 100644 --- a/basis/io/mmap/mmap-tests.factor +++ b/basis/io/mmap/mmap-tests.factor @@ -1,5 +1,6 @@ -USING: io io.mmap io.mmap.char io.files kernel tools.test -continuations sequences io.encodings.ascii accessors ; +USING: io io.mmap io.mmap.char io.files io.files.temp +io.directories kernel tools.test continuations sequences +io.encodings.ascii accessors ; IN: io.mmap.tests [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor index 3cf451bd03..6f2fabb709 100644 --- a/basis/io/mmap/mmap.factor +++ b/basis/io/mmap/mmap.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: continuations destructors io.files io.backend kernel -quotations system alien alien.accessors accessors system -vocabs.loader combinators alien.c-types ; +USING: continuations destructors io.files io.files.info +io.backend kernel quotations system alien alien.accessors +accessors system vocabs.loader combinators alien.c-types ; IN: io.mmap TUPLE: mapped-file address handle length disposed ; -HOOK: (mapped-file) io-backend ( path length -- address handle ) +HOOK: (mapped-file) os ( path length -- address handle ) : ( path -- mmap ) [ normalize-path ] [ file-info size>> ] bi [ (mapped-file) ] keep @@ -21,6 +21,6 @@ M: mapped-file dispose* ( mmap -- ) close-mapped-file ; [ ] dip with-disposal ; inline { - { [ os unix? ] [ "io.unix.mmap" require ] } - { [ os winnt? ] [ "io.windows.mmap" require ] } + { [ os unix? ] [ "io.mmap.unix" require ] } + { [ os winnt? ] [ "io.mmap.windows" require ] } } cond diff --git a/basis/io/mmap/unix/authors.txt b/basis/io/mmap/unix/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/io/mmap/unix/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/io/mmap/unix/tags.txt b/basis/io/mmap/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/mmap/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/mmap/unix/unix.factor b/basis/io/mmap/unix/unix.factor new file mode 100644 index 0000000000..9325dcd632 --- /dev/null +++ b/basis/io/mmap/unix/unix.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien io io.files kernel math math.bitwise system unix +io.backend.unix io.ports io.mmap destructors locals accessors ; +IN: io.mmap.unix + +: open-r/w ( path -- fd ) O_RDWR file-mode open-file ; + +:: mmap-open ( path length prot flags -- alien fd ) + [ + f length prot flags + path open-r/w |dispose + [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep + ] with-destructors ; + +M: unix (mapped-file) + { PROT_READ PROT_WRITE } flags + { MAP_FILE MAP_SHARED } flags + mmap-open ; + +M: unix close-mapped-file ( mmap -- ) + [ [ address>> ] [ length>> ] bi munmap io-error ] + [ handle>> close-file ] + bi ; diff --git a/basis/io/mmap/windows/authors.txt b/basis/io/mmap/windows/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/io/mmap/windows/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/io/mmap/windows/tags.txt b/basis/io/mmap/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/mmap/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/mmap/windows/windows.factor b/basis/io/mmap/windows/windows.factor new file mode 100644 index 0000000000..fcdf416511 --- /dev/null +++ b/basis/io/mmap/windows/windows.factor @@ -0,0 +1,44 @@ +USING: alien alien.c-types arrays destructors generic io.mmap +io.ports io.backend.windows io.files.windows io.backend.windows.privileges +kernel libc math math.bitwise namespaces quotations sequences +windows windows.advapi32 windows.kernel32 io.backend system +accessors locals ; +IN: io.mmap.windows + +: create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE ) + CreateFileMapping [ win32-error=0/f ] keep ; + +: map-view-of-file ( hFileMappingObject dwDesiredAccess dwFileOffsetHigh dwFileOffsetLow dwNumberOfBytesToMap -- HANDLE ) + MapViewOfFile [ win32-error=0/f ] keep ; + +:: mmap-open ( path length access-mode create-mode protect access -- handle handle address ) + [let | lo [ length HEX: ffffffff bitand ] + hi [ length -32 shift HEX: ffffffff bitand ] | + { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [ + path access-mode create-mode 0 open-file |dispose + dup handle>> f protect hi lo f create-file-mapping |dispose + dup handle>> access 0 0 0 map-view-of-file + ] with-privileges + ] ; + +TUPLE: win32-mapped-file file mapping ; + +M: win32-mapped-file dispose + [ file>> dispose ] [ mapping>> dispose ] bi ; + +C: win32-mapped-file + +M: windows (mapped-file) + [ + { GENERIC_WRITE GENERIC_READ } flags + OPEN_ALWAYS + { PAGE_READWRITE SEC_COMMIT } flags + FILE_MAP_ALL_ACCESS mmap-open + -rot + ] with-destructors ; + +M: windows close-mapped-file ( mapped-file -- ) + [ + [ handle>> &dispose drop ] + [ address>> UnmapViewOfFile win32-error=0/f ] bi + ] with-destructors ; diff --git a/basis/io/monitors/linux/linux-tests.factor b/basis/io/monitors/linux/linux-tests.factor new file mode 100644 index 0000000000..67558942f8 --- /dev/null +++ b/basis/io/monitors/linux/linux-tests.factor @@ -0,0 +1,37 @@ +IN: io.monitors.linux.tests +USING: io.monitors tools.test io.files io.files.temp +io.directories system sequences continuations namespaces +concurrency.count-downs kernel io threads calendar prettyprint +destructors io.timeouts ; + +! On Linux, a notification on the directory itself would report an invalid +! path name +[ + [ ] [ "monitor-test-self" temp-file make-directories ] unit-test + + ! Non-recursive + [ ] [ "monitor-test-self" temp-file f "m" set ] unit-test + [ ] [ 3 seconds "m" get set-timeout ] unit-test + + [ ] [ "monitor-test-self" temp-file touch-file ] unit-test + + [ t ] [ + "m" get next-change drop + [ "" = ] [ "monitor-test-self" temp-file = ] bi or + ] unit-test + + [ ] [ "m" get dispose ] unit-test + + ! Recursive + [ ] [ "monitor-test-self" temp-file t "m" set ] unit-test + [ ] [ 3 seconds "m" get set-timeout ] unit-test + + [ ] [ "monitor-test-self" temp-file touch-file ] unit-test + + [ t ] [ + "m" get next-change drop + [ "" = ] [ "monitor-test-self" temp-file = ] bi or + ] unit-test + + [ ] [ "m" get dispose ] unit-test +] with-monitors diff --git a/basis/io/monitors/linux/linux.factor b/basis/io/monitors/linux/linux.factor new file mode 100644 index 0000000000..e914f32a48 --- /dev/null +++ b/basis/io/monitors/linux/linux.factor @@ -0,0 +1,136 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel io.backend io.monitors io.monitors.recursive +io.files io.pathnames io.buffers io.monitors io.ports io.timeouts +io.backend.unix io.encodings.utf8 unix.linux.inotify assocs +namespaces make threads continuations init math math.bitwise +sets alien alien.strings alien.c-types vocabs.loader accessors +system hashtables destructors unix ; +IN: io.monitors.linux + +SYMBOL: watches + +SYMBOL: inotify + +TUPLE: linux-monitor < monitor wd inotify watches disposed ; + +: ( wd path mailbox -- monitor ) + linux-monitor new-monitor + inotify get >>inotify + watches get >>watches + swap >>wd ; + +: wd>monitor ( wd -- monitor ) watches get at ; + +: ( -- port/f ) + inotify_init dup 0 < [ drop f ] [ init-fd ] if ; + +: inotify-fd ( -- fd ) inotify get handle>> handle-fd ; + +: check-existing ( wd -- ) + watches get key? [ + "Cannot open multiple monitors for the same file" throw + ] when ; + +: (add-watch) ( path mask -- wd ) + inotify-fd -rot inotify_add_watch dup io-error dup check-existing ; + +: add-watch ( path mask mailbox -- monitor ) + [ [ (normalize-path) ] dip [ (add-watch) ] [ drop ] 2bi ] dip + [ ] [ ] [ wd>> ] tri watches get set-at ; + +: check-inotify ( -- ) + inotify get [ + "Calling outside with-monitors" throw + ] unless ; + +M: linux (monitor) ( path recursive? mailbox -- monitor ) + swap [ + + ] [ + check-inotify + IN_CHANGE_EVENTS swap add-watch + ] if ; + +M: linux-monitor dispose* ( monitor -- ) + [ [ wd>> ] [ watches>> ] bi delete-at ] + [ + dup inotify>> disposed>> [ drop ] [ + [ inotify>> handle>> handle-fd ] [ wd>> ] bi + inotify_rm_watch io-error + ] if + ] bi ; + +: ignore-flags? ( mask -- ? ) + { + IN_DELETE_SELF + IN_MOVE_SELF + IN_UNMOUNT + IN_Q_OVERFLOW + IN_IGNORED + } flags bitand 0 > ; + +: parse-action ( mask -- changed ) + [ + IN_CREATE +add-file+ ?flag + IN_DELETE +remove-file+ ?flag + IN_MODIFY +modify-file+ ?flag + IN_ATTRIB +modify-file+ ?flag + IN_MOVED_FROM +rename-file-old+ ?flag + IN_MOVED_TO +rename-file-new+ ?flag + drop + ] { } make prune ; + +: parse-event-name ( event -- name ) + dup inotify-event-len zero? + [ drop "" ] [ inotify-event-name utf8 alien>string ] if ; + +: parse-file-notify ( buffer -- path changed ) + dup inotify-event-mask ignore-flags? [ + drop f f + ] [ + [ parse-event-name ] [ inotify-event-mask parse-action ] bi + ] if ; + +: events-exhausted? ( i buffer -- ? ) + fill>> >= ; + +: inotify-event@ ( i buffer -- alien ) + ptr>> ; + +: next-event ( i buffer -- i buffer ) + 2dup inotify-event@ + inotify-event-len "inotify-event" heap-size + + swap [ + ] dip ; + +: parse-file-notifications ( i buffer -- ) + 2dup events-exhausted? [ 2drop ] [ + 2dup inotify-event@ dup inotify-event-wd wd>monitor + [ parse-file-notify ] dip queue-change + next-event parse-file-notifications + ] if ; + +: inotify-read-loop ( port -- ) + dup check-disposed + dup wait-to-read drop + 0 over buffer>> parse-file-notifications + 0 over buffer>> buffer-reset + inotify-read-loop ; + +: inotify-read-thread ( port -- ) + [ inotify-read-loop ] curry ignore-errors ; + +M: linux init-monitors + H{ } clone watches set + [ + [ inotify set ] + [ + [ inotify-read-thread ] curry + "Linux monitor thread" spawn drop + ] bi + ] [ + "Linux kernel version is too old" throw + ] if* ; + +M: linux dispose-monitors + inotify get dispose ; diff --git a/basis/io/monitors/linux/tags.txt b/basis/io/monitors/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/monitors/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/monitors/macosx/macosx.factor b/basis/io/monitors/macosx/macosx.factor new file mode 100644 index 0000000000..be1dcc64b6 --- /dev/null +++ b/basis/io/monitors/macosx/macosx.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.backend io.monitors +core-foundation.fsevents continuations kernel sequences +namespaces arrays system locals accessors destructors fry ; +IN: io.monitors.macosx + +TUPLE: macosx-monitor < monitor handle ; + +: enqueue-notifications ( triples monitor -- ) + '[ first { +modify-file+ } _ queue-change ] each ; + +M:: macosx (monitor) ( path recursive? mailbox -- monitor ) + [let | path [ path normalize-path ] | + path mailbox macosx-monitor new-monitor + dup [ enqueue-notifications ] curry + path 1array 0 0 >>handle + ] ; + +M: macosx-monitor dispose + handle>> dispose ; + +macosx set-io-backend diff --git a/basis/io/monitors/macosx/tags.txt b/basis/io/monitors/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/monitors/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/monitors/monitors-tests.factor b/basis/io/monitors/monitors-tests.factor index 1cc97753b7..9efa785061 100644 --- a/basis/io/monitors/monitors-tests.factor +++ b/basis/io/monitors/monitors-tests.factor @@ -1,7 +1,9 @@ IN: io.monitors.tests USING: io.monitors tools.test io.files system sequences continuations namespaces concurrency.count-downs kernel io -threads calendar prettyprint destructors io.timeouts ; +threads calendar prettyprint destructors io.timeouts +io.files.temp io.directories io.directories.hierarchy +io.pathnames ; os { winnt linux macosx } member? [ [ diff --git a/basis/io/monitors/monitors.factor b/basis/io/monitors/monitors.factor index 72f2bc80c5..e225e45430 100644 --- a/basis/io/monitors/monitors.factor +++ b/basis/io/monitors/monitors.factor @@ -56,8 +56,8 @@ SYMBOL: +rename-file+ [ ] dip with-disposal ; inline { - { [ os macosx? ] [ "io.unix.macosx.monitors" require ] } - { [ os linux? ] [ "io.unix.linux.monitors" require ] } - { [ os winnt? ] [ "io.windows.nt.monitors" require ] } + { [ os macosx? ] [ "io.monitors.macosx" require ] } + { [ os linux? ] [ "io.monitors.linux" require ] } + { [ os winnt? ] [ "io.monitors.windows.nt" require ] } [ ] } cond diff --git a/basis/io/monitors/recursive/recursive-tests.factor b/basis/io/monitors/recursive/recursive-tests.factor index fba879a6d2..ace93ace44 100644 --- a/basis/io/monitors/recursive/recursive-tests.factor +++ b/basis/io/monitors/recursive/recursive-tests.factor @@ -1,6 +1,7 @@ USING: accessors math kernel namespaces continuations io.files io.monitors io.monitors.recursive io.backend -concurrency.mailboxes tools.test destructors ; +concurrency.mailboxes tools.test destructors io.files.info +io.pathnames io.files.temp io.directories.hierarchy ; IN: io.monitors.recursive.tests \ pump-thread must-infer diff --git a/basis/io/monitors/recursive/recursive.factor b/basis/io/monitors/recursive/recursive.factor index a96c6f04f1..18fa62f6d6 100644 --- a/basis/io/monitors/recursive/recursive.factor +++ b/basis/io/monitors/recursive/recursive.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors sequences assocs arrays continuations destructors combinators kernel threads concurrency.messaging -concurrency.mailboxes concurrency.promises io.files io.monitors -debugger fry ; +concurrency.mailboxes concurrency.promises io.files io.files.info +io.directories io.pathnames io.monitors debugger fry ; IN: io.monitors.recursive ! Simulate recursive monitors on platforms that don't have them diff --git a/basis/io/monitors/windows/nt/authors.txt b/basis/io/monitors/windows/nt/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/io/monitors/windows/nt/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/io/monitors/windows/nt/nt-tests.factor b/basis/io/monitors/windows/nt/nt-tests.factor new file mode 100644 index 0000000000..79cd7e9e9f --- /dev/null +++ b/basis/io/monitors/windows/nt/nt-tests.factor @@ -0,0 +1,4 @@ +IN: io.monitors.windows.nt.tests +USING: io.monitors.windows.nt tools.test ; + +\ fill-queue-thread must-infer diff --git a/basis/io/monitors/windows/nt/nt.factor b/basis/io/monitors/windows/nt/nt.factor new file mode 100755 index 0000000000..d2408a3dd1 --- /dev/null +++ b/basis/io/monitors/windows/nt/nt.factor @@ -0,0 +1,106 @@ +! Copyright (C) 2008 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types alien.strings libc destructors locals +kernel math assocs namespaces make continuations sequences +hashtables sorting arrays combinators math.bitwise strings +system accessors threads splitting io.backend io.backend.windows +io.backend.windows.nt io.files.windows.nt io.monitors io.ports +io.buffers io.files io.timeouts io.encodings.string +io.encodings.utf16n io windows windows.kernel32 windows.types +io.pathnames ; +IN: io.monitors.windows.nt + +: open-directory ( path -- handle ) + normalize-path + FILE_LIST_DIRECTORY + share-mode + f + OPEN_EXISTING + { FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags + f + CreateFile opened-file ; + +TUPLE: win32-monitor-port < input-port recursive ; + +TUPLE: win32-monitor < monitor port ; + +: begin-reading-changes ( port -- overlapped ) + { + [ handle>> handle>> ] + [ buffer>> ptr>> ] + [ buffer>> size>> ] + [ recursive>> 1 0 ? ] + } cleave + FILE_NOTIFY_CHANGE_ALL + 0 + (make-overlapped) + [ f ReadDirectoryChangesW win32-error=0/f ] keep ; + +: read-changes ( port -- bytes-transferred ) + [ + [ begin-reading-changes ] [ twiddle-thumbs ] bi + ] with-destructors ; + +: parse-action ( action -- changed ) + { + { FILE_ACTION_ADDED [ +add-file+ ] } + { FILE_ACTION_REMOVED [ +remove-file+ ] } + { FILE_ACTION_MODIFIED [ +modify-file+ ] } + { FILE_ACTION_RENAMED_OLD_NAME [ +rename-file+ ] } + { FILE_ACTION_RENAMED_NEW_NAME [ +rename-file+ ] } + [ drop +modify-file+ ] + } case 1array ; + +: memory>u16-string ( alien len -- string ) + memory>byte-array utf16n decode ; + +: parse-notify-record ( buffer -- path changed ) + [ + [ FILE_NOTIFY_INFORMATION-FileName ] + [ FILE_NOTIFY_INFORMATION-FileNameLength ] + bi memory>u16-string + ] + [ FILE_NOTIFY_INFORMATION-Action parse-action ] bi ; + +: (file-notify-records) ( buffer -- buffer ) + dup , + dup FILE_NOTIFY_INFORMATION-NextEntryOffset zero? [ + [ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep + (file-notify-records) + ] unless ; + +: file-notify-records ( buffer -- seq ) + [ (file-notify-records) drop ] { } make ; + +:: parse-notify-records ( monitor buffer -- ) + buffer file-notify-records [ + parse-notify-record + [ monitor path>> prepend-path normalize-path ] dip + monitor queue-change + ] each ; + +: fill-queue ( monitor -- ) + dup port>> dup check-disposed + [ buffer>> ptr>> ] [ read-changes zero? ] bi + [ 2dup parse-notify-records ] unless + 2drop ; + +: (fill-queue-thread) ( monitor -- ) + dup fill-queue (fill-queue-thread) ; + +: fill-queue-thread ( monitor -- ) + [ dup fill-queue (fill-queue-thread) ] + [ dup already-disposed? [ 2drop ] [ rethrow ] if ] recover ; + +M:: winnt (monitor) ( path recursive? mailbox -- monitor ) + [ + path normalize-path mailbox win32-monitor new-monitor + path open-directory \ win32-monitor-port + recursive? >>recursive + >>port + dup [ fill-queue-thread ] curry + "Windows monitor thread" spawn drop + ] with-destructors ; + +M: win32-monitor dispose + port>> dispose ; diff --git a/basis/io/monitors/windows/nt/tags.txt b/basis/io/monitors/windows/nt/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/monitors/windows/nt/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/paths/authors.txt b/basis/io/paths/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/io/paths/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/io/paths/paths-tests.factor b/basis/io/paths/paths-tests.factor deleted file mode 100644 index 01763ce5c0..0000000000 --- a/basis/io/paths/paths-tests.factor +++ /dev/null @@ -1,11 +0,0 @@ -USING: io.paths kernel tools.test io.files.unique sequences -io.files namespaces sorting ; -IN: io.paths.tests - -[ t ] [ - [ - 10 [ "io.paths.test" "gogogo" make-unique-file* ] replicate - current-directory get t [ ] find-all-files - ] with-unique-directory - [ natural-sort ] bi@ = -] unit-test diff --git a/basis/io/paths/paths.factor b/basis/io/paths/paths.factor deleted file mode 100755 index 212ba9e396..0000000000 --- a/basis/io/paths/paths.factor +++ /dev/null @@ -1,58 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays deques dlists io.files -kernel sequences system vocabs.loader fry continuations ; -IN: io.paths - -TUPLE: directory-iterator path bfs queue ; - -> swap bfs>> - [ push-front ] [ push-back ] if - ] curry each ; - -: ( path bfs? -- iterator ) - directory-iterator boa - dup path>> over push-directory ; - -: next-file ( iter -- file/f ) - dup queue>> deque-empty? [ drop f ] [ - dup queue>> pop-back dup link-info directory? - [ over push-directory next-file ] [ nip ] if - ] if ; - -: iterate-directory ( iter quot: ( obj -- ? ) -- obj ) - over next-file [ - over call - [ 2nip ] [ iterate-directory ] if* - ] [ - 2drop f - ] if* ; inline recursive - -PRIVATE> - -: find-file ( path bfs? quot: ( obj -- ? ) -- path/f ) - [ ] dip - [ keep and ] curry iterate-directory ; inline - -: each-file ( path bfs? quot: ( obj -- ? ) -- ) - [ ] dip - [ f ] compose iterate-directory drop ; inline - -: find-all-files ( path bfs? quot: ( obj -- ? ) -- paths ) - [ ] dip - pusher [ [ f ] compose iterate-directory drop ] dip ; inline - -: recursive-directory ( path bfs? -- paths ) - [ ] accumulator [ each-file ] dip ; - -: find-in-directories ( directories bfs? quot -- path' ) - '[ _ _ find-file ] attempt-all ; inline - -os windows? [ "io.paths.windows" require ] when diff --git a/basis/io/paths/windows/authors.txt b/basis/io/paths/windows/authors.txt deleted file mode 100644 index 7c1b2f2279..0000000000 --- a/basis/io/paths/windows/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/io/paths/windows/tags.txt b/basis/io/paths/windows/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/paths/windows/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/paths/windows/windows.factor b/basis/io/paths/windows/windows.factor deleted file mode 100644 index b4858aaef8..0000000000 --- a/basis/io/paths/windows/windows.factor +++ /dev/null @@ -1,13 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays continuations fry io.files io.paths -kernel windows.shell32 sequences ; -IN: io.paths.windows - -: program-files-directories ( -- array ) - program-files program-files-x86 2array ; inline - -: find-in-program-files ( base-directory bfs? quot -- path ) - [ - [ program-files-directories ] dip '[ _ append-path ] map - ] 2dip find-in-directories ; inline diff --git a/basis/io/pipes/pipes.factor b/basis/io/pipes/pipes.factor index 3a7fa5a2e0..9cadb3f6cc 100644 --- a/basis/io/pipes/pipes.factor +++ b/basis/io/pipes/pipes.factor @@ -53,7 +53,7 @@ PRIVATE> ] 2parallel-map ; { - { [ os unix? ] [ "io.unix.pipes" require ] } - { [ os winnt? ] [ "io.windows.nt.pipes" require ] } + { [ os unix? ] [ "io.pipes.unix" require ] } + { [ os winnt? ] [ "io.pipes.windows.nt" require ] } [ ] } cond diff --git a/basis/io/pipes/unix/pipes-tests.factor b/basis/io/pipes/unix/pipes-tests.factor new file mode 100644 index 0000000000..ce3f1551b1 --- /dev/null +++ b/basis/io/pipes/unix/pipes-tests.factor @@ -0,0 +1,17 @@ +USING: tools.test io.pipes io.pipes.unix io.encodings.utf8 +io.encodings io namespaces sequences ; +IN: io.pipes.unix.tests + +[ { 0 0 } ] [ { "ls" "grep ." } run-pipeline ] unit-test + +[ { 0 f 0 } ] [ + { + "ls" + [ + input-stream [ utf8 ] change + output-stream [ utf8 ] change + input-stream get lines reverse [ print ] each f + ] + "grep ." + } run-pipeline +] unit-test diff --git a/basis/io/pipes/unix/tags.txt b/basis/io/pipes/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/pipes/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/pipes/unix/unix.factor b/basis/io/pipes/unix/unix.factor new file mode 100644 index 0000000000..acf8b787ed --- /dev/null +++ b/basis/io/pipes/unix/unix.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: system kernel unix math sequences qualified +io.backend.unix io.ports specialized-arrays.int accessors ; +IN: io.pipes.unix +QUALIFIED: io.pipes + +M: unix io.pipes:(pipe) ( -- pair ) + 2 + [ underlying>> pipe io-error ] + [ first2 [ init-fd ] bi@ io.pipes:pipe boa ] bi ; diff --git a/basis/io/pipes/windows/nt/authors.txt b/basis/io/pipes/windows/nt/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/io/pipes/windows/nt/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/io/pipes/windows/nt/nt.factor b/basis/io/pipes/windows/nt/nt.factor new file mode 100644 index 0000000000..cec03cf6d3 --- /dev/null +++ b/basis/io/pipes/windows/nt/nt.factor @@ -0,0 +1,46 @@ +! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types arrays destructors io io.backend.windows libc +windows.types math.bitwise windows.kernel32 windows namespaces +make kernel sequences windows.errors assocs math.parser system +random combinators accessors io.pipes io.ports ; +IN: io.pipes.windows.nt + +! This code is based on +! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py + +: create-named-pipe ( name -- handle ) + { PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED } flags + PIPE_TYPE_BYTE + 1 + 4096 + 4096 + 0 + default-security-attributes + CreateNamedPipe opened-file ; + +: open-other-end ( name -- handle ) + GENERIC_WRITE + { FILE_SHARE_READ FILE_SHARE_WRITE } flags + default-security-attributes + OPEN_EXISTING + FILE_FLAG_OVERLAPPED + f + CreateFile opened-file ; + +: unique-pipe-name ( -- string ) + [ + "\\\\.\\pipe\\factor-" % + pipe counter # + "-" % + 32 random-bits # + "-" % + micros # + ] "" make ; + +M: winnt (pipe) ( -- pipe ) + [ + unique-pipe-name + [ create-named-pipe ] [ open-other-end ] bi + pipe boa + ] with-destructors ; diff --git a/basis/io/pipes/windows/nt/tags.txt b/basis/io/pipes/windows/nt/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/pipes/windows/nt/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor index 60402c37ea..0326969e4f 100644 --- a/basis/io/sockets/secure/openssl/openssl.factor +++ b/basis/io/sockets/secure/openssl/openssl.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors byte-arrays kernel sequences -namespaces math math.order combinators init alien alien.c-types -alien.strings libc continuations destructors summary -splitting assocs random math.parser locals unicode.case openssl -openssl.libcrypto openssl.libssl io.backend io.ports io.files +USING: accessors byte-arrays kernel sequences namespaces math +math.order combinators init alien alien.c-types alien.strings +libc continuations destructors summary splitting assocs random +math.parser locals unicode.case openssl openssl.libcrypto +openssl.libssl io.backend io.ports io.pathnames io.encodings.8-bit io.timeouts io.sockets.secure ; IN: io.sockets.secure.openssl diff --git a/basis/io/sockets/secure/secure.factor b/basis/io/sockets/secure/secure.factor index e752e7c328..c0d70fc047 100644 --- a/basis/io/sockets/secure/secure.factor +++ b/basis/io/sockets/secure/secure.factor @@ -97,6 +97,6 @@ HOOK: send-secure-handshake secure-socket-backend ( -- ) HOOK: accept-secure-handshake secure-socket-backend ( -- ) { - { [ os unix? ] [ "io.unix.sockets.secure" require ] } + { [ os unix? ] [ "io.sockets.secure.unix" require ] } { [ os windows? ] [ "openssl" require ] } } cond diff --git a/basis/io/sockets/secure/unix/debug/debug.factor b/basis/io/sockets/secure/unix/debug/debug.factor new file mode 100644 index 0000000000..d32cdee2ed --- /dev/null +++ b/basis/io/sockets/secure/unix/debug/debug.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors io.sockets.secure kernel ; +IN: io.sockets.secure.unix.debug + +: with-test-context ( quot -- ) + + "resource:basis/openssl/test/server.pem" >>key-file + "resource:basis/openssl/test/dh1024.pem" >>dh-file + "password" >>password + swap with-secure-context ; inline diff --git a/basis/io/sockets/secure/unix/tags.txt b/basis/io/sockets/secure/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/sockets/secure/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/sockets/secure/unix/unix-tests.factor b/basis/io/sockets/secure/unix/unix-tests.factor new file mode 100644 index 0000000000..a3bfacc8a8 --- /dev/null +++ b/basis/io/sockets/secure/unix/unix-tests.factor @@ -0,0 +1,147 @@ +IN: io.sockets.secure.tests +USING: accessors kernel namespaces io io.sockets +io.sockets.secure io.encodings.ascii io.streams.duplex +io.backend.unix classes words destructors threads tools.test +concurrency.promises byte-arrays locals calendar io.timeouts +io.sockets.secure.unix.debug ; + +\ must-infer +{ 1 0 } [ [ ] with-secure-context ] must-infer-as + +[ ] [ "port" set ] unit-test + +:: server-test ( quot -- ) + [ + [ + "127.0.0.1" 0 ascii [ + dup addr>> addrspec>> port>> "port" get fulfill + accept [ + quot call + ] curry with-stream + ] with-disposal + ] with-test-context + ] "SSL server test" spawn drop ; + +: client-test ( -- string ) + [ + "127.0.0.1" "port" get ?promise ascii drop contents + ] with-secure-context ; + +[ ] [ [ class name>> write ] server-test ] unit-test + +[ "secure" ] [ client-test ] unit-test + +! Now, see what happens if the server closes the connection prematurely +[ ] [ "port" set ] unit-test + +[ ] [ + [ + drop + "hello" write flush + input-stream get stream>> handle>> f >>connected drop + ] server-test +] unit-test + +[ client-test ] [ premature-close? ] must-fail-with + +! Now, try validating the certificate. This should fail because its +! actually an invalid certificate +[ ] [ "port" set ] unit-test + +[ ] [ [ drop "hi" write ] server-test ] unit-test + +[ + [ + "localhost" "port" get ?promise ascii + drop dispose + ] with-secure-context +] [ certificate-verify-error? ] must-fail-with + +! Client-side handshake timeout +[ ] [ "port" set ] unit-test + +[ ] [ + [ + "127.0.0.1" 0 ascii [ + dup addr>> port>> "port" get fulfill + accept drop 1 minutes sleep dispose + ] with-disposal + ] "Silly server" spawn drop +] unit-test + +[ + 1 seconds secure-socket-timeout [ + client-test + ] with-variable +] [ io-timeout? ] must-fail-with + +! Server-side handshake timeout +[ ] [ "port" set ] unit-test + +[ ] [ + [ + "127.0.0.1" "port" get ?promise + ascii drop 1 minutes sleep dispose + ] "Silly client" spawn drop +] unit-test + +[ + 1 seconds secure-socket-timeout [ + [ + "127.0.0.1" 0 ascii [ + dup addr>> addrspec>> port>> "port" get fulfill + accept drop dup stream-read1 drop dispose + ] with-disposal + ] with-test-context + ] with-variable +] [ io-timeout? ] must-fail-with + +! Client socket shutdown timeout + +! Until I sort out two-stage handshaking, I can't do much here +[ + [ ] [ "port" set ] unit-test + + [ ] [ + [ + [ + "127.0.0.1" 0 ascii [ + dup addr>> addrspec>> port>> "port" get fulfill + accept drop 1 minutes sleep dispose + ] with-disposal + ] with-test-context + ] "Silly server" spawn drop + ] unit-test + + [ + 1 seconds secure-socket-timeout [ + [ + "127.0.0.1" "port" get ?promise + ascii drop dispose + ] with-secure-context + ] with-variable + ] [ io-timeout? ] must-fail-with + + ! Server socket shutdown timeout + [ ] [ "port" set ] unit-test + + [ ] [ + [ + [ + "127.0.0.1" "port" get ?promise + ascii drop 1 minutes sleep dispose + ] with-test-context + ] "Silly client" spawn drop + ] unit-test + + [ + 1 seconds secure-socket-timeout [ + [ + "127.0.0.1" 0 ascii [ + dup addr>> addrspec>> port>> "port" get fulfill + accept drop dispose + ] with-disposal + ] with-test-context + ] with-variable + ] [ io-timeout? ] must-fail-with +] drop diff --git a/basis/io/sockets/secure/unix/unix.factor b/basis/io/sockets/secure/unix/unix.factor new file mode 100644 index 0000000000..8419246eb6 --- /dev/null +++ b/basis/io/sockets/secure/unix/unix.factor @@ -0,0 +1,200 @@ +! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors unix byte-arrays kernel sequences +namespaces math math.order combinators init alien alien.c-types +alien.strings libc continuations destructors openssl +openssl.libcrypto openssl.libssl io io.files io.ports +io.backend.unix io.sockets.unix io.encodings.ascii io.buffers +io.sockets io.sockets.secure io.sockets.secure.openssl +io.timeouts system summary fry ; +IN: io.sockets.secure.unix + +M: ssl-handle handle-fd file>> handle-fd ; + +: syscall-error ( r -- * ) + ERR_get_error dup zero? [ + drop + { + { -1 [ err_no ECONNRESET = [ premature-close ] [ (io-error) ] if ] } + { 0 [ premature-close ] } + } case + ] [ nip (ssl-error) ] if ; + +: check-accept-response ( handle r -- event ) + over handle>> over SSL_get_error + { + { SSL_ERROR_NONE [ 2drop f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_ACCEPT [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_ZERO_RETURN [ (ssl-error) ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +: do-ssl-accept ( ssl-handle -- ) + dup dup handle>> SSL_accept check-accept-response dup + [ [ dup file>> ] dip wait-for-fd do-ssl-accept ] [ 2drop ] if ; + +: maybe-handshake ( ssl-handle -- ) + dup connected>> [ drop ] [ + t >>connected + [ do-ssl-accept ] with-timeout + ] if ; + +: check-response ( port r -- port r n ) + over handle>> handle>> over SSL_get_error ; inline + +! Input ports +: check-read-response ( port r -- event ) + check-response + { + { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] } + { SSL_ERROR_ZERO_RETURN [ 2drop f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +M: ssl-handle refill + dup maybe-handshake + handle>> ! ssl + over buffer>> + [ buffer-end ] ! buf + [ buffer-capacity ] bi ! len + SSL_read + check-read-response ; + +! Output ports +: check-write-response ( port r -- event ) + check-response + { + { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +M: ssl-handle drain + dup maybe-handshake + handle>> ! ssl + over buffer>> + [ buffer@ ] ! buf + [ buffer-length ] bi ! len + SSL_write + check-write-response ; + +M: ssl-handle cancel-operation + file>> cancel-operation ; + +M: ssl-handle timeout + drop secure-socket-timeout get ; + +! Client sockets +: ( fd -- ssl ) + [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep + [ handle>> swap dup SSL_set_bio ] keep ; + +M: secure ((client)) ( addrspec -- handle ) + addrspec>> ((client)) ; + +M: secure parse-sockaddr addrspec>> parse-sockaddr ; + +M: secure (get-local-address) addrspec>> (get-local-address) ; + +: check-connect-response ( ssl-handle r -- event ) + over handle>> over SSL_get_error + { + { SSL_ERROR_NONE [ 2drop f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +: do-ssl-connect ( ssl-handle -- ) + dup dup handle>> SSL_connect check-connect-response dup + [ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ; + +: resume-session ( ssl-handle ssl-session -- ) + [ [ handle>> ] dip SSL_set_session ssl-error ] + [ drop do-ssl-connect ] + 2bi ; + +: begin-session ( ssl-handle addrspec -- ) + [ drop do-ssl-connect ] + [ [ handle>> SSL_get1_session ] dip save-session ] + 2bi ; + +: secure-connection ( client-out addrspec -- ) + [ handle>> ] dip + [ + '[ + _ dup get-session + [ resume-session ] [ begin-session ] ?if + ] with-timeout + ] [ drop t >>connected drop ] 2bi ; + +M: secure establish-connection ( client-out remote -- ) + addrspec>> [ establish-connection ] [ secure-connection ] 2bi ; + +M: secure (server) addrspec>> (server) ; + +M: secure (accept) + [ + addrspec>> (accept) [ |dispose ] dip + ] with-destructors ; + +: check-shutdown-response ( handle r -- event ) + #! We don't do two-step shutdown here because I couldn't + #! figure out how to do it with non-blocking BIOs. Also, it + #! seems that SSL_shutdown always returns 0 -- this sounds + #! like a bug + over handle>> over SSL_get_error + { + { SSL_ERROR_NONE [ 2drop f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ dup zero? [ 2drop f ] [ syscall-error ] if ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +: (shutdown) ( handle -- ) + dup dup handle>> SSL_shutdown check-shutdown-response + dup [ dupd wait-for-fd (shutdown) ] [ 2drop ] if ; + +M: ssl-handle shutdown + dup connected>> [ + f >>connected [ (shutdown) ] with-timeout + ] [ drop ] if ; + +: check-buffer ( port -- port ) + dup buffer>> buffer-empty? [ upgrade-buffers-full ] unless ; + +: input/output-ports ( -- input output ) + input-stream output-stream + [ get underlying-port check-buffer ] bi@ + 2dup [ handle>> ] bi@ eq? [ upgrade-on-non-socket ] unless ; + +: make-input/output-secure ( input output -- ) + dup handle>> fd? [ upgrade-on-non-socket ] unless + [ ] change-handle + handle>> >>handle drop ; + +: (send-secure-handshake) ( output -- ) + remote-address get [ upgrade-on-non-socket ] unless* + secure-connection ; + +M: openssl send-secure-handshake + input/output-ports + [ make-input/output-secure ] keep + [ (send-secure-handshake) ] keep + remote-address get dup inet? [ + host>> swap handle>> check-certificate + ] [ 2drop ] if ; + +M: openssl accept-secure-handshake + input/output-ports + make-input/output-secure ; diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 597aa61138..8268030ace 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -318,7 +318,6 @@ M: inet (server) invalid-inet-server ; { - { [ os unix? ] [ "io.unix.sockets" require ] } - { [ os winnt? ] [ "io.windows.nt.sockets" require ] } - { [ os wince? ] [ "io.windows.ce.sockets" require ] } + { [ os unix? ] [ "io.sockets.unix" require ] } + { [ os winnt? ] [ "io.sockets.windows.nt" require ] } } cond diff --git a/basis/io/sockets/unix/authors.txt b/basis/io/sockets/unix/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/io/sockets/unix/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/io/sockets/unix/summary.txt b/basis/io/sockets/unix/summary.txt new file mode 100644 index 0000000000..22342ec413 --- /dev/null +++ b/basis/io/sockets/unix/summary.txt @@ -0,0 +1 @@ +Implementation of TCP/IP and UDP/IP sockets on Unix-like systems diff --git a/basis/io/sockets/unix/tags.txt b/basis/io/sockets/unix/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/sockets/unix/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor new file mode 100644 index 0000000000..1dc92d7d08 --- /dev/null +++ b/basis/io/sockets/unix/unix.factor @@ -0,0 +1,155 @@ +! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types alien.strings generic kernel math +namespaces threads sequences byte-arrays io.ports +io.binary io.backend.unix io.streams.duplex +io.backend io.ports io.pathnames io.files.private +io.encodings.utf8 math.parser continuations libc combinators +system accessors qualified destructors unix locals init ; + +EXCLUDE: io => read write close ; +EXCLUDE: io.sockets => accept ; + +IN: io.sockets.unix + +: socket-fd ( domain type -- fd ) + 0 socket dup io-error init-fd |dispose ; + +: set-socket-option ( fd level opt -- ) + [ handle-fd ] 2dip 1 "int" heap-size setsockopt io-error ; + +M: unix addrinfo-error ( n -- ) + dup zero? [ drop ] [ gai_strerror throw ] if ; + +! Client sockets - TCP and Unix domain +M: object (get-local-address) ( handle remote -- sockaddr ) + [ handle-fd ] dip empty-sockaddr/size + [ getsockname io-error ] 2keep drop ; + +M: object (get-remote-address) ( handle local -- sockaddr ) + [ handle-fd ] dip empty-sockaddr/size + [ getpeername io-error ] 2keep drop ; + +: init-client-socket ( fd -- ) + SOL_SOCKET SO_OOBINLINE set-socket-option ; + +: wait-to-connect ( port -- ) + dup handle>> handle-fd f 0 write + { + { [ 0 = ] [ drop ] } + { [ err_no EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] } + { [ err_no EINTR = ] [ wait-to-connect ] } + [ (io-error) ] + } cond ; + +M: object establish-connection ( client-out remote -- ) + [ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi + { + { [ 0 = ] [ drop ] } + { [ err_no EINPROGRESS = ] [ + [ +output+ wait-for-port ] [ wait-to-connect ] bi + ] } + [ (io-error) ] + } cond ; + +M: object ((client)) ( addrspec -- fd ) + protocol-family SOCK_STREAM socket-fd dup init-client-socket ; + +! Server sockets - TCP and Unix domain +: init-server-socket ( fd -- ) + SOL_SOCKET SO_REUSEADDR set-socket-option ; + +: server-socket-fd ( addrspec type -- fd ) + [ dup protocol-family ] dip socket-fd + dup init-server-socket + dup handle-fd rot make-sockaddr/size bind io-error ; + +M: object (server) ( addrspec -- handle ) + [ + SOCK_STREAM server-socket-fd + dup handle-fd 128 listen io-error + ] with-destructors ; + +: do-accept ( server addrspec -- fd sockaddr ) + [ handle>> handle-fd ] [ empty-sockaddr/size ] bi* + [ accept ] 2keep drop ; inline + +M: object (accept) ( server addrspec -- fd sockaddr ) + 2dup do-accept + { + { [ over 0 >= ] [ [ 2nip init-fd ] dip ] } + { [ err_no EINTR = ] [ 2drop (accept) ] } + { [ err_no EAGAIN = ] [ + 2drop + [ drop +input+ wait-for-port ] + [ (accept) ] + 2bi + ] } + [ (io-error) ] + } cond ; + +! Datagram sockets - UDP and Unix domain +M: unix (datagram) + [ SOCK_DGRAM server-socket-fd ] with-destructors ; + +SYMBOL: receive-buffer + +: packet-size 65536 ; inline + +[ packet-size malloc receive-buffer set-global ] "io.sockets.unix" add-init-hook + +:: do-receive ( port -- packet sockaddr ) + port addr>> empty-sockaddr/size [| sockaddr len | + port handle>> handle-fd ! s + receive-buffer get-global ! buf + packet-size ! nbytes + 0 ! flags + sockaddr ! from + len ! fromlen + recvfrom dup 0 >= [ + receive-buffer get-global swap memory>byte-array sockaddr + ] [ + drop f f + ] if + ] call ; + +M: unix (receive) ( datagram -- packet sockaddr ) + dup do-receive dup [ [ drop ] 2dip ] [ + 2drop [ +input+ wait-for-port ] [ (receive) ] bi + ] if ; + +:: do-send ( packet sockaddr len socket datagram -- ) + socket handle-fd packet dup length 0 sockaddr len sendto + 0 < [ + err_no EINTR = [ + packet sockaddr len socket datagram do-send + ] [ + err_no EAGAIN = [ + datagram +output+ wait-for-port + packet sockaddr len socket datagram do-send + ] [ + (io-error) + ] if + ] if + ] when ; + +M: unix (send) ( packet addrspec datagram -- ) + [ make-sockaddr/size ] [ [ handle>> ] keep ] bi* do-send ; + +! Unix domain sockets +M: local protocol-family drop PF_UNIX ; + +M: local sockaddr-size drop "sockaddr-un" heap-size ; + +M: local empty-sockaddr drop "sockaddr-un" ; + +M: local make-sockaddr + path>> (normalize-path) + dup length 1 + max-un-path > [ "Path too long" throw ] when + "sockaddr-un" + AF_UNIX over set-sockaddr-un-family + dup sockaddr-un-path rot utf8 string>alien dup length memcpy ; + +M: local parse-sockaddr + drop + sockaddr-un-path utf8 alien>string ; diff --git a/basis/io/sockets/windows/nt/authors.txt b/basis/io/sockets/windows/nt/authors.txt new file mode 100755 index 0000000000..026f4cd0de --- /dev/null +++ b/basis/io/sockets/windows/nt/authors.txt @@ -0,0 +1,3 @@ +Doug Coleman +Slava Pestov +Mackenzie Straight diff --git a/basis/io/sockets/windows/nt/nt.factor b/basis/io/sockets/windows/nt/nt.factor new file mode 100644 index 0000000000..f6a1bcfcb0 --- /dev/null +++ b/basis/io/sockets/windows/nt/nt.factor @@ -0,0 +1,216 @@ +USING: alien alien.accessors alien.c-types byte-arrays +continuations destructors io.ports io.timeouts io.sockets +io.sockets io namespaces io.streams.duplex io.backend.windows +io.sockets.windows io.backend.windows.nt windows.winsock kernel +libc math sequences threads system combinators accessors ; +IN: io.sockets.windows.nt + +: malloc-int ( object -- object ) + "int" heap-size malloc tuck 0 set-alien-signed-4 ; inline + +M: winnt WSASocket-flags ( -- DWORD ) + WSA_FLAG_OVERLAPPED ; + +: get-ConnectEx-ptr ( socket -- void* ) + SIO_GET_EXTENSION_FUNCTION_POINTER + WSAID_CONNECTEX + "GUID" heap-size + "void*" + [ + "void*" heap-size + "DWORD" + f + f + WSAIoctl SOCKET_ERROR = [ + winsock-error-string throw + ] when + ] keep *void* ; + +TUPLE: ConnectEx-args port + s name namelen lpSendBuffer dwSendDataLength + lpdwBytesSent lpOverlapped ptr ; + +: wait-for-socket ( args -- n ) + [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline + +: ( sockaddr size -- ConnectEx ) + ConnectEx-args new + swap >>namelen + swap >>name + f >>lpSendBuffer + 0 >>dwSendDataLength + f >>lpdwBytesSent + (make-overlapped) >>lpOverlapped ; inline + +: call-ConnectEx ( ConnectEx -- ) + { + [ s>> ] + [ name>> ] + [ namelen>> ] + [ lpSendBuffer>> ] + [ dwSendDataLength>> ] + [ lpdwBytesSent>> ] + [ lpOverlapped>> ] + [ ptr>> ] + } cleave + "int" + { "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" } + "stdcall" alien-indirect drop + winsock-error-string [ throw ] when* ; inline + +M: object establish-connection ( client-out remote -- ) + make-sockaddr/size + swap >>port + dup port>> handle>> handle>> >>s + dup s>> get-ConnectEx-ptr >>ptr + dup call-ConnectEx + wait-for-socket drop ; + +TUPLE: AcceptEx-args port + sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength + dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ; + +: init-accept-buffer ( addr AcceptEx -- ) + swap sockaddr-size 16 + + [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi + dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer + drop ; inline + +: ( server addr -- AcceptEx ) + AcceptEx-args new + 2dup init-accept-buffer + swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket + over handle>> handle>> >>sListenSocket + swap >>port + 0 >>dwReceiveDataLength + f >>lpdwBytesReceived + (make-overlapped) >>lpOverlapped ; inline + +: call-AcceptEx ( AcceptEx -- ) + { + [ sListenSocket>> ] + [ sAcceptSocket>> ] + [ lpOutputBuffer>> ] + [ dwReceiveDataLength>> ] + [ dwLocalAddressLength>> ] + [ dwRemoteAddressLength>> ] + [ lpdwBytesReceived>> ] + [ lpOverlapped>> ] + } cleave AcceptEx drop + winsock-error-string [ throw ] when* ; inline + +: extract-remote-address ( AcceptEx -- sockaddr ) + { + [ lpOutputBuffer>> ] + [ dwReceiveDataLength>> ] + [ dwLocalAddressLength>> ] + [ dwRemoteAddressLength>> ] + } cleave + f + 0 + f + [ 0 GetAcceptExSockaddrs ] keep *void* ; inline + +M: object (accept) ( server addr -- handle sockaddr ) + [ + + { + [ call-AcceptEx ] + [ wait-for-socket drop ] + [ sAcceptSocket>> ] + [ extract-remote-address ] + } cleave + ] with-destructors ; + +TUPLE: WSARecvFrom-args port + s lpBuffers dwBufferCount lpNumberOfBytesRecvd + lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ; + +: make-receive-buffer ( -- WSABUF ) + "WSABUF" malloc-object &free + default-buffer-size get over set-WSABUF-len + default-buffer-size get malloc &free over set-WSABUF-buf ; inline + +: ( datagram -- WSARecvFrom ) + WSARecvFrom-args new + swap >>port + dup port>> handle>> handle>> >>s + dup port>> addr>> sockaddr-size + [ malloc &free >>lpFrom ] + [ malloc-int &free >>lpFromLen ] bi + make-receive-buffer >>lpBuffers + 1 >>dwBufferCount + 0 malloc-int &free >>lpFlags + 0 malloc-int &free >>lpNumberOfBytesRecvd + (make-overlapped) >>lpOverlapped ; inline + +: call-WSARecvFrom ( WSARecvFrom -- ) + { + [ s>> ] + [ lpBuffers>> ] + [ dwBufferCount>> ] + [ lpNumberOfBytesRecvd>> ] + [ lpFlags>> ] + [ lpFrom>> ] + [ lpFromLen>> ] + [ lpOverlapped>> ] + [ lpCompletionRoutine>> ] + } cleave WSARecvFrom socket-error* ; inline + +: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr ) + [ lpBuffers>> WSABUF-buf swap memory>byte-array ] + [ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline + +M: winnt (receive) ( datagram -- packet addrspec ) + [ + + [ call-WSARecvFrom ] + [ wait-for-socket ] + [ parse-WSARecvFrom ] + tri + ] with-destructors ; + +TUPLE: WSASendTo-args port + s lpBuffers dwBufferCount lpNumberOfBytesSent + dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ; + +: make-send-buffer ( packet -- WSABUF ) + "WSABUF" malloc-object &free + [ [ malloc-byte-array &free ] dip set-WSABUF-buf ] + [ [ length ] dip set-WSABUF-len ] + [ nip ] + 2tri ; inline + +: ( packet addrspec datagram -- WSASendTo ) + WSASendTo-args new + swap >>port + dup port>> handle>> handle>> >>s + swap make-sockaddr/size + [ malloc-byte-array &free ] dip + [ >>lpTo ] [ >>iToLen ] bi* + swap make-send-buffer >>lpBuffers + 1 >>dwBufferCount + 0 >>dwFlags + 0 >>lpNumberOfBytesSent + (make-overlapped) >>lpOverlapped ; inline + +: call-WSASendTo ( WSASendTo -- ) + { + [ s>> ] + [ lpBuffers>> ] + [ dwBufferCount>> ] + [ lpNumberOfBytesSent>> ] + [ dwFlags>> ] + [ lpTo>> ] + [ iToLen>> ] + [ lpOverlapped>> ] + [ lpCompletionRoutine>> ] + } cleave WSASendTo socket-error* ; inline + +M: winnt (send) ( packet addrspec datagram -- ) + [ + + [ call-WSASendTo ] + [ wait-for-socket drop ] + bi + ] with-destructors ; diff --git a/basis/io/sockets/windows/nt/tags.txt b/basis/io/sockets/windows/nt/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/sockets/windows/nt/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/sockets/windows/tags.txt b/basis/io/sockets/windows/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/io/sockets/windows/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/io/sockets/windows/windows.factor b/basis/io/sockets/windows/windows.factor new file mode 100644 index 0000000000..29009403fc --- /dev/null +++ b/basis/io/sockets/windows/windows.factor @@ -0,0 +1,61 @@ +USING: kernel accessors io.sockets io.backend.windows io.backend +windows.winsock system destructors alien.c-types ; +IN: io.sockets.windows + +HOOK: WSASocket-flags io-backend ( -- DWORD ) + +TUPLE: win32-socket < win32-file ; + +: ( handle -- win32-socket ) + win32-socket new-win32-handle ; + +M: win32-socket dispose ( stream -- ) + handle>> closesocket drop ; + +: unspecific-sockaddr/size ( addrspec -- sockaddr len ) + [ empty-sockaddr/size ] [ protocol-family ] bi + pick set-sockaddr-in-family ; + +: opened-socket ( handle -- win32-socket ) + |dispose dup add-completion ; + +: open-socket ( addrspec type -- win32-socket ) + [ protocol-family ] dip + 0 f 0 WSASocket-flags WSASocket + dup socket-error + opened-socket ; + +M: object (get-local-address) ( socket addrspec -- sockaddr ) + [ handle>> ] dip empty-sockaddr/size + [ getsockname socket-error ] 2keep drop ; + +M: object (get-remote-address) ( socket addrspec -- sockaddr ) + [ handle>> ] dip empty-sockaddr/size + [ getpeername socket-error ] 2keep drop ; + +: bind-socket ( win32-socket sockaddr len -- ) + [ handle>> ] 2dip bind socket-error ; + +M: object ((client)) ( addrspec -- handle ) + [ SOCK_STREAM open-socket ] keep + [ unspecific-sockaddr/size bind-socket ] [ drop ] 2bi ; + +: server-socket ( addrspec type -- fd ) + [ open-socket ] [ drop ] 2bi + [ make-sockaddr/size bind-socket ] [ drop ] 2bi ; + +! http://support.microsoft.com/kb/127144 +! NOTE: Possibly tweak this because of SYN flood attacks +: listen-backlog ( -- n ) HEX: 7fffffff ; inline + +M: object (server) ( addrspec -- handle ) + [ + SOCK_STREAM server-socket + dup handle>> listen-backlog listen winsock-return-check + ] with-destructors ; + +M: windows (datagram) ( addrspec -- handle ) + [ SOCK_DGRAM server-socket ] with-destructors ; + +M: windows addrinfo-error ( n -- ) + winsock-return-check ; diff --git a/basis/io/unix/authors.txt b/basis/io/unix/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/basis/io/unix/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/io/unix/backend/authors.txt b/basis/io/unix/backend/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/basis/io/unix/backend/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/io/unix/backend/backend.factor b/basis/io/unix/backend/backend.factor deleted file mode 100644 index 41bd03a58b..0000000000 --- a/basis/io/unix/backend/backend.factor +++ /dev/null @@ -1,185 +0,0 @@ -! Copyright (C) 2004, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.syntax generic assocs kernel -kernel.private math io.ports sequences strings sbufs threads -unix vectors io.buffers io.backend io.encodings math.parser -continuations system libc qualified namespaces make io.timeouts -io.encodings.utf8 destructors accessors summary combinators -locals unix.time fry io.unix.multiplexers ; -QUALIFIED: io -IN: io.unix.backend - -GENERIC: handle-fd ( handle -- fd ) - -TUPLE: fd fd disposed ; - -: init-fd ( fd -- fd ) - [ - |dispose - dup fd>> F_SETFL O_NONBLOCK fcntl io-error - dup fd>> F_SETFD FD_CLOEXEC fcntl io-error - ] with-destructors ; - -: ( n -- fd ) - #! We drop the error code rather than calling io-error, - #! since on OS X 10.3, this operation fails from init-io - #! when running the Factor.app (presumably because fd 0 and - #! 1 are closed). - f fd boa ; - -M: fd dispose - dup disposed>> [ drop ] [ - [ cancel-operation ] - [ t >>disposed drop ] - [ fd>> close-file ] - tri - ] if ; - -M: fd handle-fd dup check-disposed fd>> ; - -M: fd cancel-operation ( fd -- ) - dup disposed>> [ drop ] [ - fd>> - mx get-global - [ remove-input-callbacks [ t swap resume-with ] each ] - [ remove-output-callbacks [ t swap resume-with ] each ] - 2bi - ] if ; - -SYMBOL: +retry+ ! just try the operation again without blocking -SYMBOL: +input+ -SYMBOL: +output+ - -ERROR: io-timeout ; - -M: io-timeout summary drop "I/O operation timed out" ; - -: wait-for-fd ( handle event -- ) - dup +retry+ eq? [ 2drop ] [ - '[ - swap handle-fd mx get-global _ { - { +input+ [ add-input-callback ] } - { +output+ [ add-output-callback ] } - } case - ] "I/O" suspend nip [ io-timeout ] when - ] if ; - -: wait-for-port ( port event -- ) - '[ handle>> _ wait-for-fd ] with-timeout ; - -! Some general stuff -: file-mode OCT: 0666 ; - -! Readers -: (refill) ( port -- n ) - [ handle>> ] - [ buffer>> buffer-end ] - [ buffer>> buffer-capacity ] tri read ; - -! Returns an event to wait for which will ensure completion of -! this request -GENERIC: refill ( port handle -- event/f ) - -M: fd refill - fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read - { - { [ dup 0 >= ] [ swap buffer>> n>buffer f ] } - { [ err_no EINTR = ] [ 2drop +retry+ ] } - { [ err_no EAGAIN = ] [ 2drop +input+ ] } - [ (io-error) ] - } cond ; - -M: unix (wait-to-read) ( port -- ) - dup - dup handle>> dup check-disposed refill dup - [ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ; - -! Writers -GENERIC: drain ( port handle -- event/f ) - -M: fd drain - fd>> over buffer>> [ buffer@ ] [ buffer-length ] bi write - { - { [ dup 0 >= ] [ - over buffer>> buffer-consume - buffer>> buffer-empty? f +output+ ? - ] } - { [ err_no EINTR = ] [ 2drop +retry+ ] } - { [ err_no EAGAIN = ] [ 2drop +output+ ] } - [ (io-error) ] - } cond ; - -M: unix (wait-to-write) ( port -- ) - dup - dup handle>> dup check-disposed drain - dup [ wait-for-port ] [ 2drop ] if ; - -M: unix io-multiplex ( ms/f -- ) - mx get-global wait-for-events ; - -! On Unix, you're not supposed to set stdin to non-blocking -! because the fd might be shared with another process (either -! parent or child). So what we do is have the VM start a thread -! which pumps data from the real stdin to a pipe. We set the -! pipe to non-blocking, and read from it instead of the real -! stdin. Very crufty, but it will suffice until we get native -! threading support at the language level. -TUPLE: stdin control size data disposed ; - -M: stdin dispose* - [ - [ control>> &dispose drop ] - [ size>> &dispose drop ] - [ data>> &dispose drop ] - tri - ] with-destructors ; - -: wait-for-stdin ( stdin -- n ) - [ control>> CHAR: X over io:stream-write1 io:stream-flush ] - [ size>> "ssize_t" heap-size swap io:stream-read *int ] - bi ; - -:: refill-stdin ( buffer stdin size -- ) - stdin data>> handle-fd buffer buffer-end size read - dup 0 < [ - drop - err_no EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if - ] [ - size = [ "Error reading stdin pipe" throw ] unless - size buffer n>buffer - ] if ; - -M: stdin refill - [ buffer>> ] [ dup wait-for-stdin ] bi* refill-stdin f ; - -: control-write-fd ( -- fd ) &: control_write *uint ; - -: size-read-fd ( -- fd ) &: size_read *uint ; - -: data-read-fd ( -- fd ) &: stdin_read *uint ; - -: ( -- stdin ) - stdin new - control-write-fd >>control - size-read-fd init-fd >>size - data-read-fd >>data ; - -M: unix (init-stdio) ( -- ) - - 1 - 2 ; - -! mx io-task for embedding an fd-based mx inside another mx -TUPLE: mx-port < port mx ; - -: ( mx -- port ) - dup fd>> mx-port swap >>mx ; - -: multiplexer-error ( n -- n ) - dup 0 < [ - err_no [ EAGAIN = ] [ EINTR = ] bi or - [ drop 0 ] [ (io-error) ] if - ] when ; - -: ?flag ( n mask symbol -- n ) - pick rot bitand 0 > [ , ] [ drop ] if ; diff --git a/basis/io/unix/backend/summary.txt b/basis/io/unix/backend/summary.txt deleted file mode 100644 index 8f66d889cc..0000000000 --- a/basis/io/unix/backend/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Non-blocking I/O and sockets on Unix-like systems diff --git a/basis/io/unix/backend/tags.txt b/basis/io/unix/backend/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/backend/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/bsd/authors.txt b/basis/io/unix/bsd/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/basis/io/unix/bsd/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/io/unix/bsd/bsd.factor b/basis/io/unix/bsd/bsd.factor deleted file mode 100644 index 83f063d713..0000000000 --- a/basis/io/unix/bsd/bsd.factor +++ /dev/null @@ -1,13 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces system kernel accessors assocs continuations -unix io.backend io.unix.backend io.unix.multiplexers -io.unix.multiplexers.kqueue ; -IN: io.unix.bsd - -M: bsd init-io ( -- ) - mx set-global ; - -! M: bsd (monitor) ( path recursive? mailbox -- ) -! swap [ "Recursive kqueue monitors not supported" throw ] when -! ; diff --git a/basis/io/unix/bsd/tags.txt b/basis/io/unix/bsd/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/bsd/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/epoll/authors.txt b/basis/io/unix/epoll/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/basis/io/unix/epoll/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/io/unix/epoll/epoll.factor b/basis/io/unix/epoll/epoll.factor deleted file mode 100644 index 93d0b4aa99..0000000000 --- a/basis/io/unix/epoll/epoll.factor +++ /dev/null @@ -1,63 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types kernel io.ports io.unix.backend -bit-arrays sequences assocs struct-arrays math namespaces locals -fry unix unix.linux.epoll unix.time ; -IN: io.unix.epoll - -TUPLE: epoll-mx < mx events ; - -: max-events ( -- n ) - #! We read up to 256 events at a time. This is an arbitrary - #! constant... - 256 ; inline - -: ( -- mx ) - epoll-mx new-mx - max-events epoll_create dup io-error >>fd - max-events "epoll-event" >>events ; - -: make-event ( fd events -- event ) - "epoll-event" - [ set-epoll-event-events ] keep - [ set-epoll-event-fd ] keep ; - -:: do-epoll-ctl ( fd mx what events -- ) - mx fd>> what fd fd events make-event epoll_ctl io-error ; - -: do-epoll-add ( fd mx events -- ) - EPOLL_CTL_ADD swap EPOLLONESHOT bitor do-epoll-ctl ; - -: do-epoll-del ( fd mx events -- ) - EPOLL_CTL_DEL swap do-epoll-ctl ; - -M: epoll-mx add-input-callback ( thread fd mx -- ) - [ EPOLLIN do-epoll-add ] [ call-next-method ] 2bi ; - -M: epoll-mx add-output-callback ( thread fd mx -- ) - [ EPOLLOUT do-epoll-add ] [ call-next-method ] 2bi ; - -M: epoll-mx remove-input-callbacks ( fd mx -- seq ) - 2dup reads>> key? [ - [ call-next-method ] [ EPOLLIN do-epoll-del ] 2bi - ] [ 2drop f ] if ; - -M: epoll-mx remove-output-callbacks ( fd mx -- seq ) - 2dup writes>> key? [ - [ EPOLLOUT do-epoll-del ] [ call-next-method ] 2bi - ] [ 2drop f ] if ; - -: wait-event ( mx us -- n ) - [ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi* - epoll_wait multiplexer-error ; - -: handle-event ( event mx -- ) - [ epoll-event-fd ] dip - [ EPOLLIN EPOLLOUT bitor do-epoll-del ] - [ input-available ] [ output-available ] 2tri ; - -: handle-events ( mx n -- ) - [ dup events>> ] dip head-slice swap '[ _ handle-event ] each ; - -M: epoll-mx wait-for-events ( us mx -- ) - swap 60000000 or dupd wait-event handle-events ; diff --git a/basis/io/unix/epoll/tags.txt b/basis/io/unix/epoll/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/epoll/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/files/authors.txt b/basis/io/unix/files/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/basis/io/unix/files/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/io/unix/files/bsd/bsd.factor b/basis/io/unix/files/bsd/bsd.factor deleted file mode 100644 index 3c94baa39a..0000000000 --- a/basis/io/unix/files/bsd/bsd.factor +++ /dev/null @@ -1,20 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel alien.syntax math io.unix.files system -unix.stat accessors combinators calendar.unix ; -IN: io.unix.files.bsd - -TUPLE: bsd-file-info < unix-file-info birth-time flags gen ; - -M: bsd new-file-info ( -- class ) bsd-file-info new ; - -M: bsd stat>file-info ( stat -- file-info ) - [ call-next-method ] keep - { - [ stat-st_flags >>flags ] - [ stat-st_gen >>gen ] - [ - stat-st_birthtimespec timespec>unix-time - >>birth-time - ] - } cleave ; diff --git a/basis/io/unix/files/bsd/tags.txt b/basis/io/unix/files/bsd/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/files/bsd/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/files/files-docs.factor b/basis/io/unix/files/files-docs.factor deleted file mode 100644 index 3798380e0f..0000000000 --- a/basis/io/unix/files/files-docs.factor +++ /dev/null @@ -1,277 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: classes help.markup help.syntax io.streams.string -strings math calendar io.files ; -IN: io.unix.files - -HELP: file-group-id -{ $values - { "path" "a pathname string" } - { "gid" integer } } -{ $description "Returns the group id for a given file." } ; - -HELP: file-group-name -{ $values - { "path" "a pathname string" } - { "string" string } } -{ $description "Returns the group name for a given file." } ; - -HELP: file-permissions -{ $values - { "path" "a pathname string" } - { "n" integer } } -{ $description "Returns the Unix file permissions for a given file." } ; - -HELP: file-username -{ $values - { "path" "a pathname string" } - { "string" string } } -{ $description "Returns the username for a given file." } ; - -HELP: file-user-id -{ $values - { "path" "a pathname string" } - { "uid" integer } } -{ $description "Returns the user id for a given file." } ; - -HELP: group-execute? -{ $values - { "obj" "a pathname string or an integer" } - { "?" "a boolean" } } -{ $description "Tests whether the " { $snippet "group execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ; - -HELP: group-read? -{ $values - { "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, " { $link file-info } ", or an integer." } ; - -HELP: group-write? -{ $values - { "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, " { $link file-info } ", or an integer." } ; - -HELP: other-execute? -{ $values - { "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, " { $link file-info } ", or an integer." } ; - -HELP: other-read? -{ $values - { "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, " { $link file-info } ", or an integer." } ; - -HELP: other-write? -{ $values - { "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, " { $link file-info } ", or an integer." } ; - -HELP: set-file-access-time -{ $values - { "path" "a pathname string" } { "timestamp" timestamp } } -{ $description "Sets a file's last access timestamp." } ; - -HELP: set-file-group -{ $values - { "path" "a pathname string" } { "string/id" "a string or a group id" } } -{ $description "Sets a file's group id from the given group id or group name." } ; - -HELP: set-file-ids -{ $values - { "path" "a pathname string" } { "uid" integer } { "gid" integer } } -{ $description "Sets the user id and group id of a file with a single library call." } ; - -HELP: set-file-permissions -{ $values - { "path" "a pathname string" } { "n" "an integer, interepreted as a string of bits" } } -{ $description "Sets the file permissions for a given file with the supplied Unix permissions integer. Supplying an octal number with " { $link POSTPONE: OCT: } " is recommended." } -{ $examples "Using the tradidional octal value:" - { $unchecked-example "USING: io.unix.files kernel ;" - "\"resource:license.txt\" OCT: 755 set-file-permissions" - "" - } - "Higher-level, setting named bits:" - { $unchecked-example "USING: io.unix.files kernel math.bitwise ;" - "\"resource:license.txt\"" - "{ USER-ALL GROUP-READ GROUP-EXECUTE OTHER-READ OTHER-EXECUTE }" - "flags set-file-permissions" - "" } -} ; - -HELP: set-file-times -{ $values - { "path" "a pathname string" } { "timestamps" "an array of two timestamps" } } -{ $description "Sets the access and write timestamps for a file as provided in the input array. A value of " { $link f } " provided for either of the timestamps will not change that timestamp." } ; - -HELP: set-file-user -{ $values - { "path" "a pathname string" } { "string/id" "a string or a user id" } } -{ $description "Sets a file's user id from the given user id or username." } ; - -HELP: set-file-modified-time -{ $values - { "path" "a pathname string" } { "timestamp" timestamp } } -{ $description "Sets a file's last modified timestamp, or write timestamp." } ; - -HELP: set-gid -{ $values - { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Sets the " { $snippet "gid" } " bit of a file to true or false." } ; - -HELP: gid? -{ $values - { "obj" "a pathname string, file-info object, or an integer" } - { "?" "a boolean" } } -{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file, " { $link file-info } ", or an integer." } ; - -HELP: set-group-execute -{ $values - { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Sets the " { $snippet "group execute" } " bit of a file to true or false." } ; - -HELP: set-group-read -{ $values - { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Sets the " { $snippet "group read" } " bit of a file to true or false." } ; - -HELP: set-group-write -{ $values - { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Sets the " { $snippet "group write" } " bit of a file to true or false." } ; - -HELP: set-other-execute -{ $values - { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Sets the " { $snippet "other execute" } " bit of a file to true or false." } ; - -HELP: set-other-read -{ $values - { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Sets the " { $snippet "other read" } " bit of a file to true or false." } ; - -HELP: set-other-write -{ $values - { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Sets the " { $snippet "other execute" } " bit of a file to true or false." } ; - -HELP: set-sticky -{ $values - { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Sets the " { $snippet "sticky" } " bit of a file to true or false." } ; - -HELP: sticky? -{ $values - { "obj" "a pathname string, file-info object, or an integer" } - { "?" "a boolean" } } -{ $description "Tests whether the " { $snippet "sticky" } " bit is set on a file, " { $link file-info } ", or an integer." } ; - -HELP: set-uid -{ $values - { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Sets the " { $snippet "uid" } " bit of a file to true or false." } ; - -HELP: uid? -{ $values - { "obj" "a pathname string, file-info object, or an integer" } - { "?" "a boolean" } } -{ $description "Tests whether the " { $snippet "uid" } " bit is set on a file, " { $link file-info } ", or an integer." } ; - -HELP: set-user-execute -{ $values - { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Sets the " { $snippet "user execute" } " bit of a file to true or false." } ; - -HELP: set-user-read -{ $values - { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Sets the " { $snippet "user read" } " bit of a file to true or false." } ; - -HELP: set-user-write -{ $values - { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Sets the " { $snippet "user write" } " bit of a file to true or false." } ; - -HELP: user-execute? -{ $values - { "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, " { $link file-info } ", or an integer." } ; - -HELP: user-read? -{ $values - { "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, " { $link file-info } ", or an integer." } ; - -HELP: user-write? -{ $values - { "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, " { $link file-info } ", or an integer." } ; - -ARTICLE: "unix-file-permissions" "Unix file permissions" -"Reading all file permissions:" -{ $subsection file-permissions } -"Reading individual file permissions:" -{ $subsection uid? } -{ $subsection gid? } -{ $subsection sticky? } -{ $subsection user-read? } -{ $subsection user-write? } -{ $subsection user-execute? } -{ $subsection group-read? } -{ $subsection group-write? } -{ $subsection group-execute? } -{ $subsection other-read? } -{ $subsection other-write? } -{ $subsection other-execute? } -"Writing all file permissions:" -{ $subsection set-file-permissions } -"Writing individual file permissions:" -{ $subsection set-uid } -{ $subsection set-gid } -{ $subsection set-sticky } -{ $subsection set-user-read } -{ $subsection set-user-write } -{ $subsection set-user-execute } -{ $subsection set-group-read } -{ $subsection set-group-write } -{ $subsection set-group-execute } -{ $subsection set-other-read } -{ $subsection set-other-write } -{ $subsection set-other-execute } ; - -ARTICLE: "unix-file-timestamps" "Unix file timestamps" -"To read file times, use the accessors on the object returned by the " { $link file-info } " word." $nl -"Setting multiple file times:" -{ $subsection set-file-times } -"Setting just the last access time:" -{ $subsection set-file-access-time } -"Setting just the last modified time:" -{ $subsection set-file-modified-time } ; - - -ARTICLE: "unix-file-ids" "Unix file user and group ids" -"Reading file user data:" -{ $subsection file-user-id } -{ $subsection file-username } -"Setting file user data:" -{ $subsection set-file-user } -"Reading file group data:" -{ $subsection file-group-id } -{ $subsection file-group-name } -"Setting file group data:" -{ $subsection set-file-group } ; - - -ARTICLE: "io.unix.files" "Unix file attributes" -"The " { $vocab-link "io.unix.files" } " vocabulary implements the Unix backend for opening files and provides a high-level way to set permissions, timestamps, and user and group ids for files." -{ $subsection "unix-file-permissions" } -{ $subsection "unix-file-timestamps" } -{ $subsection "unix-file-ids" } ; - -ABOUT: "io.unix.files" diff --git a/basis/io/unix/files/files-tests.factor b/basis/io/unix/files/files-tests.factor deleted file mode 100644 index 78a80ad969..0000000000 --- a/basis/io/unix/files/files-tests.factor +++ /dev/null @@ -1,163 +0,0 @@ -USING: tools.test io.files continuations kernel io.unix.files -math.bitwise calendar accessors math.functions math unix.users -unix.groups arrays sequences ; -IN: io.unix.files.tests - -[ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test -[ "/etc/" ] [ "/etc/passwd" parent-directory ] unit-test -[ "/" ] [ "/etc/" parent-directory ] unit-test -[ "/" ] [ "/etc" parent-directory ] unit-test -[ "/" ] [ "/" parent-directory ] unit-test - -[ f ] [ "" root-directory? ] unit-test -[ t ] [ "/" root-directory? ] unit-test -[ t ] [ "//" root-directory? ] unit-test -[ t ] [ "///////" root-directory? ] unit-test - -[ "/" ] [ "/" file-name ] unit-test -[ "///" ] [ "///" file-name ] unit-test - -[ "/" ] [ "/" "../.." append-path ] unit-test -[ "/" ] [ "/" "../../" append-path ] unit-test -[ "/lib" ] [ "/" "../lib" append-path ] unit-test -[ "/lib/" ] [ "/" "../lib/" append-path ] unit-test -[ "/lib" ] [ "/" "../../lib" append-path ] unit-test -[ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test - -[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test -[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test -[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test -[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test -[ t ] [ "/foo" absolute-path? ] unit-test - -: test-file ( -- path ) - "permissions" temp-file ; - -: prepare-test-file ( -- ) - [ test-file delete-file ] ignore-errors - test-file touch-file ; - -: perms ( -- n ) - test-file file-permissions OCT: 7777 mask ; - -prepare-test-file - -[ t ] -[ test-file { USER-ALL GROUP-ALL OTHER-ALL } flags set-file-permissions perms OCT: 777 = ] unit-test - -[ t ] [ test-file user-read? ] unit-test -[ t ] [ test-file user-write? ] unit-test -[ t ] [ test-file user-execute? ] unit-test -[ t ] [ test-file group-read? ] unit-test -[ t ] [ test-file group-write? ] unit-test -[ t ] [ test-file group-execute? ] unit-test -[ t ] [ test-file other-read? ] unit-test -[ 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 -[ f ] [ test-file file-info other-execute? ] 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 -[ f ] [ test-file file-info other-read? ] 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 -[ f ] [ test-file file-info group-write? ] 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 -[ f ] [ test-file file-info other-execute? ] 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 -[ 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 - -prepare-test-file - -[ t ] -[ - test-file now - [ set-file-access-time ] 2keep - [ file-info accessed>> ] - [ [ [ truncate >integer ] change-second ] bi@ ] bi* = -] unit-test - -[ t ] -[ - test-file now - [ set-file-modified-time ] 2keep - [ file-info modified>> ] - [ [ [ truncate >integer ] change-second ] bi@ ] bi* = -] unit-test - -[ t ] -[ - test-file now [ dup 2array set-file-times ] 2keep - [ file-info [ modified>> ] [ accessed>> ] bi ] dip - 3array - [ [ truncate >integer ] change-second ] map all-equal? -] unit-test - -[ ] [ test-file f now 2array set-file-times ] unit-test -[ ] [ test-file now f 2array set-file-times ] unit-test -[ ] [ test-file f f 2array set-file-times ] unit-test - - -[ ] [ test-file real-username set-file-user ] unit-test -[ ] [ test-file real-user-id set-file-user ] unit-test -[ ] [ test-file real-group-name set-file-group ] unit-test -[ ] [ test-file real-group-id set-file-group ] unit-test - -[ t ] [ test-file file-username real-username = ] unit-test -[ t ] [ test-file file-group-name real-group-name = ] unit-test - -[ ] -[ test-file real-user-id real-group-id set-file-ids ] unit-test - -[ ] -[ test-file f real-group-id set-file-ids ] unit-test - -[ ] -[ test-file real-user-id f set-file-ids ] unit-test - -[ ] -[ 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 diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor deleted file mode 100644 index 1fc5fe9226..0000000000 --- a/basis/io/unix/files/files.factor +++ /dev/null @@ -1,371 +0,0 @@ -! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: io.backend io.ports io.unix.backend io.files io -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 -environment fry io.encodings.utf8 alien.strings -combinators.short-circuit ; -IN: io.unix.files - -M: unix cwd ( -- path ) - MAXPATHLEN [ ] keep getcwd - [ (io-error) ] unless* ; - -M: unix cd ( path -- ) [ chdir ] unix-system-call drop ; - -: read-flags O_RDONLY ; inline - -: open-read ( path -- fd ) O_RDONLY file-mode open-file ; - -M: unix (file-reader) ( path -- stream ) - open-read init-fd ; - -: write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline - -: open-write ( path -- fd ) - write-flags file-mode open-file ; - -M: unix (file-writer) ( path -- stream ) - open-write init-fd ; - -: append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline - -: open-append ( path -- fd ) - [ - append-flags file-mode open-file |dispose - dup 0 SEEK_END lseek io-error - ] with-destructors ; - -M: unix (file-appender) ( path -- stream ) - open-append init-fd ; - -: touch-mode ( -- n ) - { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable - -M: unix touch-file ( path -- ) - normalize-path - dup exists? [ touch ] [ - touch-mode file-mode open-file close-file - ] if ; - -M: unix move-file ( from to -- ) - [ normalize-path ] bi@ rename io-error ; - -M: unix delete-file ( path -- ) normalize-path unlink-file ; - -M: unix make-directory ( path -- ) - normalize-path OCT: 777 mkdir io-error ; - -M: unix delete-directory ( path -- ) - normalize-path rmdir io-error ; - -: (copy-file) ( from to -- ) - dup parent-directory make-directories - binary [ - swap binary [ - swap stream-copy - ] with-disposal - ] with-disposal ; - -M: unix copy-file ( from to -- ) - [ normalize-path ] bi@ - [ (copy-file) ] - [ swap file-info permissions>> chmod io-error ] - 2bi ; - -TUPLE: unix-file-system-info < file-system-info -block-size preferred-block-size -blocks blocks-free blocks-available -files files-free files-available -name-max flags id ; - -HOOK: new-file-system-info os ( -- file-system-info ) - -M: unix new-file-system-info ( -- ) unix-file-system-info new ; - -HOOK: file-system-statfs os ( path -- statfs ) - -M: unix file-system-statfs drop f ; - -HOOK: file-system-statvfs os ( path -- statvfs ) - -M: unix file-system-statvfs drop f ; - -HOOK: statfs>file-system-info os ( file-system-info statfs -- file-system-info' ) - -M: unix statfs>file-system-info drop ; - -HOOK: statvfs>file-system-info os ( file-system-info statvfs -- file-system-info' ) - -M: unix statvfs>file-system-info drop ; - -: file-system-calculations ( file-system-info -- file-system-info' ) - { - [ dup [ blocks-available>> ] [ block-size>> ] bi * >>available-space drop ] - [ dup [ blocks-free>> ] [ block-size>> ] bi * >>free-space drop ] - [ dup [ blocks>> ] [ block-size>> ] bi * >>total-space drop ] - [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ] - [ ] - } cleave ; - -M: unix file-system-info - normalize-path - [ new-file-system-info ] dip - [ file-system-statfs statfs>file-system-info ] - [ file-system-statvfs statvfs>file-system-info ] bi - file-system-calculations ; - -os { - { linux [ "io.unix.files.linux" require ] } - { macosx [ "io.unix.files.macosx" require ] } - { freebsd [ "io.unix.files.freebsd" require ] } - { netbsd [ "io.unix.files.netbsd" require ] } - { openbsd [ "io.unix.files.openbsd" require ] } -} case - -TUPLE: unix-file-info < file-info uid gid dev ino -nlink rdev blocks blocksize ; - -HOOK: new-file-info os ( -- file-info ) - -HOOK: stat>file-info os ( stat -- file-info ) - -HOOK: stat>type os ( stat -- file-info ) - -M: unix file-info ( path -- info ) - normalize-path file-status stat>file-info ; - -M: unix link-info ( path -- info ) - normalize-path link-status stat>file-info ; - -M: unix make-link ( path1 path2 -- ) - normalize-path symlink io-error ; - -M: unix read-link ( path -- path' ) - normalize-path read-symbolic-link ; - -M: unix new-file-info ( -- class ) unix-file-info new ; - -M: unix stat>file-info ( stat -- file-info ) - [ new-file-info ] dip - { - [ stat>type >>type ] - [ stat-st_size >>size ] - [ stat-st_mode >>permissions ] - [ stat-st_ctimespec timespec>unix-time >>created ] - [ stat-st_mtimespec timespec>unix-time >>modified ] - [ stat-st_atimespec timespec>unix-time >>accessed ] - [ stat-st_uid >>uid ] - [ stat-st_gid >>gid ] - [ stat-st_dev >>dev ] - [ stat-st_ino >>ino ] - [ stat-st_nlink >>nlink ] - [ stat-st_rdev >>rdev ] - [ stat-st_blocks >>blocks ] - [ stat-st_blksize >>blocksize ] - } cleave ; - -: n>file-type ( n -- type ) - S_IFMT bitand { - { S_IFREG [ +regular-file+ ] } - { S_IFDIR [ +directory+ ] } - { S_IFCHR [ +character-device+ ] } - { S_IFBLK [ +block-device+ ] } - { S_IFIFO [ +fifo+ ] } - { S_IFLNK [ +symbolic-link+ ] } - { S_IFSOCK [ +socket+ ] } - [ drop +unknown+ ] - } case ; - -M: unix stat>type ( stat -- type ) - stat-st_mode n>file-type ; - -! Linux has no extra fields in its stat struct -os { - { macosx [ "io.unix.files.bsd" require ] } - { netbsd [ "io.unix.files.bsd" require ] } - { openbsd [ "io.unix.files.bsd" require ] } - { freebsd [ "io.unix.files.bsd" require ] } - { 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" - f - [ 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 dirent-type>file-type ] bi directory-entry boa ; - -M: unix (directory-entries) ( path -- seq ) - [ - '[ _ find-next-file dup ] - [ >directory-entry ] - [ drop ] produce - ] with-unix-directory ; - -> ] dip mask? ; - -PRIVATE> - -: ch>file-type ( ch -- type ) - { - { CHAR: b [ +block-device+ ] } - { CHAR: c [ +character-device+ ] } - { CHAR: d [ +directory+ ] } - { CHAR: l [ +symbolic-link+ ] } - { CHAR: s [ +socket+ ] } - { CHAR: p [ +fifo+ ] } - { CHAR: - [ +regular-file+ ] } - [ drop +unknown+ ] - } case ; - -: file-type>ch ( type -- string ) - { - { +block-device+ [ CHAR: b ] } - { +character-device+ [ CHAR: c ] } - { +directory+ [ CHAR: d ] } - { +symbolic-link+ [ CHAR: l ] } - { +socket+ [ CHAR: s ] } - { +fifo+ [ CHAR: p ] } - { +regular-file+ [ CHAR: - ] } - [ drop CHAR: - ] - } case ; - -: UID OCT: 0004000 ; inline -: GID OCT: 0002000 ; inline -: STICKY OCT: 0001000 ; inline -: USER-ALL OCT: 0000700 ; inline -: USER-READ OCT: 0000400 ; inline -: USER-WRITE OCT: 0000200 ; inline -: USER-EXECUTE OCT: 0000100 ; inline -: GROUP-ALL OCT: 0000070 ; inline -: GROUP-READ OCT: 0000040 ; inline -: GROUP-WRITE OCT: 0000020 ; inline -: GROUP-EXECUTE OCT: 0000010 ; inline -: OTHER-ALL OCT: 0000007 ; inline -: OTHER-READ OCT: 0000004 ; inline -: OTHER-WRITE OCT: 0000002 ; inline -: OTHER-EXECUTE OCT: 0000001 ; inline - -: uid? ( obj -- ? ) UID file-mode? ; -: gid? ( obj -- ? ) GID file-mode? ; -: sticky? ( obj -- ? ) STICKY file-mode? ; -: user-read? ( obj -- ? ) USER-READ file-mode? ; -: user-write? ( obj -- ? ) USER-WRITE file-mode? ; -: user-execute? ( obj -- ? ) USER-EXECUTE file-mode? ; -: group-read? ( obj -- ? ) GROUP-READ file-mode? ; -: group-write? ( obj -- ? ) GROUP-WRITE file-mode? ; -: group-execute? ( obj -- ? ) GROUP-EXECUTE file-mode? ; -: other-read? ( obj -- ? ) OTHER-READ file-mode? ; -: other-write? ( obj -- ? ) OTHER-WRITE file-mode? ; -: other-execute? ( obj -- ? ) OTHER-EXECUTE file-mode? ; - -: any-read? ( obj -- ? ) - { [ user-read? ] [ group-read? ] [ other-read? ] } 1|| ; - -: any-write? ( obj -- ? ) - { [ user-write? ] [ group-write? ] [ other-write? ] } 1|| ; - -: any-execute? ( obj -- ? ) - { [ user-execute? ] [ group-execute? ] [ other-execute? ] } 1|| ; - -: set-uid ( path ? -- ) UID swap chmod-set-bit ; -: set-gid ( path ? -- ) GID swap chmod-set-bit ; -: set-sticky ( path ? -- ) STICKY swap chmod-set-bit ; -: set-user-read ( path ? -- ) USER-READ swap chmod-set-bit ; -: set-user-write ( path ? -- ) USER-WRITE swap chmod-set-bit ; -: set-user-execute ( path ? -- ) USER-EXECUTE swap chmod-set-bit ; -: set-group-read ( path ? -- ) GROUP-READ swap chmod-set-bit ; -: set-group-write ( path ? -- ) GROUP-WRITE swap chmod-set-bit ; -: set-group-execute ( path ? -- ) GROUP-EXECUTE swap chmod-set-bit ; -: set-other-read ( path ? -- ) OTHER-READ swap chmod-set-bit ; -: set-other-write ( path ? -- ) OTHER-WRITE swap chmod-set-bit ; -: set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ; - -: set-file-permissions ( path n -- ) - [ normalize-path ] dip chmod io-error ; - -: file-permissions ( path -- n ) - normalize-path file-info permissions>> ; - - ] unless* ] map concat ; - -: timestamp>timeval ( timestamp -- timeval ) - unix-1970 time- duration>microseconds make-timeval ; - -: timestamps>byte-array ( timestamps -- byte-array ) - [ dup [ timestamp>timeval ] when ] map make-timeval-array ; - -PRIVATE> - -: set-file-times ( path timestamps -- ) - #! set access, write - [ normalize-path ] dip - timestamps>byte-array utimes io-error ; - -: set-file-access-time ( path timestamp -- ) - f 2array set-file-times ; - -: set-file-modified-time ( path timestamp -- ) - f swap 2array set-file-times ; - -: set-file-ids ( path uid gid -- ) - [ normalize-path ] 2dip - [ [ -1 ] unless* ] bi@ chown io-error ; - -GENERIC: set-file-user ( path string/id -- ) - -GENERIC: set-file-group ( path string/id -- ) - -M: integer set-file-user ( path uid -- ) - f set-file-ids ; - -M: string set-file-user ( path string -- ) - user-id f set-file-ids ; - -M: integer set-file-group ( path gid -- ) - f swap set-file-ids ; - -M: string set-file-group ( path string -- ) - group-id - f swap set-file-ids ; - -: file-user-id ( path -- uid ) - normalize-path file-info uid>> ; - -: file-username ( path -- string ) - file-user-id username ; - -: file-group-id ( path -- gid ) - normalize-path file-info gid>> ; - -: file-group-name ( path -- string ) - file-group-id group-name ; - -M: unix home "HOME" os-env ; diff --git a/basis/io/unix/files/freebsd/freebsd.factor b/basis/io/unix/files/freebsd/freebsd.factor deleted file mode 100644 index eaf217af62..0000000000 --- a/basis/io/unix/files/freebsd/freebsd.factor +++ /dev/null @@ -1,55 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types alien.syntax combinators -io.backend io.files io.unix.files kernel math system unix -unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd -sequences grouping alien.strings io.encodings.utf8 -specialized-arrays.direct.uint arrays ; -IN: io.unix.files.freebsd - -TUPLE: freebsd-file-system-info < unix-file-system-info -version io-size owner syncreads syncwrites asyncreads asyncwrites ; - -M: freebsd new-file-system-info freebsd-file-system-info new ; - -M: freebsd file-system-statfs ( path -- byte-array ) - "statfs" tuck statfs io-error ; - -M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-info ) - { - [ statfs-f_version >>version ] - [ statfs-f_type >>type ] - [ statfs-f_flags >>flags ] - [ statfs-f_bsize >>block-size ] - [ statfs-f_iosize >>io-size ] - [ statfs-f_blocks >>blocks ] - [ statfs-f_bfree >>blocks-free ] - [ statfs-f_bavail >>blocks-available ] - [ statfs-f_files >>files ] - [ statfs-f_ffree >>files-free ] - [ statfs-f_syncwrites >>syncwrites ] - [ statfs-f_asyncwrites >>asyncwrites ] - [ statfs-f_syncreads >>syncreads ] - [ statfs-f_asyncreads >>asyncreads ] - [ statfs-f_namemax >>name-max ] - [ statfs-f_owner >>owner ] - [ statfs-f_fsid 2 >array >>id ] - [ statfs-f_fstypename utf8 alien>string >>type ] - [ statfs-f_mntfromname utf8 alien>string >>device-name ] - [ statfs-f_mntonname utf8 alien>string >>mount-point ] - } cleave ; - -M: freebsd file-system-statvfs ( path -- byte-array ) - "statvfs" tuck statvfs io-error ; - -M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info ) - { - [ statvfs-f_favail >>files-available ] - [ statvfs-f_frsize >>preferred-block-size ] - } cleave ; - -M: freebsd file-systems ( -- array ) - f 0 0 getfsstat dup io-error - "statfs" dup dup length 0 getfsstat io-error - "statfs" heap-size group - [ statfs-f_mntonname alien>native-string file-system-info ] map ; diff --git a/basis/io/unix/files/freebsd/tags.txt b/basis/io/unix/files/freebsd/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/files/freebsd/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/files/linux/linux.factor b/basis/io/unix/files/linux/linux.factor deleted file mode 100644 index c30855c3ee..0000000000 --- a/basis/io/unix/files/linux/linux.factor +++ /dev/null @@ -1,90 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types alien.syntax combinators csv -io.backend io.encodings.utf8 io.files io.streams.string -io.unix.files kernel math.order namespaces sequences sorting -system unix unix.statfs.linux unix.statvfs.linux -specialized-arrays.direct.uint arrays ; -IN: io.unix.files.linux - -TUPLE: linux-file-system-info < unix-file-system-info -namelen ; - -M: linux new-file-system-info linux-file-system-info new ; - -M: linux file-system-statfs ( path -- byte-array ) - "statfs64" tuck statfs64 io-error ; - -M: linux statfs>file-system-info ( struct -- statfs ) - { - [ statfs64-f_type >>type ] - [ statfs64-f_bsize >>block-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 2 >array >>id ] - [ statfs64-f_namelen >>namelen ] - [ statfs64-f_frsize >>preferred-block-size ] - ! [ statfs64-f_spare >>spare ] - } cleave ; - -M: linux file-system-statvfs ( path -- byte-array ) - "statvfs64" tuck statvfs64 io-error ; - -M: linux statvfs>file-system-info ( struct -- statfs ) - { - [ statvfs64-f_flag >>flags ] - [ statvfs64-f_namemax >>name-max ] - } cleave ; - -TUPLE: mtab-entry file-system-name mount-point type options -frequency pass-number ; - -: mtab-csv>mtab-entry ( csv -- mtab-entry ) - [ mtab-entry new ] dip - { - [ first >>file-system-name ] - [ second >>mount-point ] - [ third >>type ] - [ fourth csv first >>options ] - [ 4 swap nth >>frequency ] - [ 5 swap nth >>pass-number ] - } cleave ; - -: parse-mtab ( -- array ) - [ - "/etc/mtab" utf8 - CHAR: \s delimiter set csv - ] with-scope - [ mtab-csv>mtab-entry ] map ; - -M: linux file-systems - parse-mtab [ - [ mount-point>> file-system-info ] keep - { - [ file-system-name>> >>device-name ] - [ mount-point>> >>mount-point ] - [ type>> >>type ] - } cleave - ] map ; - -ERROR: file-system-not-found ; - -M: linux file-system-info ( path -- ) - normalize-path - [ - [ new-file-system-info ] dip - [ file-system-statfs statfs>file-system-info ] - [ file-system-statvfs statvfs>file-system-info ] bi - file-system-calculations - ] keep - - parse-mtab [ [ mount-point>> ] bi@ <=> invert-comparison ] sort - [ mount-point>> head? ] with find nip [ file-system-not-found ] unless* - { - [ file-system-name>> >>device-name drop ] - [ mount-point>> >>mount-point drop ] - [ type>> >>type ] - } 2cleave ; diff --git a/basis/io/unix/files/linux/tags.txt b/basis/io/unix/files/linux/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/files/linux/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/files/macosx/macosx.factor b/basis/io/unix/files/macosx/macosx.factor deleted file mode 100644 index 397145c9ae..0000000000 --- a/basis/io/unix/files/macosx/macosx.factor +++ /dev/null @@ -1,51 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types alien.strings combinators -grouping io.encodings.utf8 io.files kernel math sequences -system unix io.unix.files specialized-arrays.direct.uint arrays -unix.statfs.macosx unix.statvfs.macosx unix.getfsstat.macosx ; -IN: io.unix.files.macosx - -TUPLE: macosx-file-system-info < unix-file-system-info -io-size owner type-id filesystem-subtype ; - -M: macosx file-systems ( -- array ) - f dup 0 getmntinfo64 dup io-error - [ *void* ] dip - "statfs64" heap-size [ * memory>byte-array ] keep group - [ statfs64-f_mntonname utf8 alien>string file-system-info ] map ; - ! [ [ new-file-system-info ] dip statfs>file-system-info ] map ; - -M: macosx new-file-system-info macosx-file-system-info new ; - -M: macosx file-system-statfs ( normalized-path -- statfs ) - "statfs64" tuck statfs64 io-error ; - -M: macosx file-system-statvfs ( normalized-path -- statvfs ) - "statvfs" tuck statvfs io-error ; - -M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' ) - { - [ 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 2 >array >>id ] - [ statfs64-f_owner >>owner ] - [ statfs64-f_type >>type-id ] - [ statfs64-f_flags >>flags ] - [ statfs64-f_fssubtype >>filesystem-subtype ] - [ statfs64-f_fstypename utf8 alien>string >>type ] - [ statfs64-f_mntonname utf8 alien>string >>mount-point ] - [ statfs64-f_mntfromname utf8 alien>string >>device-name ] - } cleave ; - -M: macosx statvfs>file-system-info ( file-system-info byte-array -- file-system-info' ) - { - [ statvfs-f_frsize >>preferred-block-size ] - [ statvfs-f_favail >>files-available ] - [ statvfs-f_namemax >>name-max ] - } cleave ; diff --git a/basis/io/unix/files/macosx/tags.txt b/basis/io/unix/files/macosx/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/files/macosx/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/files/netbsd/netbsd.factor b/basis/io/unix/files/netbsd/netbsd.factor deleted file mode 100644 index 82ac3dc70d..0000000000 --- a/basis/io/unix/files/netbsd/netbsd.factor +++ /dev/null @@ -1,52 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel unix.stat math unix -combinators system io.backend accessors alien.c-types -io.encodings.utf8 alien.strings unix.types io.unix.files -io.files unix.statvfs.netbsd unix.getfsstat.netbsd arrays -grouping sequences io.encodings.utf8 specialized-arrays.direct.uint ; -IN: io.unix.files.netbsd - -TUPLE: netbsd-file-system-info < unix-file-system-info -blocks-reserved files-reserved -owner io-size sync-reads sync-writes async-reads async-writes -idx mount-from ; - -M: netbsd new-file-system-info netbsd-file-system-info new ; - -M: netbsd file-system-statvfs - "statvfs" tuck statvfs io-error ; - -M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' ) - { - [ statvfs-f_flag >>flags ] - [ statvfs-f_bsize >>block-size ] - [ statvfs-f_frsize >>preferred-block-size ] - [ statvfs-f_iosize >>io-size ] - [ statvfs-f_blocks >>blocks ] - [ statvfs-f_bfree >>blocks-free ] - [ statvfs-f_bavail >>blocks-available ] - [ statvfs-f_bresvd >>blocks-reserved ] - [ statvfs-f_files >>files ] - [ statvfs-f_ffree >>files-free ] - [ statvfs-f_favail >>files-available ] - [ statvfs-f_fresvd >>files-reserved ] - [ statvfs-f_syncreads >>sync-reads ] - [ statvfs-f_syncwrites >>sync-writes ] - [ statvfs-f_asyncreads >>async-reads ] - [ statvfs-f_asyncwrites >>async-writes ] - [ statvfs-f_fsidx 2 >array >>idx ] - [ statvfs-f_fsid >>id ] - [ statvfs-f_namemax >>name-max ] - [ statvfs-f_owner >>owner ] - ! [ statvfs-f_spare >>spare ] - [ statvfs-f_fstypename utf8 alien>string >>type ] - [ statvfs-f_mntonname utf8 alien>string >>mount-point ] - [ statvfs-f_mntfromname utf8 alien>string >>device-name ] - } cleave ; - -M: netbsd file-systems ( -- array ) - f 0 0 getvfsstat dup io-error - "statvfs" dup dup length 0 getvfsstat io-error - "statvfs" heap-size group - [ statvfs-f_mntonname utf8 alien>string file-system-info ] map ; diff --git a/basis/io/unix/files/netbsd/tags.txt b/basis/io/unix/files/netbsd/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/files/netbsd/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/files/openbsd/openbsd.factor b/basis/io/unix/files/openbsd/openbsd.factor deleted file mode 100644 index e5e18b29ea..0000000000 --- a/basis/io/unix/files/openbsd/openbsd.factor +++ /dev/null @@ -1,55 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types alien.strings alien.syntax -combinators io.backend io.files io.unix.files kernel math -sequences system unix unix.getfsstat.openbsd grouping -unix.statfs.openbsd unix.statvfs.openbsd unix.types -specialized-arrays.direct.uint arrays ; -IN: io.unix.files.openbsd - -TUPLE: freebsd-file-system-info < unix-file-system-info -io-size sync-writes sync-reads async-writes async-reads -owner ; - -M: openbsd new-file-system-info freebsd-file-system-info new ; - -M: openbsd file-system-statfs - "statfs" tuck statfs io-error ; - -M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info' ) - { - [ statfs-f_flags >>flags ] - [ statfs-f_bsize >>block-size ] - [ statfs-f_iosize >>io-size ] - [ statfs-f_blocks >>blocks ] - [ statfs-f_bfree >>blocks-free ] - [ statfs-f_bavail >>blocks-available ] - [ statfs-f_files >>files ] - [ statfs-f_ffree >>files-free ] - [ statfs-f_favail >>files-available ] - [ statfs-f_syncwrites >>sync-writes ] - [ statfs-f_syncreads >>sync-reads ] - [ statfs-f_asyncwrites >>async-writes ] - [ statfs-f_asyncreads >>async-reads ] - [ statfs-f_fsid 2 >array >>id ] - [ statfs-f_namemax >>name-max ] - [ statfs-f_owner >>owner ] - ! [ statfs-f_spare >>spare ] - [ statfs-f_fstypename alien>native-string >>type ] - [ statfs-f_mntonname alien>native-string >>mount-point ] - [ statfs-f_mntfromname alien>native-string >>device-name ] - } cleave ; - -M: openbsd file-system-statvfs ( normalized-path -- statvfs ) - "statvfs" tuck statvfs io-error ; - -M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' ) - { - [ statvfs-f_frsize >>preferred-block-size ] - } cleave ; - -M: openbsd file-systems ( -- seq ) - f 0 0 getfsstat dup io-error - "statfs" dup dup length 0 getfsstat io-error - "statfs" heap-size group - [ statfs-f_mntonname alien>native-string file-system-info ] map ; diff --git a/basis/io/unix/files/openbsd/tags.txt b/basis/io/unix/files/openbsd/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/files/openbsd/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/files/summary.txt b/basis/io/unix/files/summary.txt deleted file mode 100644 index 57527bef70..0000000000 --- a/basis/io/unix/files/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Implementation of reading and writing files on Unix-like systems diff --git a/basis/io/unix/files/tags.txt b/basis/io/unix/files/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/files/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/files/unique/tags.txt b/basis/io/unix/files/unique/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/files/unique/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/files/unique/unique.factor b/basis/io/unix/files/unique/unique.factor deleted file mode 100644 index 24dcdcb65a..0000000000 --- a/basis/io/unix/files/unique/unique.factor +++ /dev/null @@ -1,13 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel io.ports io.unix.backend math.bitwise -unix system io.files.unique ; -IN: io.unix.files.unique - -: open-unique-flags ( -- flags ) - { O_RDWR O_CREAT O_EXCL } flags ; - -M: unix touch-unique-file ( path -- ) - open-unique-flags file-mode open-file close-file ; - -M: unix temporary-path ( -- path ) "/tmp" ; diff --git a/basis/io/unix/freebsd/freebsd.factor b/basis/io/unix/freebsd/freebsd.factor deleted file mode 100644 index 49fbc9af7e..0000000000 --- a/basis/io/unix/freebsd/freebsd.factor +++ /dev/null @@ -1,3 +0,0 @@ -USING: io.unix.bsd io.backend system ; - -freebsd set-io-backend diff --git a/basis/io/unix/freebsd/tags.txt b/basis/io/unix/freebsd/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/freebsd/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/kqueue/authors.txt b/basis/io/unix/kqueue/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/basis/io/unix/kqueue/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/io/unix/kqueue/kqueue.factor b/basis/io/unix/kqueue/kqueue.factor deleted file mode 100644 index be99d17572..0000000000 --- a/basis/io/unix/kqueue/kqueue.factor +++ /dev/null @@ -1,74 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types combinators io.unix.backend -kernel math.bitwise sequences struct-arrays unix unix.kqueue -unix.time assocs ; -IN: io.unix.kqueue - -TUPLE: kqueue-mx < mx events ; - -: max-events ( -- n ) - #! We read up to 256 events at a time. This is an arbitrary - #! constant... - 256 ; inline - -: ( -- mx ) - kqueue-mx new-mx - kqueue dup io-error >>fd - max-events "kevent" >>events ; - -: make-kevent ( fd filter flags -- event ) - "kevent" - [ set-kevent-flags ] keep - [ set-kevent-filter ] keep - [ set-kevent-ident ] keep ; - -: register-kevent ( kevent mx -- ) - fd>> swap 1 f 0 f kevent io-error ; - -M: kqueue-mx add-input-callback ( thread fd mx -- ) - [ call-next-method ] [ - [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip - register-kevent - ] 2bi ; - -M: kqueue-mx add-output-callback ( thread fd mx -- ) - [ call-next-method ] [ - [ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip - register-kevent - ] 2bi ; - -M: kqueue-mx remove-input-callbacks ( fd mx -- seq ) - 2dup reads>> key? [ - [ call-next-method ] [ - [ EVFILT_READ EV_DELETE make-kevent ] dip - register-kevent - ] 2bi - ] [ 2drop f ] if ; - -M: kqueue-mx remove-output-callbacks ( fd mx -- seq ) - 2dup writes>> key? [ - [ - [ EVFILT_WRITE EV_DELETE make-kevent ] dip - register-kevent - ] [ call-next-method ] 2bi - ] [ 2drop f ] if ; - -: wait-kevent ( mx timespec -- n ) - [ - [ fd>> f 0 ] - [ events>> [ underlying>> ] [ length ] bi ] bi - ] dip kevent multiplexer-error ; - -: handle-kevent ( mx kevent -- ) - [ kevent-ident swap ] [ kevent-filter ] bi { - { EVFILT_READ [ input-available ] } - { EVFILT_WRITE [ output-available ] } - } case ; - -: handle-kevents ( mx n -- ) - [ dup events>> ] dip head-slice [ handle-kevent ] with each ; - -M: kqueue-mx wait-for-events ( us mx -- ) - swap dup [ make-timespec ] when - dupd wait-kevent handle-kevents ; diff --git a/basis/io/unix/kqueue/tags.txt b/basis/io/unix/kqueue/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/kqueue/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/launcher/authors.txt b/basis/io/unix/launcher/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/basis/io/unix/launcher/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/io/unix/launcher/launcher-tests.factor b/basis/io/unix/launcher/launcher-tests.factor deleted file mode 100644 index 68ca821ed4..0000000000 --- a/basis/io/unix/launcher/launcher-tests.factor +++ /dev/null @@ -1,138 +0,0 @@ -IN: io.unix.launcher.tests -USING: io.files tools.test io.launcher arrays io namespaces -continuations math io.encodings.binary io.encodings.ascii -accessors kernel sequences io.encodings.utf8 destructors -io.streams.duplex locals concurrency.promises threads -unix.process ; - -[ ] [ - [ "launcher-test-1" temp-file delete-file ] ignore-errors -] unit-test - -[ ] [ - "touch" - "launcher-test-1" temp-file - 2array - try-process -] unit-test - -[ t ] [ "launcher-test-1" temp-file exists? ] unit-test - -[ ] [ - [ "launcher-test-1" temp-file delete-file ] ignore-errors -] unit-test - -[ ] [ - - "echo Hello" >>command - "launcher-test-1" temp-file >>stdout - try-process -] unit-test - -[ "Hello\n" ] [ - "cat" - "launcher-test-1" temp-file - 2array - ascii contents -] unit-test - -[ ] [ - [ "launcher-test-1" temp-file delete-file ] ignore-errors -] unit-test - -[ ] [ - - "cat" >>command - +closed+ >>stdin - "launcher-test-1" temp-file >>stdout - try-process -] unit-test - -[ f ] [ - "cat" - "launcher-test-1" temp-file - 2array - ascii contents -] unit-test - -[ ] [ - 2 [ - "launcher-test-1" temp-file binary [ - - swap >>stdout - "echo Hello" >>command - try-process - ] with-disposal - ] times -] unit-test - -[ "Hello\nHello\n" ] [ - "cat" - "launcher-test-1" temp-file - 2array - ascii contents -] unit-test - -[ t ] [ - - "env" >>command - { { "A" "B" } } >>environment - ascii lines - "A=B" swap member? -] unit-test - -[ { "A=B" } ] [ - - "env" >>command - { { "A" "B" } } >>environment - +replace-environment+ >>environment-mode - ascii lines -] unit-test - -[ "hi\n" ] [ - temp-directory [ - [ "aloha" delete-file ] ignore-errors - - { "echo" "hi" } >>command - "aloha" >>stdout - try-process - ] with-directory - temp-directory "aloha" append-path - utf8 file-contents -] unit-test - -[ "append-test" temp-file delete-file ] ignore-errors - -[ "hi\nhi\n" ] [ - 2 [ - - "echo hi" >>command - "append-test" temp-file >>stdout - try-process - ] times - "append-test" temp-file utf8 file-contents -] unit-test - -[ t ] [ "ls" utf8 contents >boolean ] unit-test - -[ "Hello world.\n" ] [ - "cat" utf8 [ - "Hello world.\n" write - output-stream get dispose - input-stream get contents - ] with-stream -] unit-test - -! Killed processes were exiting with code 0 on FreeBSD -[ f ] [ - [let | p [ ] - s [ ] | - [ - "sleep 1000" run-detached - [ p fulfill ] [ wait-for-process s fulfill ] bi - ] in-thread - - p ?promise handle>> 9 kill drop - s ?promise 0 = - ] -] unit-test diff --git a/basis/io/unix/launcher/launcher.factor b/basis/io/unix/launcher/launcher.factor deleted file mode 100644 index 729c1545d8..0000000000 --- a/basis/io/unix/launcher/launcher.factor +++ /dev/null @@ -1,107 +0,0 @@ -! Copyright (C) 2007, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces math system sequences -continuations arrays assocs combinators alien.c-types strings -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 -unix unix.process ; -IN: io.unix.launcher - -! Search unix first -USE: unix - -: get-arguments ( process -- seq ) - command>> dup string? [ tokenize-command ] when ; - -: assoc>env ( assoc -- env ) - [ "=" glue ] { } assoc>map ; - -: setup-priority ( process -- process ) - dup priority>> [ - H{ - { +lowest-priority+ 20 } - { +low-priority+ 10 } - { +normal-priority+ 0 } - { +high-priority+ -10 } - { +highest-priority+ -20 } - { +realtime-priority+ -20 } - } at set-priority - ] when* ; - -: reset-fd ( fd -- ) - [ F_SETFL 0 fcntl io-error ] [ F_SETFD 0 fcntl io-error ] bi ; - -: redirect-fd ( oldfd fd -- ) - 2dup = [ 2drop ] [ dup2 io-error ] if ; - -: redirect-file ( obj mode fd -- ) - [ [ normalize-path ] dip file-mode open-file ] dip redirect-fd ; - -: redirect-file-append ( obj mode fd -- ) - [ drop path>> normalize-path open-append ] dip redirect-fd ; - -: redirect-closed ( obj mode fd -- ) - [ drop "/dev/null" ] 2dip redirect-file ; - -: redirect ( obj mode fd -- ) - { - { [ pick not ] [ 3drop ] } - { [ pick string? ] [ redirect-file ] } - { [ pick appender? ] [ redirect-file-append ] } - { [ pick +closed+ eq? ] [ redirect-closed ] } - { [ pick fd? ] [ [ drop fd>> dup reset-fd ] dip redirect-fd ] } - [ [ underlying-handle ] 2dip redirect ] - } cond ; - -: ?closed ( obj -- obj' ) - dup +closed+ eq? [ drop "/dev/null" ] when ; - -: setup-redirection ( process -- process ) - dup stdin>> ?closed read-flags 0 redirect - dup stdout>> ?closed write-flags 1 redirect - dup stderr>> dup +stdout+ eq? [ - drop 1 2 dup2 io-error - ] [ - ?closed write-flags 2 redirect - ] if ; - -: setup-environment ( process -- process ) - dup pass-environment? [ - dup get-environment set-os-envs - ] when ; - -: spawn-process ( process -- * ) - [ setup-priority ] [ 250 _exit ] recover - [ setup-redirection ] [ 251 _exit ] recover - [ current-directory get (normalize-path) cd ] [ 252 _exit ] recover - [ setup-environment ] [ 253 _exit ] recover - [ get-arguments exec-args-with-path ] [ 254 _exit ] recover - 255 _exit ; - -M: unix current-process-handle ( -- handle ) getpid ; - -M: unix run-process* ( process -- pid ) - [ spawn-process ] curry [ ] with-fork ; - -M: unix kill-process* ( pid -- ) - SIGTERM kill io-error ; - -: find-process ( handle -- process ) - processes get swap [ nip swap handle>> = ] curry - assoc-find 2drop ; - -TUPLE: signal n ; - -: code>status ( code -- obj ) - dup WIFEXITED [ WEXITSTATUS ] [ WTERMSIG signal boa ] if ; - -M: unix wait-for-processes ( -- ? ) - -1 0 tuck WNOHANG waitpid - dup 0 <= [ - 2drop t - ] [ - find-process dup - [ swap *int code>status notify-exit f ] [ 2drop f ] if - ] if ; diff --git a/basis/io/unix/launcher/parser/parser-tests.factor b/basis/io/unix/launcher/parser/parser-tests.factor deleted file mode 100644 index 63aadcabbe..0000000000 --- a/basis/io/unix/launcher/parser/parser-tests.factor +++ /dev/null @@ -1,33 +0,0 @@ -IN: io.unix.launcher.parser.tests -USING: io.unix.launcher.parser tools.test ; - -[ "" tokenize-command ] must-fail -[ " " tokenize-command ] must-fail -[ V{ "a" } ] [ "a" tokenize-command ] unit-test -[ V{ "abc" } ] [ "abc" tokenize-command ] unit-test -[ V{ "abc" } ] [ "abc " tokenize-command ] unit-test -[ V{ "abc" } ] [ " abc" tokenize-command ] unit-test -[ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test -[ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test -[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test -[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test -[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test -[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test -[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test -[ "'abc def' \"hey" tokenize-command ] must-fail -[ "'abc def" tokenize-command ] must-fail -[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test - -[ - V{ - "Hello world.app/Contents/MacOS/hello-ui" - "-i=boot.macosx-ppc.image" - "-include= math compiler ui" - "-deploy-vocab=hello-ui" - "-output-image=Hello world.app/Contents/Resources/hello-ui.image" - "-no-stack-traces" - "-no-user-init" - } -] [ - "\"Hello world.app/Contents/MacOS/hello-ui\" -i=boot.macosx-ppc.image \"-include= math compiler ui\" -deploy-vocab=hello-ui \"-output-image=Hello world.app/Contents/Resources/hello-ui.image\" -no-stack-traces -no-user-init" tokenize-command -] unit-test diff --git a/basis/io/unix/launcher/parser/parser.factor b/basis/io/unix/launcher/parser/parser.factor deleted file mode 100644 index 276ed45f27..0000000000 --- a/basis/io/unix/launcher/parser/parser.factor +++ /dev/null @@ -1,33 +0,0 @@ -! Copyright (C) 2008 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: peg peg.parsers kernel sequences strings words ; -IN: io.unix.launcher.parser - -! Our command line parser. Supported syntax: -! foo bar baz -- simple tokens -! foo\ bar -- escaping the space -! 'foo bar' -- quotation -! "foo bar" -- quotation -: 'escaped-char' ( -- parser ) - "\\" token any-char 2seq [ second ] action ; - -: 'quoted-char' ( delimiter -- parser' ) - 'escaped-char' - swap [ member? not ] curry satisfy - 2choice ; inline - -: 'quoted' ( delimiter -- parser ) - dup 'quoted-char' repeat0 swap dup surrounded-by ; - -: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ; - -: 'argument' ( -- parser ) - "\"" 'quoted' - "'" 'quoted' - 'unquoted' 3choice - [ >string ] action ; - -PEG: tokenize-command ( command -- ast/f ) - 'argument' " " token repeat1 list-of - " " token repeat0 tuck pack - just ; diff --git a/basis/io/unix/launcher/parser/tags.txt b/basis/io/unix/launcher/parser/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/launcher/parser/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/launcher/tags.txt b/basis/io/unix/launcher/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/launcher/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/linux/authors.txt b/basis/io/unix/linux/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/basis/io/unix/linux/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/io/unix/linux/linux.factor b/basis/io/unix/linux/linux.factor deleted file mode 100644 index fd24e0ac02..0000000000 --- a/basis/io/unix/linux/linux.factor +++ /dev/null @@ -1,10 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel system namespaces io.backend io.unix.backend -io.unix.multiplexers io.unix.multiplexers.epoll ; -IN: io.unix.linux - -M: linux init-io ( -- ) - mx set-global ; - -linux set-io-backend diff --git a/basis/io/unix/linux/monitors/monitors-tests.factor b/basis/io/unix/linux/monitors/monitors-tests.factor deleted file mode 100644 index 42c5009ccb..0000000000 --- a/basis/io/unix/linux/monitors/monitors-tests.factor +++ /dev/null @@ -1,36 +0,0 @@ -IN: io.unix.linux.monitors.tests -USING: io.monitors tools.test io.files system sequences -continuations namespaces concurrency.count-downs kernel io -threads calendar prettyprint destructors io.timeouts ; - -! On Linux, a notification on the directory itself would report an invalid -! path name -[ - [ ] [ "monitor-test-self" temp-file make-directories ] unit-test - - ! Non-recursive - [ ] [ "monitor-test-self" temp-file f "m" set ] unit-test - [ ] [ 3 seconds "m" get set-timeout ] unit-test - - [ ] [ "monitor-test-self" temp-file touch-file ] unit-test - - [ t ] [ - "m" get next-change drop - [ "" = ] [ "monitor-test-self" temp-file = ] bi or - ] unit-test - - [ ] [ "m" get dispose ] unit-test - - ! Recursive - [ ] [ "monitor-test-self" temp-file t "m" set ] unit-test - [ ] [ 3 seconds "m" get set-timeout ] unit-test - - [ ] [ "monitor-test-self" temp-file touch-file ] unit-test - - [ t ] [ - "m" get next-change drop - [ "" = ] [ "monitor-test-self" temp-file = ] bi or - ] unit-test - - [ ] [ "m" get dispose ] unit-test -] with-monitors diff --git a/basis/io/unix/linux/monitors/monitors.factor b/basis/io/unix/linux/monitors/monitors.factor deleted file mode 100644 index 3964a25a04..0000000000 --- a/basis/io/unix/linux/monitors/monitors.factor +++ /dev/null @@ -1,136 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel io.backend io.monitors io.monitors.recursive -io.files io.buffers io.monitors io.ports io.timeouts -io.unix.backend io.encodings.utf8 unix.linux.inotify assocs -namespaces make threads continuations init math math.bitwise -sets alien alien.strings alien.c-types vocabs.loader accessors -system hashtables destructors unix ; -IN: io.unix.linux.monitors - -SYMBOL: watches - -SYMBOL: inotify - -TUPLE: linux-monitor < monitor wd inotify watches disposed ; - -: ( wd path mailbox -- monitor ) - linux-monitor new-monitor - inotify get >>inotify - watches get >>watches - swap >>wd ; - -: wd>monitor ( wd -- monitor ) watches get at ; - -: ( -- port/f ) - inotify_init dup 0 < [ drop f ] [ init-fd ] if ; - -: inotify-fd ( -- fd ) inotify get handle>> handle-fd ; - -: check-existing ( wd -- ) - watches get key? [ - "Cannot open multiple monitors for the same file" throw - ] when ; - -: (add-watch) ( path mask -- wd ) - inotify-fd -rot inotify_add_watch dup io-error dup check-existing ; - -: add-watch ( path mask mailbox -- monitor ) - [ [ (normalize-path) ] dip [ (add-watch) ] [ drop ] 2bi ] dip - [ ] [ ] [ wd>> ] tri watches get set-at ; - -: check-inotify ( -- ) - inotify get [ - "Calling outside with-monitors" throw - ] unless ; - -M: linux (monitor) ( path recursive? mailbox -- monitor ) - swap [ - - ] [ - check-inotify - IN_CHANGE_EVENTS swap add-watch - ] if ; - -M: linux-monitor dispose* ( monitor -- ) - [ [ wd>> ] [ watches>> ] bi delete-at ] - [ - dup inotify>> disposed>> [ drop ] [ - [ inotify>> handle>> handle-fd ] [ wd>> ] bi - inotify_rm_watch io-error - ] if - ] bi ; - -: ignore-flags? ( mask -- ? ) - { - IN_DELETE_SELF - IN_MOVE_SELF - IN_UNMOUNT - IN_Q_OVERFLOW - IN_IGNORED - } flags bitand 0 > ; - -: parse-action ( mask -- changed ) - [ - IN_CREATE +add-file+ ?flag - IN_DELETE +remove-file+ ?flag - IN_MODIFY +modify-file+ ?flag - IN_ATTRIB +modify-file+ ?flag - IN_MOVED_FROM +rename-file-old+ ?flag - IN_MOVED_TO +rename-file-new+ ?flag - drop - ] { } make prune ; - -: parse-event-name ( event -- name ) - dup inotify-event-len zero? - [ drop "" ] [ inotify-event-name utf8 alien>string ] if ; - -: parse-file-notify ( buffer -- path changed ) - dup inotify-event-mask ignore-flags? [ - drop f f - ] [ - [ parse-event-name ] [ inotify-event-mask parse-action ] bi - ] if ; - -: events-exhausted? ( i buffer -- ? ) - fill>> >= ; - -: inotify-event@ ( i buffer -- alien ) - ptr>> ; - -: next-event ( i buffer -- i buffer ) - 2dup inotify-event@ - inotify-event-len "inotify-event" heap-size + - swap [ + ] dip ; - -: parse-file-notifications ( i buffer -- ) - 2dup events-exhausted? [ 2drop ] [ - 2dup inotify-event@ dup inotify-event-wd wd>monitor - [ parse-file-notify ] dip queue-change - next-event parse-file-notifications - ] if ; - -: inotify-read-loop ( port -- ) - dup check-disposed - dup wait-to-read drop - 0 over buffer>> parse-file-notifications - 0 over buffer>> buffer-reset - inotify-read-loop ; - -: inotify-read-thread ( port -- ) - [ inotify-read-loop ] curry ignore-errors ; - -M: linux init-monitors - H{ } clone watches set - [ - [ inotify set ] - [ - [ inotify-read-thread ] curry - "Linux monitor thread" spawn drop - ] bi - ] [ - "Linux kernel version is too old" throw - ] if* ; - -M: linux dispose-monitors - inotify get dispose ; diff --git a/basis/io/unix/linux/monitors/tags.txt b/basis/io/unix/linux/monitors/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/linux/monitors/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/linux/tags.txt b/basis/io/unix/linux/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/linux/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/macosx/macosx.factor b/basis/io/unix/macosx/macosx.factor deleted file mode 100644 index 75f42b7394..0000000000 --- a/basis/io/unix/macosx/macosx.factor +++ /dev/null @@ -1,10 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: io.backend system namespaces io.unix.multiplexers -io.unix.multiplexers.run-loop ; -IN: io.unix.macosx - -M: macosx init-io ( -- ) - mx set-global ; - -macosx set-io-backend diff --git a/basis/io/unix/macosx/monitors/monitors.factor b/basis/io/unix/macosx/monitors/monitors.factor deleted file mode 100644 index cde1d6339a..0000000000 --- a/basis/io/unix/macosx/monitors/monitors.factor +++ /dev/null @@ -1,23 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: io.backend io.monitors -core-foundation.fsevents continuations kernel sequences -namespaces arrays system locals accessors destructors fry ; -IN: io.unix.macosx.monitors - -TUPLE: macosx-monitor < monitor handle ; - -: enqueue-notifications ( triples monitor -- ) - '[ first { +modify-file+ } _ queue-change ] each ; - -M:: macosx (monitor) ( path recursive? mailbox -- monitor ) - [let | path [ path normalize-path ] | - path mailbox macosx-monitor new-monitor - dup [ enqueue-notifications ] curry - path 1array 0 0 >>handle - ] ; - -M: macosx-monitor dispose - handle>> dispose ; - -macosx set-io-backend diff --git a/basis/io/unix/macosx/monitors/tags.txt b/basis/io/unix/macosx/monitors/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/macosx/monitors/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/macosx/tags.txt b/basis/io/unix/macosx/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/macosx/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/mmap/authors.txt b/basis/io/unix/mmap/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/basis/io/unix/mmap/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/io/unix/mmap/mmap.factor b/basis/io/unix/mmap/mmap.factor deleted file mode 100644 index d5dcda9436..0000000000 --- a/basis/io/unix/mmap/mmap.factor +++ /dev/null @@ -1,24 +0,0 @@ -! Copyright (C) 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: alien io io.files kernel math math.bitwise system unix -io.unix.backend io.ports io.mmap destructors locals accessors ; -IN: io.unix.mmap - -: open-r/w ( path -- fd ) O_RDWR file-mode open-file ; - -:: mmap-open ( path length prot flags -- alien fd ) - [ - f length prot flags - path open-r/w |dispose - [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep - ] with-destructors ; - -M: unix (mapped-file) - { PROT_READ PROT_WRITE } flags - { MAP_FILE MAP_SHARED } flags - mmap-open ; - -M: unix close-mapped-file ( mmap -- ) - [ [ address>> ] [ length>> ] bi munmap io-error ] - [ handle>> close-file ] - bi ; diff --git a/basis/io/unix/mmap/tags.txt b/basis/io/unix/mmap/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/mmap/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/multiplexers/epoll/authors.txt b/basis/io/unix/multiplexers/epoll/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/basis/io/unix/multiplexers/epoll/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/io/unix/multiplexers/epoll/epoll.factor b/basis/io/unix/multiplexers/epoll/epoll.factor deleted file mode 100644 index 08e20d4b95..0000000000 --- a/basis/io/unix/multiplexers/epoll/epoll.factor +++ /dev/null @@ -1,66 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types kernel destructors bit-arrays -sequences assocs struct-arrays math namespaces locals fry unix -unix.linux.epoll unix.time io.ports io.unix.backend -io.unix.multiplexers ; -IN: io.unix.multiplexers.epoll - -TUPLE: epoll-mx < mx events ; - -: max-events ( -- n ) - #! We read up to 256 events at a time. This is an arbitrary - #! constant... - 256 ; inline - -: ( -- mx ) - epoll-mx new-mx - max-events epoll_create dup io-error >>fd - max-events "epoll-event" >>events ; - -M: epoll-mx dispose fd>> close-file ; - -: make-event ( fd events -- event ) - "epoll-event" - [ set-epoll-event-events ] keep - [ set-epoll-event-fd ] keep ; - -:: do-epoll-ctl ( fd mx what events -- ) - mx fd>> what fd fd events make-event epoll_ctl io-error ; - -: do-epoll-add ( fd mx events -- ) - EPOLL_CTL_ADD swap EPOLLONESHOT bitor do-epoll-ctl ; - -: do-epoll-del ( fd mx events -- ) - EPOLL_CTL_DEL swap do-epoll-ctl ; - -M: epoll-mx add-input-callback ( thread fd mx -- ) - [ EPOLLIN do-epoll-add ] [ call-next-method ] 2bi ; - -M: epoll-mx add-output-callback ( thread fd mx -- ) - [ EPOLLOUT do-epoll-add ] [ call-next-method ] 2bi ; - -M: epoll-mx remove-input-callbacks ( fd mx -- seq ) - 2dup reads>> key? [ - [ call-next-method ] [ EPOLLIN do-epoll-del ] 2bi - ] [ 2drop f ] if ; - -M: epoll-mx remove-output-callbacks ( fd mx -- seq ) - 2dup writes>> key? [ - [ EPOLLOUT do-epoll-del ] [ call-next-method ] 2bi - ] [ 2drop f ] if ; - -: wait-event ( mx us -- n ) - [ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi* - epoll_wait multiplexer-error ; - -: handle-event ( event mx -- ) - [ epoll-event-fd ] dip - [ EPOLLIN EPOLLOUT bitor do-epoll-del ] - [ input-available ] [ output-available ] 2tri ; - -: handle-events ( mx n -- ) - [ dup events>> ] dip head-slice swap '[ _ handle-event ] each ; - -M: epoll-mx wait-for-events ( us mx -- ) - swap 60000000 or dupd wait-event handle-events ; diff --git a/basis/io/unix/multiplexers/epoll/tags.txt b/basis/io/unix/multiplexers/epoll/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/multiplexers/epoll/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/multiplexers/kqueue/authors.txt b/basis/io/unix/multiplexers/kqueue/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/basis/io/unix/multiplexers/kqueue/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/io/unix/multiplexers/kqueue/kqueue.factor b/basis/io/unix/multiplexers/kqueue/kqueue.factor deleted file mode 100644 index a66e86a6a7..0000000000 --- a/basis/io/unix/multiplexers/kqueue/kqueue.factor +++ /dev/null @@ -1,76 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.c-types combinators destructors -io.unix.backend kernel math.bitwise sequences struct-arrays unix -unix.kqueue unix.time assocs io.unix.multiplexers ; -IN: io.unix.multiplexers.kqueue - -TUPLE: kqueue-mx < mx events ; - -: max-events ( -- n ) - #! We read up to 256 events at a time. This is an arbitrary - #! constant... - 256 ; inline - -: ( -- mx ) - kqueue-mx new-mx - kqueue dup io-error >>fd - max-events "kevent" >>events ; - -M: kqueue-mx dispose fd>> close-file ; - -: make-kevent ( fd filter flags -- event ) - "kevent" - [ set-kevent-flags ] keep - [ set-kevent-filter ] keep - [ set-kevent-ident ] keep ; - -: register-kevent ( kevent mx -- ) - fd>> swap 1 f 0 f kevent io-error ; - -M: kqueue-mx add-input-callback ( thread fd mx -- ) - [ call-next-method ] [ - [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip - register-kevent - ] 2bi ; - -M: kqueue-mx add-output-callback ( thread fd mx -- ) - [ call-next-method ] [ - [ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip - register-kevent - ] 2bi ; - -M: kqueue-mx remove-input-callbacks ( fd mx -- seq ) - 2dup reads>> key? [ - [ call-next-method ] [ - [ EVFILT_READ EV_DELETE make-kevent ] dip - register-kevent - ] 2bi - ] [ 2drop f ] if ; - -M: kqueue-mx remove-output-callbacks ( fd mx -- seq ) - 2dup writes>> key? [ - [ - [ EVFILT_WRITE EV_DELETE make-kevent ] dip - register-kevent - ] [ call-next-method ] 2bi - ] [ 2drop f ] if ; - -: wait-kevent ( mx timespec -- n ) - [ - [ fd>> f 0 ] - [ events>> [ underlying>> ] [ length ] bi ] bi - ] dip kevent multiplexer-error ; - -: handle-kevent ( mx kevent -- ) - [ kevent-ident swap ] [ kevent-filter ] bi { - { EVFILT_READ [ input-available ] } - { EVFILT_WRITE [ output-available ] } - } case ; - -: handle-kevents ( mx n -- ) - [ dup events>> ] dip head-slice [ handle-kevent ] with each ; - -M: kqueue-mx wait-for-events ( us mx -- ) - swap dup [ make-timespec ] when - dupd wait-kevent handle-kevents ; diff --git a/basis/io/unix/multiplexers/kqueue/tags.txt b/basis/io/unix/multiplexers/kqueue/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/multiplexers/kqueue/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/multiplexers/multiplexers.factor b/basis/io/unix/multiplexers/multiplexers.factor deleted file mode 100644 index 1c9fb134e7..0000000000 --- a/basis/io/unix/multiplexers/multiplexers.factor +++ /dev/null @@ -1,35 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors assocs sequences threads ; -IN: io.unix.multiplexers - -TUPLE: mx fd reads writes ; - -: new-mx ( class -- obj ) - new - H{ } clone >>reads - H{ } clone >>writes ; inline - -GENERIC: add-input-callback ( thread fd mx -- ) - -M: mx add-input-callback reads>> push-at ; - -GENERIC: add-output-callback ( thread fd mx -- ) - -M: mx add-output-callback writes>> push-at ; - -GENERIC: remove-input-callbacks ( fd mx -- callbacks ) - -M: mx remove-input-callbacks reads>> delete-at* drop ; - -GENERIC: remove-output-callbacks ( fd mx -- callbacks ) - -M: mx remove-output-callbacks writes>> delete-at* drop ; - -GENERIC: wait-for-events ( ms mx -- ) - -: input-available ( fd mx -- ) - reads>> delete-at* drop [ resume ] each ; - -: output-available ( fd mx -- ) - writes>> delete-at* drop [ resume ] each ; diff --git a/basis/io/unix/multiplexers/run-loop/run-loop.factor b/basis/io/unix/multiplexers/run-loop/run-loop.factor deleted file mode 100644 index 4b2486d19f..0000000000 --- a/basis/io/unix/multiplexers/run-loop/run-loop.factor +++ /dev/null @@ -1,33 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel arrays namespaces math accessors alien locals -destructors system threads io.unix.multiplexers -io.unix.multiplexers.kqueue core-foundation -core-foundation.run-loop ; -IN: io.unix.multiplexers.run-loop - -TUPLE: run-loop-mx kqueue-mx ; - -: file-descriptor-callback ( -- callback ) - "void" { "CFFileDescriptorRef" "CFOptionFlags" "void*" } - "cdecl" [ - 3drop - 0 mx get kqueue-mx>> wait-for-events - reset-run-loop - yield - ] alien-callback ; - -: ( -- mx ) - [ - |dispose - dup fd>> file-descriptor-callback add-fd-to-run-loop - run-loop-mx boa - ] with-destructors ; - -M: run-loop-mx add-input-callback kqueue-mx>> add-input-callback ; -M: run-loop-mx add-output-callback kqueue-mx>> add-output-callback ; -M: run-loop-mx remove-input-callbacks kqueue-mx>> remove-input-callbacks ; -M: run-loop-mx remove-output-callbacks kqueue-mx>> remove-output-callbacks ; - -M: run-loop-mx wait-for-events ( us mx -- ) - swap run-one-iteration [ 0 swap wait-for-events ] [ drop ] if ; diff --git a/basis/io/unix/multiplexers/run-loop/tags.txt b/basis/io/unix/multiplexers/run-loop/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/multiplexers/run-loop/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/multiplexers/select/authors.txt b/basis/io/unix/multiplexers/select/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/basis/io/unix/multiplexers/select/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/io/unix/multiplexers/select/select.factor b/basis/io/unix/multiplexers/select/select.factor deleted file mode 100644 index 915daac2d3..0000000000 --- a/basis/io/unix/multiplexers/select/select.factor +++ /dev/null @@ -1,56 +0,0 @@ -! Copyright (C) 2004, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel bit-arrays sequences assocs unix -math namespaces accessors math.order locals unix.time fry -io.ports io.unix.backend io.unix.multiplexers ; -IN: io.unix.multiplexers.select - -TUPLE: select-mx < mx read-fdset write-fdset ; - -! Factor's bit-arrays are an array of bytes, OS X expects -! FD_SET to be an array of cells, so we have to account for -! byte order differences on big endian platforms -: munge ( i -- i' ) - little-endian? [ BIN: 11000 bitxor ] unless ; inline - -: ( -- mx ) - select-mx new-mx - FD_SETSIZE 8 * >>read-fdset - FD_SETSIZE 8 * >>write-fdset ; - -: clear-nth ( n seq -- ? ) - [ nth ] [ [ f ] 2dip set-nth ] 2bi ; - -:: check-fd ( fd fdset mx quot -- ) - fd munge fdset clear-nth [ fd mx quot call ] when ; inline - -: check-fdset ( fds fdset mx quot -- ) - [ check-fd ] 3curry each ; inline - -: init-fdset ( fds fdset -- ) - '[ t swap munge _ set-nth ] each ; - -: read-fdset/tasks ( mx -- seq fdset ) - [ reads>> keys ] [ read-fdset>> ] bi ; - -: write-fdset/tasks ( mx -- seq fdset ) - [ writes>> keys ] [ write-fdset>> ] bi ; - -: max-fd ( assoc -- n ) - dup assoc-empty? [ drop 0 ] [ keys supremum ] if ; - -: num-fds ( mx -- n ) - [ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ; - -: init-fdsets ( mx -- nfds read write except ) - [ num-fds ] - [ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] - [ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri - f ; - -M:: select-mx wait-for-events ( us mx -- ) - mx - [ init-fdsets us dup [ make-timeval ] when select multiplexer-error drop ] - [ [ read-fdset/tasks ] keep [ input-available ] check-fdset ] - [ [ write-fdset/tasks ] keep [ output-available ] check-fdset ] - tri ; diff --git a/basis/io/unix/multiplexers/select/tags.txt b/basis/io/unix/multiplexers/select/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/multiplexers/select/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/netbsd/netbsd.factor b/basis/io/unix/netbsd/netbsd.factor deleted file mode 100644 index ed134788b6..0000000000 --- a/basis/io/unix/netbsd/netbsd.factor +++ /dev/null @@ -1,3 +0,0 @@ -USING: io.unix.bsd io.backend system ; - -netbsd set-io-backend diff --git a/basis/io/unix/netbsd/tags.txt b/basis/io/unix/netbsd/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/netbsd/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/openbsd/openbsd.factor b/basis/io/unix/openbsd/openbsd.factor deleted file mode 100644 index dfc466f94b..0000000000 --- a/basis/io/unix/openbsd/openbsd.factor +++ /dev/null @@ -1,3 +0,0 @@ -USING: io.unix.bsd io.backend system ; - -openbsd set-io-backend diff --git a/basis/io/unix/openbsd/tags.txt b/basis/io/unix/openbsd/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/openbsd/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/pipes/pipes-tests.factor b/basis/io/unix/pipes/pipes-tests.factor deleted file mode 100644 index 6ea74043ca..0000000000 --- a/basis/io/unix/pipes/pipes-tests.factor +++ /dev/null @@ -1,17 +0,0 @@ -USING: tools.test io.pipes io.unix.pipes io.encodings.utf8 -io.encodings io namespaces sequences ; -IN: io.unix.pipes.tests - -[ { 0 0 } ] [ { "ls" "grep ." } run-pipeline ] unit-test - -[ { 0 f 0 } ] [ - { - "ls" - [ - input-stream [ utf8 ] change - output-stream [ utf8 ] change - input-stream get lines reverse [ print ] each f - ] - "grep ." - } run-pipeline -] unit-test diff --git a/basis/io/unix/pipes/pipes.factor b/basis/io/unix/pipes/pipes.factor deleted file mode 100644 index a28738e147..0000000000 --- a/basis/io/unix/pipes/pipes.factor +++ /dev/null @@ -1,11 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: system kernel unix math sequences qualified -io.unix.backend io.ports specialized-arrays.int accessors ; -IN: io.unix.pipes -QUALIFIED: io.pipes - -M: unix io.pipes:(pipe) ( -- pair ) - 2 - [ underlying>> pipe io-error ] - [ first2 [ init-fd ] bi@ io.pipes:pipe boa ] bi ; diff --git a/basis/io/unix/pipes/tags.txt b/basis/io/unix/pipes/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/pipes/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/select/authors.txt b/basis/io/unix/select/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/basis/io/unix/select/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/io/unix/select/select.factor b/basis/io/unix/select/select.factor deleted file mode 100644 index a6b61001a6..0000000000 --- a/basis/io/unix/select/select.factor +++ /dev/null @@ -1,56 +0,0 @@ -! Copyright (C) 2004, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel io.ports io.unix.backend -bit-arrays sequences assocs unix math namespaces -accessors math.order locals unix.time fry ; -IN: io.unix.select - -TUPLE: select-mx < mx read-fdset write-fdset ; - -! Factor's bit-arrays are an array of bytes, OS X expects -! FD_SET to be an array of cells, so we have to account for -! byte order differences on big endian platforms -: munge ( i -- i' ) - little-endian? [ BIN: 11000 bitxor ] unless ; inline - -: ( -- mx ) - select-mx new-mx - FD_SETSIZE 8 * >>read-fdset - FD_SETSIZE 8 * >>write-fdset ; - -: clear-nth ( n seq -- ? ) - [ nth ] [ [ f ] 2dip set-nth ] 2bi ; - -:: check-fd ( fd fdset mx quot -- ) - fd munge fdset clear-nth [ fd mx quot call ] when ; inline - -: check-fdset ( fds fdset mx quot -- ) - [ check-fd ] 3curry each ; inline - -: init-fdset ( fds fdset -- ) - '[ t swap munge _ set-nth ] each ; - -: read-fdset/tasks ( mx -- seq fdset ) - [ reads>> keys ] [ read-fdset>> ] bi ; - -: write-fdset/tasks ( mx -- seq fdset ) - [ writes>> keys ] [ write-fdset>> ] bi ; - -: max-fd ( assoc -- n ) - dup assoc-empty? [ drop 0 ] [ keys supremum ] if ; - -: num-fds ( mx -- n ) - [ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ; - -: init-fdsets ( mx -- nfds read write except ) - [ num-fds ] - [ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] - [ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri - f ; - -M:: select-mx wait-for-events ( us mx -- ) - mx - [ init-fdsets us dup [ make-timeval ] when select multiplexer-error drop ] - [ [ read-fdset/tasks ] keep [ input-available ] check-fdset ] - [ [ write-fdset/tasks ] keep [ output-available ] check-fdset ] - tri ; diff --git a/basis/io/unix/select/tags.txt b/basis/io/unix/select/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/select/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/sockets/authors.txt b/basis/io/unix/sockets/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/basis/io/unix/sockets/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/io/unix/sockets/secure/debug/debug.factor b/basis/io/unix/sockets/secure/debug/debug.factor deleted file mode 100644 index cd5353ea7b..0000000000 --- a/basis/io/unix/sockets/secure/debug/debug.factor +++ /dev/null @@ -1,11 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors io.sockets.secure kernel ; -IN: io.unix.sockets.secure.debug - -: with-test-context ( quot -- ) - - "resource:basis/openssl/test/server.pem" >>key-file - "resource:basis/openssl/test/dh1024.pem" >>dh-file - "password" >>password - swap with-secure-context ; inline diff --git a/basis/io/unix/sockets/secure/secure-tests.factor b/basis/io/unix/sockets/secure/secure-tests.factor deleted file mode 100644 index 0816dd270b..0000000000 --- a/basis/io/unix/sockets/secure/secure-tests.factor +++ /dev/null @@ -1,147 +0,0 @@ -IN: io.sockets.secure.tests -USING: accessors kernel namespaces io io.sockets -io.sockets.secure io.encodings.ascii io.streams.duplex -io.unix.backend classes words destructors threads tools.test -concurrency.promises byte-arrays locals calendar io.timeouts -io.unix.sockets.secure.debug ; - -\ must-infer -{ 1 0 } [ [ ] with-secure-context ] must-infer-as - -[ ] [ "port" set ] unit-test - -:: server-test ( quot -- ) - [ - [ - "127.0.0.1" 0 ascii [ - dup addr>> addrspec>> port>> "port" get fulfill - accept [ - quot call - ] curry with-stream - ] with-disposal - ] with-test-context - ] "SSL server test" spawn drop ; - -: client-test ( -- string ) - [ - "127.0.0.1" "port" get ?promise ascii drop contents - ] with-secure-context ; - -[ ] [ [ class name>> write ] server-test ] unit-test - -[ "secure" ] [ client-test ] unit-test - -! Now, see what happens if the server closes the connection prematurely -[ ] [ "port" set ] unit-test - -[ ] [ - [ - drop - "hello" write flush - input-stream get stream>> handle>> f >>connected drop - ] server-test -] unit-test - -[ client-test ] [ premature-close? ] must-fail-with - -! Now, try validating the certificate. This should fail because its -! actually an invalid certificate -[ ] [ "port" set ] unit-test - -[ ] [ [ drop "hi" write ] server-test ] unit-test - -[ - [ - "localhost" "port" get ?promise ascii - drop dispose - ] with-secure-context -] [ certificate-verify-error? ] must-fail-with - -! Client-side handshake timeout -[ ] [ "port" set ] unit-test - -[ ] [ - [ - "127.0.0.1" 0 ascii [ - dup addr>> port>> "port" get fulfill - accept drop 1 minutes sleep dispose - ] with-disposal - ] "Silly server" spawn drop -] unit-test - -[ - 1 seconds secure-socket-timeout [ - client-test - ] with-variable -] [ io-timeout? ] must-fail-with - -! Server-side handshake timeout -[ ] [ "port" set ] unit-test - -[ ] [ - [ - "127.0.0.1" "port" get ?promise - ascii drop 1 minutes sleep dispose - ] "Silly client" spawn drop -] unit-test - -[ - 1 seconds secure-socket-timeout [ - [ - "127.0.0.1" 0 ascii [ - dup addr>> addrspec>> port>> "port" get fulfill - accept drop dup stream-read1 drop dispose - ] with-disposal - ] with-test-context - ] with-variable -] [ io-timeout? ] must-fail-with - -! Client socket shutdown timeout - -! Until I sort out two-stage handshaking, I can't do much here -[ - [ ] [ "port" set ] unit-test - - [ ] [ - [ - [ - "127.0.0.1" 0 ascii [ - dup addr>> addrspec>> port>> "port" get fulfill - accept drop 1 minutes sleep dispose - ] with-disposal - ] with-test-context - ] "Silly server" spawn drop - ] unit-test - - [ - 1 seconds secure-socket-timeout [ - [ - "127.0.0.1" "port" get ?promise - ascii drop dispose - ] with-secure-context - ] with-variable - ] [ io-timeout? ] must-fail-with - - ! Server socket shutdown timeout - [ ] [ "port" set ] unit-test - - [ ] [ - [ - [ - "127.0.0.1" "port" get ?promise - ascii drop 1 minutes sleep dispose - ] with-test-context - ] "Silly client" spawn drop - ] unit-test - - [ - 1 seconds secure-socket-timeout [ - [ - "127.0.0.1" 0 ascii [ - dup addr>> addrspec>> port>> "port" get fulfill - accept drop dispose - ] with-disposal - ] with-test-context - ] with-variable - ] [ io-timeout? ] must-fail-with -] drop diff --git a/basis/io/unix/sockets/secure/secure.factor b/basis/io/unix/sockets/secure/secure.factor deleted file mode 100644 index 106b6569ed..0000000000 --- a/basis/io/unix/sockets/secure/secure.factor +++ /dev/null @@ -1,200 +0,0 @@ -! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors unix byte-arrays kernel sequences -namespaces math math.order combinators init alien alien.c-types -alien.strings libc continuations destructors openssl -openssl.libcrypto openssl.libssl io io.files io.ports -io.unix.backend io.unix.sockets io.encodings.ascii io.buffers -io.sockets io.sockets.secure io.sockets.secure.openssl -io.timeouts system summary fry ; -IN: io.unix.sockets.secure - -M: ssl-handle handle-fd file>> handle-fd ; - -: syscall-error ( r -- * ) - ERR_get_error dup zero? [ - drop - { - { -1 [ err_no ECONNRESET = [ premature-close ] [ (io-error) ] if ] } - { 0 [ premature-close ] } - } case - ] [ nip (ssl-error) ] if ; - -: check-accept-response ( handle r -- event ) - over handle>> over SSL_get_error - { - { SSL_ERROR_NONE [ 2drop f ] } - { SSL_ERROR_WANT_READ [ 2drop +input+ ] } - { SSL_ERROR_WANT_ACCEPT [ 2drop +input+ ] } - { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } - { SSL_ERROR_SYSCALL [ syscall-error ] } - { SSL_ERROR_ZERO_RETURN [ (ssl-error) ] } - { SSL_ERROR_SSL [ (ssl-error) ] } - } case ; - -: do-ssl-accept ( ssl-handle -- ) - dup dup handle>> SSL_accept check-accept-response dup - [ [ dup file>> ] dip wait-for-fd do-ssl-accept ] [ 2drop ] if ; - -: maybe-handshake ( ssl-handle -- ) - dup connected>> [ drop ] [ - t >>connected - [ do-ssl-accept ] with-timeout - ] if ; - -: check-response ( port r -- port r n ) - over handle>> handle>> over SSL_get_error ; inline - -! Input ports -: check-read-response ( port r -- event ) - check-response - { - { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] } - { SSL_ERROR_ZERO_RETURN [ 2drop f ] } - { SSL_ERROR_WANT_READ [ 2drop +input+ ] } - { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } - { SSL_ERROR_SYSCALL [ syscall-error ] } - { SSL_ERROR_SSL [ (ssl-error) ] } - } case ; - -M: ssl-handle refill - dup maybe-handshake - handle>> ! ssl - over buffer>> - [ buffer-end ] ! buf - [ buffer-capacity ] bi ! len - SSL_read - check-read-response ; - -! Output ports -: check-write-response ( port r -- event ) - check-response - { - { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] } - { SSL_ERROR_WANT_READ [ 2drop +input+ ] } - { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } - { SSL_ERROR_SYSCALL [ syscall-error ] } - { SSL_ERROR_SSL [ (ssl-error) ] } - } case ; - -M: ssl-handle drain - dup maybe-handshake - handle>> ! ssl - over buffer>> - [ buffer@ ] ! buf - [ buffer-length ] bi ! len - SSL_write - check-write-response ; - -M: ssl-handle cancel-operation - file>> cancel-operation ; - -M: ssl-handle timeout - drop secure-socket-timeout get ; - -! Client sockets -: ( fd -- ssl ) - [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep - [ handle>> swap dup SSL_set_bio ] keep ; - -M: secure ((client)) ( addrspec -- handle ) - addrspec>> ((client)) ; - -M: secure parse-sockaddr addrspec>> parse-sockaddr ; - -M: secure (get-local-address) addrspec>> (get-local-address) ; - -: check-connect-response ( ssl-handle r -- event ) - over handle>> over SSL_get_error - { - { SSL_ERROR_NONE [ 2drop f ] } - { SSL_ERROR_WANT_READ [ 2drop +input+ ] } - { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } - { SSL_ERROR_SYSCALL [ syscall-error ] } - { SSL_ERROR_SSL [ (ssl-error) ] } - } case ; - -: do-ssl-connect ( ssl-handle -- ) - dup dup handle>> SSL_connect check-connect-response dup - [ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ; - -: resume-session ( ssl-handle ssl-session -- ) - [ [ handle>> ] dip SSL_set_session ssl-error ] - [ drop do-ssl-connect ] - 2bi ; - -: begin-session ( ssl-handle addrspec -- ) - [ drop do-ssl-connect ] - [ [ handle>> SSL_get1_session ] dip save-session ] - 2bi ; - -: secure-connection ( client-out addrspec -- ) - [ handle>> ] dip - [ - '[ - _ dup get-session - [ resume-session ] [ begin-session ] ?if - ] with-timeout - ] [ drop t >>connected drop ] 2bi ; - -M: secure establish-connection ( client-out remote -- ) - addrspec>> [ establish-connection ] [ secure-connection ] 2bi ; - -M: secure (server) addrspec>> (server) ; - -M: secure (accept) - [ - addrspec>> (accept) [ |dispose ] dip - ] with-destructors ; - -: check-shutdown-response ( handle r -- event ) - #! We don't do two-step shutdown here because I couldn't - #! figure out how to do it with non-blocking BIOs. Also, it - #! seems that SSL_shutdown always returns 0 -- this sounds - #! like a bug - over handle>> over SSL_get_error - { - { SSL_ERROR_NONE [ 2drop f ] } - { SSL_ERROR_WANT_READ [ 2drop +input+ ] } - { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } - { SSL_ERROR_SYSCALL [ dup zero? [ 2drop f ] [ syscall-error ] if ] } - { SSL_ERROR_SSL [ (ssl-error) ] } - } case ; - -: (shutdown) ( handle -- ) - dup dup handle>> SSL_shutdown check-shutdown-response - dup [ dupd wait-for-fd (shutdown) ] [ 2drop ] if ; - -M: ssl-handle shutdown - dup connected>> [ - f >>connected [ (shutdown) ] with-timeout - ] [ drop ] if ; - -: check-buffer ( port -- port ) - dup buffer>> buffer-empty? [ upgrade-buffers-full ] unless ; - -: input/output-ports ( -- input output ) - input-stream output-stream - [ get underlying-port check-buffer ] bi@ - 2dup [ handle>> ] bi@ eq? [ upgrade-on-non-socket ] unless ; - -: make-input/output-secure ( input output -- ) - dup handle>> fd? [ upgrade-on-non-socket ] unless - [ ] change-handle - handle>> >>handle drop ; - -: (send-secure-handshake) ( output -- ) - remote-address get [ upgrade-on-non-socket ] unless* - secure-connection ; - -M: openssl send-secure-handshake - input/output-ports - [ make-input/output-secure ] keep - [ (send-secure-handshake) ] keep - remote-address get dup inet? [ - host>> swap handle>> check-certificate - ] [ 2drop ] if ; - -M: openssl accept-secure-handshake - input/output-ports - make-input/output-secure ; diff --git a/basis/io/unix/sockets/secure/tags.txt b/basis/io/unix/sockets/secure/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/sockets/secure/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/sockets/sockets.factor b/basis/io/unix/sockets/sockets.factor deleted file mode 100644 index 5fba7badb0..0000000000 --- a/basis/io/unix/sockets/sockets.factor +++ /dev/null @@ -1,155 +0,0 @@ -! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.strings generic kernel math -namespaces threads sequences byte-arrays io.ports -io.binary io.unix.backend io.streams.duplex -io.backend io.ports io.files io.files.private -io.encodings.utf8 math.parser continuations libc combinators -system accessors qualified destructors unix locals init ; - -EXCLUDE: io => read write close ; -EXCLUDE: io.sockets => accept ; - -IN: io.unix.sockets - -: socket-fd ( domain type -- fd ) - 0 socket dup io-error init-fd |dispose ; - -: set-socket-option ( fd level opt -- ) - [ handle-fd ] 2dip 1 "int" heap-size setsockopt io-error ; - -M: unix addrinfo-error ( n -- ) - dup zero? [ drop ] [ gai_strerror throw ] if ; - -! Client sockets - TCP and Unix domain -M: object (get-local-address) ( handle remote -- sockaddr ) - [ handle-fd ] dip empty-sockaddr/size - [ getsockname io-error ] 2keep drop ; - -M: object (get-remote-address) ( handle local -- sockaddr ) - [ handle-fd ] dip empty-sockaddr/size - [ getpeername io-error ] 2keep drop ; - -: init-client-socket ( fd -- ) - SOL_SOCKET SO_OOBINLINE set-socket-option ; - -: wait-to-connect ( port -- ) - dup handle>> handle-fd f 0 write - { - { [ 0 = ] [ drop ] } - { [ err_no EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] } - { [ err_no EINTR = ] [ wait-to-connect ] } - [ (io-error) ] - } cond ; - -M: object establish-connection ( client-out remote -- ) - [ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi - { - { [ 0 = ] [ drop ] } - { [ err_no EINPROGRESS = ] [ - [ +output+ wait-for-port ] [ wait-to-connect ] bi - ] } - [ (io-error) ] - } cond ; - -M: object ((client)) ( addrspec -- fd ) - protocol-family SOCK_STREAM socket-fd dup init-client-socket ; - -! Server sockets - TCP and Unix domain -: init-server-socket ( fd -- ) - SOL_SOCKET SO_REUSEADDR set-socket-option ; - -: server-socket-fd ( addrspec type -- fd ) - [ dup protocol-family ] dip socket-fd - dup init-server-socket - dup handle-fd rot make-sockaddr/size bind io-error ; - -M: object (server) ( addrspec -- handle ) - [ - SOCK_STREAM server-socket-fd - dup handle-fd 128 listen io-error - ] with-destructors ; - -: do-accept ( server addrspec -- fd sockaddr ) - [ handle>> handle-fd ] [ empty-sockaddr/size ] bi* - [ accept ] 2keep drop ; inline - -M: object (accept) ( server addrspec -- fd sockaddr ) - 2dup do-accept - { - { [ over 0 >= ] [ [ 2nip init-fd ] dip ] } - { [ err_no EINTR = ] [ 2drop (accept) ] } - { [ err_no EAGAIN = ] [ - 2drop - [ drop +input+ wait-for-port ] - [ (accept) ] - 2bi - ] } - [ (io-error) ] - } cond ; - -! Datagram sockets - UDP and Unix domain -M: unix (datagram) - [ SOCK_DGRAM server-socket-fd ] with-destructors ; - -SYMBOL: receive-buffer - -: packet-size 65536 ; inline - -[ packet-size malloc receive-buffer set-global ] "io.unix.sockets" add-init-hook - -:: do-receive ( port -- packet sockaddr ) - port addr>> empty-sockaddr/size [| sockaddr len | - port handle>> handle-fd ! s - receive-buffer get-global ! buf - packet-size ! nbytes - 0 ! flags - sockaddr ! from - len ! fromlen - recvfrom dup 0 >= [ - receive-buffer get-global swap memory>byte-array sockaddr - ] [ - drop f f - ] if - ] call ; - -M: unix (receive) ( datagram -- packet sockaddr ) - dup do-receive dup [ [ drop ] 2dip ] [ - 2drop [ +input+ wait-for-port ] [ (receive) ] bi - ] if ; - -:: do-send ( packet sockaddr len socket datagram -- ) - socket handle-fd packet dup length 0 sockaddr len sendto - 0 < [ - err_no EINTR = [ - packet sockaddr len socket datagram do-send - ] [ - err_no EAGAIN = [ - datagram +output+ wait-for-port - packet sockaddr len socket datagram do-send - ] [ - (io-error) - ] if - ] if - ] when ; - -M: unix (send) ( packet addrspec datagram -- ) - [ make-sockaddr/size ] [ [ handle>> ] keep ] bi* do-send ; - -! Unix domain sockets -M: local protocol-family drop PF_UNIX ; - -M: local sockaddr-size drop "sockaddr-un" heap-size ; - -M: local empty-sockaddr drop "sockaddr-un" ; - -M: local make-sockaddr - path>> (normalize-path) - dup length 1 + max-un-path > [ "Path too long" throw ] when - "sockaddr-un" - AF_UNIX over set-sockaddr-un-family - dup sockaddr-un-path rot utf8 string>alien dup length memcpy ; - -M: local parse-sockaddr - drop - sockaddr-un-path utf8 alien>string ; diff --git a/basis/io/unix/sockets/summary.txt b/basis/io/unix/sockets/summary.txt deleted file mode 100644 index 22342ec413..0000000000 --- a/basis/io/unix/sockets/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Implementation of TCP/IP and UDP/IP sockets on Unix-like systems diff --git a/basis/io/unix/sockets/tags.txt b/basis/io/unix/sockets/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/sockets/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/summary.txt b/basis/io/unix/summary.txt deleted file mode 100644 index 8f66d889cc..0000000000 --- a/basis/io/unix/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Non-blocking I/O and sockets on Unix-like systems diff --git a/basis/io/unix/tags.txt b/basis/io/unix/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/unix/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/unix/unix-tests.factor b/basis/io/unix/unix-tests.factor deleted file mode 100644 index df61420c77..0000000000 --- a/basis/io/unix/unix-tests.factor +++ /dev/null @@ -1,140 +0,0 @@ -USING: io.files io.sockets io kernel threads -namespaces tools.test continuations strings byte-arrays -sequences prettyprint system io.encodings.binary io.encodings.ascii -io.streams.duplex destructors make ; -IN: io.unix.tests - -! Unix domain stream sockets -: socket-server "unix-domain-socket-test" temp-file ; - -[ - [ socket-server delete-file ] ignore-errors - - socket-server - ascii [ - accept drop [ - "Hello world" print flush - readln "XYZ" = "FOO" "BAR" ? print flush - ] with-stream - ] with-disposal - - socket-server delete-file -] "Test" spawn drop - -yield - -[ { "Hello world" "FOO" } ] [ - [ - socket-server ascii [ - readln , - "XYZ" print flush - readln , - ] with-client - ] { } make -] unit-test - -: datagram-server "unix-domain-datagram-test" temp-file ; -: datagram-client "unix-domain-datagram-test-2" temp-file ; - -! Unix domain datagram sockets -[ datagram-server delete-file ] ignore-errors -[ datagram-client delete-file ] ignore-errors - -[ - [ - datagram-server "d" set - - "Receive 1" print - - "d" get receive [ reverse ] dip - - "Send 1" print - dup . - - "d" get send - - "Receive 2" print - - "d" get receive [ " world" append ] dip - - "Send 1" print - dup . - - "d" get send - - "d" get dispose - - "Done" print - - datagram-server delete-file - ] with-scope -] "Test" spawn drop - -yield - -[ datagram-client delete-file ] ignore-errors - -datagram-client -"d" set - -[ ] [ - "hello" >byte-array - datagram-server - "d" get send -] unit-test - -[ "olleh" t ] [ - "d" get receive - datagram-server = - [ >string ] dip -] unit-test - -[ ] [ - "hello" >byte-array - datagram-server - "d" get send -] unit-test - -[ "hello world" t ] [ - "d" get receive - datagram-server = - [ >string ] dip -] unit-test - -[ ] [ "d" get dispose ] unit-test - -! Test error behavior -: another-datagram "unix-domain-datagram-test-3" temp-file ; - -[ another-datagram delete-file ] ignore-errors - -datagram-client delete-file - -[ ] [ datagram-client "d" set ] unit-test - -[ B{ 1 2 3 } another-datagram "d" get send ] must-fail - -[ ] [ "d" get dispose ] unit-test - -! See what happens on send/receive after close - -[ "d" get receive ] must-fail - -[ B{ 1 2 } datagram-server "d" get send ] must-fail - -! Invalid parameter tests - -[ - image binary [ input-stream get accept ] with-file-reader -] must-fail - -[ - image binary [ input-stream get receive ] with-file-reader -] must-fail - -[ - image binary [ - B{ 1 2 } datagram-server - input-stream get send - ] with-file-reader -] must-fail diff --git a/basis/io/unix/unix.factor b/basis/io/unix/unix.factor deleted file mode 100644 index 93b5fa620e..0000000000 --- a/basis/io/unix/unix.factor +++ /dev/null @@ -1,4 +0,0 @@ -USING: accessors system words sequences vocabs.loader -io.unix.backend io.unix.files ; - -"io.unix." os name>> append require diff --git a/basis/io/windows/authors.txt b/basis/io/windows/authors.txt deleted file mode 100644 index 781acc2b62..0000000000 --- a/basis/io/windows/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Doug Coleman -Mackenzie Straight diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor deleted file mode 100755 index 664727dbdb..0000000000 --- a/basis/io/windows/files/files.factor +++ /dev/null @@ -1,378 +0,0 @@ -! 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.encodings.utf16n io.ports io.windows kernel math splitting -fry alien.strings windows windows.kernel32 windows.time calendar -combinators math.functions sequences namespaces make words -symbols system destructors accessors math.bitwise continuations -windows.errors arrays byte-arrays generalizations ; -IN: io.windows.files - -: open-file ( path access-mode create-mode flags -- handle ) - [ - [ share-mode default-security-attributes ] 2dip - CreateFile-flags f CreateFile opened-file - ] with-destructors ; - -: open-pipe-r/w ( path -- win32-file ) - { GENERIC_READ GENERIC_WRITE } flags - OPEN_EXISTING 0 open-file ; - -: open-read ( path -- win32-file ) - GENERIC_READ OPEN_EXISTING 0 open-file 0 >>ptr ; - -: open-write ( path -- win32-file ) - GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 >>ptr ; - -: (open-append) ( path -- win32-file ) - GENERIC_WRITE OPEN_ALWAYS 0 open-file ; - -: open-existing ( path -- win32-file ) - { GENERIC_READ GENERIC_WRITE } flags - share-mode - f - OPEN_EXISTING - FILE_FLAG_BACKUP_SEMANTICS - f CreateFileW dup win32-error=0/f ; - -: maybe-create-file ( path -- win32-file ? ) - #! return true if file was just created - { GENERIC_READ GENERIC_WRITE } flags - share-mode - f - OPEN_ALWAYS - 0 CreateFile-flags - f CreateFileW dup win32-error=0/f - GetLastError ERROR_ALREADY_EXISTS = not ; - -: set-file-pointer ( handle length method -- ) - [ dupd d>w/w ] dip SetFilePointer - INVALID_SET_FILE_POINTER = [ - CloseHandle "SetFilePointer failed" throw - ] when drop ; - -HOOK: open-append os ( path -- win32-file ) - -TUPLE: FileArgs - hFile lpBuffer nNumberOfBytesToRead - lpNumberOfBytesRet lpOverlapped ; - -C: FileArgs - -: make-FileArgs ( port -- ) - { - [ handle>> check-disposed ] - [ handle>> handle>> ] - [ buffer>> ] - [ buffer>> buffer-length ] - [ drop "DWORD" ] - [ FileArgs-overlapped ] - } cleave ; - -: setup-read ( -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped ) - { - [ hFile>> ] - [ lpBuffer>> buffer-end ] - [ lpBuffer>> buffer-capacity ] - [ lpNumberOfBytesRet>> ] - [ lpOverlapped>> ] - } cleave ; - -: setup-write ( -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped ) - { - [ hFile>> ] - [ lpBuffer>> buffer@ ] - [ lpBuffer>> buffer-length ] - [ lpNumberOfBytesRet>> ] - [ lpOverlapped>> ] - } cleave ; - -M: windows (file-reader) ( path -- stream ) - open-read ; - -M: windows (file-writer) ( path -- stream ) - open-write ; - -M: windows (file-appender) ( path -- stream ) - open-append ; - -M: windows move-file ( from to -- ) - [ normalize-path ] bi@ MoveFile win32-error=0/f ; - -M: windows delete-file ( path -- ) - normalize-path DeleteFile win32-error=0/f ; - -M: windows copy-file ( from to -- ) - dup parent-directory make-directories - [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ; - -M: windows make-directory ( path -- ) - normalize-path - f CreateDirectory win32-error=0/f ; - -M: windows delete-directory ( path -- ) - normalize-path - RemoveDirectory win32-error=0/f ; - -: find-first-file ( path -- WIN32_FIND_DATA handle ) - "WIN32_FIND_DATA" tuck - FindFirstFile - [ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ; - -: find-next-file ( path -- WIN32_FIND_DATA/f ) - "WIN32_FIND_DATA" 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+ -+sparse-file+ +reparse-point+ +compressed+ +offline+ -+not-content-indexed+ +encrypted+ ; - -TUPLE: windows-file-info < file-info attributes ; - -: win32-file-attribute ( n attr symbol -- ) - rot mask? [ , ] [ drop ] if ; - -: win32-file-attributes ( n -- seq ) - [ - { - [ +read-only+ FILE_ATTRIBUTE_READONLY win32-file-attribute ] - [ +hidden+ FILE_ATTRIBUTE_HIDDEN win32-file-attribute ] - [ +system+ FILE_ATTRIBUTE_SYSTEM win32-file-attribute ] - [ +directory+ FILE_ATTRIBUTE_DIRECTORY win32-file-attribute ] - [ +archive+ FILE_ATTRIBUTE_ARCHIVE win32-file-attribute ] - [ +device+ FILE_ATTRIBUTE_DEVICE win32-file-attribute ] - [ +normal+ FILE_ATTRIBUTE_NORMAL win32-file-attribute ] - [ +temporary+ FILE_ATTRIBUTE_TEMPORARY win32-file-attribute ] - [ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE win32-file-attribute ] - [ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT win32-file-attribute ] - [ +compressed+ FILE_ATTRIBUTE_COMPRESSED win32-file-attribute ] - [ +offline+ FILE_ATTRIBUTE_OFFLINE win32-file-attribute ] - [ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED win32-file-attribute ] - [ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED win32-file-attribute ] - } cleave - ] { } make ; - -: win32-file-type ( n -- symbol ) - FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ; - -TUPLE: windows-directory-entry < directory-entry attributes ; - -M: windows >directory-entry ( byte-array -- directory-entry ) - [ WIN32_FIND_DATA-cFileName utf16n alien>string ] - [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ] - [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ] - tri - dupd remove windows-directory-entry boa ; - -: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info ) - [ \ windows-file-info new ] dip - { - [ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ] - [ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes >>attributes ] - [ - [ WIN32_FIND_DATA-nFileSizeLow ] - [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size - ] - [ WIN32_FIND_DATA-dwFileAttributes >>permissions ] - [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp >>created ] - [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp >>modified ] - [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp >>accessed ] - } cleave ; - -: find-first-file-stat ( path -- WIN32_FIND_DATA ) - "WIN32_FIND_DATA" [ - FindFirstFile - [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep - FindClose win32-error=0/f - ] keep ; - -: BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info ) - [ \ windows-file-info new ] dip - { - [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ] - [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes >>attributes ] - [ - [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ] - [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size - ] - [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes >>permissions ] - [ - BY_HANDLE_FILE_INFORMATION-ftCreationTime - FILETIME>timestamp >>created - ] - [ - BY_HANDLE_FILE_INFORMATION-ftLastWriteTime - FILETIME>timestamp >>modified - ] - [ - BY_HANDLE_FILE_INFORMATION-ftLastAccessTime - FILETIME>timestamp >>accessed - ] - ! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ] - ! [ - ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ] - ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit - ! ] - } cleave ; - -: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION ) - [ - "BY_HANDLE_FILE_INFORMATION" - [ GetFileInformationByHandle win32-error=0/f ] keep - ] keep CloseHandle win32-error=0/f ; - -: get-file-information-stat ( path -- BY_HANDLE_FILE_INFORMATION ) - dup - GENERIC_READ FILE_SHARE_READ f - OPEN_EXISTING FILE_FLAG_BACKUP_SEMANTICS f - CreateFileW dup INVALID_HANDLE_VALUE = [ - drop find-first-file-stat WIN32_FIND_DATA>file-info - ] [ - nip - get-file-information BY_HANDLE_FILE_INFORMATION>file-info - ] if ; - -M: winnt file-info ( path -- info ) - normalize-path get-file-information-stat ; - -M: winnt link-info ( path -- info ) - file-info ; - -HOOK: root-directory os ( string -- string' ) - -: volume-information ( normalized-path -- volume-name volume-serial max-component flags type ) - MAX_PATH 1+ [ ] keep - "DWORD" - "DWORD" - "DWORD" - MAX_PATH 1+ [ ] keep - [ GetVolumeInformation win32-error=0/f ] 7 nkeep - drop 5 nrot drop - [ utf16n alien>string ] 4 ndip - utf16n alien>string ; - -: file-system-space ( normalized-path -- available-space total-space free-space ) - "ULARGE_INTEGER" - "ULARGE_INTEGER" - "ULARGE_INTEGER" - [ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ; - -: calculate-file-system-info ( file-system-info -- file-system-info' ) - { - [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ] - [ ] - } cleave ; - -TUPLE: win32-file-system-info < file-system-info max-component flags device-serial ; - -M: winnt file-system-info ( path -- file-system-info ) - normalize-path root-directory - dup [ volume-information ] [ file-system-space ] bi - \ win32-file-system-info new - swap *ulonglong >>free-space - swap *ulonglong >>total-space - swap *ulonglong >>available-space - swap >>type - swap *uint >>flags - swap *uint >>max-component - swap *uint >>device-serial - swap >>device-name - swap >>mount-point - calculate-file-system-info ; - -: volume>paths ( string -- array ) - 16384 "ushort" tuck dup length - 0 dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [ - win32-error-string throw - ] [ - *uint "ushort" heap-size * head - utf16n alien>string CHAR: \0 split - ] if ; - -: find-first-volume ( -- string handle ) - MAX_PATH 1+ [ ] keep - dupd - FindFirstVolume dup win32-error=0/f - [ utf16n alien>string ] dip ; - -: find-next-volume ( handle -- string/f ) - MAX_PATH 1+ [ tuck ] keep - FindNextVolume 0 = [ - GetLastError ERROR_NO_MORE_FILES = - [ drop f ] [ win32-error-string throw ] if - ] [ - utf16n alien>string - ] if ; - -: find-volumes ( -- array ) - find-first-volume - [ - '[ - [ _ find-next-volume dup ] - [ ] - [ drop ] produce - swap prefix - ] - ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ; - -M: winnt file-systems ( -- array ) - find-volumes [ volume>paths ] map - concat [ - [ file-system-info ] - [ drop \ file-system-info new swap >>mount-point ] recover - ] map ; - -: file-times ( path -- timestamp timestamp timestamp ) - [ - normalize-path open-existing &dispose handle>> - "FILETIME" - "FILETIME" - "FILETIME" - [ GetFileTime win32-error=0/f ] 3keep - [ FILETIME>timestamp >local-time ] tri@ - ] with-destructors ; - -: (set-file-times) ( handle timestamp/f timestamp/f timestamp/f -- ) - [ timestamp>FILETIME ] tri@ - SetFileTime win32-error=0/f ; - -: set-file-times ( path timestamp/f timestamp/f timestamp/f -- ) - #! timestamp order: creation access write - [ - [ - normalize-path open-existing &dispose handle>> - ] 3dip (set-file-times) - ] with-destructors ; - -: set-file-create-time ( path timestamp -- ) - f f set-file-times ; - -: set-file-access-time ( path timestamp -- ) - [ f ] dip f set-file-times ; - -: set-file-write-time ( path timestamp -- ) - [ f f ] dip set-file-times ; - -M: winnt touch-file ( path -- ) - [ - normalize-path - maybe-create-file [ &dispose ] dip - [ drop ] [ handle>> f now dup (set-file-times) ] if - ] with-destructors ; diff --git a/basis/io/windows/files/tags.txt b/basis/io/windows/files/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/windows/files/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/windows/files/unique/tags.txt b/basis/io/windows/files/unique/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/windows/files/unique/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/windows/files/unique/unique.factor b/basis/io/windows/files/unique/unique.factor deleted file mode 100644 index ab99bf2cac..0000000000 --- a/basis/io/windows/files/unique/unique.factor +++ /dev/null @@ -1,10 +0,0 @@ -USING: kernel system windows.kernel32 io.windows -io.windows.files io.ports windows destructors environment -io.files.unique ; -IN: io.windows.files.unique - -M: windows touch-unique-file ( path -- ) - GENERIC_WRITE CREATE_NEW 0 open-file dispose ; - -M: windows temporary-path ( -- path ) - "TEMP" os-env ; diff --git a/basis/io/windows/launcher/authors.txt b/basis/io/windows/launcher/authors.txt deleted file mode 100755 index 5674120196..0000000000 --- a/basis/io/windows/launcher/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Doug Coleman -Slava Pestov diff --git a/basis/io/windows/launcher/launcher-tests.factor b/basis/io/windows/launcher/launcher-tests.factor deleted file mode 100644 index 1dba8bd0ec..0000000000 --- a/basis/io/windows/launcher/launcher-tests.factor +++ /dev/null @@ -1,10 +0,0 @@ -IN: io.windows.launcher.tests -USING: tools.test io.windows.launcher ; - -[ "hello world" ] [ { "hello" "world" } join-arguments ] unit-test - -[ "bob \"mac arthur\"" ] [ { "bob" "mac arthur" } join-arguments ] unit-test - -[ "bob mac\\\\arthur" ] [ { "bob" "mac\\\\arthur" } join-arguments ] unit-test - -[ "bob \"mac arthur\\\\\"" ] [ { "bob" "mac arthur\\" } join-arguments ] unit-test diff --git a/basis/io/windows/launcher/launcher.factor b/basis/io/windows/launcher/launcher.factor deleted file mode 100644 index fd31ca999f..0000000000 --- a/basis/io/windows/launcher/launcher.factor +++ /dev/null @@ -1,164 +0,0 @@ -! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays continuations io -io.windows io.windows.nt.pipes libc io.ports -windows.types math windows.kernel32 -namespaces make io.launcher kernel sequences windows.errors -splitting system threads init strings combinators -io.backend accessors concurrency.flags io.files assocs -io.files.private windows destructors specialized-arrays.ushort -specialized-arrays.alien ; -IN: io.windows.launcher - -TUPLE: CreateProcess-args - lpApplicationName - lpCommandLine - lpProcessAttributes - lpThreadAttributes - bInheritHandles - dwCreateFlags - lpEnvironment - lpCurrentDirectory - lpStartupInfo - lpProcessInformation ; - -: default-CreateProcess-args ( -- obj ) - CreateProcess-args new - "STARTUPINFO" - "STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo - "PROCESS_INFORMATION" >>lpProcessInformation - TRUE >>bInheritHandles - 0 >>dwCreateFlags ; - -: call-CreateProcess ( CreateProcess-args -- ) - { - [ lpApplicationName>> ] - [ lpCommandLine>> ] - [ lpProcessAttributes>> ] - [ lpThreadAttributes>> ] - [ bInheritHandles>> ] - [ dwCreateFlags>> ] - [ lpEnvironment>> ] - [ lpCurrentDirectory>> ] - [ lpStartupInfo>> ] - [ lpProcessInformation>> ] - } cleave - CreateProcess win32-error=0/f ; - -: count-trailing-backslashes ( str n -- str n ) - [ "\\" ?tail ] dip swap [ - 1+ count-trailing-backslashes - ] when ; - -: fix-trailing-backslashes ( str -- str' ) - 0 count-trailing-backslashes - 2 * CHAR: \\ append ; - -: escape-argument ( str -- newstr ) - CHAR: \s over member? [ - fix-trailing-backslashes "\"" dup surround - ] when ; - -: join-arguments ( args -- cmd-line ) - [ escape-argument ] map " " join ; - -: lookup-priority ( process -- n ) - priority>> { - { +lowest-priority+ [ IDLE_PRIORITY_CLASS ] } - { +low-priority+ [ BELOW_NORMAL_PRIORITY_CLASS ] } - { +normal-priority+ [ NORMAL_PRIORITY_CLASS ] } - { +high-priority+ [ ABOVE_NORMAL_PRIORITY_CLASS ] } - { +highest-priority+ [ HIGH_PRIORITY_CLASS ] } - { +realtime-priority+ [ REALTIME_PRIORITY_CLASS ] } - [ drop f ] - } case ; - -: app-name/cmd-line ( process -- app-name cmd-line ) - command>> dup string? [ - " " split1 - ] [ - unclip swap join-arguments - ] if ; - -: cmd-line ( process -- cmd-line ) - command>> dup string? [ join-arguments ] unless ; - -: fill-lpApplicationName ( process args -- process args ) - over app-name/cmd-line - [ >>lpApplicationName ] [ >>lpCommandLine ] bi* ; - -: fill-lpCommandLine ( process args -- process args ) - over cmd-line >>lpCommandLine ; - -: fill-dwCreateFlags ( process args -- process args ) - 0 - pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when - pick detached>> os winnt? and [ DETACHED_PROCESS bitor ] when - pick lookup-priority [ bitor ] when* - >>dwCreateFlags ; - -: fill-lpEnvironment ( process args -- process args ) - over pass-environment? [ - [ - over get-environment - [ swap % "=" % % "\0" % ] assoc-each - "\0" % - ] ushort-array{ } make underlying>> - >>lpEnvironment - ] when ; - -: fill-startup-info ( process args -- process args ) - STARTF_USESTDHANDLES over lpStartupInfo>> set-STARTUPINFO-dwFlags ; - -HOOK: fill-redirection io-backend ( process args -- ) - -M: wince fill-redirection 2drop ; - -: make-CreateProcess-args ( process -- args ) - default-CreateProcess-args - os wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if - fill-dwCreateFlags - fill-lpEnvironment - fill-startup-info - nip ; - -M: windows current-process-handle ( -- handle ) - GetCurrentProcessId ; - -M: windows run-process* ( process -- handle ) - [ - current-directory get (normalize-path) cd - - dup make-CreateProcess-args - tuck fill-redirection - dup call-CreateProcess - lpProcessInformation>> - ] with-destructors ; - -M: windows kill-process* ( handle -- ) - PROCESS_INFORMATION-hProcess - 255 TerminateProcess win32-error=0/f ; - -: dispose-process ( process-information -- ) - #! From MSDN: "Handles in PROCESS_INFORMATION must be closed - #! with CloseHandle when they are no longer needed." - dup PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when* - PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ; - -: exit-code ( process -- n ) - PROCESS_INFORMATION-hProcess - 0 [ GetExitCodeProcess ] keep *ulong - swap win32-error=0/f ; - -: process-exited ( process -- ) - dup handle>> exit-code - over handle>> dispose-process - notify-exit ; - -M: windows wait-for-processes ( -- ? ) - processes get keys dup - [ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as - [ length ] [ underlying>> ] bi 0 0 - WaitForMultipleObjects - dup HEX: ffffffff = [ win32-error ] when - dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ; diff --git a/basis/io/windows/launcher/tags.txt b/basis/io/windows/launcher/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/windows/launcher/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/windows/mmap/authors.txt b/basis/io/windows/mmap/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/io/windows/mmap/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/io/windows/mmap/mmap.factor b/basis/io/windows/mmap/mmap.factor deleted file mode 100644 index e5b0d10f2f..0000000000 --- a/basis/io/windows/mmap/mmap.factor +++ /dev/null @@ -1,44 +0,0 @@ -USING: alien alien.c-types arrays destructors generic io.mmap -io.ports io.windows io.windows.files io.windows.privileges -kernel libc math math.bitwise namespaces quotations sequences -windows windows.advapi32 windows.kernel32 io.backend system -accessors locals ; -IN: io.windows.mmap - -: create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE ) - CreateFileMapping [ win32-error=0/f ] keep ; - -: map-view-of-file ( hFileMappingObject dwDesiredAccess dwFileOffsetHigh dwFileOffsetLow dwNumberOfBytesToMap -- HANDLE ) - MapViewOfFile [ win32-error=0/f ] keep ; - -:: mmap-open ( path length access-mode create-mode protect access -- handle handle address ) - [let | lo [ length HEX: ffffffff bitand ] - hi [ length -32 shift HEX: ffffffff bitand ] | - { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [ - path access-mode create-mode 0 open-file |dispose - dup handle>> f protect hi lo f create-file-mapping |dispose - dup handle>> access 0 0 0 map-view-of-file - ] with-privileges - ] ; - -TUPLE: win32-mapped-file file mapping ; - -M: win32-mapped-file dispose - [ file>> dispose ] [ mapping>> dispose ] bi ; - -C: win32-mapped-file - -M: windows (mapped-file) - [ - { GENERIC_WRITE GENERIC_READ } flags - OPEN_ALWAYS - { PAGE_READWRITE SEC_COMMIT } flags - FILE_MAP_ALL_ACCESS mmap-open - -rot - ] with-destructors ; - -M: windows close-mapped-file ( mapped-file -- ) - [ - [ handle>> &dispose drop ] - [ address>> UnmapViewOfFile win32-error=0/f ] bi - ] with-destructors ; diff --git a/basis/io/windows/mmap/tags.txt b/basis/io/windows/mmap/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/windows/mmap/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/windows/nt/authors.txt b/basis/io/windows/nt/authors.txt deleted file mode 100644 index 781acc2b62..0000000000 --- a/basis/io/windows/nt/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Doug Coleman -Mackenzie Straight diff --git a/basis/io/windows/nt/backend/authors.txt b/basis/io/windows/nt/backend/authors.txt deleted file mode 100755 index 026f4cd0de..0000000000 --- a/basis/io/windows/nt/backend/authors.txt +++ /dev/null @@ -1,3 +0,0 @@ -Doug Coleman -Slava Pestov -Mackenzie Straight diff --git a/basis/io/windows/nt/backend/backend.factor b/basis/io/windows/nt/backend/backend.factor deleted file mode 100644 index 8035bd66e9..0000000000 --- a/basis/io/windows/nt/backend/backend.factor +++ /dev/null @@ -1,120 +0,0 @@ -USING: alien alien.c-types arrays assocs combinators -continuations destructors io io.backend io.ports io.timeouts -io.windows io.windows.files io.files io.buffers io.streams.c -libc kernel math namespaces sequences threads windows -windows.errors windows.kernel32 strings splitting qualified -ascii system accessors locals ; -QUALIFIED: windows.winsock -IN: io.windows.nt.backend - -! Global variable with assoc mapping overlapped to threads -SYMBOL: pending-overlapped - -TUPLE: io-callback port thread ; - -C: io-callback - -: (make-overlapped) ( -- overlapped-ext ) - "OVERLAPPED" malloc-object &free ; - -: make-overlapped ( port -- overlapped-ext ) - [ (make-overlapped) ] dip - handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ; - -: ( handle existing -- handle ) - f 1 CreateIoCompletionPort dup win32-error=0/f ; - -SYMBOL: master-completion-port - -: ( -- handle ) - INVALID_HANDLE_VALUE f ; - -M: winnt add-completion ( win32-handle -- ) - handle>> master-completion-port get-global drop ; - -: eof? ( error -- ? ) - [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] bi or ; - -: twiddle-thumbs ( overlapped port -- bytes-transferred ) - [ - 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 ; - -:: wait-for-overlapped ( us -- bytes-transferred overlapped error? ) - master-completion-port get-global - 0 [ ! bytes - f ! key - f [ ! overlapped - us [ 1000 /i ] [ INFINITE ] if* ! timeout - GetQueuedCompletionStatus zero? - ] keep *void* - ] keep *int spin ; - -: resume-callback ( result overlapped -- ) - pending-overlapped get-global delete-at* drop resume-with ; - -: handle-overlapped ( us -- ? ) - wait-for-overlapped [ - dup [ - [ drop GetLastError 1array ] dip resume-callback t - ] [ 2drop f ] if - ] [ resume-callback t ] if ; - -M: win32-handle cancel-operation - [ check-disposed ] [ handle>> CancelIo drop ] bi ; - -M: winnt io-multiplex ( us -- ) - handle-overlapped [ 0 io-multiplex ] when ; - -M: winnt init-io ( -- ) - master-completion-port 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 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ; - -: update-file-ptr ( n port -- ) - handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ; - -: finish-write ( n port -- ) - [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ; - -M: winnt (wait-to-write) - [ - [ make-FileArgs dup setup-write WriteFile ] - [ wait-for-file ] - [ finish-write ] - tri - ] with-destructors ; - -: finish-read ( n port -- ) - [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ; - -M: winnt (wait-to-read) ( port -- ) - [ - [ make-FileArgs dup setup-read ReadFile ] - [ wait-for-file ] - [ finish-read ] - tri - ] with-destructors ; - -M: winnt (init-stdio) init-c-stdio ; diff --git a/basis/io/windows/nt/backend/tags.txt b/basis/io/windows/nt/backend/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/windows/nt/backend/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/windows/nt/files/authors.txt b/basis/io/windows/nt/files/authors.txt deleted file mode 100755 index 026f4cd0de..0000000000 --- a/basis/io/windows/nt/files/authors.txt +++ /dev/null @@ -1,3 +0,0 @@ -Doug Coleman -Slava Pestov -Mackenzie Straight diff --git a/basis/io/windows/nt/files/files-tests.factor b/basis/io/windows/nt/files/files-tests.factor deleted file mode 100644 index 6620dd691e..0000000000 --- a/basis/io/windows/nt/files/files-tests.factor +++ /dev/null @@ -1,55 +0,0 @@ -USING: io.files kernel tools.test io.backend -io.windows.nt.files splitting sequences ; -IN: io.windows.nt.files.tests - -[ f ] [ "\\foo" absolute-path? ] unit-test -[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test -[ t ] [ "\\\\?\\c:\\" absolute-path? ] unit-test -[ t ] [ "\\\\?\\c:" absolute-path? ] unit-test -[ t ] [ "c:\\foo" absolute-path? ] unit-test -[ t ] [ "c:" absolute-path? ] unit-test -[ t ] [ "c:\\" absolute-path? ] unit-test -[ f ] [ "/cygdrive/c/builds" absolute-path? ] unit-test - -[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test -[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test -[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test -! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing -[ "c:\\" ] [ "c:\\" parent-directory ] unit-test -[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test -[ "c:" ] [ "c:" parent-directory ] unit-test -[ "Z:" ] [ "Z:" parent-directory ] unit-test - -[ f ] [ "" root-directory? ] unit-test -[ t ] [ "\\" root-directory? ] unit-test -[ t ] [ "\\\\" root-directory? ] unit-test -[ t ] [ "/" root-directory? ] unit-test -[ t ] [ "//" root-directory? ] unit-test -[ t ] [ "c:\\" trim-right-separators root-directory? ] unit-test -[ t ] [ "Z:\\" trim-right-separators root-directory? ] unit-test -[ f ] [ "c:\\foo" root-directory? ] unit-test -[ f ] [ "." root-directory? ] unit-test -[ f ] [ ".." root-directory? ] unit-test -[ t ] [ "\\\\?\\c:\\" root-directory? ] unit-test -[ t ] [ "\\\\?\\c:" root-directory? ] unit-test -[ f ] [ "\\\\?\\c:\\bar" root-directory? ] unit-test - -[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test - -[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [ - "C:\\builds\\factor\\12345\\" - "..\\log.txt" append-path normalize-path -] unit-test - -[ "\\\\?\\C:\\builds\\" ] [ - "C:\\builds\\factor\\12345\\" - "..\\.." append-path normalize-path -] unit-test - -[ "\\\\?\\C:\\builds\\" ] [ - "C:\\builds\\factor\\12345\\" - "..\\.." append-path normalize-path -] unit-test - -[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test -[ t ] [ "" resource-path 2 tail exists? ] unit-test diff --git a/basis/io/windows/nt/files/files.factor b/basis/io/windows/nt/files/files.factor deleted file mode 100755 index 892a5c4d31..0000000000 --- a/basis/io/windows/nt/files/files.factor +++ /dev/null @@ -1,64 +0,0 @@ -USING: continuations destructors io.buffers io.files io.backend -io.timeouts io.ports io.files.private io.windows -io.windows.files io.windows.nt.backend io.encodings.utf16n -windows windows.kernel32 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 accessors tr ; -IN: io.windows.nt.files - -M: winnt cwd - MAX_UNICODE_PATH dup "ushort" - [ GetCurrentDirectory win32-error=0/f ] keep - utf16n alien>string ; - -M: winnt cd - SetCurrentDirectory win32-error=0/f ; - -: unicode-prefix ( -- seq ) - "\\\\?\\" ; inline - -M: winnt root-directory? ( path -- ? ) - { - { [ dup empty? ] [ drop f ] } - { [ dup [ path-separator? ] all? ] [ drop t ] } - { [ dup trim-right-separators { [ length 2 = ] - [ second CHAR: : = ] } 1&& ] [ drop t ] } - { [ dup unicode-prefix head? ] - [ trim-right-separators length unicode-prefix length 2 + = ] } - [ drop f ] - } cond ; - -ERROR: not-absolute-path ; - -M: winnt root-directory ( string -- string' ) - unicode-prefix ?head drop - dup { - [ length 2 >= ] - [ second CHAR: : = ] - [ first Letter? ] - } 1&& [ 2 head "\\" append ] [ not-absolute-path ] if ; - -: prepend-prefix ( string -- string' ) - dup unicode-prefix head? [ - unicode-prefix prepend - ] unless ; - -TR: normalize-separators "/" "\\" ; - -M: winnt normalize-path ( string -- string' ) - (normalize-path) - normalize-separators - prepend-prefix ; - -M: winnt CreateFile-flags ( DWORD -- DWORD ) - FILE_FLAG_OVERLAPPED bitor ; - -M: winnt FileArgs-overlapped ( port -- overlapped ) - make-overlapped ; - -M: winnt open-append - [ dup file-info size>> ] [ drop 0 ] recover - [ (open-append) ] dip >>ptr ; - -M: winnt home "USERPROFILE" os-env ; diff --git a/basis/io/windows/nt/files/tags.txt b/basis/io/windows/nt/files/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/windows/nt/files/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/windows/nt/launcher/authors.txt b/basis/io/windows/nt/launcher/authors.txt deleted file mode 100755 index 026f4cd0de..0000000000 --- a/basis/io/windows/nt/launcher/authors.txt +++ /dev/null @@ -1,3 +0,0 @@ -Doug Coleman -Slava Pestov -Mackenzie Straight diff --git a/basis/io/windows/nt/launcher/launcher-tests.factor b/basis/io/windows/nt/launcher/launcher-tests.factor deleted file mode 100644 index cbae2f5eca..0000000000 --- a/basis/io/windows/nt/launcher/launcher-tests.factor +++ /dev/null @@ -1,157 +0,0 @@ -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 - -[ ] [ - - "notepad" >>command - 1/2 seconds >>timeout - "notepad" set -] unit-test - -[ f ] [ "notepad" get process-running? ] unit-test - -[ f ] [ "notepad" get process-started? ] unit-test - -[ ] [ "notepad" [ run-detached ] change ] unit-test - -[ "notepad" get wait-for-process ] must-fail - -[ t ] [ "notepad" get killed>> ] unit-test - -[ f ] [ "notepad" get process-running? ] unit-test - -[ ] [ - - vm "-quiet" "-run=hello-world" 3array >>command - "out.txt" temp-file >>stdout - try-process -] unit-test - -[ "Hello world" ] [ - "out.txt" temp-file ascii file-lines first -] unit-test - -[ ] [ - - vm "-run=listener" 2array >>command - +closed+ >>stdin - try-process -] unit-test - -[ ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "stderr.factor" 3array >>command - "out.txt" temp-file >>stdout - "err.txt" temp-file >>stderr - try-process - ] with-directory -] unit-test - -[ "output" ] [ - "out.txt" temp-file ascii file-lines first -] unit-test - -[ "error" ] [ - "err.txt" temp-file ascii file-lines first -] unit-test - -[ ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "stderr.factor" 3array >>command - "out.txt" temp-file >>stdout - +stdout+ >>stderr - try-process - ] with-directory -] unit-test - -[ "outputerror" ] [ - "out.txt" temp-file ascii file-lines first -] unit-test - -[ "output" ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "stderr.factor" 3array >>command - "err2.txt" temp-file >>stderr - ascii lines first - ] with-directory -] unit-test - -[ "error" ] [ - "err2.txt" temp-file ascii file-lines first -] unit-test - -[ t ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "env.factor" 3array >>command - ascii contents - ] with-directory eval - - os-envs = -] unit-test - -[ t ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "env.factor" 3array >>command - +replace-environment+ >>environment-mode - os-envs >>environment - ascii contents - ] with-directory eval - - os-envs = -] unit-test - -[ "B" ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "env.factor" 3array >>command - { { "A" "B" } } >>environment - ascii contents - ] with-directory eval - - "A" swap at -] unit-test - -[ f ] [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "env.factor" 3array >>command - { { "USERPROFILE" "XXX" } } >>environment - +prepend-environment+ >>environment-mode - ascii contents - ] with-directory eval - - "USERPROFILE" swap at "XXX" = -] unit-test - -2 [ - [ ] [ - - "cmd.exe /c dir" >>command - "dir.txt" temp-file >>stdout - try-process - ] unit-test - - [ ] [ "dir.txt" temp-file delete-file ] unit-test -] times - -[ "append-test" temp-file delete-file ] ignore-errors - -[ "Hello appender\r\nHello appender\r\n" ] [ - 2 [ - "resource:basis/io/windows/nt/launcher/test" [ - - vm "-script" "append.factor" 3array >>command - "append-test" temp-file >>stdout - try-process - ] with-directory - ] times - - "append-test" temp-file ascii file-contents -] unit-test diff --git a/basis/io/windows/nt/launcher/launcher.factor b/basis/io/windows/nt/launcher/launcher.factor deleted file mode 100644 index de4fb99c64..0000000000 --- a/basis/io/windows/nt/launcher/launcher.factor +++ /dev/null @@ -1,110 +0,0 @@ -! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays continuations destructors io -io.windows libc io.ports io.pipes windows.types math -windows.kernel32 windows namespaces make io.launcher kernel -sequences windows.errors assocs splitting system strings -io.windows.launcher io.windows.files io.backend io.files -io.files.private combinators shuffle accessors locals ; -IN: io.windows.nt.launcher - -: duplicate-handle ( handle -- handle' ) - GetCurrentProcess ! source process - swap ! handle - GetCurrentProcess ! target process - f [ ! target handle - DUPLICATE_SAME_ACCESS ! desired access - TRUE ! inherit handle - DUPLICATE_CLOSE_SOURCE ! options - DuplicateHandle win32-error=0/f - ] keep *void* ; - -! /dev/null simulation -: null-input ( -- pipe ) - (pipe) [ in>> handle>> ] [ out>> dispose ] bi ; - -: null-output ( -- pipe ) - (pipe) [ in>> dispose ] [ out>> handle>> ] bi ; - -: null-pipe ( mode -- pipe ) - { - { GENERIC_READ [ null-input ] } - { GENERIC_WRITE [ null-output ] } - } case ; - -! The below code is based on the example given in -! http://msdn2.microsoft.com/en-us/library/ms682499.aspx - -: redirect-default ( obj access-mode create-mode -- handle ) - 3drop f ; - -: redirect-closed ( obj access-mode create-mode -- handle ) - drop nip null-pipe ; - -:: redirect-file ( path access-mode create-mode -- handle ) - path normalize-path - access-mode - share-mode - default-security-attributes - create-mode - FILE_ATTRIBUTE_NORMAL ! flags and attributes - f ! template file - CreateFile dup invalid-handle? &dispose handle>> ; - -: redirect-append ( path access-mode create-mode -- handle ) - [ path>> ] 2dip - drop OPEN_ALWAYS - redirect-file - dup 0 FILE_END set-file-pointer ; - -: redirect-handle ( handle access-mode create-mode -- handle ) - 2drop handle>> duplicate-handle ; - -: redirect-stream ( stream access-mode create-mode -- handle ) - [ underlying-handle handle>> ] 2dip redirect-handle ; - -: redirect ( obj access-mode create-mode -- handle ) - { - { [ pick not ] [ redirect-default ] } - { [ pick +closed+ eq? ] [ redirect-closed ] } - { [ pick string? ] [ redirect-file ] } - { [ pick appender? ] [ redirect-append ] } - { [ pick win32-file? ] [ redirect-handle ] } - [ redirect-stream ] - } cond - dup [ dup t set-inherit ] when ; - -: redirect-stdout ( process args -- handle ) - drop - stdout>> - GENERIC_WRITE - CREATE_ALWAYS - redirect - STD_OUTPUT_HANDLE GetStdHandle or ; - -: redirect-stderr ( process args -- handle ) - over stderr>> +stdout+ eq? [ - nip - lpStartupInfo>> STARTUPINFO-hStdOutput - ] [ - drop - stderr>> - GENERIC_WRITE - CREATE_ALWAYS - redirect - STD_ERROR_HANDLE GetStdHandle or - ] if ; - -: redirect-stdin ( process args -- handle ) - drop - stdin>> - GENERIC_READ - OPEN_EXISTING - redirect - STD_INPUT_HANDLE GetStdHandle or ; - -M: winnt fill-redirection ( process args -- ) - [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput - [ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError - [ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput - 2drop ; diff --git a/basis/io/windows/nt/launcher/tags.txt b/basis/io/windows/nt/launcher/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/windows/nt/launcher/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/windows/nt/launcher/test/append.factor b/basis/io/windows/nt/launcher/test/append.factor deleted file mode 100644 index 4c1de0c5f9..0000000000 --- a/basis/io/windows/nt/launcher/test/append.factor +++ /dev/null @@ -1,2 +0,0 @@ -USE: io -"Hello appender" print diff --git a/basis/io/windows/nt/launcher/test/env.factor b/basis/io/windows/nt/launcher/test/env.factor deleted file mode 100644 index 503ca7d018..0000000000 --- a/basis/io/windows/nt/launcher/test/env.factor +++ /dev/null @@ -1,4 +0,0 @@ -USE: system -USE: prettyprint -USE: environment -os-envs . diff --git a/basis/io/windows/nt/launcher/test/stderr.factor b/basis/io/windows/nt/launcher/test/stderr.factor deleted file mode 100644 index f22f50e406..0000000000 --- a/basis/io/windows/nt/launcher/test/stderr.factor +++ /dev/null @@ -1,5 +0,0 @@ -USE: io -USE: namespaces - -"output" write flush -"error" error-stream get stream-write error-stream get stream-flush diff --git a/basis/io/windows/nt/monitors/authors.txt b/basis/io/windows/nt/monitors/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/io/windows/nt/monitors/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/io/windows/nt/monitors/monitors-tests.factor b/basis/io/windows/nt/monitors/monitors-tests.factor deleted file mode 100644 index ef36baedc5..0000000000 --- a/basis/io/windows/nt/monitors/monitors-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: io.windows.nt.monitors.tests -USING: io.windows.nt.monitors tools.test ; - -\ fill-queue-thread must-infer diff --git a/basis/io/windows/nt/monitors/monitors.factor b/basis/io/windows/nt/monitors/monitors.factor deleted file mode 100755 index a2b7c4fa2d..0000000000 --- a/basis/io/windows/nt/monitors/monitors.factor +++ /dev/null @@ -1,105 +0,0 @@ -! Copyright (C) 2008 Doug Coleman, Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.strings libc destructors locals -kernel math assocs namespaces make continuations sequences -hashtables sorting arrays combinators math.bitwise strings -system accessors threads splitting io.backend io.windows -io.windows.nt.backend io.windows.nt.files io.monitors io.ports -io.buffers io.files io.timeouts io.encodings.string -io.encodings.utf16n io windows windows.kernel32 windows.types ; -IN: io.windows.nt.monitors - -: open-directory ( path -- handle ) - normalize-path - FILE_LIST_DIRECTORY - share-mode - f - OPEN_EXISTING - { FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags - f - CreateFile opened-file ; - -TUPLE: win32-monitor-port < input-port recursive ; - -TUPLE: win32-monitor < monitor port ; - -: begin-reading-changes ( port -- overlapped ) - { - [ handle>> handle>> ] - [ buffer>> ptr>> ] - [ buffer>> size>> ] - [ recursive>> 1 0 ? ] - } cleave - FILE_NOTIFY_CHANGE_ALL - 0 - (make-overlapped) - [ f ReadDirectoryChangesW win32-error=0/f ] keep ; - -: read-changes ( port -- bytes-transferred ) - [ - [ begin-reading-changes ] [ twiddle-thumbs ] bi - ] with-destructors ; - -: parse-action ( action -- changed ) - { - { FILE_ACTION_ADDED [ +add-file+ ] } - { FILE_ACTION_REMOVED [ +remove-file+ ] } - { FILE_ACTION_MODIFIED [ +modify-file+ ] } - { FILE_ACTION_RENAMED_OLD_NAME [ +rename-file+ ] } - { FILE_ACTION_RENAMED_NEW_NAME [ +rename-file+ ] } - [ drop +modify-file+ ] - } case 1array ; - -: memory>u16-string ( alien len -- string ) - memory>byte-array utf16n decode ; - -: parse-notify-record ( buffer -- path changed ) - [ - [ FILE_NOTIFY_INFORMATION-FileName ] - [ FILE_NOTIFY_INFORMATION-FileNameLength ] - bi memory>u16-string - ] - [ FILE_NOTIFY_INFORMATION-Action parse-action ] bi ; - -: (file-notify-records) ( buffer -- buffer ) - dup , - dup FILE_NOTIFY_INFORMATION-NextEntryOffset zero? [ - [ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep - (file-notify-records) - ] unless ; - -: file-notify-records ( buffer -- seq ) - [ (file-notify-records) drop ] { } make ; - -:: parse-notify-records ( monitor buffer -- ) - buffer file-notify-records [ - parse-notify-record - [ monitor path>> prepend-path normalize-path ] dip - monitor queue-change - ] each ; - -: fill-queue ( monitor -- ) - dup port>> dup check-disposed - [ buffer>> ptr>> ] [ read-changes zero? ] bi - [ 2dup parse-notify-records ] unless - 2drop ; - -: (fill-queue-thread) ( monitor -- ) - dup fill-queue (fill-queue-thread) ; - -: fill-queue-thread ( monitor -- ) - [ dup fill-queue (fill-queue-thread) ] - [ dup already-disposed? [ 2drop ] [ rethrow ] if ] recover ; - -M:: winnt (monitor) ( path recursive? mailbox -- monitor ) - [ - path normalize-path mailbox win32-monitor new-monitor - path open-directory \ win32-monitor-port - recursive? >>recursive - >>port - dup [ fill-queue-thread ] curry - "Windows monitor thread" spawn drop - ] with-destructors ; - -M: win32-monitor dispose - port>> dispose ; diff --git a/basis/io/windows/nt/monitors/tags.txt b/basis/io/windows/nt/monitors/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/windows/nt/monitors/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/windows/nt/nt.factor b/basis/io/windows/nt/nt.factor deleted file mode 100644 index efde4f4035..0000000000 --- a/basis/io/windows/nt/nt.factor +++ /dev/null @@ -1,7 +0,0 @@ -! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman, -! Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: vocabs.loader io.windows io.windows.nt.backend -io.windows.nt.files io.windows.files io.backend system ; - -winnt set-io-backend diff --git a/basis/io/windows/nt/pipes/authors.txt b/basis/io/windows/nt/pipes/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/basis/io/windows/nt/pipes/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/io/windows/nt/pipes/pipes.factor b/basis/io/windows/nt/pipes/pipes.factor deleted file mode 100644 index d498875c87..0000000000 --- a/basis/io/windows/nt/pipes/pipes.factor +++ /dev/null @@ -1,46 +0,0 @@ -! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays destructors io io.windows libc -windows.types math.bitwise windows.kernel32 windows namespaces -make kernel sequences windows.errors assocs math.parser system -random combinators accessors io.pipes io.ports ; -IN: io.windows.nt.pipes - -! This code is based on -! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py - -: create-named-pipe ( name -- handle ) - { PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED } flags - PIPE_TYPE_BYTE - 1 - 4096 - 4096 - 0 - default-security-attributes - CreateNamedPipe opened-file ; - -: open-other-end ( name -- handle ) - GENERIC_WRITE - { FILE_SHARE_READ FILE_SHARE_WRITE } flags - default-security-attributes - OPEN_EXISTING - FILE_FLAG_OVERLAPPED - f - CreateFile opened-file ; - -: unique-pipe-name ( -- string ) - [ - "\\\\.\\pipe\\factor-" % - pipe counter # - "-" % - 32 random-bits # - "-" % - micros # - ] "" make ; - -M: winnt (pipe) ( -- pipe ) - [ - unique-pipe-name - [ create-named-pipe ] [ open-other-end ] bi - pipe boa - ] with-destructors ; diff --git a/basis/io/windows/nt/pipes/tags.txt b/basis/io/windows/nt/pipes/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/windows/nt/pipes/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/windows/nt/privileges/privileges.factor b/basis/io/windows/nt/privileges/privileges.factor deleted file mode 100755 index 264f337eaf..0000000000 --- a/basis/io/windows/nt/privileges/privileges.factor +++ /dev/null @@ -1,52 +0,0 @@ -USING: alien alien.c-types alien.syntax arrays continuations -destructors generic io.mmap io.ports io.windows io.windows.files -kernel libc math math.bitwise namespaces quotations sequences windows -windows.advapi32 windows.kernel32 io.backend system accessors -io.windows.privileges ; -IN: io.windows.nt.privileges - -TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES - -! Security tokens -! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/ - -: (open-process-token) ( handle -- handle ) - { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" - [ OpenProcessToken win32-error=0/f ] keep *void* ; - -: open-process-token ( -- handle ) - #! remember to CloseHandle - GetCurrentProcess (open-process-token) ; - -: with-process-token ( quot -- ) - #! quot: ( token-handle -- token-handle ) - [ open-process-token ] dip - [ keep ] curry - [ CloseHandle drop ] [ ] cleanup ; inline - -: lookup-privilege ( string -- luid ) - [ f ] dip "LUID" - [ LookupPrivilegeValue win32-error=0/f ] keep ; - -: make-token-privileges ( name ? -- obj ) - "TOKEN_PRIVILEGES" - 1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep - "LUID_AND_ATTRIBUTES" malloc-array &free - over set-TOKEN_PRIVILEGES-Privileges - - swap [ - SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges - set-LUID_AND_ATTRIBUTES-Attributes - ] when - - [ lookup-privilege ] dip - [ - TOKEN_PRIVILEGES-Privileges - set-LUID_AND_ATTRIBUTES-Luid - ] keep ; - -M: winnt set-privilege ( name ? -- ) - [ - -rot 0 -rot make-token-privileges - dup length f f AdjustTokenPrivileges win32-error=0/f - ] with-process-token ; diff --git a/basis/io/windows/nt/privileges/tags.txt b/basis/io/windows/nt/privileges/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/windows/nt/privileges/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/windows/nt/sockets/authors.txt b/basis/io/windows/nt/sockets/authors.txt deleted file mode 100755 index 026f4cd0de..0000000000 --- a/basis/io/windows/nt/sockets/authors.txt +++ /dev/null @@ -1,3 +0,0 @@ -Doug Coleman -Slava Pestov -Mackenzie Straight diff --git a/basis/io/windows/nt/sockets/sockets.factor b/basis/io/windows/nt/sockets/sockets.factor deleted file mode 100644 index ecd9ea9d9b..0000000000 --- a/basis/io/windows/nt/sockets/sockets.factor +++ /dev/null @@ -1,216 +0,0 @@ -USING: alien alien.accessors alien.c-types byte-arrays -continuations destructors io.ports io.timeouts io.sockets -io.sockets io namespaces io.streams.duplex io.windows -io.windows.sockets io.windows.nt.backend windows.winsock kernel -libc math sequences threads system combinators accessors ; -IN: io.windows.nt.sockets - -: malloc-int ( object -- object ) - "int" heap-size malloc tuck 0 set-alien-signed-4 ; inline - -M: winnt WSASocket-flags ( -- DWORD ) - WSA_FLAG_OVERLAPPED ; - -: get-ConnectEx-ptr ( socket -- void* ) - SIO_GET_EXTENSION_FUNCTION_POINTER - WSAID_CONNECTEX - "GUID" heap-size - "void*" - [ - "void*" heap-size - "DWORD" - f - f - WSAIoctl SOCKET_ERROR = [ - winsock-error-string throw - ] when - ] keep *void* ; - -TUPLE: ConnectEx-args port - s name namelen lpSendBuffer dwSendDataLength - lpdwBytesSent lpOverlapped ptr ; - -: wait-for-socket ( args -- n ) - [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline - -: ( sockaddr size -- ConnectEx ) - ConnectEx-args new - swap >>namelen - swap >>name - f >>lpSendBuffer - 0 >>dwSendDataLength - f >>lpdwBytesSent - (make-overlapped) >>lpOverlapped ; inline - -: call-ConnectEx ( ConnectEx -- ) - { - [ s>> ] - [ name>> ] - [ namelen>> ] - [ lpSendBuffer>> ] - [ dwSendDataLength>> ] - [ lpdwBytesSent>> ] - [ lpOverlapped>> ] - [ ptr>> ] - } cleave - "int" - { "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" } - "stdcall" alien-indirect drop - winsock-error-string [ throw ] when* ; inline - -M: object establish-connection ( client-out remote -- ) - make-sockaddr/size - swap >>port - dup port>> handle>> handle>> >>s - dup s>> get-ConnectEx-ptr >>ptr - dup call-ConnectEx - wait-for-socket drop ; - -TUPLE: AcceptEx-args port - sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength - dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ; - -: init-accept-buffer ( addr AcceptEx -- ) - swap sockaddr-size 16 + - [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi - dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer - drop ; inline - -: ( server addr -- AcceptEx ) - AcceptEx-args new - 2dup init-accept-buffer - swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket - over handle>> handle>> >>sListenSocket - swap >>port - 0 >>dwReceiveDataLength - f >>lpdwBytesReceived - (make-overlapped) >>lpOverlapped ; inline - -: call-AcceptEx ( AcceptEx -- ) - { - [ sListenSocket>> ] - [ sAcceptSocket>> ] - [ lpOutputBuffer>> ] - [ dwReceiveDataLength>> ] - [ dwLocalAddressLength>> ] - [ dwRemoteAddressLength>> ] - [ lpdwBytesReceived>> ] - [ lpOverlapped>> ] - } cleave AcceptEx drop - winsock-error-string [ throw ] when* ; inline - -: extract-remote-address ( AcceptEx -- sockaddr ) - { - [ lpOutputBuffer>> ] - [ dwReceiveDataLength>> ] - [ dwLocalAddressLength>> ] - [ dwRemoteAddressLength>> ] - } cleave - f - 0 - f - [ 0 GetAcceptExSockaddrs ] keep *void* ; inline - -M: object (accept) ( server addr -- handle sockaddr ) - [ - - { - [ call-AcceptEx ] - [ wait-for-socket drop ] - [ sAcceptSocket>> ] - [ extract-remote-address ] - } cleave - ] with-destructors ; - -TUPLE: WSARecvFrom-args port - s lpBuffers dwBufferCount lpNumberOfBytesRecvd - lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ; - -: make-receive-buffer ( -- WSABUF ) - "WSABUF" malloc-object &free - default-buffer-size get over set-WSABUF-len - default-buffer-size get malloc &free over set-WSABUF-buf ; inline - -: ( datagram -- WSARecvFrom ) - WSARecvFrom-args new - swap >>port - dup port>> handle>> handle>> >>s - dup port>> addr>> sockaddr-size - [ malloc &free >>lpFrom ] - [ malloc-int &free >>lpFromLen ] bi - make-receive-buffer >>lpBuffers - 1 >>dwBufferCount - 0 malloc-int &free >>lpFlags - 0 malloc-int &free >>lpNumberOfBytesRecvd - (make-overlapped) >>lpOverlapped ; inline - -: call-WSARecvFrom ( WSARecvFrom -- ) - { - [ s>> ] - [ lpBuffers>> ] - [ dwBufferCount>> ] - [ lpNumberOfBytesRecvd>> ] - [ lpFlags>> ] - [ lpFrom>> ] - [ lpFromLen>> ] - [ lpOverlapped>> ] - [ lpCompletionRoutine>> ] - } cleave WSARecvFrom socket-error* ; inline - -: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr ) - [ lpBuffers>> WSABUF-buf swap memory>byte-array ] - [ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline - -M: winnt (receive) ( datagram -- packet addrspec ) - [ - - [ call-WSARecvFrom ] - [ wait-for-socket ] - [ parse-WSARecvFrom ] - tri - ] with-destructors ; - -TUPLE: WSASendTo-args port - s lpBuffers dwBufferCount lpNumberOfBytesSent - dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ; - -: make-send-buffer ( packet -- WSABUF ) - "WSABUF" malloc-object &free - [ [ malloc-byte-array &free ] dip set-WSABUF-buf ] - [ [ length ] dip set-WSABUF-len ] - [ nip ] - 2tri ; inline - -: ( packet addrspec datagram -- WSASendTo ) - WSASendTo-args new - swap >>port - dup port>> handle>> handle>> >>s - swap make-sockaddr/size - [ malloc-byte-array &free ] dip - [ >>lpTo ] [ >>iToLen ] bi* - swap make-send-buffer >>lpBuffers - 1 >>dwBufferCount - 0 >>dwFlags - 0 >>lpNumberOfBytesSent - (make-overlapped) >>lpOverlapped ; inline - -: call-WSASendTo ( WSASendTo -- ) - { - [ s>> ] - [ lpBuffers>> ] - [ dwBufferCount>> ] - [ lpNumberOfBytesSent>> ] - [ dwFlags>> ] - [ lpTo>> ] - [ iToLen>> ] - [ lpOverlapped>> ] - [ lpCompletionRoutine>> ] - } cleave WSASendTo socket-error* ; inline - -M: winnt (send) ( packet addrspec datagram -- ) - [ - - [ call-WSASendTo ] - [ wait-for-socket drop ] - bi - ] with-destructors ; diff --git a/basis/io/windows/nt/sockets/tags.txt b/basis/io/windows/nt/sockets/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/windows/nt/sockets/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/windows/nt/summary.txt b/basis/io/windows/nt/summary.txt deleted file mode 100644 index 0e1b3e244f..0000000000 --- a/basis/io/windows/nt/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Microsoft Windows XP/Vista native I/O implementation diff --git a/basis/io/windows/nt/tags.txt b/basis/io/windows/nt/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/windows/nt/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/windows/privileges/privileges.factor b/basis/io/windows/privileges/privileges.factor deleted file mode 100644 index e169bdf12f..0000000000 --- a/basis/io/windows/privileges/privileges.factor +++ /dev/null @@ -1,14 +0,0 @@ -USING: io.backend kernel continuations sequences -system vocabs.loader combinators ; -IN: io.windows.privileges - -HOOK: set-privilege io-backend ( name ? -- ) inline - -: with-privileges ( seq quot -- ) - over [ [ t set-privilege ] each ] curry compose - swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline - -{ - { [ os winnt? ] [ "io.windows.nt.privileges" require ] } - { [ os wince? ] [ "io.windows.ce.privileges" require ] } -} cond diff --git a/basis/io/windows/privileges/tags.txt b/basis/io/windows/privileges/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/windows/privileges/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/windows/sockets/sockets.factor b/basis/io/windows/sockets/sockets.factor deleted file mode 100644 index 809af605e0..0000000000 --- a/basis/io/windows/sockets/sockets.factor +++ /dev/null @@ -1,61 +0,0 @@ -USING: kernel accessors io.sockets io.windows io.backend -windows.winsock system destructors alien.c-types ; -IN: io.windows.sockets - -HOOK: WSASocket-flags io-backend ( -- DWORD ) - -TUPLE: win32-socket < win32-file ; - -: ( handle -- win32-socket ) - win32-socket new-win32-handle ; - -M: win32-socket dispose ( stream -- ) - handle>> closesocket drop ; - -: unspecific-sockaddr/size ( addrspec -- sockaddr len ) - [ empty-sockaddr/size ] [ protocol-family ] bi - pick set-sockaddr-in-family ; - -: opened-socket ( handle -- win32-socket ) - |dispose dup add-completion ; - -: open-socket ( addrspec type -- win32-socket ) - [ protocol-family ] dip - 0 f 0 WSASocket-flags WSASocket - dup socket-error - opened-socket ; - -M: object (get-local-address) ( socket addrspec -- sockaddr ) - [ handle>> ] dip empty-sockaddr/size - [ getsockname socket-error ] 2keep drop ; - -M: object (get-remote-address) ( socket addrspec -- sockaddr ) - [ handle>> ] dip empty-sockaddr/size - [ getpeername socket-error ] 2keep drop ; - -: bind-socket ( win32-socket sockaddr len -- ) - [ handle>> ] 2dip bind socket-error ; - -M: object ((client)) ( addrspec -- handle ) - [ SOCK_STREAM open-socket ] keep - [ unspecific-sockaddr/size bind-socket ] [ drop ] 2bi ; - -: server-socket ( addrspec type -- fd ) - [ open-socket ] [ drop ] 2bi - [ make-sockaddr/size bind-socket ] [ drop ] 2bi ; - -! http://support.microsoft.com/kb/127144 -! NOTE: Possibly tweak this because of SYN flood attacks -: listen-backlog ( -- n ) HEX: 7fffffff ; inline - -M: object (server) ( addrspec -- handle ) - [ - SOCK_STREAM server-socket - dup handle>> listen-backlog listen winsock-return-check - ] with-destructors ; - -M: windows (datagram) ( addrspec -- handle ) - [ SOCK_DGRAM server-socket ] with-destructors ; - -M: windows addrinfo-error ( n -- ) - winsock-return-check ; diff --git a/basis/io/windows/sockets/tags.txt b/basis/io/windows/sockets/tags.txt deleted file mode 100644 index 6bf68304bb..0000000000 --- a/basis/io/windows/sockets/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/windows/summary.txt b/basis/io/windows/summary.txt deleted file mode 100644 index 2a2d5443b2..0000000000 --- a/basis/io/windows/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Microsoft Windows native I/O implementation diff --git a/basis/io/windows/tags.txt b/basis/io/windows/tags.txt deleted file mode 100755 index 6bf68304bb..0000000000 --- a/basis/io/windows/tags.txt +++ /dev/null @@ -1 +0,0 @@ -unportable diff --git a/basis/io/windows/windows.factor b/basis/io/windows/windows.factor deleted file mode 100755 index 94304edc05..0000000000 --- a/basis/io/windows/windows.factor +++ /dev/null @@ -1,54 +0,0 @@ -! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays destructors io io.backend -io.buffers io.files io.ports io.binary io.timeouts -windows.errors strings kernel math namespaces sequences windows -windows.kernel32 windows.shell32 windows.types windows.winsock -splitting continuations math.bitwise system accessors ; -IN: io.windows - -: set-inherit ( handle ? -- ) - [ HANDLE_FLAG_INHERIT ] dip - >BOOLEAN SetHandleInformation win32-error=0/f ; - -TUPLE: win32-handle handle disposed ; - -: new-win32-handle ( handle class -- win32-handle ) - new swap [ >>handle ] [ f set-inherit ] bi ; - -: ( handle -- win32-handle ) - win32-handle new-win32-handle ; - -M: win32-handle dispose* ( handle -- ) - handle>> CloseHandle drop ; - -TUPLE: win32-file < win32-handle ptr ; - -: ( handle -- win32-file ) - win32-file new-win32-handle ; - -M: win32-file dispose - dup disposed>> [ drop ] [ - [ cancel-operation ] [ call-next-method ] bi - ] if ; - -HOOK: CreateFile-flags io-backend ( DWORD -- DWORD ) -HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) -HOOK: add-completion io-backend ( port -- ) - -: opened-file ( handle -- win32-file ) - dup invalid-handle? - |dispose - dup add-completion ; - -: share-mode ( -- fixnum ) - { - FILE_SHARE_READ - FILE_SHARE_WRITE - FILE_SHARE_DELETE - } flags ; foldable - -: default-security-attributes ( -- obj ) - "SECURITY_ATTRIBUTES" - "SECURITY_ATTRIBUTES" heap-size - over set-SECURITY_ATTRIBUTES-nLength ; diff --git a/basis/logging/server/server.factor b/basis/logging/server/server.factor index 1872bb0af2..68f8d74571 100644 --- a/basis/logging/server/server.factor +++ b/basis/logging/server/server.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel io calendar sequences io.files -io.sockets continuations destructors prettyprint assocs -math.parser words debugger math combinators -concurrency.messaging threads arrays init math.ranges strings -calendar.format io.encodings.utf8 ; +USING: namespaces kernel io io.files io.pathnames io.directories +io.sockets io.encodings.utf8 +calendar calendar.format sequences continuations destructors +prettyprint assocs math.parser words debugger math combinators +concurrency.messaging threads arrays init math.ranges strings ; IN: logging.server : log-root ( -- string ) diff --git a/basis/mime/multipart/multipart-tests.factor b/basis/mime/multipart/multipart-tests.factor index 1445af8309..1fb2530705 100644 --- a/basis/mime/multipart/multipart-tests.factor +++ b/basis/mime/multipart/multipart-tests.factor @@ -1,7 +1,8 @@ USING: accessors checksums checksums.md5 io io.encodings.ascii -io.encodings.binary io.files io.streams.byte-array -io.streams.string kernel make mime.multipart -mime.multipart.private multiline sequences strings tools.test ; +io.encodings.binary io.files io.files.temp io.files.info +io.streams.byte-array io.streams.string kernel make +mime.multipart mime.multipart.private multiline sequences +strings tools.test ; IN: mime.multipart.tests [ { "a" } ] [ diff --git a/basis/mime/types/types.factor b/basis/mime/types/types.factor index bb0d674f23..ac5233c543 100644 --- a/basis/mime/types/types.factor +++ b/basis/mime/types/types.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files io.encodings.ascii assocs sequences splitting -kernel namespaces fry memoize ; +USING: io.pathnames io.files io.encodings.ascii assocs sequences +splitting kernel namespaces fry memoize ; IN: mime.types MEMO: mime-db ( -- seq ) diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 92d039a15d..bcd91a4d94 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays byte-arrays generic hashtables io assocs -kernel math namespaces make sequences strings sbufs io.styles -vectors words prettyprint.config prettyprint.custom -prettyprint.sections quotations io io.files math.parser effects +kernel math namespaces make sequences strings sbufs vectors +words prettyprint.config prettyprint.custom prettyprint.sections +quotations io io.pathnames io.styles math.parser effects classes.tuple math.order classes.tuple.private classes combinators colors ; IN: prettyprint.backend diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 9d5af9e6a5..6b49c4a35a 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -5,7 +5,7 @@ namespaces make sequences strings io.styles io.streams.string vectors words prettyprint.backend prettyprint.custom prettyprint.sections prettyprint.config sorting splitting grouping math.parser vocabs definitions effects classes.builtin -classes.tuple io.files classes continuations hashtables +classes.tuple io.pathnames classes continuations hashtables classes.mixin classes.union classes.intersection classes.predicate classes.singleton combinators quotations sets accessors colors parser summary ; diff --git a/basis/smtp/server/server.factor b/basis/smtp/server/server.factor index 7de22e9af9..f986404404 100644 --- a/basis/smtp/server/server.factor +++ b/basis/smtp/server/server.factor @@ -4,7 +4,7 @@ USING: combinators kernel prettyprint io io.timeouts sequences namespaces io.sockets io.sockets.secure continuations calendar io.encodings.ascii io.streams.duplex destructors locals concurrency.promises threads accessors smtp.private -io.unix.sockets.secure.debug ; +io.sockets.secure.unix.debug ; IN: smtp.server ! Mock SMTP server for testing purposes. diff --git a/basis/tools/crossref/crossref-tests.factor b/basis/tools/crossref/crossref-tests.factor index 5bf917f906..e7e2e55259 100644 --- a/basis/tools/crossref/crossref-tests.factor +++ b/basis/tools/crossref/crossref-tests.factor @@ -1,5 +1,6 @@ -USING: math kernel sequences io.files tools.crossref tools.test -parser namespaces source-files generic definitions ; +USING: math kernel sequences io.files io.pathnames +tools.crossref tools.test parser namespaces source-files generic +definitions ; IN: tools.crossref.tests GENERIC: foo diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index ee8615ac5a..636e44062e 100644 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -4,9 +4,11 @@ USING: namespaces make continuations.private kernel.private init assocs kernel vocabs words sequences memory io system arrays continuations math definitions mirrors splitting parser classes summary layouts vocabs.loader prettyprint.config prettyprint -debugger io.streams.c io.files io.backend quotations io.launcher -words.private tools.deploy.config tools.deploy.config.editor -bootstrap.image io.encodings.utf8 destructors accessors ; +debugger io.streams.c io.files io.files.temp io.pathnames +io.directories io.directories.hierarchy io.backend quotations +io.launcher words.private tools.deploy.config +tools.deploy.config.editor bootstrap.image io.encodings.utf8 +destructors accessors ; IN: tools.deploy.backend : copy-vm ( executable bundle-name extension -- vm ) diff --git a/basis/tools/deploy/config/editor/editor.factor b/basis/tools/deploy/config/editor/editor.factor index 2b5788adfc..ac89e3290b 100644 --- a/basis/tools/deploy/config/editor/editor.factor +++ b/basis/tools/deploy/config/editor/editor.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs io.files kernel parser prettyprint sequences +USING: assocs io.pathnames kernel parser prettyprint sequences splitting tools.deploy.config tools.vocabs vocabs.loader ; IN: tools.deploy.config.editor diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index a390ce56c4..e15ba9b90e 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -1,8 +1,9 @@ IN: tools.deploy.tests -USING: tools.test system io.files kernel tools.deploy.config +USING: tools.test system io.pathnames io.files io.files.info +io.files.temp kernel tools.deploy.config tools.deploy.config.editor tools.deploy.backend math sequences io.launcher arrays namespaces continuations layouts accessors -io.encodings.ascii urls math.parser ; +io.encodings.ascii urls math.parser io.directories ; : shake-and-bake ( vocab -- ) [ "test.image" temp-file delete-file ] ignore-errors diff --git a/basis/tools/deploy/macosx/macosx.factor b/basis/tools/deploy/macosx/macosx.factor index 1f0e482441..10e1566290 100644 --- a/basis/tools/deploy/macosx/macosx.factor +++ b/basis/tools/deploy/macosx/macosx.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.files kernel namespaces make sequences system -tools.deploy.backend tools.deploy.config +USING: io io.files io.files.info.unix io.pathnames +io.directories io.directories.hierarchy kernel namespaces make +sequences system tools.deploy.backend tools.deploy.config tools.deploy.config.editor assocs hashtables prettyprint -io.unix.backend cocoa io.encodings.utf8 io.backend +io.backend.unix cocoa io.encodings.utf8 io.backend cocoa.application cocoa.classes cocoa.plists qualified combinators ; IN: tools.deploy.macosx @@ -53,7 +54,8 @@ IN: tools.deploy.macosx } cleave ] [ create-app-plist ] - [ "Contents/MacOS/" append-path "" copy-vm ] 2tri ; + [ "Contents/MacOS/" append-path "" copy-vm ] 2tri + dup OCT: 755 set-file-permissions ; : deploy.app-image ( vocab bundle-name -- str ) [ % "/Contents/Resources/" % % ".image" % ] "" make ; diff --git a/basis/tools/deploy/unix/unix.factor b/basis/tools/deploy/unix/unix.factor index bd49155e84..9e0bb8ac68 100644 --- a/basis/tools/deploy/unix/unix.factor +++ b/basis/tools/deploy/unix/unix.factor @@ -1,13 +1,15 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: io io.files io.backend kernel namespaces make sequences +USING: io io.pathnames io.directories io.files +io.files.info.unix io.backend kernel namespaces make sequences system tools.deploy.backend tools.deploy.config tools.deploy.config.editor assocs hashtables prettyprint ; IN: tools.deploy.unix : create-app-dir ( vocab bundle-name -- vm ) dup "" copy-fonts - "" copy-vm ; + "" copy-vm + dup OCT: 755 set-file-permissions ; : bundle-name ( -- str ) deploy-name get ; diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor index 6188e78b0e..7ce635b1ba 100755 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.files kernel namespaces sequences system +USING: io io.files io.directories kernel namespaces sequences system tools.deploy.backend tools.deploy.config tools.deploy.config.editor assocs hashtables prettyprint combinators windows.shell32 windows.user32 ; diff --git a/basis/tools/disassembler/gdb/gdb.factor b/basis/tools/disassembler/gdb/gdb.factor old mode 100644 new mode 100755 index 65d0e2f43a..e97cc203a2 --- a/basis/tools/disassembler/gdb/gdb.factor +++ b/basis/tools/disassembler/gdb/gdb.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files io words alien kernel math.parser alien.syntax -io.launcher system assocs arrays sequences namespaces make -qualified system math io.encodings.ascii accessors -tools.disassembler ; +USING: io.files io.files.temp io words alien kernel math.parser +alien.syntax io.launcher system assocs arrays sequences +namespaces make qualified system math io.encodings.ascii +accessors tools.disassembler ; IN: tools.disassembler.gdb SINGLETON: gdb-disassembler diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 7968639d47..54882800b0 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators io io.files kernel -math.parser sequences system vocabs.loader calendar math -symbols fry prettyprint ; +USING: accessors arrays combinators io io.files io.files.info +io.directories kernel math.parser sequences system vocabs.loader +calendar math symbols fry prettyprint ; IN: tools.files vocab ] unit-test diff --git a/basis/tools/vocabs/monitor/monitor.factor b/basis/tools/vocabs/monitor/monitor.factor index 416eec91d2..ac0160e58f 100644 --- a/basis/tools/vocabs/monitor/monitor.factor +++ b/basis/tools/vocabs/monitor/monitor.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: threads io.files io.monitors init kernel +USING: threads io.files io.pathnames io.monitors init kernel vocabs vocabs.loader tools.vocabs namespaces continuations sequences splitting assocs command-line concurrency.messaging io.backend sets tr ; diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index ab2d089d94..fe380e0afe 100644 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel io io.styles io.files io.encodings.utf8 -vocabs.loader vocabs sequences namespaces make math.parser -arrays hashtables assocs memoize summary sorting splitting -combinators source-files debugger continuations compiler.errors -init checksums checksums.crc32 sets accessors generic -definitions words ; +USING: kernel io io.styles io.files io.files.info io.directories +io.pathnames io.encodings.utf8 vocabs.loader vocabs sequences +namespaces make math.parser arrays hashtables assocs memoize +summary sorting splitting combinators source-files debugger +continuations compiler.errors init checksums checksums.crc32 +sets accessors generic definitions words ; IN: tools.vocabs : vocab-xref ( vocab quot -- vocabs ) diff --git a/basis/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor index e3c3d46904..2297382a96 100644 --- a/basis/ui/tools/operations/operations.factor +++ b/basis/ui/tools/operations/operations.factor @@ -3,8 +3,8 @@ USING: continuations definitions ui.tools.browser ui.tools.interactor ui.tools.listener ui.tools.profiler ui.tools.search ui.tools.traceback ui.tools.workspace generic -help.topics stack-checker summary inspector io.files io.styles -kernel namespaces parser prettyprint quotations +help.topics stack-checker summary inspector io.pathnames +io.styles kernel namespaces parser prettyprint quotations tools.annotations editors tools.profiler tools.test tools.time tools.walker ui.commands ui.gadgets.editors ui.gestures ui.operations ui.tools.deploy vocabs vocabs.loader words diff --git a/basis/ui/tools/search/search-tests.factor b/basis/ui/tools/search/search-tests.factor index 39a6442308..4f239ba6e9 100644 --- a/basis/ui/tools/search/search-tests.factor +++ b/basis/ui/tools/search/search-tests.factor @@ -1,4 +1,4 @@ -USING: assocs ui.tools.search help.topics io.files io.styles +USING: assocs ui.tools.search help.topics io.pathnames io.styles kernel namespaces sequences source-files threads tools.test ui.gadgets ui.gestures vocabs accessors vocabs.loader words tools.test.ui debugger calendar ; diff --git a/basis/ui/tools/search/search.factor b/basis/ui/tools/search/search.factor index cf980cfc23..9d248e29bd 100644 --- a/basis/ui/tools/search/search.factor +++ b/basis/ui/tools/search/search.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs help help.topics io.files io.styles +USING: accessors assocs help help.topics io.pathnames io.styles kernel models models.delay models.filter namespaces prettyprint quotations sequences sorting source-files definitions strings tools.completion tools.crossref classes.tuple vocabs words diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index 177949aec9..f6aa7fa3e9 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings io.encodings.utf8 -io.unix.backend kernel math sequences splitting unix strings +io.backend.unix kernel math sequences splitting unix strings combinators.short-circuit byte-arrays combinators qualified accessors math.parser fry assocs namespaces continuations unix.users unix.utilities ; diff --git a/basis/unix/process/process.factor b/basis/unix/process/process.factor index 7d5f9eb330..04ba4d3438 100644 --- a/basis/unix/process/process.factor +++ b/basis/unix/process/process.factor @@ -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 unix.utilities ; +io.backend.unix io.encodings.utf8 unix.utilities ; IN: unix.process ! Low-level Unix process launching utilities. These are used diff --git a/basis/unix/stat/stat.factor b/basis/unix/stat/stat.factor index a3b0ed11b7..a3f8a5ce82 100644 --- a/basis/unix/stat/stat.factor +++ b/basis/unix/stat/stat.factor @@ -1,5 +1,5 @@ USING: kernel system combinators alien.syntax alien.c-types -math io.unix.backend vocabs.loader unix ; +math io.backend.unix vocabs.loader unix ; IN: unix.stat ! File Types diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 555f8e2c7d..2652a95d3e 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -4,7 +4,7 @@ USING: alien alien.c-types alien.syntax kernel libc sequences continuations byte-arrays strings math namespaces system combinators vocabs.loader qualified accessors stack-checker macros locals generalizations unix.types -io io.files vocabs vocabs.loader ; +io vocabs vocabs.loader ; IN: unix : PROT_NONE 0 ; inline @@ -30,19 +30,6 @@ IN: unix : DT_SOCK 12 ; inline : DT_WHT 14 ; inline -: dirent-type>file-type ( ch -- type ) - { - { DT_BLK [ +block-device+ ] } - { DT_CHR [ +character-device+ ] } - { DT_DIR [ +directory+ ] } - { DT_LNK [ +symbolic-link+ ] } - { DT_SOCK [ +socket+ ] } - { DT_FIFO [ +fifo+ ] } - { DT_REG [ +regular-file+ ] } - { DT_WHT [ +whiteout+ ] } - [ drop +unknown+ ] - } case ; - C-STRUCT: group { "char*" "gr_name" } { "char*" "gr_passwd" } diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index 8487d5adf2..78417c66bf 100644 --- a/basis/unix/users/users.factor +++ b/basis/unix/users/users.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings io.encodings.utf8 -io.unix.backend kernel math sequences splitting unix strings +io.backend.unix kernel math sequences splitting unix strings combinators.short-circuit grouping byte-arrays combinators accessors math.parser fry assocs namespaces continuations vocabs.loader system ; diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor index ce8a7be88c..f6c25980ea 100644 --- a/basis/urls/urls-docs.factor +++ b/basis/urls/urls-docs.factor @@ -1,6 +1,6 @@ USING: assocs hashtables help.markup help.syntax -io.streams.string io.files kernel strings present math multiline -; +io.streams.string io.files io.pathnames kernel strings present +math multiline ; IN: urls HELP: url diff --git a/basis/windows/shell32/shell32.factor b/basis/windows/shell32/shell32.factor index eae796ac08..13d71f1ff3 100644 --- a/basis/windows/shell32/shell32.factor +++ b/basis/windows/shell32/shell32.factor @@ -1,6 +1,9 @@ -USING: alien alien.c-types alien.strings alien.syntax combinators -kernel windows windows.user32 windows.ole32 -windows.com windows.com.syntax io.files io.encodings.utf16n ; +! Copyright (C) 2006, 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types alien.strings alien.syntax +combinators io.encodings.utf16n io.files io.pathnames kernel +windows windows.com windows.com.syntax windows.ole32 +windows.user32 ; IN: windows.shell32 : CSIDL_DESKTOP HEX: 00 ; inline diff --git a/basis/windows/time/time.factor b/basis/windows/time/time.factor index 54a7a8e32a..e63834d369 100644 --- a/basis/windows/time/time.factor +++ b/basis/windows/time/time.factor @@ -11,8 +11,9 @@ IN: windows.time 1601 1 1 0 0 0 instant ; : FILETIME>windows-time ( FILETIME -- n ) - [ FILETIME-dwLowDateTime ] keep - FILETIME-dwHighDateTime >64bit ; + [ FILETIME-dwLowDateTime ] + [ FILETIME-dwHighDateTime ] + bi >64bit ; : windows-time>timestamp ( n -- timestamp ) 10000000 /i seconds windows-1601 swap time+ ; @@ -28,12 +29,12 @@ IN: windows.time : windows-time>FILETIME ( n -- FILETIME ) "FILETIME" [ - [ 32 bits set-FILETIME-dwLowDateTime ] 2keep - [ -32 shift ] dip set-FILETIME-dwHighDateTime + [ [ 32 bits ] dip set-FILETIME-dwLowDateTime ] + [ [ -32 shift ] dip set-FILETIME-dwHighDateTime ] 2bi ] keep ; : timestamp>FILETIME ( timestamp -- FILETIME/f ) - [ >gmt timestamp>windows-time windows-time>FILETIME ] [ f ] if* ; + dup [ >gmt timestamp>windows-time windows-time>FILETIME ] when ; : FILETIME>timestamp ( FILETIME -- timestamp/f ) FILETIME>windows-time windows-time>timestamp ; diff --git a/basis/xmode/code2html/responder/responder.factor b/basis/xmode/code2html/responder/responder.factor index 9115b1389b..39ff627b84 100644 --- a/basis/xmode/code2html/responder/responder.factor +++ b/basis/xmode/code2html/responder/responder.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.files io.encodings.utf8 namespaces http.server -http.server.responses http.server.static http xmode.code2html -kernel sequences accessors fry ; +USING: io io.files io.pathnames io.encodings.utf8 namespaces +http.server http.server.responses http.server.static http +xmode.code2html kernel sequences accessors fry ; IN: xmode.code2html.responder : ( root -- responder ) diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 699d93b8b4..a3662fcaa6 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: sequences math.parser io io.encodings.binary io.files +USING: sequences math.parser io io.backend io.files kernel ; IN: checksums @@ -19,7 +19,10 @@ M: checksum checksum-lines [ B{ CHAR: \n } join ] dip checksum-bytes ; : checksum-file ( path checksum -- value ) - [ binary ] dip checksum-stream ; + #! normalize-path (file-reader) is equivalen to + #! binary . We use the lower-level form + #! so that we can move io.encodings.binary to basis/. + [ normalize-path (file-reader) ] dip checksum-stream ; : hex-string ( seq -- str ) [ >hex 2 CHAR: 0 pad-left ] { } map-as concat ; diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 80b515b13f..7948a2e912 100644 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax io strings arrays io.backend io.files.private quotations ; IN: io.files -ARTICLE: "file-streams" "Reading and writing files" +ARTICLE: "io.files" "Reading and writing files" "File streams:" { $subsection } { $subsection } @@ -17,182 +17,10 @@ ARTICLE: "file-streams" "Reading and writing files" { $subsection with-file-writer } { $subsection with-file-appender } ; -ARTICLE: "pathnames" "Pathname manipulation" -"Pathname manipulation:" -{ $subsection parent-directory } -{ $subsection file-name } -{ $subsection last-path-separator } -{ $subsection append-path } -"Pathnames relative to Factor's temporary files directory:" -{ $subsection temp-directory } -{ $subsection temp-file } -"Pathname presentations:" -{ $subsection pathname } -{ $subsection } ; - -ARTICLE: "symbolic-links" "Symbolic links" -"Reading and creating links:" -{ $subsection read-link } -{ $subsection make-link } -"Copying links:" -{ $subsection copy-link } -"Not all operating systems support symbolic links." -{ $see-also link-info } ; - -ARTICLE: "current-directory" "Current working directory" -"File system I/O operations use the value of a variable to resolve relative pathnames:" -{ $subsection current-directory } -"This variable can be changed with a pair of words:" -{ $subsection set-current-directory } -{ $subsection with-directory } -"This variable is independent of the operating system notion of ``current working directory''. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:" -{ $subsection (normalize-path) } -"The second is to change the working directory of the current process:" -{ $subsection cd } -{ $subsection cwd } ; - -ARTICLE: "directories" "Directories" -"Home directory:" -{ $subsection home } -"Directory listing:" -{ $subsection directory-entries } -{ $subsection directory-files } -{ $subsection with-directory-files } -"Creating directories:" -{ $subsection make-directory } -{ $subsection make-directories } -{ $subsection "current-directory" } ; - -ARTICLE: "file-types" "File Types" -"Platform-independent types:" -{ $subsection +regular-file+ } -{ $subsection +directory+ } -"Platform-specific types:" -{ $subsection +character-device+ } -{ $subsection +block-device+ } -{ $subsection +fifo+ } -{ $subsection +symbolic-link+ } -{ $subsection +socket+ } -{ $subsection +unknown+ } ; - -ARTICLE: "fs-meta" "File metadata" -"Querying file-system metadata:" -{ $subsection file-info } -{ $subsection link-info } -{ $subsection exists? } -{ $subsection directory? } - -"File types:" -{ $subsection "file-types" } ; - -ARTICLE: "delete-move-copy" "Deleting, moving, copying files" -"Operations for deleting and copying files come in two forms:" -{ $list - { "Words named " { $snippet { $emphasis "operation" } "-file" } " which work on regular files only." } - { "Words named " { $snippet { $emphasis "operation" } "-tree" } " works on directory trees recursively, and also accepts regular files." } -} -"The operations for moving and copying files come in three flavors:" -{ $list - { "A word named " { $snippet { $emphasis "operation" } } " which takes a source and destination path." } - { "A word named " { $snippet { $emphasis "operation" } "-into" } " which takes a source path and destination directory. The destination file will be stored in the destination directory and will have the same file name as the source path." } - { "A word named " { $snippet { $emphasis "operation" } "s-into" } " which takes a sequence of source paths and destination directory." } -} -"Since both of the above lists apply to copying files, that this means that there are a total of six variations on copying a file." -$nl -"Deleting files:" -{ $subsection delete-file } -{ $subsection delete-directory } -{ $subsection delete-tree } -"Moving files:" -{ $subsection move-file } -{ $subsection move-file-into } -{ $subsection move-files-into } -"Copying files:" -{ $subsection copy-file } -{ $subsection copy-file-into } -{ $subsection copy-files-into } -"Copying directory trees recursively:" -{ $subsection copy-tree } -{ $subsection copy-tree-into } -{ $subsection copy-trees-into } -"On most operating systems, files can only be moved within the same file system. To move files between file systems, use " { $link copy-file } " followed by " { $link delete-file } " on the old name." ; - -ARTICLE: "io.files" "Basic file operations" -"The " { $vocab-link "io.files" } " vocabulary provides basic support for working with files." -{ $subsection "pathnames" } -{ $subsection "file-streams" } -{ $subsection "fs-meta" } -{ $subsection "directories" } -{ $subsection "delete-move-copy" } -{ $subsection "symbolic-links" } ; - ABOUT: "io.files" -HELP: path-separator? -{ $values { "ch" "a code point" } { "?" "a boolean" } } -{ $description "Tests if the code point is a platform-specific path separator." } -{ $examples - "On Unix:" - { $example "USING: io.files prettyprint ;" "CHAR: / path-separator? ." "t" } -} ; - -HELP: parent-directory -{ $values { "path" "a pathname string" } { "parent" "a pathname string" } } -{ $description "Strips the last component off a pathname." } -{ $examples { $example "USING: io io.files ;" "\"/etc/passwd\" parent-directory print" "/etc/" } } ; - -HELP: file-name -{ $values { "path" "a pathname string" } { "string" string } } -{ $description "Outputs the last component of a pathname string." } -{ $examples - { $example "USING: io.files prettyprint ;" "\"/usr/bin/gcc\" file-name ." "\"gcc\"" } - { $example "USING: io.files prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" } -} ; - -! need a $class-description file-info - -HELP: file-info -{ $values { "path" "a pathname string" } { "info" file-info } } -{ $description "Queries the file system for metadata. If " { $snippet "path" } " refers to a symbolic link, it is followed. See the article " { $link "file-types" } " for a list of metadata symbols." } -{ $errors "Throws an error if the file does not exist." } ; - -HELP: link-info -{ $values { "path" "a pathname string" } { "info" "a file-info tuple" } } -{ $description "Queries the file system for metadata. If path refers to a symbolic link, information about the symbolic link itself is returned. If the file does not exist, an exception is thrown." } ; - -{ file-info link-info } related-words - -HELP: +regular-file+ -{ $description "A regular file. This type exists on all platforms. See " { $link "file-streams" } " for words operating on files." } ; - -HELP: +directory+ -{ $description "A directory. This type exists on all platforms. See " { $link "directories" } " for words operating on directories." } ; - -HELP: +symbolic-link+ -{ $description "A symbolic link file. This type is currently implemented on Unix platforms only. See " { $link "symbolic-links" } " for words operating on symbolic links." } ; - -HELP: +character-device+ -{ $description "A Unix character device file. This type exists on Unix platforms only." } ; - -HELP: +block-device+ -{ $description "A Unix block device file. This type exists on Unix platforms only." } ; - -HELP: +fifo+ -{ $description "A Unix fifo file. This type exists on Unix platforms only." } ; - -HELP: +socket+ -{ $description "A Unix socket file. This type exists on Unix platforms only." } ; - -HELP: +unknown+ -{ $description "A unknown file type." } ; - HELP: -{ - $values - { "path" "a pathname string" } - { "encoding" "an encoding descriptor" } - { "stream" "an input stream" } -} +{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "stream" "an input stream" } } { $description "Outputs an input stream for reading from the specified pathname using the given encoding." } { $errors "Throws an error if the file is unreadable." } ; @@ -243,205 +71,6 @@ HELP: file-contents { set-file-lines file-lines set-file-contents file-contents } related-words -HELP: cwd -{ $values { "path" "a pathname string" } } -{ $description "Outputs the current working directory of the Factor process." } -{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } -{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ; - -HELP: cd -{ $values { "path" "a pathname string" } } -{ $description "Changes the current working directory of the Factor process." } -{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } -{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ; - -{ cd cwd current-directory set-current-directory with-directory } related-words - -HELP: current-directory -{ $description "A variable holding the current directory as an absolute path. Words that use the filesystem do so in relation to this variable." -$nl -"This variable should never be set directly; instead, use " { $link set-current-directory } " or " { $link with-directory } ". This preserves the invariant that the value of this variable is an absolute path." } ; - -HELP: set-current-directory -{ $values { "path" "a pathname string" } } -{ $description "Changes the " { $link current-directory } " variable." -$nl -"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ; - -HELP: with-directory -{ $values { "path" "a pathname string" } { "quot" quotation } } -{ $description "Calls the quotation in a new dynamic scope with the " { $link current-directory } " variable rebound." -$nl -"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ; - -HELP: append-path -{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } -{ $description "Appends " { $snippet "str1" } " and " { $snippet "str2" } " to form a pathname." } ; - -HELP: prepend-path -{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } -{ $description "Appends " { $snippet "str2" } " and " { $snippet "str1" } " to form a pathname." } ; - -{ append-path prepend-path } related-words - -HELP: absolute-path? -{ $values { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Tests if a pathname is absolute. Examples of absolute pathnames are " { $snippet "/foo/bar" } " on Unix and " { $snippet "c:\\foo\\bar" } " on Windows." } ; - -HELP: windows-absolute-path? -{ $values { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Tests if a pathname is absolute on Windows. Examples of absolute pathnames on Windows are " { $snippet "c:\\foo\\bar" } " and " { $snippet "\\\\?\\c:\\foo\\bar" } " for absolute Unicode pathnames." } ; - -HELP: root-directory? -{ $values { "path" "a pathname string" } { "?" "a boolean" } } -{ $description "Tests if a pathname is a root directory. Examples of root directory pathnames are " { $snippet "/" } " on Unix and " { $snippet "c:\\" } " on Windows." } ; - -{ absolute-path? windows-absolute-path? root-directory? } related-words - HELP: exists? { $values { "path" "a pathname string" } { "?" "a boolean" } } { $description "Tests if the file named by " { $snippet "path" } " exists." } ; - -HELP: directory? -{ $values { "file-info" file-info } { "?" "a boolean" } } -{ $description "Tests if " { $snippet "file-info" } " is a directory." } ; - -HELP: (directory-entries) -{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } } -{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } -{ $notes "This is a low-level word, and user code should call one of the related words instead." } ; - -HELP: directory-entries -{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $link directory-entry } " objects" } } -{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ; - -HELP: directory-files -{ $values { "path" "a pathname string" } { "seq" "a sequence of filenames" } } -{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ; - -HELP: with-directory-files -{ $values { "path" "a pathname string" } { "quot" quotation } } -{ $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ; - -HELP: file-systems -{ $values { "array" array } } -{ $description "Returns an array of " { $link file-system-info } " objects returned by iterating the mount points and calling " { $link file-system-info } " on each." } ; - -HELP: file-system-info -{ $values -{ "path" "a pathname string" } -{ "file-system-info" file-system-info } } -{ $description "Returns a platform-specific object describing the file-system that contains the path. The cross-platform slot is " { $slot "free-space" } "." } ; - -HELP: resource-path -{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } } -{ $description "Resolve a path relative to the Factor source code location." } ; - -HELP: pathname -{ $class-description "Class of path name objects. Path name objects can be created by calling " { $link } "." } ; - -HELP: normalize-path -{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } } -{ $description "Called by words such as " { $link } " and " { $link } " to prepare a pathname before passing it to underlying code." } ; - -HELP: ( str -- pathname ) -{ $values { "str" "a pathname string" } { "pathname" pathname } } -{ $description "Creates a new " { $link pathname } "." } ; - -HELP: make-link -{ $values { "target" "a path to the symbolic link's target" } { "symlink" "a path to new symbolic link" } } -{ $description "Creates a symbolic link." } ; - -HELP: read-link -{ $values { "symlink" "a path to an existing symbolic link" } { "path" "the path pointed to by the symbolic link" } } -{ $description "Reads the symbolic link and returns its target path." } ; - -HELP: copy-link -{ $values { "target" "a path to an existing symlink" } { "symlink" "a path to a new symbolic link" } } -{ $description "Copies a symbolic link without following the link." } ; - -{ make-link read-link copy-link } related-words - -HELP: home -{ $values { "dir" string } } -{ $description "Outputs the user's home directory." } ; - -HELP: delete-file -{ $values { "path" "a pathname string" } } -{ $description "Deletes a file." } -{ $errors "Throws an error if the file could not be deleted." } ; - -HELP: make-directory -{ $values { "path" "a pathname string" } } -{ $description "Creates a directory." } -{ $errors "Throws an error if the directory could not be created." } ; - -HELP: make-directories -{ $values { "path" "a pathname string" } } -{ $description "Creates a directory and any parent directories which do not yet exist." } -{ $errors "Throws an error if the directories could not be created." } ; - -HELP: delete-directory -{ $values { "path" "a pathname string" } } -{ $description "Deletes a directory. The directory must be empty." } -{ $errors "Throws an error if the directory could not be deleted." } ; - -HELP: touch-file -{ $values { "path" "a pathname string" } } -{ $description "Updates the modification time of a file or directory. If the file does not exist, creates a new, empty file." } -{ $errors "Throws an error if the file could not be touched." } ; - -HELP: delete-tree -{ $values { "path" "a pathname string" } } -{ $description "Deletes a file or directory, recursing into subdirectories." } -{ $errors "Throws an error if the deletion fails." } -{ $warning "Misuse of this word can lead to catastrophic data loss." } ; - -HELP: move-file -{ $values { "from" "a pathname string" } { "to" "a pathname string" } } -{ $description "Moves or renames a file." } -{ $errors "Throws an error if the file does not exist or if the move operation fails." } ; - -HELP: move-file-into -{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } } -{ $description "Moves a file to another directory without renaming it." } -{ $errors "Throws an error if the file does not exist or if the move operation fails." } ; - -HELP: move-files-into -{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } } -{ $description "Moves a set of files to another directory." } -{ $errors "Throws an error if the file does not exist or if the move operation fails." } ; - -HELP: copy-file -{ $values { "from" "a pathname string" } { "to" "a pathname string" } } -{ $description "Copies a file." } -{ $notes "This operation attempts to preserve the original file's attributes, however not all attributes may be preserved." } -{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ; - -HELP: copy-file-into -{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } } -{ $description "Copies a file to another directory." } -{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ; - -HELP: copy-files-into -{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } } -{ $description "Copies a set of files to another directory." } -{ $errors "Throws an error if the file does not exist or if the copy operation fails." } ; - -HELP: copy-tree -{ $values { "from" "a pathname string" } { "to" "a pathname string" } } -{ $description "Copies a directory tree recursively." } -{ $notes "This operation attempts to preserve original file attributes, however not all attributes may be preserved." } -{ $errors "Throws an error if the copy operation fails." } ; - -HELP: copy-tree-into -{ $values { "from" "a pathname string" } { "to" "a directory pathname string" } } -{ $description "Copies a directory tree to another directory, recursively." } -{ $errors "Throws an error if the copy operation fails." } ; - -HELP: copy-trees-into -{ $values { "files" "a sequence of pathname strings" } { "to" "a directory pathname string" } } -{ $description "Copies a set of directory trees to another directory, recursively." } -{ $errors "Throws an error if the copy operation fails." } ; - - diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 4299634642..d2611d73a9 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,131 +1,68 @@ +USING: tools.test io.files io.files.private io.files.temp +io.directories io.encodings.8-bit arrays make system +io.encodings.binary io +threads kernel continuations io.encodings.ascii sequences +strings accessors io.encodings.utf8 math destructors namespaces +; IN: io.files.tests -USING: tools.test io.files io.files.private io threads kernel -continuations io.encodings.ascii sequences -strings accessors io.encodings.utf8 math destructors -namespaces ; \ exists? must-infer \ (exists?) must-infer -\ file-info must-infer -\ link-info must-infer -[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test -[ ] [ "blahblah" temp-file make-directory ] unit-test -[ t ] [ "blahblah" temp-file file-info directory? ] unit-test - -[ t ] [ - [ temp-directory "loldir" append-path delete-directory ] ignore-errors - temp-directory [ - "loldir" make-directory - ] with-directory - temp-directory "loldir" append-path exists? -] unit-test - -[ ] [ - [ temp-directory "loldir" append-path delete-directory ] ignore-errors - temp-directory [ - "loldir" make-directory - "loldir" delete-directory - ] with-directory -] unit-test - -[ "file1 contents" ] [ - [ temp-directory "loldir" append-path delete-directory ] ignore-errors - temp-directory [ - "file1 contents" "file1" utf8 set-file-contents - "file1" "file2" copy-file - "file2" utf8 file-contents - ] with-directory - "file1" temp-file delete-file - "file2" temp-file delete-file -] unit-test - -[ "file3 contents" ] [ - temp-directory [ - "file3 contents" "file3" utf8 set-file-contents - "file3" "file4" move-file - "file4" utf8 file-contents - ] with-directory - "file4" temp-file delete-file -] unit-test - -[ "file5" temp-file delete-file ] ignore-errors - -[ ] [ - temp-directory [ - "file5" touch-file - "file5" delete-file - ] with-directory -] unit-test - -[ "file6" temp-file delete-file ] ignore-errors - -[ ] [ - temp-directory [ - "file6" touch-file - "file6" link-info drop - ] with-directory -] unit-test - -[ "passwd" ] [ "/etc/passwd" file-name ] unit-test -[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test -[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test -[ "" ] [ "" file-name ] unit-test +[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test -[ "freetype6.dll" ] [ "resource:freetype6.dll" file-name ] unit-test -[ "freetype6.dll" ] [ "resource:/freetype6.dll" file-name ] unit-test +[ ] [ "append-test" temp-file ascii dispose ] unit-test -[ ] [ - { "Hello world." } - "test-foo.txt" temp-file ascii set-file-lines +[ + "This is a line.\rThis is another line.\r" +] [ + "resource:core/io/test/mac-os-eol.txt" latin1 + [ 500 read ] with-input-stream ] unit-test -[ ] [ - "test-foo.txt" temp-file ascii [ - "Hello appender." print - ] with-file-appender +[ + 255 +] [ + "resource:core/io/test/binary.txt" latin1 + [ read1 ] with-input-stream >fixnum ] unit-test [ ] [ - "test-bar.txt" temp-file ascii [ - "Hello appender." print - ] with-file-appender + "It seems Jobs has lost his grasp on reality again.\n" + "separator-test.txt" temp-file latin1 set-file-contents ] unit-test -[ "Hello world.\nHello appender.\n" ] [ - "test-foo.txt" temp-file ascii file-contents -] unit-test - -[ "Hello appender.\n" ] [ - "test-bar.txt" temp-file ascii file-contents +[ + { + { "It seems " CHAR: J } + { "obs has lost h" CHAR: i } + { "s grasp on reality again.\n" f } + } +] [ + [ + "separator-test.txt" temp-file + latin1 [ + "J" read-until 2array , + "i" read-until 2array , + "X" read-until 2array , + ] with-input-stream + ] { } make ] unit-test -[ ] [ "test-foo.txt" temp-file delete-file ] unit-test - -[ ] [ "test-bar.txt" temp-file delete-file ] unit-test - -[ f ] [ "test-foo.txt" temp-file exists? ] unit-test - -[ 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 - [ ] [ - "test-blah/fooz" temp-file ascii dispose + image binary [ + 10 [ 65536 read drop ] times + ] with-file-reader ] unit-test -[ t ] [ - "test-blah/fooz" temp-file exists? +! Test EOF behavior +[ 10 ] [ + image binary [ + 0 read drop + 10 read length + ] with-file-reader ] unit-test -[ ] [ "test-blah/fooz" temp-file delete-file ] unit-test - -[ ] [ "test-blah" temp-file delete-directory ] unit-test - -[ f ] [ "test-blah" temp-file exists? ] unit-test - USE: debugger.threads [ ] [ "test-quux.txt" temp-file ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test @@ -139,150 +76,3 @@ USE: debugger.threads [ t ] [ "quux-test.txt" temp-file exists? ] unit-test [ ] [ "quux-test.txt" temp-file delete-file ] unit-test - -[ ] [ "delete-tree-test/a/b/c" temp-file make-directories ] unit-test - -[ ] [ - { "Hi" } - "delete-tree-test/a/b/c/d" temp-file ascii set-file-lines -] unit-test - -[ ] [ - "delete-tree-test" temp-file delete-tree -] unit-test - -[ { "kernel" } ] [ - "core" resource-path [ - "." directory-files [ "kernel" = ] filter - ] with-directory -] unit-test - -[ { "kernel" } ] [ - "resource:core" [ - "." directory-files [ "kernel" = ] filter - ] with-directory -] unit-test - -[ { "kernel" } ] [ - "resource:core" [ - [ "kernel" = ] filter - ] with-directory-files -] unit-test - -[ ] [ - "copy-tree-test/a/b/c" temp-file make-directories -] unit-test - -[ ] [ - "Foobar" - "copy-tree-test/a/b/c/d" temp-file - ascii set-file-contents -] unit-test - -[ ] [ - "copy-tree-test" temp-file - "copy-destination" temp-file copy-tree -] unit-test - -[ "Foobar" ] [ - "copy-destination/a/b/c/d" temp-file ascii file-contents -] unit-test - -[ ] [ - "copy-destination" temp-file delete-tree -] unit-test - -[ ] [ - "copy-tree-test" temp-file - "copy-destination" temp-file copy-tree-into -] unit-test - -[ "Foobar" ] [ - "copy-destination/copy-tree-test/a/b/c/d" temp-file ascii file-contents -] unit-test - -[ ] [ - "copy-destination/copy-tree-test/a/b/c/d" temp-file "" temp-file copy-file-into -] unit-test - -[ "Foobar" ] [ - "d" temp-file ascii file-contents -] unit-test - -[ ] [ "d" temp-file delete-file ] unit-test - -[ ] [ "copy-destination" temp-file delete-tree ] unit-test - -[ ] [ "copy-tree-test" temp-file delete-tree ] unit-test - -[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test - -[ t ] [ - temp-directory [ "hi41" "test41" utf8 set-file-contents ] with-directory - temp-directory "test41" append-path utf8 file-contents "hi41" = -] unit-test - -[ t ] [ - temp-directory [ "test41" file-info size>> ] with-directory 4 = -] unit-test - -[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test - -[ ] [ "append-test" temp-file ascii dispose ] unit-test - -[ "/usr/lib" ] [ "/usr" "lib" append-path ] unit-test -[ "/usr/lib" ] [ "/usr/" "lib" append-path ] unit-test -[ "/usr/lib" ] [ "/usr" "./lib" append-path ] unit-test -[ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test -[ "/lib" ] [ "/usr" "../lib" append-path ] unit-test -[ "/lib/" ] [ "/usr" "../lib/" append-path ] unit-test - -[ "" ] [ "" "." append-path ] unit-test -[ "" ".." append-path ] must-fail - -[ "/" ] [ "/" "./." append-path ] unit-test -[ "/" ] [ "/" "././" append-path ] unit-test -[ "/a/b/lib" ] [ "/a/b/c/d/e/f/" "../../../../lib" append-path ] unit-test -[ "/a/b/lib/" ] [ "/a/b/c/d/e/f/" "../../../../lib/" append-path ] unit-test - -[ "" "../lib/" append-path ] must-fail -[ "lib" ] [ "" "lib" append-path ] unit-test -[ "lib" ] [ "" "./lib" append-path ] unit-test - -[ "foo/bar/." parent-directory ] must-fail -[ "foo/bar/./" parent-directory ] must-fail -[ "foo/bar/baz/.." parent-directory ] must-fail -[ "foo/bar/baz/../" parent-directory ] must-fail - -[ "." parent-directory ] must-fail -[ "./" parent-directory ] must-fail -[ ".." parent-directory ] must-fail -[ "../" parent-directory ] must-fail -[ "../../" parent-directory ] must-fail -[ "foo/.." parent-directory ] must-fail -[ "foo/../" parent-directory ] must-fail -[ "" parent-directory ] must-fail -[ "." ] [ "boot.x86.64.image" parent-directory ] unit-test - -[ "bar/foo" ] [ "bar/baz" "..///foo" append-path ] unit-test -[ "bar/baz/foo" ] [ "bar/baz" ".///foo" append-path ] unit-test -[ "bar/foo" ] [ "bar/baz" "./..//foo" append-path ] unit-test -[ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test - -[ t ] [ "resource:core" absolute-path? ] unit-test -[ f ] [ "" absolute-path? ] unit-test - -[ "touch-twice-test" temp-file delete-file ] ignore-errors -[ ] [ 2 [ "touch-twice-test" temp-file touch-file ] times ] unit-test - -! aum's bug -[ - "." current-directory set - ".." "resource-path" set - [ "../core/bootstrap/stage2.factor" ] - [ "resource:core/bootstrap/stage2.factor" (normalize-path) ] - unit-test -] with-scope - -[ t ] [ "/" file-system-info file-system-info? ] unit-test -[ t ] [ file-systems [ file-system-info? ] all? ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 77b37180c6..19659ee5bb 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -1,10 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: io.backend io.files.private io hashtables kernel -kernel.private math memory namespaces sequences strings assocs -arrays definitions system combinators splitting sbufs -continuations destructors io.encodings io.encodings.binary init -accessors math.order ; +USING: kernel kernel.private sequences init namespaces system io +io.backend io.pathnames io.encodings io.files.private ; IN: io.files HOOK: (file-reader) io-backend ( path -- stream ) @@ -43,155 +40,9 @@ HOOK: (file-appender) io-backend ( path -- stream ) : with-file-appender ( path encoding quot -- ) [ ] dip with-output-stream ; inline -! Pathnames -: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ; - -: path-separator ( -- string ) os windows? "\\" "/" ? ; - -: trim-right-separators ( str -- newstr ) - [ path-separator? ] trim-right ; - -: trim-left-separators ( str -- newstr ) - [ path-separator? ] trim-left ; - -: last-path-separator ( path -- n ? ) - [ length 1- ] keep [ path-separator? ] find-last-from ; - -HOOK: root-directory? io-backend ( path -- ? ) - -M: object root-directory? ( path -- ? ) - [ f ] [ [ path-separator? ] all? ] if-empty ; - -ERROR: no-parent-directory path ; - -: parent-directory ( path -- parent ) - dup root-directory? [ - trim-right-separators - dup last-path-separator [ - 1+ cut - ] [ - drop "." swap - ] if - { "" "." ".." } member? [ - no-parent-directory - ] when - ] unless ; - - - -: windows-absolute-path? ( path -- path ? ) - { - { [ dup "\\\\?\\" head? ] [ t ] } - { [ dup length 2 < ] [ f ] } - { [ dup second CHAR: : = ] [ t ] } - [ f ] - } cond ; - -: absolute-path? ( path -- ? ) - { - { [ dup empty? ] [ f ] } - { [ dup "resource:" head? ] [ t ] } - { [ os windows? ] [ windows-absolute-path? ] } - { [ dup first path-separator? ] [ t ] } - [ f ] - } cond nip ; - -: append-path ( str1 str2 -- str ) - { - { [ over empty? ] [ append-path-empty ] } - { [ dup empty? ] [ drop ] } - { [ over trim-right-separators "." = ] [ nip ] } - { [ dup absolute-path? ] [ nip ] } - { [ dup head.? ] [ rest trim-left-separators append-path ] } - { [ dup head..? ] [ - 2 tail trim-left-separators - [ parent-directory ] dip append-path - ] } - { [ over absolute-path? over first path-separator? and ] [ - [ 2 head ] dip append - ] } - [ - [ trim-right-separators "/" ] dip - trim-left-separators 3append - ] - } cond ; - -: prepend-path ( str1 str2 -- str ) - swap append-path ; inline - -: file-name ( path -- string ) - dup root-directory? [ - trim-right-separators - dup last-path-separator [ 1+ tail ] [ - drop "resource:" ?head [ file-name ] when - ] if - ] unless ; - -: file-extension ( filename -- extension ) - "." split1-last nip ; - -! File info -TUPLE: file-info type size permissions created modified -accessed ; - -HOOK: file-info io-backend ( path -- info ) - -! Symlinks -HOOK: link-info io-backend ( path -- info ) - -HOOK: make-link io-backend ( target symlink -- ) - -HOOK: read-link io-backend ( symlink -- path ) - -: copy-link ( target symlink -- ) - [ read-link ] dip make-link ; - -SYMBOL: +regular-file+ -SYMBOL: +directory+ -SYMBOL: +symbolic-link+ -SYMBOL: +character-device+ -SYMBOL: +block-device+ -SYMBOL: +fifo+ -SYMBOL: +socket+ -SYMBOL: +whiteout+ -SYMBOL: +unknown+ - -! File metadata : exists? ( path -- ? ) normalize-path (exists?) ; -: directory? ( file-info -- ? ) type>> +directory+ = ; - -! File-system - -HOOK: file-systems os ( -- array ) - -TUPLE: file-system-info device-name mount-point type -available-space free-space used-space total-space ; - -HOOK: file-system-info os ( path -- file-system-info ) - +! Current directory -SYMBOL: current-directory - [ cwd current-directory set-global 13 getenv cwd prepend-path \ image set-global 14 getenv cwd prepend-path \ vm set-global image parent-directory "resource-path" set-global -] "io.files" add-init-hook - -: resource-path ( path -- newpath ) - "resource-path" get prepend-path ; - -: (normalize-path) ( path -- path' ) - "resource:" ?head [ - trim-left-separators resource-path - (normalize-path) - ] [ - current-directory get prepend-path - ] if ; - -M: object normalize-path ( path -- path' ) - (normalize-path) ; - -: set-current-directory ( path -- ) - (normalize-path) current-directory set ; - -: with-directory ( path quot -- ) - [ (normalize-path) current-directory ] dip with-variable ; inline - -! Creating directories -HOOK: make-directory io-backend ( path -- ) - -: make-directories ( path -- ) - normalize-path trim-right-separators { - { [ dup "." = ] [ ] } - { [ dup root-directory? ] [ ] } - { [ dup empty? ] [ ] } - { [ dup exists? ] [ ] } - [ - dup parent-directory make-directories - dup make-directory - ] - } cond drop ; - -TUPLE: directory-entry name type ; - -HOOK: >directory-entry os ( byte-array -- directory-entry ) - -HOOK: (directory-entries) os ( path -- seq ) - -: directory-entries ( path -- seq ) - normalize-path - (directory-entries) - [ name>> { "." ".." } member? not ] filter ; - -: directory-files ( path -- seq ) - directory-entries [ name>> ] map ; - -: with-directory-files ( path quot -- ) - [ "" directory-files ] prepose with-directory ; inline - -! Touching files -HOOK: touch-file io-backend ( path -- ) - -! Deleting files -HOOK: delete-file io-backend ( path -- ) - -HOOK: delete-directory io-backend ( path -- ) - -: delete-tree ( path -- ) - dup link-info type>> +directory+ = [ - [ [ [ delete-tree ] each ] with-directory-files ] - [ delete-directory ] - bi - ] [ delete-file ] if ; - -: to-directory ( from to -- from to' ) - over file-name append-path ; - -! Moving and renaming files -HOOK: move-file io-backend ( from to -- ) - -: move-file-into ( from to -- ) - to-directory move-file ; - -: move-files-into ( files to -- ) - [ move-file-into ] curry each ; - -! Copying files -HOOK: copy-file io-backend ( from to -- ) - -M: object copy-file - dup parent-directory make-directories - binary [ - swap binary [ - swap stream-copy - ] with-disposal - ] with-disposal ; - -: copy-file-into ( from to -- ) - to-directory copy-file ; - -: copy-files-into ( files to -- ) - [ copy-file-into ] curry each ; - -DEFER: copy-tree-into - -: copy-tree ( from to -- ) - normalize-path - over link-info type>> - { - { +symbolic-link+ [ copy-link ] } - { +directory+ [ - swap [ - [ swap copy-tree-into ] with each - ] with-directory-files - ] } - [ drop copy-file ] - } case ; - -: copy-tree-into ( from to -- ) - to-directory copy-tree ; - -: copy-trees-into ( files to -- ) - [ copy-tree-into ] curry each ; - -! Special paths - -: temp-directory ( -- path ) - "temp" resource-path dup make-directories ; - -: temp-file ( name -- path ) - temp-directory prepend-path ; - -! Pathname presentations -TUPLE: pathname string ; - -C: pathname - -M: pathname <=> [ string>> ] compare ; - -! Home directory -HOOK: home io-backend ( -- dir ) - -M: object home "" resource-path ; +] "io.files" add-init-hook \ No newline at end of file diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 18cde1a35c..009ba3a9e7 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -8,55 +8,5 @@ IN: io.tests "foo" "io.tests" lookup ] unit-test -[ - "This is a line.\rThis is another line.\r" -] [ - "resource:core/io/test/mac-os-eol.txt" latin1 - [ 500 read ] with-input-stream -] unit-test - -[ - 255 -] [ - "resource:core/io/test/binary.txt" latin1 - [ read1 ] with-input-stream >fixnum -] unit-test - ! Make sure we use correct to_c_string form when writing [ ] [ "\0" write ] unit-test - -[ ] [ - "It seems Jobs has lost his grasp on reality again.\n" - "separator-test.txt" temp-file latin1 set-file-contents -] unit-test - -[ - { - { "It seems " CHAR: J } - { "obs has lost h" CHAR: i } - { "s grasp on reality again.\n" f } - } -] [ - [ - "separator-test.txt" temp-file - latin1 [ - "J" read-until 2array , - "i" read-until 2array , - "X" read-until 2array , - ] with-input-stream - ] { } make -] unit-test - -[ ] [ - image binary [ - 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 diff --git a/core/io/pathnames/authors.txt b/core/io/pathnames/authors.txt new file mode 100644 index 0000000000..f372b574ae --- /dev/null +++ b/core/io/pathnames/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Doug Coleman diff --git a/core/io/pathnames/pathnames-docs.factor b/core/io/pathnames/pathnames-docs.factor new file mode 100644 index 0000000000..8ef0de86b7 --- /dev/null +++ b/core/io/pathnames/pathnames-docs.factor @@ -0,0 +1,78 @@ +USING: help.markup help.syntax io.backend io.files strings ; +IN: io.pathnames + +HELP: path-separator? +{ $values { "ch" "a code point" } { "?" "a boolean" } } +{ $description "Tests if the code point is a platform-specific path separator." } +{ $examples + "On Unix:" + { $example "USING: io.pathnames prettyprint ;" "CHAR: / path-separator? ." "t" } +} ; + +HELP: parent-directory +{ $values { "path" "a pathname string" } { "parent" "a pathname string" } } +{ $description "Strips the last component off a pathname." } +{ $examples { $example "USING: io io.pathnames ;" "\"/etc/passwd\" parent-directory print" "/etc/" } } ; + +HELP: file-name +{ $values { "path" "a pathname string" } { "string" string } } +{ $description "Outputs the last component of a pathname string." } +{ $examples + { $example "USING: io.pathnames prettyprint ;" "\"/usr/bin/gcc\" file-name ." "\"gcc\"" } + { $example "USING: io.pathnames prettyprint ;" "\"/usr/libexec/awk/\" file-name ." "\"awk\"" } +} ; + +HELP: append-path +{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } +{ $description "Appends " { $snippet "str1" } " and " { $snippet "str2" } " to form a pathname." } ; + +HELP: prepend-path +{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } } +{ $description "Appends " { $snippet "str2" } " and " { $snippet "str1" } " to form a pathname." } ; + +{ append-path prepend-path } related-words + +HELP: absolute-path? +{ $values { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Tests if a pathname is absolute. Examples of absolute pathnames are " { $snippet "/foo/bar" } " on Unix and " { $snippet "c:\\foo\\bar" } " on Windows." } ; + +HELP: windows-absolute-path? +{ $values { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Tests if a pathname is absolute on Windows. Examples of absolute pathnames on Windows are " { $snippet "c:\\foo\\bar" } " and " { $snippet "\\\\?\\c:\\foo\\bar" } " for absolute Unicode pathnames." } ; + +HELP: root-directory? +{ $values { "path" "a pathname string" } { "?" "a boolean" } } +{ $description "Tests if a pathname is a root directory. Examples of root directory pathnames are " { $snippet "/" } " on Unix and " { $snippet "c:\\" } " on Windows." } ; + +{ absolute-path? windows-absolute-path? root-directory? } related-words + +HELP: resource-path +{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } } +{ $description "Resolve a path relative to the Factor source code location." } ; + +HELP: pathname +{ $class-description "Class of path name objects. Path name objects can be created by calling " { $link } "." } ; + +HELP: normalize-path +{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } } +{ $description "Called by words such as " { $link } " and " { $link } " to prepare a pathname before passing it to underlying code." } ; + +HELP: ( str -- pathname ) +{ $values { "str" "a pathname string" } { "pathname" pathname } } +{ $description "Creates a new " { $link pathname } "." } ; + +HELP: home +{ $values { "dir" string } } +{ $description "Outputs the user's home directory." } ; + +ARTICLE: "io.pathnames" "Pathname manipulation" +"Pathname manipulation:" +{ $subsection parent-directory } +{ $subsection file-name } +{ $subsection last-path-separator } +{ $subsection append-path } +"Pathname presentations:" +{ $subsection pathname } +{ $subsection } ; + +ABOUT: "io.pathnames" diff --git a/core/io/pathnames/pathnames-tests.factor b/core/io/pathnames/pathnames-tests.factor new file mode 100644 index 0000000000..41498fa15a --- /dev/null +++ b/core/io/pathnames/pathnames-tests.factor @@ -0,0 +1,68 @@ +USING: io.pathnames io.files.temp io.directories +continuations math io.files.private kernel +namespaces tools.test ; +IN: io.pathnames.tests + +[ "passwd" ] [ "/etc/passwd" file-name ] unit-test +[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test +[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test +[ "" ] [ "" file-name ] unit-test + +[ "freetype6.dll" ] [ "resource:freetype6.dll" file-name ] unit-test +[ "freetype6.dll" ] [ "resource:/freetype6.dll" file-name ] unit-test + +[ "/usr/lib" ] [ "/usr" "lib" append-path ] unit-test +[ "/usr/lib" ] [ "/usr/" "lib" append-path ] unit-test +[ "/usr/lib" ] [ "/usr" "./lib" append-path ] unit-test +[ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test +[ "/lib" ] [ "/usr" "../lib" append-path ] unit-test +[ "/lib/" ] [ "/usr" "../lib/" append-path ] unit-test + +[ "" ] [ "" "." append-path ] unit-test +[ "" ".." append-path ] must-fail + +[ "/" ] [ "/" "./." append-path ] unit-test +[ "/" ] [ "/" "././" append-path ] unit-test +[ "/a/b/lib" ] [ "/a/b/c/d/e/f/" "../../../../lib" append-path ] unit-test +[ "/a/b/lib/" ] [ "/a/b/c/d/e/f/" "../../../../lib/" append-path ] unit-test + +[ "" "../lib/" append-path ] must-fail +[ "lib" ] [ "" "lib" append-path ] unit-test +[ "lib" ] [ "" "./lib" append-path ] unit-test + +[ "foo/bar/." parent-directory ] must-fail +[ "foo/bar/./" parent-directory ] must-fail +[ "foo/bar/baz/.." parent-directory ] must-fail +[ "foo/bar/baz/../" parent-directory ] must-fail + +[ "." parent-directory ] must-fail +[ "./" parent-directory ] must-fail +[ ".." parent-directory ] must-fail +[ "../" parent-directory ] must-fail +[ "../../" parent-directory ] must-fail +[ "foo/.." parent-directory ] must-fail +[ "foo/../" parent-directory ] must-fail +[ "" parent-directory ] must-fail +[ "." ] [ "boot.x86.64.image" parent-directory ] unit-test + +[ "bar/foo" ] [ "bar/baz" "..///foo" append-path ] unit-test +[ "bar/baz/foo" ] [ "bar/baz" ".///foo" append-path ] unit-test +[ "bar/foo" ] [ "bar/baz" "./..//foo" append-path ] unit-test +[ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test + +[ t ] [ "resource:core" absolute-path? ] unit-test +[ f ] [ "" absolute-path? ] unit-test + +[ "touch-twice-test" temp-file delete-file ] ignore-errors +[ ] [ 2 [ "touch-twice-test" temp-file touch-file ] times ] unit-test + +! aum's bug +[ + "." current-directory set + ".." "resource-path" set + [ "../core/bootstrap/stage2.factor" ] + [ "resource:core/bootstrap/stage2.factor" (normalize-path) ] + unit-test +] with-scope + +[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor new file mode 100644 index 0000000000..e81d8c2bfd --- /dev/null +++ b/core/io/pathnames/pathnames.factor @@ -0,0 +1,143 @@ +! Copyright (C) 2004, 2008 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators io.backend kernel math math.order +namespaces sequences splitting strings system ; +IN: io.pathnames + +SYMBOL: current-directory + +: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ; + +: path-separator ( -- string ) os windows? "\\" "/" ? ; + +: trim-right-separators ( str -- newstr ) + [ path-separator? ] trim-right ; + +: trim-left-separators ( str -- newstr ) + [ path-separator? ] trim-left ; + +: last-path-separator ( path -- n ? ) + [ length 1- ] keep [ path-separator? ] find-last-from ; + +HOOK: root-directory? io-backend ( path -- ? ) + +M: object root-directory? ( path -- ? ) + [ f ] [ [ path-separator? ] all? ] if-empty ; + +ERROR: no-parent-directory path ; + +: parent-directory ( path -- parent ) + dup root-directory? [ + trim-right-separators + dup last-path-separator [ + 1+ cut + ] [ + drop "." swap + ] if + { "" "." ".." } member? [ + no-parent-directory + ] when + ] unless ; + + + +: windows-absolute-path? ( path -- path ? ) + { + { [ dup "\\\\?\\" head? ] [ t ] } + { [ dup length 2 < ] [ f ] } + { [ dup second CHAR: : = ] [ t ] } + [ f ] + } cond ; + +: absolute-path? ( path -- ? ) + { + { [ dup empty? ] [ f ] } + { [ dup "resource:" head? ] [ t ] } + { [ os windows? ] [ windows-absolute-path? ] } + { [ dup first path-separator? ] [ t ] } + [ f ] + } cond nip ; + +: append-path ( str1 str2 -- str ) + { + { [ over empty? ] [ append-path-empty ] } + { [ dup empty? ] [ drop ] } + { [ over trim-right-separators "." = ] [ nip ] } + { [ dup absolute-path? ] [ nip ] } + { [ dup head.? ] [ rest trim-left-separators append-path ] } + { [ dup head..? ] [ + 2 tail trim-left-separators + [ parent-directory ] dip append-path + ] } + { [ over absolute-path? over first path-separator? and ] [ + [ 2 head ] dip append + ] } + [ + [ trim-right-separators "/" ] dip + trim-left-separators 3append + ] + } cond ; + +: prepend-path ( str1 str2 -- str ) + swap append-path ; inline + +: file-name ( path -- string ) + dup root-directory? [ + trim-right-separators + dup last-path-separator [ 1+ tail ] [ + drop "resource:" ?head [ file-name ] when + ] if + ] unless ; + +: file-extension ( filename -- extension ) + "." split1-last nip ; + +: resource-path ( path -- newpath ) + "resource-path" get prepend-path ; + +GENERIC: (normalize-path) ( path -- path' ) + +M: string (normalize-path) + "resource:" ?head [ + trim-left-separators resource-path + (normalize-path) + ] [ + current-directory get prepend-path + ] if ; + +M: object normalize-path ( path -- path' ) + (normalize-path) ; + +TUPLE: pathname string ; + +C: pathname + +M: pathname (normalize-path) string>> (normalize-path) ; + +M: pathname <=> [ string>> ] compare ; + +HOOK: home io-backend ( -- dir ) + +M: object home "" resource-path ; \ No newline at end of file diff --git a/core/io/pathnames/summary.txt b/core/io/pathnames/summary.txt new file mode 100644 index 0000000000..de19eed0d1 --- /dev/null +++ b/core/io/pathnames/summary.txt @@ -0,0 +1 @@ +Pathname manipulation diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor index 4a3d94a172..3dde9152d0 100644 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test io.files io io.streams.c +USING: tools.test io.files io.files.temp io io.streams.c io.encodings.ascii strings ; IN: io.streams.c.tests diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index cc97b78eb6..6ddf299f7f 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -1,8 +1,8 @@ USING: arrays math parser tools.test kernel generic words -io.streams.string namespaces classes effects source-files -assocs sequences strings io.files definitions continuations -sorting classes.tuple compiler.units debugger vocabs -vocabs.loader accessors eval combinators lexer ; +io.streams.string namespaces classes effects source-files assocs +sequences strings io.files io.pathnames definitions +continuations sorting classes.tuple compiler.units debugger +vocabs vocabs.loader accessors eval combinators lexer ; IN: parser.tests \ run-file must-infer diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor index 89ffbfd795..2c9e2172cc 100644 --- a/core/source-files/source-files-docs.factor +++ b/core/source-files/source-files-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax vocabs.loader io.files strings +USING: help.markup help.syntax vocabs.loader io.pathnames strings definitions quotations compiler.units ; IN: source-files diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 3ae50a9a15..7ecc967e9e 100644 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic assocs kernel math namespaces -sequences strings vectors words quotations io -combinators sorting splitting math.parser effects continuations -io.files checksums checksums.crc32 vocabs hashtables graphs +sequences strings vectors words quotations io io.files +io.pathnames combinators sorting splitting math.parser effects +continuations checksums checksums.crc32 vocabs hashtables graphs compiler.units io.encodings.utf8 accessors ; IN: source-files diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 2b7de36d56..7a1cb5fd92 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -1,6 +1,6 @@ USING: generic help.syntax help.markup kernel math parser words effects classes generic.standard classes.tuple generic.math -generic.standard arrays io.files vocabs.loader io sequences +generic.standard arrays io.pathnames vocabs.loader io sequences assocs ; IN: syntax @@ -144,7 +144,7 @@ ARTICLE: "syntax-byte-arrays" "Byte array syntax" ARTICLE: "syntax-pathnames" "Pathname syntax" { $subsection POSTPONE: P" } -"Pathnames are documented in " { $link "pathnames" } "." ; +"Pathnames are documented in " { $link "io.pathnames" } "." ; ARTICLE: "syntax-literals" "Literals" "Many different types of objects can be constructed at parse time via literal syntax. Numbers are a special case since support for reading them is built-in to the parser. All other literals are constructed via parsing words." diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 0b7d9d008f..7d76bdd10b 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -4,7 +4,7 @@ USING: accessors alien arrays byte-arrays definitions generic hashtables kernel math namespaces parser lexer sequences strings strings.parser sbufs vectors words quotations io assocs splitting classes.tuple generic.standard generic.math -generic.parser classes io.files vocabs classes.parser +generic.parser classes io.pathnames vocabs classes.parser classes.union classes.intersection classes.mixin classes.predicate classes.singleton classes.tuple.parser compiler.units combinators effects.parser slots ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 97fbfe8a07..53f8fbadf6 100644 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces make sequences io.files kernel assocs words -vocabs definitions parser continuations io hashtables sorting -source-files arrays combinators strings system math.parser -compiler.errors splitting init accessors sets ; +USING: namespaces make sequences io io.files io.pathnames kernel +assocs words vocabs definitions parser continuations hashtables +sorting source-files arrays combinators strings system +math.parser compiler.errors splitting init accessors sets ; IN: vocabs.loader SYMBOL: vocab-roots diff --git a/extra/benchmark/mandel/mandel.factor b/extra/benchmark/mandel/mandel.factor index 64a673c8ec..c501c35c6a 100755 --- a/extra/benchmark/mandel/mandel.factor +++ b/extra/benchmark/mandel/mandel.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io kernel math math.functions sequences prettyprint -io.files io.encodings io.encodings.ascii io.encodings.binary fry -benchmark.mandel.params benchmark.mandel.colors ; +io.files io.files.temp io.encodings io.encodings.ascii +io.encodings.binary fry benchmark.mandel.params +benchmark.mandel.colors ; IN: benchmark.mandel : x-inc width 200000 zoom-fact * / ; inline diff --git a/extra/benchmark/random/random.factor b/extra/benchmark/random/random.factor index 985c9a59b2..d2eb4cdab5 100755 --- a/extra/benchmark/random/random.factor +++ b/extra/benchmark/random/random.factor @@ -1,4 +1,5 @@ -USING: io.files io.encodings.ascii random math.parser io math ; +USING: io io.files io.files.temp io.encodings.ascii random +math.parser math ; IN: benchmark.random : random-numbers-path ( -- path ) diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index 7fe46e9c36..c16e47846e 100755 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -2,8 +2,9 @@ ! http://www.ffconsultancy.com/free/ray_tracer/languages.html USING: arrays accessors specialized-arrays.double io io.files -io.encodings.binary kernel math math.functions math.vectors -math.parser make sequences sequences.private words hints ; +io.files.temp io.encodings.binary kernel math math.functions +math.vectors math.parser make sequences sequences.private words +hints ; IN: benchmark.raytracer ! parameters diff --git a/extra/benchmark/reverse-complement/reverse-complement.factor b/extra/benchmark/reverse-complement/reverse-complement.factor index 665cbba30d..3298706da3 100755 --- a/extra/benchmark/reverse-complement/reverse-complement.factor +++ b/extra/benchmark/reverse-complement/reverse-complement.factor @@ -1,6 +1,8 @@ -USING: io io.files io.streams.duplex kernel sequences -sequences.private strings vectors words memoize splitting -grouping hints tr continuations io.encodings.ascii +! Copyright (C) 2006, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io io.files io.files.temp io.streams.duplex kernel +sequences sequences.private strings vectors words memoize +splitting grouping hints tr continuations io.encodings.ascii unicode.case ; IN: benchmark.reverse-complement diff --git a/extra/benchmark/xml/xml.factor b/extra/benchmark/xml/xml.factor index a61293cd99..a32a98a133 100644 --- a/extra/benchmark/xml/xml.factor +++ b/extra/benchmark/xml/xml.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.encodings.utf8 io.files kernel sequences xml ; +USING: io.encodings.utf8 io.directories io.files kernel +sequences xml ; IN: benchmark.xml : xml-benchmark ( -- ) diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 9dddd0d8cd..3e00191108 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -1,6 +1,6 @@ USING: accessors alien.c-types arrays combinators destructors -http.client io io.encodings.ascii io.files kernel math -math.matrices math.parser math.vectors opengl +http.client io io.encodings.ascii io.files io.files.temp kernel +math math.matrices math.parser math.vectors opengl opengl.capabilities opengl.gl opengl.demo-support sequences splitting vectors words specialized-arrays.float specialized-arrays.uint ; diff --git a/extra/contributors/contributors.factor b/extra/contributors/contributors.factor index 4d6479db91..1879c52826 100755 --- a/extra/contributors/contributors.factor +++ b/extra/contributors/contributors.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files io.launcher io.styles io.encodings.ascii -prettyprint io hashtables kernel sequences assocs system sorting -math.parser sets ; +USING: io.files io.launcher io.directories io.pathnames +io.encodings.ascii io prettyprint hashtables kernel sequences +assocs system sorting math.parser sets ; IN: contributors : changelog ( -- authors ) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 6c86889040..2de80de4a4 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -2,10 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays classes classes.tuple compiler.units -combinators continuations debugger definitions eval help -io io.files io.streams.string kernel lexer listener listener.private -make math namespaces parser prettyprint prettyprint.config -quotations sequences strings source-files vectors vocabs vocabs.loader ; +combinators continuations debugger definitions eval help io +io.files io.pathnames io.streams.string kernel lexer listener +listener.private make math namespaces parser prettyprint +prettyprint.config quotations sequences strings source-files +tools.vocabs vectors vocabs vocabs.loader ; IN: fuel @@ -156,12 +157,10 @@ M: source-file fuel-pprint path>> fuel-pprint ; ] when* ; : fuel-get-vocab-location ( vocab -- ) - vocab-source-path [ - (normalize-path) 1 2array fuel-eval-set-result - ] when* ; + >vocab-link fuel-get-edit-location ; : fuel-get-vocabs ( -- ) - vocabs fuel-eval-set-result ; inline + all-vocabs-seq [ vocab-name ] map fuel-eval-set-result ; inline : fuel-run-file ( path -- ) run-file ; inline diff --git a/extra/geo-ip/geo-ip.factor b/extra/geo-ip/geo-ip.factor index aee53f24f5..c878306d7d 100644 --- a/extra/geo-ip/geo-ip.factor +++ b/extra/geo-ip/geo-ip.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences io.files io.launcher io.encodings.ascii -io.streams.string http.client generalizations combinators -math.parser math.vectors math.intervals interval-maps memoize -csv accessors assocs strings math splitting grouping arrays ; +USING: kernel sequences io.files io.files.temp io.launcher +io.pathnames io.encodings.ascii io.streams.string http.client +generalizations combinators math.parser math.vectors +math.intervals interval-maps memoize csv accessors assocs +strings math splitting grouping arrays ; IN: geo-ip : db-path ( -- path ) "IpToCountry.csv" temp-file ; diff --git a/extra/irc/ui/load/load.factor b/extra/irc/ui/load/load.factor index e6f4d07b56..6048d93711 100755 --- a/extra/irc/ui/load/load.factor +++ b/extra/irc/ui/load/load.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 William Schlieper ! See http://factorcode.org/license.txt for BSD license. -USING: kernel io.files parser editors sequences ; +USING: kernel io.files io.pathnames parser editors sequences ; IN: irc.ui.load diff --git a/extra/log-viewer/log-viewer.factor b/extra/log-viewer/log-viewer.factor index 7bc63d3e34..263454f769 100755 --- a/extra/log-viewer/log-viewer.factor +++ b/extra/log-viewer/log-viewer.factor @@ -1,4 +1,4 @@ -USING: kernel io io.files io.monitors io.encodings.utf8 ; +USING: kernel io io.files io.pathnames io.monitors io.encodings.utf8 ; IN: log-viewer : read-lines ( stream -- ) diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor index 35070d8902..4d705610b4 100644 --- a/extra/mason/build/build.factor +++ b/extra/mason/build/build.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files io.launcher io.encodings.utf8 prettyprint arrays -calendar namespaces mason.common mason.child -mason.release mason.report mason.email mason.cleanup -mason.help ; +USING: arrays calendar io.directories io.encodings.utf8 +io.files io.launcher mason.child mason.cleanup mason.common +mason.email mason.help mason.release mason.report namespaces +prettyprint ; IN: mason.build : create-build-dir ( -- ) diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor index 0c9669ed5a..5a3a0d6ceb 100644 --- a/extra/mason/child/child.factor +++ b/extra/mason/child/child.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces make debugger sequences io.files -io.launcher arrays accessors calendar continuations -combinators.short-circuit mason.common mason.report -mason.platform mason.config http.client ; +USING: accessors arrays calendar combinators.short-circuit +continuations debugger http.client io.directories io.files +io.launcher io.pathnames kernel make mason.common mason.config +mason.platform mason.report namespaces sequences ; IN: mason.child : make-cmd ( -- args ) diff --git a/extra/mason/cleanup/cleanup.factor b/extra/mason/cleanup/cleanup.factor index ae24f533d6..a2c087392a 100644 --- a/extra/mason/cleanup/cleanup.factor +++ b/extra/mason/cleanup/cleanup.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces arrays continuations io.files io.launcher -mason.common mason.platform mason.config ; +USING: arrays continuations io.directories +io.directories.hierarchy io.files io.launcher kernel +mason.common mason.config mason.platform namespaces ; IN: mason.cleanup : compress-image ( -- ) diff --git a/extra/mason/common/common-tests.factor b/extra/mason/common/common-tests.factor index ed6ffecdd1..095cbd1a80 100644 --- a/extra/mason/common/common-tests.factor +++ b/extra/mason/common/common-tests.factor @@ -1,6 +1,6 @@ IN: mason.common.tests USING: prettyprint mason.common mason.config -namespaces calendar tools.test io.files io.encodings.utf8 ; +namespaces calendar tools.test io.files io.files.temp io.encodings.utf8 ; [ "00:01:01" ] [ 61000 milli-seconds>time ] unit-test diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index 49f280fa84..ec0cbdbc9c 100644 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces sequences splitting system accessors -math.functions make io io.files io.launcher io.encodings.utf8 -prettyprint combinators.short-circuit parser combinators -calendar calendar.format arrays mason.config locals ; +math.functions make io io.files io.pathnames io.directories +io.launcher io.encodings.utf8 prettyprint +combinators.short-circuit parser combinators calendar +calendar.format arrays mason.config locals ; IN: mason.common : short-running-process ( command -- ) diff --git a/extra/mason/config/config.factor b/extra/mason/config/config.factor index 9169fbf196..b1739d85fa 100644 --- a/extra/mason/config/config.factor +++ b/extra/mason/config/config.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: system io.files namespaces kernel accessors assocs ; +USING: system io.files io.pathnames namespaces kernel accessors +assocs ; IN: mason.config ! (Optional) Location for build directories diff --git a/extra/mason/help/help.factor b/extra/mason/help/help.factor index c9ca50f0c2..9a4e2be996 100644 --- a/extra/mason/help/help.factor +++ b/extra/mason/help/help.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: help.html sequences io.files io.launcher make namespaces -kernel arrays mason.common mason.config ; +USING: arrays help.html io.directories io.files io.launcher +kernel make mason.common mason.config namespaces sequences ; IN: mason.help : make-help-archive ( -- ) diff --git a/extra/mason/mason.factor b/extra/mason/mason.factor index 4f9c8f65d3..299a2f4e1f 100644 --- a/extra/mason/mason.factor +++ b/extra/mason/mason.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel debugger io io.files threads debugger continuations -namespaces accessors calendar mason.common mason.updates -mason.build mason.email ; +USING: accessors calendar continuations debugger debugger io +io.directories io.files kernel mason.build mason.common +mason.email mason.updates namespaces threads ; IN: mason : build-loop-error ( error -- ) diff --git a/extra/mason/release/archive/archive.factor b/extra/mason/release/archive/archive.factor index e76979d885..5ef424ad4f 100644 --- a/extra/mason/release/archive/archive.factor +++ b/extra/mason/release/archive/archive.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel combinators sequences make namespaces io.files -io.launcher prettyprint arrays -mason.common mason.platform mason.config ; +USING: arrays combinators io.directories +io.directories.hierarchy io.files io.launcher io.pathnames +kernel make mason.common mason.config mason.platform namespaces +prettyprint sequences ; IN: mason.release.archive : base-name ( -- string ) diff --git a/extra/mason/release/branch/branch.factor b/extra/mason/release/branch/branch.factor index 600b08c6b6..75ce828c28 100644 --- a/extra/mason/release/branch/branch.factor +++ b/extra/mason/release/branch/branch.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces sequences prettyprint io.files -io.launcher make mason.common mason.platform mason.config ; +USING: io.directories io.files io.launcher kernel make +mason.common mason.config mason.platform namespaces prettyprint +sequences ; IN: mason.release.branch : branch-name ( -- string ) "clean-" platform append ; diff --git a/extra/mason/release/tidy/tidy.factor b/extra/mason/release/tidy/tidy.factor index fb931650d4..58046ce64c 100644 --- a/extra/mason/release/tidy/tidy.factor +++ b/extra/mason/release/tidy/tidy.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces continuations debugger sequences fry -io.files io.launcher bootstrap.image qualified mason.common -mason.config ; +USING: bootstrap.image continuations debugger fry +io.directories io.directories.hierarchy io.files io.launcher +kernel mason.common namespaces qualified sequences ; FROM: mason.config => target-os ; IN: mason.release.tidy diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index b23ad19e5e..a15a96c63e 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces assocs io.files io.encodings.utf8 -prettyprint help.lint benchmark tools.time bootstrap.stage2 -tools.test tools.vocabs help.html mason.common words generic -accessors compiler.errors sequences sets sorting math ; +USING: accessors assocs benchmark bootstrap.stage2 +compiler.errors generic help.html help.lint io.directories +io.encodings.utf8 io.files kernel mason.common math namespaces +prettyprint sequences sets sorting tools.test tools.time +tools.vocabs words ; IN: mason.test : do-load ( -- ) diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 027e8fe50f..f9fa0f4f18 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: definitions io io.files kernel math math.parser +USING: definitions io io.files io.pathnames kernel math math.parser prettyprint project-euler.ave-time sequences vocabs vocabs.loader project-euler.001 project-euler.002 project-euler.003 project-euler.004 project-euler.005 project-euler.006 project-euler.007 project-euler.008 diff --git a/extra/shell/shell.factor b/extra/shell/shell.factor index ae9b94ba0e..d6c98ea203 100644 --- a/extra/shell/shell.factor +++ b/extra/shell/shell.factor @@ -1,10 +1,8 @@ - USING: kernel parser words continuations namespaces debugger - sequences combinators splitting prettyprint - system io io.files io.launcher io.encodings.utf8 io.pipes sequences.deep - accessors multi-methods newfx shell.parser - combinators.short-circuit eval environment ; - +sequences combinators splitting prettyprint system io io.files +io.pathnames io.launcher io.directories io.encodings.utf8 io.pipes +sequences.deep accessors multi-methods newfx shell.parser +combinators.short-circuit eval environment ; IN: shell ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/system-info/linux/linux.factor b/extra/system-info/linux/linux.factor index d7f53fb9fb..d9c39ca6cf 100644 --- a/extra/system-info/linux/linux.factor +++ b/extra/system-info/linux/linux.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: unix alien alien.c-types kernel math sequences strings -io.unix.backend splitting ; +io.backend.unix splitting ; IN: system-info.linux : (uname) ( buf -- int ) diff --git a/extra/system-info/macosx/macosx.factor b/extra/system-info/macosx/macosx.factor index a06c01b950..b51fd52995 100644 --- a/extra/system-info/macosx/macosx.factor +++ b/extra/system-info/macosx/macosx.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings alien.syntax byte-arrays kernel namespaces sequences unix -system-info.backend system io.unix.backend io.encodings.utf8 ; +system-info.backend system io.encodings.utf8 ; IN: system-info.macosx ! See /usr/include/sys/sysctl.h for constants diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index e3c14854d3..132e401f16 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -1,6 +1,7 @@ -USING: combinators io io.files io.streams.string kernel math -math.parser continuations namespaces pack prettyprint sequences -strings system tools.hexdump io.encodings.binary summary accessors +USING: combinators io io.files io.files.links io.directories +io.pathnames io.streams.string kernel math math.parser +continuations namespaces pack prettyprint sequences strings +system tools.hexdump io.encodings.binary summary accessors io.backend symbols byte-arrays ; IN: tar diff --git a/extra/update/backup/backup.factor b/extra/update/backup/backup.factor index 0c7b442ffa..7728003189 100644 --- a/extra/update/backup/backup.factor +++ b/extra/update/backup/backup.factor @@ -1,6 +1,5 @@ - -USING: namespaces debugger io.files bootstrap.image update.util ; - +USING: namespaces debugger io.files io.directories +bootstrap.image update.util ; IN: update.backup : backup-boot-image ( -- ) diff --git a/extra/update/latest/latest.factor b/extra/update/latest/latest.factor index 9546379223..98d264d227 100644 --- a/extra/update/latest/latest.factor +++ b/extra/update/latest/latest.factor @@ -1,7 +1,5 @@ - -USING: kernel namespaces system io.files bootstrap.image http.client - update update.backup update.util ; - +USING: kernel namespaces system io.files io.pathnames io.directories +bootstrap.image http.client update update.backup update.util ; IN: update.latest ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/update/update.factor b/extra/update/update.factor index c6a5671345..ba09cc3f3d 100644 --- a/extra/update/update.factor +++ b/extra/update/update.factor @@ -1,10 +1,5 @@ - -USING: kernel system sequences io.files io.launcher bootstrap.image - http.client - update.util ; - - ! builder.util builder.release.branch ; - +USING: kernel system sequences io.files io.directories +io.pathnames io.launcher bootstrap.image http.client update.util ; IN: update ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/vpri-talk/vpri-talk.factor b/extra/vpri-talk/vpri-talk.factor index 131b569a92..35d8bb52ff 100644 --- a/extra/vpri-talk/vpri-talk.factor +++ b/extra/vpri-talk/vpri-talk.factor @@ -80,19 +80,19 @@ IN: vpri-talk { $slide "Object system" "New operation, existing types:" { $code - "GENERIC: perimiter ( shape -- n )" + "GENERIC: perimeter ( shape -- n )" "" - "M: rectangle perimiter" + "M: rectangle perimeter" " [ width>> ] [ height>> ] bi + 2 * ;" "" - "M: circle perimiter" + "M: circle perimeter" " radius>> 2 * pi * ;" } } { $slide "Object system" "We can compute perimiters now." - { $code "100 20 perimiter ." } - { $code "3 perimiter ." } + { $code "100 20 perimeter ." } + { $code "3 perimeter ." } } { $slide "Object system" "New type, extending existing operations:" @@ -110,7 +110,7 @@ IN: vpri-talk { $code ": hypotenuse ( x y -- z ) [ sq ] bi@ + sqrt ;" "" - "M: triangle perimiter" + "M: triangle perimeter" " [ base>> ] [ height>> ] bi" " [ + ] [ hypotenuse ] 2bi + ;" } @@ -151,10 +151,10 @@ IN: vpri-talk "Libraries can define new parsing words" } { $slide "Example: float arrays" - { $vocab-link "float-arrays" } + { $vocab-link "specialized-arrays.float" } "Avoids boxing and unboxing overhead" "Implemented with library code" - { $code "F{ 3.14 7.6 10.3 }" } + { $code "float-array{ 3.14 7.6 10.3 }" } } { $slide "Example: memoization" { "Memoization with " { $link POSTPONE: MEMO: } } diff --git a/extra/webapps/help/help.factor b/extra/webapps/help/help.factor index 96401b6afd..1c17e3214f 100644 --- a/extra/webapps/help/help.factor +++ b/extra/webapps/help/help.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors http.server.dispatchers http.server.static furnace.actions furnace.redirection urls -validators locals io.files html.forms html.components help.html ; +validators locals io.files io.directories html.forms +html.components help.html ; IN: webapps.help TUPLE: help-webapp < dispatcher ; diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index f2c0600ed5..07fbbe0596 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel hashtables calendar random assocs namespaces make splitting sequences sorting math.order present -io.files io.encodings.ascii +io.files io.directories io.encodings.ascii syndication farkup html.components html.forms http.server diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index d7fdfa2460..302967969f 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences assocs io.files io.sockets -io.sockets.secure io.servers.connection +USING: accessors kernel sequences assocs io.files io.pathnames +io.sockets io.sockets.secure io.servers.connection namespaces db db.tuples db.sqlite smtp urls logging.insomniac html.templates.chloe diff --git a/misc/fuel/fuel-connection.el b/misc/fuel/fuel-connection.el index b72e6843bf..168501171e 100644 --- a/misc/fuel/fuel-connection.el +++ b/misc/fuel/fuel-connection.el @@ -14,6 +14,9 @@ ;;; Code: +(require 'fuel-base) +(require 'fuel-log) + ;;; Default connection: @@ -122,49 +125,6 @@ (add-hook 'comint-redirect-hook 'fuel-con--comint-redirect-hook)) - -;;; Logging: - -(defvar fuel-con--log-size 32000 - "Maximum size of the Factor messages log.") - -(defvar fuel-con--log-verbose-p t - "Log level for Factor messages.") - -(define-derived-mode factor-messages-mode fundamental-mode "Factor Messages" - "Simple mode to log interactions with the factor listener" - (kill-all-local-variables) - (buffer-disable-undo) - (set (make-local-variable 'comint-redirect-subvert-readonly) t) - (add-hook 'after-change-functions - '(lambda (b e len) - (let ((inhibit-read-only t)) - (when (> b fuel-con--log-size) - (delete-region (point-min) b)))) - nil t) - (setq buffer-read-only t)) - -(defun fuel-con--log-buffer () - (or (get-buffer "*factor messages*") - (save-current-buffer - (set-buffer (get-buffer-create "*factor messages*")) - (factor-messages-mode) - (current-buffer)))) - -(defun fuel-con--log-msg (type &rest args) - (with-current-buffer (fuel-con--log-buffer) - (let ((inhibit-read-only t)) - (insert (format "\n%s: %s\n" type (apply 'format args)))))) - -(defsubst fuel-con--log-warn (&rest args) - (apply 'fuel-con--log-msg 'WARNING args)) - -(defsubst fuel-con--log-error (&rest args) - (apply 'fuel-con--log-msg 'ERROR args)) - -(defsubst fuel-con--log-info (&rest args) - (if fuel-con--log-verbose-p (apply 'fuel-con--log-msg 'INFO args) "")) - ;;; Requests handling: @@ -175,11 +135,11 @@ (str (and req (fuel-con--request-string req)))) (when (and buffer req str) (set-buffer buffer) - (when fuel-con--log-verbose-p - (with-current-buffer (fuel-con--log-buffer) + (when fuel-log--verbose-p + (with-current-buffer (fuel-log--buffer) (let ((inhibit-read-only t)) - (fuel-con--log-info "<%s>: %s" (fuel-con--request-id req) str)))) - (comint-redirect-send-command str (fuel-con--log-buffer) nil t))))) + (fuel-log--info "<%s>: %s" (fuel-con--request-id req) str)))) + (comint-redirect-send-command str (fuel-log--buffer) nil t))))) (defun fuel-con--process-completed-request (req) (let ((str (fuel-con--request-output req)) @@ -188,29 +148,29 @@ (rstr (fuel-con--request-string req)) (buffer (fuel-con--request-buffer req))) (if (not cont) - (fuel-con--log-warn "<%s> Droping result for request %S (%s)" + (fuel-log--warn "<%s> Droping result for request %S (%s)" id rstr str) (condition-case cerr (with-current-buffer (or buffer (current-buffer)) (funcall cont str) - (fuel-con--log-info "<%s>: processed\n\t%s" id str)) - (error (fuel-con--log-error "<%s>: continuation failed %S \n\t%s" + (fuel-log--info "<%s>: processed\n\t%s" id str)) + (error (fuel-log--error "<%s>: continuation failed %S \n\t%s" id rstr cerr)))))) (defun fuel-con--comint-redirect-filter (str) (if (not fuel-con--connection) - (fuel-con--log-error "No connection in buffer (%s)" str) + (fuel-log--error "No connection in buffer (%s)" str) (let ((req (fuel-con--connection-current-request fuel-con--connection))) - (if (not req) (fuel-con--log-error "No current request (%s)" str) + (if (not req) (fuel-log--error "No current request (%s)" str) (fuel-con--request-output req str) - (fuel-con--log-info "<%s>: in progress" (fuel-con--request-id req))))) - ".\n") + (fuel-log--info "<%s>: in progress" (fuel-con--request-id req))))) + ".") (defun fuel-con--comint-redirect-hook () (if (not fuel-con--connection) - (fuel-con--log-error "No connection in buffer") + (fuel-log--error "No connection in buffer") (let ((req (fuel-con--connection-current-request fuel-con--connection))) - (if (not req) (fuel-con--log-error "No current request (%s)" str) + (if (not req) (fuel-log--error "No current request (%s)" str) (fuel-con--process-completed-request req) (fuel-con--connection-clean-current-request fuel-con--connection))))) diff --git a/misc/fuel/fuel-debug.el b/misc/fuel/fuel-debug.el index a7c06e4b3e..d34b31903e 100644 --- a/misc/fuel/fuel-debug.el +++ b/misc/fuel/fuel-debug.el @@ -214,7 +214,7 @@ (buffer (if file (find-file-noselect file) (current-buffer)))) (with-current-buffer buffer (fuel-debug--display-retort - (fuel-eval--send/wait (fuel-eval--cmd/string (format ":%s" n))) + (fuel-eval--send/wait `(:fuel ((:factor ,(format ":%s" n))))) (format "Restart %s (%s) successful" n (nth (1- n) rs)))))))) (defun fuel-debug-show--compiler-info (info) @@ -224,7 +224,7 @@ (error "%s information not available" info)) (message "Retrieving %s info ..." info) (unless (fuel-debug--display-retort - (fuel-eval--send/wait (fuel-eval--cmd/string info)) + (fuel-eval--send/wait `(:fuel ((:factor ,info)))) "" (fuel-debug--buffer-file)) (error "Sorry, no %s info available" info)))) diff --git a/misc/fuel/fuel-eval.el b/misc/fuel/fuel-eval.el index 02bcb54d66..07c2ca3445 100644 --- a/misc/fuel/fuel-eval.el +++ b/misc/fuel/fuel-eval.el @@ -17,6 +17,93 @@ (require 'fuel-syntax) (require 'fuel-connection) + +;;; Simple sexp-based representation of factor code + +(defun factor (sexp) + (cond ((null sexp) "f") + ((eq sexp t) "t") + ((or (stringp sexp) (numberp sexp)) (format "%S" sexp)) + ((vectorp sexp) (cons :quotation (append sexp nil))) + ((listp sexp) + (case (car sexp) + (:array (factor--seq 'V{ '} (cdr sexp))) + (:quote (format "\\ %s" (factor `(:factor ,(cadr sexp))))) + (:quotation (factor--seq '\[ '\] (cdr sexp))) + (:factor (format "%s" (mapconcat 'identity (cdr sexp) " "))) + (:fuel (factor--fuel-factor (cons :rs (cdr sexp)))) + (:fuel* (factor--fuel-factor (cons :nrs (cdr sexp)))) + (t (mapconcat 'factor sexp " ")))) + ((keywordp sexp) + (factor (case sexp + (:rs 'fuel-eval-restartable) + (:nrs 'fuel-eval-non-restartable) + (:in (fuel-syntax--current-vocab)) + (:usings `(:array ,@(fuel-syntax--usings-update))) + (:get 'fuel-eval-set-result) + (t `(:factor ,(symbol-name sexp)))))) + ((symbolp sexp) (symbol-name sexp)))) + +(defsubst factor--seq (begin end forms) + (format "%s %s %s" begin (if forms (factor forms) "") end)) + +(defsubst factor--fuel-factor (sexp) + (factor `(,(factor--fuel-restart (nth 0 sexp)) + ,(factor--fuel-lines (nth 1 sexp)) + ,(factor--fuel-in (nth 2 sexp)) + ,(factor--fuel-usings (nth 3 sexp)) + fuel-eval-in-context))) + +(defsubst factor--fuel-restart (rs) + (unless (member rs '(:rs :nrs)) + (error "Invalid restart spec (%s)" rs)) + rs) + +(defsubst factor--fuel-lines (lst) + (cons :array (mapcar 'factor lst))) + +(defsubst factor--fuel-in (in) + (cond ((null in) :in) + ((eq in t) "fuel-scratchpad") + ((stringp in) in) + (t (error "Invalid 'in' (%s)" in)))) + +(defsubst factor--fuel-usings (usings) + (cond ((null usings) :usings) + ((eq usings t) nil) + ((listp usings) `(:array ,@usings)) + (t (error "Invalid 'usings' (%s)" usings)))) + + + +;;; Code sending: + +(defvar fuel-eval--default-proc-function nil) +(defsubst fuel-eval--default-proc () + (and fuel-eval--default-proc-function + (funcall fuel-eval--default-proc-function))) + +(defvar fuel-eval--proc nil) + +(defvar fuel-eval--sync-retort nil) + +(defun fuel-eval--send/wait (code &optional timeout buffer) + (setq fuel-eval--sync-retort nil) + (fuel-con--send-string/wait (or fuel-eval--proc (fuel-eval--default-proc)) + (if (stringp code) code (factor code)) + '(lambda (s) + (setq fuel-eval--sync-retort + (fuel-eval--parse-retort s))) + timeout + buffer) + fuel-eval--sync-retort) + +(defun fuel-eval--send (code cont &optional buffer) + (fuel-con--send-string (or fuel-eval--proc (fuel-eval--default-proc)) + (if (stringp code) code (factor code)) + `(lambda (s) (,cont (fuel-eval--parse-retort s))) + buffer)) + ;;; Retort and retort-error datatypes: @@ -64,69 +151,6 @@ (defsubst fuel-eval--error-line-text (err) (nth 3 (fuel-eval--error-lexer-p err))) - -;;; String sending:: - -(defvar fuel-eval-log-max-length 16000) - -(defvar fuel-eval--default-proc-function nil) -(defsubst fuel-eval--default-proc () - (and fuel-eval--default-proc-function - (funcall fuel-eval--default-proc-function))) - -(defvar fuel-eval--proc nil) - -(defvar fuel-eval--log t) - -(defvar fuel-eval--sync-retort nil) - -(defun fuel-eval--send/wait (str &optional timeout buffer) - (setq fuel-eval--sync-retort nil) - (fuel-con--send-string/wait (or fuel-eval--proc (fuel-eval--default-proc)) - str - '(lambda (s) - (setq fuel-eval--sync-retort - (fuel-eval--parse-retort s))) - timeout - buffer) - fuel-eval--sync-retort) - -(defun fuel-eval--send (str cont &optional buffer) - (fuel-con--send-string (or fuel-eval--proc (fuel-eval--default-proc)) - str - `(lambda (s) (,cont (fuel-eval--parse-retort s))) - buffer)) - - -;;; Evaluation protocol - -(defsubst fuel-eval--factor-array (strs) - (format "V{ %S }" (mapconcat 'identity strs " "))) - -(defun fuel-eval--cmd/lines (strs &optional no-rs in usings) - (unless (and in usings) (fuel-syntax--usings-update)) - (let* ((in (cond ((not in) (or fuel-syntax--current-vocab "f")) - ((eq in t) "fuel-scratchpad") - (in in))) - (usings (cond ((not usings) fuel-syntax--usings) - ((eq usings t) nil) - (usings usings)))) - (format "fuel-eval-%srestartable %s %S %s fuel-eval-in-context" - (if no-rs "non-" "") - (fuel-eval--factor-array strs) - in - (fuel-eval--factor-array usings)))) - -(defsubst fuel-eval--cmd/string (str &optional no-rs in usings) - (fuel-eval--cmd/lines (list str) no-rs in usings)) - -(defun fuel-eval--cmd/region (begin end &optional no-rs in usings) - (let ((lines (split-string (buffer-substring-no-properties begin end) - "[\f\n\r\v]+" t))) - (when (> (length lines) 0) - (fuel-eval--cmd/lines lines no-rs in usings)))) - - (provide 'fuel-eval) ;;; fuel-eval.el ends here diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index 1d39d1571d..d4bf757cd7 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -75,8 +75,7 @@ (let ((word (or word (fuel-syntax-symbol-at-point))) (fuel-eval--log t)) (when word - (let* ((str (format "\\ %s synopsis fuel-eval-set-result" word)) - (cmd (fuel-eval--cmd/string str t t)) + (let* ((cmd `(:fuel* (((:quote ,word) synopsis :get)) t)) (ret (fuel-eval--send/wait cmd 20))) (when (and ret (not (fuel-eval--retort-error ret))) (if fuel-help-minibuffer-font-lock @@ -151,10 +150,9 @@ displayed in the minibuffer." fuel-help-always-ask)) (def (if ask (read-string prompt nil 'fuel-help--prompt-history def) def)) - (cmd (format "\\ %s %s" def (if see "see" "help")))) + (cmd `(:fuel* ((:quote ,def) ,(if see 'see 'help)) t))) (message "Looking up '%s' ..." def) - (fuel-eval--send (fuel-eval--cmd/string cmd t t) - `(lambda (r) (fuel-help--show-help-cont ,def r))))) + (fuel-eval--send cmd `(lambda (r) (fuel-help--show-help-cont ,def r))))) (defun fuel-help--show-help-cont (def ret) (let ((out (fuel-eval--retort-output ret))) diff --git a/misc/fuel/fuel-log.el b/misc/fuel/fuel-log.el new file mode 100644 index 0000000000..ba048a6157 --- /dev/null +++ b/misc/fuel/fuel-log.el @@ -0,0 +1,72 @@ +;;; fuel-log.el -- logging utilities + +;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; See http://factorcode.org/license.txt for BSD license. + +;; Author: Jose Antonio Ortega Ruiz +;; Keywords: languages, fuel, factor +;; Start date: Sun Dec 14, 2008 01:00 + +;;; Comentary: + +;; Some utilities for maintaining a simple log buffer, mainly for +;; debugging purposes. + +;;; Code: + +(require 'fuel-base) + + +;;; Customization: + +(defvar fuel-log--buffer-name "*fuel messages*" + "Name of the log buffer") + +(defvar fuel-log--max-buffer-size 32000 + "Maximum size of the Factor messages log") + +(defvar fuel-log--max-message-size 512 + "Maximum size of individual log messages") + +(defvar fuel-log--verbose-p t + "Log level for Factor messages") + +(define-derived-mode factor-messages-mode fundamental-mode "FUEL Messages" + "Simple mode to log interactions with the factor listener" + (kill-all-local-variables) + (buffer-disable-undo) + (set (make-local-variable 'comint-redirect-subvert-readonly) t) + (add-hook 'after-change-functions + '(lambda (b e len) + (let ((inhibit-read-only t)) + (when (> b fuel-log--max-buffer-size) + (delete-region (point-min) b)))) + nil t) + (setq buffer-read-only t)) + +(defun fuel-log--buffer () + (or (get-buffer fuel-log--buffer-name) + (save-current-buffer + (set-buffer (get-buffer-create fuel-log--buffer-name)) + (factor-messages-mode) + (current-buffer)))) + +(defun fuel-log--msg (type &rest args) + (with-current-buffer (fuel-log--buffer) + (let ((inhibit-read-only t)) + (insert + (fuel--shorten-str (format "\n%s: %s\n" type (apply 'format args)) + fuel-log--max-message-size))))) + +(defsubst fuel-log--warn (&rest args) + (apply 'fuel-log--msg 'WARNING args)) + +(defsubst fuel-log--error (&rest args) + (apply 'fuel-log--msg 'ERROR args)) + +(defsubst fuel-log--info (&rest args) + (if fuel-log--verbose-p (apply 'fuel-log--msg 'INFO args) "")) + + +(provide 'fuel-log) +;;; fuel-log.el ends here diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index fbfe614526..2dc15ce272 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -49,7 +49,7 @@ With prefix argument, ask for the file to run." (when buffer (with-current-buffer buffer (message "Compiling %s ..." file) - (fuel-eval--send (fuel-eval--cmd/string (format "%S fuel-run-file" file)) + (fuel-eval--send `(:fuel (,file fuel-run-file)) `(lambda (r) (fuel--run-file-cont r ,file))))))) (defun fuel--run-file-cont (ret file) @@ -65,15 +65,18 @@ With prefix argument, ask for the file to run." Unless called with a prefix, switchs to the compilation results buffer in case of errors." (interactive "r\nP") - (fuel-debug--display-retort - (fuel-eval--send/wait (fuel-eval--cmd/region begin end) 10000) - (format "%s%s" - (if fuel-syntax--current-vocab - (format "IN: %s " fuel-syntax--current-vocab) - "") - (fuel--shorten-region begin end 70)) - arg - (buffer-file-name))) + (let* ((lines (split-string (buffer-substring-no-properties begin end) + "[\f\n\r\v]+" t)) + (cmd `(:fuel (,(mapcar (lambda (l) `(:factor ,l)) lines))))) + (fuel-debug--display-retort + (fuel-eval--send/wait cmd 10000) + (format "%s%s" + (if fuel-syntax--current-vocab + (format "IN: %s " fuel-syntax--current-vocab) + "") + (fuel--shorten-region begin end 70)) + arg + (buffer-file-name)))) (defun fuel-eval-extended-region (begin end &optional arg) "Sends region extended outwards to nearest definitions, @@ -119,17 +122,16 @@ With prefix, asks for the word to edit." (if word (format " (%s)" word) "")) word) word))) - (let ((str (fuel-eval--cmd/string - (format "\\ %s fuel-get-edit-location" word)))) + (let ((cmd `(:fuel ((:quote ,word) fuel-get-edit-location)))) (condition-case nil - (fuel--try-edit (fuel-eval--send/wait str)) + (fuel--try-edit (fuel-eval--send/wait cmd)) (error (fuel-edit-vocabulary word)))))) (defvar fuel--vocabs-prompt-history nil) (defun fuel--read-vocabulary-name () - (let* ((str (fuel-eval--cmd/string "fuel-get-vocabs" t "fuel" t)) - (vocabs (fuel-eval--retort-result (fuel-eval--send/wait str))) + (let* ((cmd '(:fuel* (fuel-get-vocabs) "fuel" t)) + (vocabs (fuel-eval--retort-result (fuel-eval--send/wait cmd))) (prompt "Vocabulary name: ")) (if vocabs (completing-read prompt vocabs nil t nil fuel--vocabs-prompt-history) @@ -139,9 +141,8 @@ With prefix, asks for the word to edit." "Visits vocabulary file in Emacs. When called interactively, asks for vocabulary with completion." (interactive (list (fuel--read-vocabulary-name))) - (let* ((str (fuel-eval--cmd/string - (format "%S fuel-get-vocab-location" vocab) t "fuel" t))) - (fuel--try-edit (fuel-eval--send/wait str)))) + (let* ((cmd `(:fuel* (,vocab fuel-get-vocab-location) "fuel" t))) + (fuel--try-edit (fuel-eval--send/wait cmd)))) ;;; Minor mode definition: diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index a0485f9183..ff8126c507 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -101,7 +101,7 @@ fuel-syntax--declaration-words-regex)) (defconst fuel-syntax--single-liner-regex - (format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:" + (format "^%s" (regexp-opt '("C:" "DEFER:" "GENERIC:" "IN:" "PRIVATE>" "