--- /dev/null
+unportable
-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"
! 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
! 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
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
! 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
! 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
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 )
{
TYPEDEF: uint UInt32
TYPEDEF: ulong CFTypeID
TYPEDEF: UInt32 CFOptionFlags
+TYPEDEF: void* CFUUIDRef
FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ;
TYPEDEF: void* CFMutableDictionaryRef
TYPEDEF: void* CFNumberRef
TYPEDEF: void* CFSetRef
-TYPEDEF: void* CFUUIDRef
TYPEDEF: int CFNumberType
: kCFNumberSInt8Type 1 ; inline
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 ;
\ <db-pool> must-infer
-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
! 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
! 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
! 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 ;
-USING: io.unix.backend kernel namespaces editors.gvim
-system ;
+USING: kernel namespaces editors.gvim system ;
IN: editors.gvim.unix
M: unix gvim-path
-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
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 )
! 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
[ nip parent-directory ftp-cwd drop ]
[ file-name (ftp-get) ] 2bi
] with-ftp-client ;
-
-
-
-
! 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
! 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 ;
furnace.auth.providers\r
furnace.auth.providers.db tools.test\r
namespaces db db.sqlite db.tuples continuations\r
-io.files accessors kernel ;\r
+io.files io.files.temp io.directories accessors kernel ;\r
\r
<action> "test" <login-realm> realm set\r
\r
USING: tools.test http furnace.sessions furnace.actions\r
http.server http.server.responses math namespaces make kernel\r
accessors io.sockets io.servers.connection prettyprint\r
-io.streams.string io.files splitting destructors sequences db\r
-db.tuples db.sqlite continuations urls math.parser furnace\r
-furnace.utilities ;\r
+io.streams.string io.files io.files.temp io.directories\r
+splitting destructors sequences db db.tuples db.sqlite\r
+continuations urls math.parser furnace furnace.utilities ;\r
\r
: with-session\r
[\r
{ $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" }
! 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
! 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
-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
! 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
! 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 ;
! Copyright (C) 2004, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: calendar io io.files kernel math math.order\r
-math.parser namespaces parser sequences strings\r
-assocs hashtables debugger mime.types sorting logging\r
-calendar.format accessors splitting\r
-io.encodings.binary fry xml.entities destructors urls\r
-html.elements html.templates.fhtml\r
-http\r
-http.server\r
-http.server.responses\r
+USING: calendar kernel math math.order math.parser namespaces\r
+parser sequences strings assocs hashtables debugger mime.types\r
+sorting logging calendar.format accessors splitting io io.files\r
+io.files.info io.directories io.pathnames io.encodings.binary\r
+fry xml.entities destructors urls html.elements\r
+html.templates.fhtml http http.server http.server.responses\r
http.server.redirection ;\r
IN: http.server.static\r
\r
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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 ( -- )
+ <kqueue-mx> mx set-global ;
+
+! M: bsd (monitor) ( path recursive? mailbox -- )
+! swap [ "Recursive kqueue monitors not supported" throw ] when
+! <vnode-monitor> ;
--- /dev/null
+unportable
--- /dev/null
+USING: io.backend.unix.bsd io.backend system ;
+
+freebsd set-io-backend
--- /dev/null
+unportable
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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 ( -- )
+ <epoll-mx> mx set-global ;
+
+linux set-io-backend
--- /dev/null
+unportable
--- /dev/null
+! 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 ( -- )
+ <run-loop-mx> mx set-global ;
+
+macosx set-io-backend
--- /dev/null
+unportable
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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
+
+: <epoll-mx> ( -- mx )
+ epoll-mx new-mx
+ max-events epoll_create dup io-error >>fd
+ max-events "epoll-event" <struct-array> >>events ;
+
+M: epoll-mx dispose fd>> close-file ;
+
+: make-event ( fd events -- event )
+ "epoll-event" <c-object>
+ [ 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 ;
--- /dev/null
+unportable
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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
+
+: <kqueue-mx> ( -- mx )
+ kqueue-mx new-mx
+ kqueue dup io-error >>fd
+ max-events "kevent" <struct-array> >>events ;
+
+M: kqueue-mx dispose fd>> close-file ;
+
+: make-kevent ( fd filter flags -- event )
+ "kevent" <c-object>
+ [ 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 ;
--- /dev/null
+unportable
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 ;
+
+: <run-loop-mx> ( -- mx )
+ [
+ <kqueue-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 ;
--- /dev/null
+unportable
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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
+
+: <select-mx> ( -- mx )
+ select-mx new-mx
+ FD_SETSIZE 8 * <bit-array> >>read-fdset
+ FD_SETSIZE 8 * <bit-array> >>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 ;
--- /dev/null
+unportable
--- /dev/null
+USING: io.backend.unix.bsd io.backend system ;
+
+netbsd set-io-backend
--- /dev/null
+unportable
--- /dev/null
+USING: io.backend.unix.bsd io.backend system ;
+
+openbsd set-io-backend
--- /dev/null
+unportable
--- /dev/null
+Non-blocking I/O and sockets on Unix-like systems
--- /dev/null
+unportable
--- /dev/null
+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 <local>
+ ascii <server> [
+ 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 <local> 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 <local> <datagram> "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 <local> <datagram>
+"d" set
+
+[ ] [
+ "hello" >byte-array
+ datagram-server <local>
+ "d" get send
+] unit-test
+
+[ "olleh" t ] [
+ "d" get receive
+ datagram-server <local> =
+ [ >string ] dip
+] unit-test
+
+[ ] [
+ "hello" >byte-array
+ datagram-server <local>
+ "d" get send
+] unit-test
+
+[ "hello world" t ] [
+ "d" get receive
+ datagram-server <local> =
+ [ >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 <local> <datagram> "d" set ] unit-test
+
+[ B{ 1 2 3 } another-datagram <local> "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 <local> "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 <local>
+ input-stream get send
+ ] with-file-reader
+] must-fail
--- /dev/null
+! 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 ;
+
+: <fd> ( 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 )
+ stdin new
+ control-write-fd <fd> <output-port> >>control
+ size-read-fd <fd> init-fd <input-port> >>size
+ data-read-fd <fd> >>data ;
+
+M: unix (init-stdio) ( -- )
+ <stdin> <input-port>
+ 1 <fd> <output-port>
+ 2 <fd> <output-port> ;
+
+! mx io-task for embedding an fd-based mx inside another mx
+TUPLE: mx-port < port mx ;
+
+: <mx-port> ( mx -- port )
+ dup fd>> mx-port <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 ;
--- /dev/null
+Doug Coleman
+Mackenzie Straight
--- /dev/null
+Doug Coleman
+Slava Pestov
+Mackenzie Straight
--- /dev/null
+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> 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* ;
+
+: <completion-port> ( handle existing -- handle )
+ f 1 CreateIoCompletionPort dup win32-error=0/f ;
+
+SYMBOL: master-completion-port
+
+: <master-completion-port> ( -- handle )
+ INVALID_HANDLE_VALUE f <completion-port> ;
+
+M: winnt add-completion ( win32-handle -- )
+ handle>> master-completion-port get-global <completion-port> 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 <int> [ ! bytes
+ f <void*> ! key
+ f <void*> [ ! 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> 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
--- /dev/null
+USING: alien alien.c-types alien.syntax arrays continuations\r
+destructors generic io.mmap io.ports io.backend.windows io.files.windows\r
+kernel libc math math.bitwise namespaces quotations sequences windows\r
+windows.advapi32 windows.kernel32 io.backend system accessors\r
+io.backend.windows.privileges ;\r
+IN: io.backend.windows.nt.privileges\r
+\r
+TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES\r
+\r
+! Security tokens\r
+! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/\r
+\r
+: (open-process-token) ( handle -- handle )\r
+ { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" <c-object>\r
+ [ OpenProcessToken win32-error=0/f ] keep *void* ;\r
+\r
+: open-process-token ( -- handle )\r
+ #! remember to CloseHandle\r
+ GetCurrentProcess (open-process-token) ;\r
+\r
+: with-process-token ( quot -- )\r
+ #! quot: ( token-handle -- token-handle )\r
+ [ open-process-token ] dip\r
+ [ keep ] curry\r
+ [ CloseHandle drop ] [ ] cleanup ; inline\r
+\r
+: lookup-privilege ( string -- luid )\r
+ [ f ] dip "LUID" <c-object>\r
+ [ LookupPrivilegeValue win32-error=0/f ] keep ;\r
+\r
+: make-token-privileges ( name ? -- obj )\r
+ "TOKEN_PRIVILEGES" <c-object>\r
+ 1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep\r
+ "LUID_AND_ATTRIBUTES" malloc-array &free\r
+ over set-TOKEN_PRIVILEGES-Privileges\r
+\r
+ swap [\r
+ SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges\r
+ set-LUID_AND_ATTRIBUTES-Attributes\r
+ ] when\r
+\r
+ [ lookup-privilege ] dip\r
+ [\r
+ TOKEN_PRIVILEGES-Privileges\r
+ set-LUID_AND_ATTRIBUTES-Luid\r
+ ] keep ;\r
+\r
+M: winnt set-privilege ( name ? -- )\r
+ [\r
+ -rot 0 -rot make-token-privileges\r
+ dup length f f AdjustTokenPrivileges win32-error=0/f\r
+ ] with-process-token ;\r
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+USING: io.backend kernel continuations sequences\r
+system vocabs.loader combinators ;\r
+IN: io.backend.windows.privileges\r
+\r
+HOOK: set-privilege io-backend ( name ? -- ) inline\r
+\r
+: with-privileges ( seq quot -- )\r
+ over [ [ t set-privilege ] each ] curry compose\r
+ swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline\r
+\r
+{\r
+ { [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] }\r
+ { [ os wince? ] [ "io.backend.windows.ce.privileges" require ] }\r
+} cond\r
--- /dev/null
+unportable
--- /dev/null
+Microsoft Windows native I/O implementation
--- /dev/null
+unportable
--- /dev/null
+! 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 ;
+
+: <win32-handle> ( handle -- win32-handle )
+ win32-handle new-win32-handle ;
+
+M: win32-handle dispose* ( handle -- )
+ handle>> CloseHandle drop ;
+
+TUPLE: win32-file < win32-handle ptr ;
+
+: <win32-file> ( 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?
+ <win32-file> |dispose
+ dup add-completion ;
+
+: share-mode ( -- fixnum )
+ {
+ FILE_SHARE_READ
+ FILE_SHARE_WRITE
+ FILE_SHARE_DELETE
+ } flags ; foldable
+
+: default-security-attributes ( -- obj )
+ "SECURITY_ATTRIBUTES" <c-object>
+ "SECURITY_ATTRIBUTES" heap-size
+ over set-SECURITY_ATTRIBUTES-nLength ;
--- /dev/null
+Slava Pestov
+Doug Coleman
--- /dev/null
+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"
--- /dev/null
+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 <file-writer> 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
--- /dev/null
+! 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 <file-writer> [
+ swap binary <file-reader> [
+ 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
--- /dev/null
+Slava Pestov
--- /dev/null
+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"
--- /dev/null
+! 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 ;
+
--- /dev/null
+Deleting and copying directory hierarchies
--- /dev/null
+Doug Coleman
--- /dev/null
+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
--- /dev/null
+! 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 ;
+
+<PRIVATE
+
+: qualified-directory ( path -- seq )
+ dup directory-files [ append-path ] with map ;
+
+: push-directory ( path iter -- )
+ [ qualified-directory ] dip [
+ dup queue>> swap bfs>>
+ [ push-front ] [ push-back ] if
+ ] curry each ;
+
+: <directory-iterator> ( path bfs? -- iterator )
+ <dlist> 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 )
+ [ <directory-iterator> ] dip
+ [ keep and ] curry iterate-directory ; inline
+
+: each-file ( path bfs? quot: ( obj -- ? ) -- )
+ [ <directory-iterator> ] dip
+ [ f ] compose iterate-directory drop ; inline
+
+: find-all-files ( path bfs? quot: ( obj -- ? ) -- paths )
+ [ <directory-iterator> ] 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
--- /dev/null
+Doug Coleman
--- /dev/null
+unportable
--- /dev/null
+! 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
--- /dev/null
+Listing directories, moving, copying and deleting files
--- /dev/null
+! 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 <file-writer> [
+ swap binary <file-reader> [
+ 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" <c-object>
+ f <void*>
+ [ 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 ;
--- /dev/null
+unportable
--- /dev/null
+! 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" <c-object> tuck
+ FindFirstFile
+ [ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ;
+
+: find-next-file ( path -- WIN32_FIND_DATA/f )
+ "WIN32_FIND_DATA" <c-object> tuck
+ FindNextFile 0 = [
+ GetLastError ERROR_NO_MORE_FILES = [
+ win32-error
+ ] unless drop f
+ ] when ;
+
+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 ;
+
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+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"
--- /dev/null
+! 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 <encoder> drop ;
+M: binary <decoder> drop ;
--- /dev/null
+Dummy encoding for binary I/O
--- /dev/null
+Slava Pestov
+Doug Coleman
--- /dev/null
+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"
--- /dev/null
+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
--- /dev/null
+! 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
--- /dev/null
+File and file system meta-data
--- /dev/null
+! 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 ;
--- /dev/null
+unportable
--- /dev/null
+! 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" <c-object> 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 <direct-uint-array> >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" <c-object> 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" <c-array> dup dup length 0 getfsstat io-error
+ "statfs" heap-size group
+ [ statfs-f_mntonname alien>native-string file-system-info ] map ;
--- /dev/null
+unportable
--- /dev/null
+! 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" <c-object> 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 <direct-uint-array> >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" <c-object> 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 <string-reader> csv first >>options ]
+ [ 4 swap nth >>frequency ]
+ [ 5 swap nth >>pass-number ]
+ } cleave ;
+
+: parse-mtab ( -- array )
+ [
+ "/etc/mtab" utf8 <file-reader>
+ 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 ;
--- /dev/null
+unportable
--- /dev/null
+! 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 <void*> 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" <c-object> tuck statfs64 io-error ;
+
+M: macosx file-system-statvfs ( normalized-path -- statvfs )
+ "statvfs" <c-object> 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 <direct-uint-array> >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 ;
--- /dev/null
+unportable
--- /dev/null
+! 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" <c-object> 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 <direct-uint-array> >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" <c-array> dup dup length 0 getvfsstat io-error
+ "statvfs" heap-size group
+ [ statvfs-f_mntonname utf8 alien>string file-system-info ] map ;
--- /dev/null
+unportable
--- /dev/null
+! 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" <c-object> 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 <direct-uint-array> >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" <c-object> 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" <c-array> dup dup length 0 getfsstat io-error
+ "statfs" heap-size group
+ [ statfs-f_mntonname alien>native-string file-system-info ] map ;
--- /dev/null
+unportable
--- /dev/null
+! 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"
--- /dev/null
+! 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 ;
+
+<PRIVATE
+
+: stat-mode ( path -- mode )
+ normalize-path file-status stat-st_mode ;
+
+: chmod-set-bit ( path mask ? -- )
+ [ dup stat-mode ] 2dip
+ [ bitor ] [ unmask ] if chmod io-error ;
+
+GENERIC# file-mode? 1 ( obj mask -- ? )
+
+M: integer file-mode? mask? ;
+M: string file-mode? [ stat-mode ] dip mask? ;
+M: file-info file-mode? [ permissions>> ] 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>> ;
+
+<PRIVATE
+
+: make-timeval-array ( array -- byte-array )
+ [ [ "timeval" <c-object> ] 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 ;
--- /dev/null
+unportable
--- /dev/null
+! 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" <c-object> [
+ 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" <c-object>
+ [ 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+ [ <byte-array> ] keep
+ "DWORD" <c-object>
+ "DWORD" <c-object>
+ "DWORD" <c-object>
+ MAX_PATH 1+ [ <byte-array> ] 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" <c-object>
+ "ULARGE_INTEGER" <c-object>
+ "ULARGE_INTEGER" <c-object>
+ [ 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" <c-array> tuck dup length
+ 0 <uint> 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+ [ <byte-array> ] keep
+ dupd
+ FindFirstVolume dup win32-error=0/f
+ [ utf16n alien>string ] dip ;
+
+: find-next-volume ( handle -- string/f )
+ MAX_PATH 1+ [ <byte-array> 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" <c-object>
+ "FILETIME" <c-object>
+ "FILETIME" <c-object>
+ [ 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 ;
--- /dev/null
+Slava Pestov
+Doug Coleman
--- /dev/null
+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"
--- /dev/null
+! 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
--- /dev/null
+Working with symbolic links
--- /dev/null
+! 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 ;
--- /dev/null
+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"
--- /dev/null
+! 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
--- /dev/null
+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"
--- /dev/null
+! 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+
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
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 ] [
! 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 -- )
'[ _ 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
--- /dev/null
+unportable
--- /dev/null
+! 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" ;
--- /dev/null
+unportable
--- /dev/null
+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 ;
--- /dev/null
+Slava Pestov
--- /dev/null
+Implementation of reading and writing files on Unix-like systems
--- /dev/null
+unportable
--- /dev/null
+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
--- /dev/null
+! 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 [ <byte-array> ] 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 <fd> init-fd <input-port> ;
+
+: 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 <fd> init-fd <output-port> ;
+
+: 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 <fd> init-fd <output-port> ;
+
+M: unix home "HOME" os-env ;
--- /dev/null
+Doug Coleman
+Slava Pestov
+Mackenzie Straight
--- /dev/null
+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
--- /dev/null
+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" <c-array>
+ [ 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 ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! 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 <win32-file> ;
+
+: 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 <win32-file>
+ GetLastError ERROR_ALREADY_EXISTS = not ;
+
+: set-file-pointer ( handle length method -- )
+ [ dupd d>w/w <uint> ] 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> FileArgs
+
+: make-FileArgs ( port -- <FileArgs> )
+ {
+ [ handle>> check-disposed ]
+ [ handle>> handle>> ]
+ [ buffer>> ]
+ [ buffer>> buffer-length ]
+ [ drop "DWORD" <c-object> ]
+ [ FileArgs-overlapped ]
+ } cleave <FileArgs> ;
+
+: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
+ {
+ [ hFile>> ]
+ [ lpBuffer>> buffer-end ]
+ [ lpBuffer>> buffer-capacity ]
+ [ lpNumberOfBytesRet>> ]
+ [ lpOverlapped>> ]
+ } cleave ;
+
+: setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
+ {
+ [ hFile>> ]
+ [ lpBuffer>> buffer@ ]
+ [ lpBuffer>> buffer-length ]
+ [ lpNumberOfBytesRet>> ]
+ [ lpOverlapped>> ]
+ } cleave ;
+
+M: windows (file-reader) ( path -- stream )
+ open-read <input-port> ;
+
+M: windows (file-writer) ( path -- stream )
+ open-write <output-port> ;
+
+M: windows (file-appender) ( path -- stream )
+ open-append <output-port> ;
+
+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 ;
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
--- /dev/null
+Slava Pestov
--- /dev/null
+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
--- /dev/null
+! 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 ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+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
+
+[ ] [
+ <process>
+ "echo Hello" >>command
+ "launcher-test-1" temp-file >>stdout
+ try-process
+] unit-test
+
+[ "Hello\n" ] [
+ "cat"
+ "launcher-test-1" temp-file
+ 2array
+ ascii <process-reader> contents
+] unit-test
+
+[ ] [
+ [ "launcher-test-1" temp-file delete-file ] ignore-errors
+] unit-test
+
+[ ] [
+ <process>
+ "cat" >>command
+ +closed+ >>stdin
+ "launcher-test-1" temp-file >>stdout
+ try-process
+] unit-test
+
+[ f ] [
+ "cat"
+ "launcher-test-1" temp-file
+ 2array
+ ascii <process-reader> contents
+] unit-test
+
+[ ] [
+ 2 [
+ "launcher-test-1" temp-file binary <file-appender> [
+ <process>
+ swap >>stdout
+ "echo Hello" >>command
+ try-process
+ ] with-disposal
+ ] times
+] unit-test
+
+[ "Hello\nHello\n" ] [
+ "cat"
+ "launcher-test-1" temp-file
+ 2array
+ ascii <process-reader> contents
+] unit-test
+
+[ t ] [
+ <process>
+ "env" >>command
+ { { "A" "B" } } >>environment
+ ascii <process-reader> lines
+ "A=B" swap member?
+] unit-test
+
+[ { "A=B" } ] [
+ <process>
+ "env" >>command
+ { { "A" "B" } } >>environment
+ +replace-environment+ >>environment-mode
+ ascii <process-reader> lines
+] unit-test
+
+[ "hi\n" ] [
+ temp-directory [
+ [ "aloha" delete-file ] ignore-errors
+ <process>
+ { "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 [
+ <process>
+ "echo hi" >>command
+ "append-test" temp-file <appender> >>stdout
+ try-process
+ ] times
+ "append-test" temp-file utf8 file-contents
+] unit-test
+
+[ t ] [ "ls" utf8 <process-stream> contents >boolean ] unit-test
+
+[ "Hello world.\n" ] [
+ "cat" utf8 <process-stream> [
+ "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 [ <promise> ]
+ s [ <promise> ] |
+ [
+ "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
--- /dev/null
+! 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 <int> tuck WNOHANG waitpid
+ dup 0 <= [
+ 2drop t
+ ] [
+ find-process dup
+ [ swap *int code>status notify-exit f ] [ 2drop f ] if
+ ] if ;
--- /dev/null
+Doug Coleman
+Slava Pestov
--- /dev/null
+Doug Coleman
+Slava Pestov
+Mackenzie Straight
--- /dev/null
+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
+
+[ ] [
+ <process>
+ "notepad" >>command
+ 1/2 seconds >>timeout
+ "notepad" set
+] unit-test
+
+[ f ] [ "notepad" get process-running? ] unit-test
+
+[ f ] [ "notepad" get process-started? ] unit-test
+
+[ ] [ "notepad" [ run-detached ] change ] unit-test
+
+[ "notepad" get wait-for-process ] must-fail
+
+[ t ] [ "notepad" get killed>> ] unit-test
+
+[ f ] [ "notepad" get process-running? ] unit-test
+
+[ ] [
+ <process>
+ vm "-quiet" "-run=hello-world" 3array >>command
+ "out.txt" temp-file >>stdout
+ try-process
+] unit-test
+
+[ "Hello world" ] [
+ "out.txt" temp-file ascii file-lines first
+] unit-test
+
+[ ] [
+ <process>
+ vm "-run=listener" 2array >>command
+ +closed+ >>stdin
+ try-process
+] unit-test
+
+[ ] [
+ "resource:basis/io/windows/nt/launcher/test" [
+ <process>
+ vm "-script" "stderr.factor" 3array >>command
+ "out.txt" temp-file >>stdout
+ "err.txt" temp-file >>stderr
+ try-process
+ ] with-directory
+] unit-test
+
+[ "output" ] [
+ "out.txt" temp-file ascii file-lines first
+] unit-test
+
+[ "error" ] [
+ "err.txt" temp-file ascii file-lines first
+] unit-test
+
+[ ] [
+ "resource:basis/io/windows/nt/launcher/test" [
+ <process>
+ vm "-script" "stderr.factor" 3array >>command
+ "out.txt" temp-file >>stdout
+ +stdout+ >>stderr
+ try-process
+ ] with-directory
+] unit-test
+
+[ "outputerror" ] [
+ "out.txt" temp-file ascii file-lines first
+] unit-test
+
+[ "output" ] [
+ "resource:basis/io/windows/nt/launcher/test" [
+ <process>
+ vm "-script" "stderr.factor" 3array >>command
+ "err2.txt" temp-file >>stderr
+ ascii <process-reader> 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" [
+ <process>
+ vm "-script" "env.factor" 3array >>command
+ ascii <process-reader> contents
+ ] with-directory eval
+
+ os-envs =
+] unit-test
+
+[ t ] [
+ "resource:basis/io/windows/nt/launcher/test" [
+ <process>
+ vm "-script" "env.factor" 3array >>command
+ +replace-environment+ >>environment-mode
+ os-envs >>environment
+ ascii <process-reader> contents
+ ] with-directory eval
+
+ os-envs =
+] unit-test
+
+[ "B" ] [
+ "resource:basis/io/windows/nt/launcher/test" [
+ <process>
+ vm "-script" "env.factor" 3array >>command
+ { { "A" "B" } } >>environment
+ ascii <process-reader> contents
+ ] with-directory eval
+
+ "A" swap at
+] unit-test
+
+[ f ] [
+ "resource:basis/io/windows/nt/launcher/test" [
+ <process>
+ vm "-script" "env.factor" 3array >>command
+ { { "USERPROFILE" "XXX" } } >>environment
+ +prepend-environment+ >>environment-mode
+ ascii <process-reader> contents
+ ] with-directory eval
+
+ "USERPROFILE" swap at "XXX" =
+] unit-test
+
+2 [
+ [ ] [
+ <process>
+ "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" [
+ <process>
+ vm "-script" "append.factor" 3array >>command
+ "append-test" temp-file <appender> >>stdout
+ try-process
+ ] with-directory
+ ] times
+
+ "append-test" temp-file ascii file-contents
+] unit-test
--- /dev/null
+! 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 <void*> [ ! 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? <win32-file> &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 ;
--- /dev/null
+unportable
--- /dev/null
+USE: io\r
+"Hello appender" print\r
--- /dev/null
+USE: system
+USE: prettyprint
+USE: environment
+os-envs .
--- /dev/null
+USE: io\r
+USE: namespaces\r
+\r
+"output" write flush\r
+"error" error-stream get stream-write error-stream get stream-flush\r
--- /dev/null
+unportable
--- /dev/null
+IN: io.launcher.windows.tests\r
+USING: tools.test io.launcher.windows ;\r
+\r
+[ "hello world" ] [ { "hello" "world" } join-arguments ] unit-test\r
+\r
+[ "bob \"mac arthur\"" ] [ { "bob" "mac arthur" } join-arguments ] unit-test\r
+\r
+[ "bob mac\\\\arthur" ] [ { "bob" "mac\\\\arthur" } join-arguments ] unit-test\r
+\r
+[ "bob \"mac arthur\\\\\"" ] [ { "bob" "mac arthur\\" } join-arguments ] unit-test\r
--- /dev/null
+! 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" <c-object>
+ "STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
+ "PROCESS_INFORMATION" <c-object> >>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: \\ <repetition> 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 <ulong> [ 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 ;
-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
! 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 )
: <mapped-file> ( path -- mmap )
[ normalize-path ] [ file-info size>> ] bi [ (mapped-file) ] keep
[ <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
--- /dev/null
+Slava Pestov
--- /dev/null
+unportable
--- /dev/null
+! 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 ;
--- /dev/null
+Doug Coleman
--- /dev/null
+unportable
--- /dev/null
+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 <win32-handle> ;
+
+: 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> 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 <win32-mapped-file>
+ ] with-destructors ;
+
+M: windows close-mapped-file ( mapped-file -- )
+ [
+ [ handle>> &dispose drop ]
+ [ address>> UnmapViewOfFile win32-error=0/f ] bi
+ ] with-destructors ;
--- /dev/null
+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 <monitor> "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 <monitor> "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
--- /dev/null
+! 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 ;
+
+: <linux-monitor> ( wd path mailbox -- monitor )
+ linux-monitor new-monitor
+ inotify get >>inotify
+ watches get >>watches
+ swap >>wd ;
+
+: wd>monitor ( wd -- monitor ) watches get at ;
+
+: <inotify> ( -- port/f )
+ inotify_init dup 0 < [ drop f ] [ <fd> init-fd <input-port> ] 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
+ <linux-monitor> [ ] [ ] [ wd>> ] tri watches get set-at ;
+
+: check-inotify ( -- )
+ inotify get [
+ "Calling <monitor> outside with-monitors" throw
+ ] unless ;
+
+M: linux (monitor) ( path recursive? mailbox -- monitor )
+ swap [
+ <recursive-monitor>
+ ] [
+ 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>> <displaced-alien> ;
+
+: 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> [
+ [ 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 ;
--- /dev/null
+unportable
--- /dev/null
+! 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 <event-stream> >>handle
+ ] ;
+
+M: macosx-monitor dispose
+ handle>> dispose ;
+
+macosx set-io-backend
--- /dev/null
+unportable
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? [
[
[ <monitor> ] 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
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
! 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
--- /dev/null
+Doug Coleman
--- /dev/null
+IN: io.monitors.windows.nt.tests\r
+USING: io.monitors.windows.nt tools.test ;\r
+\r
+\ fill-queue-thread must-infer\r
--- /dev/null
+! 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 <uint>
+ (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 <displaced-alien>
+ (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 <buffered-port>
+ recursive? >>recursive
+ >>port
+ dup [ fill-queue-thread ] curry
+ "Windows monitor thread" spawn drop
+ ] with-destructors ;
+
+M: win32-monitor dispose
+ port>> dispose ;
--- /dev/null
+unportable
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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
+++ /dev/null
-! 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 ;
-
-<PRIVATE
-
-: qualified-directory ( path -- seq )
- dup directory-files [ append-path ] with map ;
-
-: push-directory ( path iter -- )
- [ qualified-directory ] dip [
- dup queue>> swap bfs>>
- [ push-front ] [ push-back ] if
- ] curry each ;
-
-: <directory-iterator> ( path bfs? -- iterator )
- <dlist> 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 )
- [ <directory-iterator> ] dip
- [ keep and ] curry iterate-directory ; inline
-
-: each-file ( path bfs? quot: ( obj -- ? ) -- )
- [ <directory-iterator> ] dip
- [ f ] compose iterate-directory drop ; inline
-
-: find-all-files ( path bfs? quot: ( obj -- ? ) -- paths )
- [ <directory-iterator> ] 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
+++ /dev/null
-Doug Coleman
+++ /dev/null
-unportable
+++ /dev/null
-! 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
] 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
--- /dev/null
+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 <decoder> ] change
+ output-stream [ utf8 <encoder> ] change
+ input-stream get lines reverse [ print ] each f
+ ]
+ "grep ."
+ } run-pipeline
+] unit-test
--- /dev/null
+unportable
--- /dev/null
+! 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 <int-array>
+ [ underlying>> pipe io-error ]
+ [ first2 [ <fd> init-fd ] bi@ io.pipes:pipe boa ] bi ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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 ;
--- /dev/null
+unportable
! 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
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
--- /dev/null
+! 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 -- )
+ <secure-config>
+ "resource:basis/openssl/test/server.pem" >>key-file
+ "resource:basis/openssl/test/dh1024.pem" >>dh-file
+ "password" >>password
+ swap with-secure-context ; inline
--- /dev/null
+unportable
--- /dev/null
+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 ;
+
+\ <secure-config> must-infer
+{ 1 0 } [ [ ] with-secure-context ] must-infer-as
+
+[ ] [ <promise> "port" set ] unit-test
+
+:: server-test ( quot -- )
+ [
+ [
+ "127.0.0.1" 0 <inet4> <secure> ascii <server> [
+ 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 )
+ <secure-config> [
+ "127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> 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
+[ ] [ <promise> "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
+[ ] [ <promise> "port" set ] unit-test
+
+[ ] [ [ drop "hi" write ] server-test ] unit-test
+
+[
+ <secure-config> [
+ "localhost" "port" get ?promise <inet> <secure> ascii
+ <client> drop dispose
+ ] with-secure-context
+] [ certificate-verify-error? ] must-fail-with
+
+! Client-side handshake timeout
+[ ] [ <promise> "port" set ] unit-test
+
+[ ] [
+ [
+ "127.0.0.1" 0 <inet4> ascii <server> [
+ 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
+[ ] [ <promise> "port" set ] unit-test
+
+[ ] [
+ [
+ "127.0.0.1" "port" get ?promise
+ <inet4> ascii <client> drop 1 minutes sleep dispose
+ ] "Silly client" spawn drop
+] unit-test
+
+[
+ 1 seconds secure-socket-timeout [
+ [
+ "127.0.0.1" 0 <inet4> <secure> ascii <server> [
+ 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
+[
+ [ ] [ <promise> "port" set ] unit-test
+
+ [ ] [
+ [
+ [
+ "127.0.0.1" 0 <inet4> <secure> ascii <server> [
+ 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 [
+ <secure-config> [
+ "127.0.0.1" "port" get ?promise <inet4> <secure>
+ ascii <client> drop dispose
+ ] with-secure-context
+ ] with-variable
+ ] [ io-timeout? ] must-fail-with
+
+ ! Server socket shutdown timeout
+ [ ] [ <promise> "port" set ] unit-test
+
+ [ ] [
+ [
+ [
+ "127.0.0.1" "port" get ?promise
+ <inet4> <secure> ascii <client> drop 1 minutes sleep dispose
+ ] with-test-context
+ ] "Silly client" spawn drop
+ ] unit-test
+
+ [
+ 1 seconds secure-socket-timeout [
+ [
+ "127.0.0.1" 0 <inet4> <secure> ascii <server> [
+ dup addr>> addrspec>> port>> "port" get fulfill
+ accept drop dispose
+ ] with-disposal
+ ] with-test-context
+ ] with-variable
+ ] [ io-timeout? ] must-fail-with
+] drop
--- /dev/null
+! 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
+: <ssl-socket> ( fd -- ssl )
+ [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep <ssl-handle>
+ [ handle>> swap dup SSL_set_bio ] keep ;
+
+M: secure ((client)) ( addrspec -- handle )
+ addrspec>> ((client)) <ssl-socket> ;
+
+M: secure parse-sockaddr addrspec>> parse-sockaddr <secure> ;
+
+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 <ssl-socket> ] 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
+ [ <ssl-socket> ] 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 ;
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
--- /dev/null
+Slava Pestov
--- /dev/null
+Implementation of TCP/IP and UDP/IP sockets on Unix-like systems
--- /dev/null
+unportable
--- /dev/null
+! 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 <fd> init-fd |dispose ;
+
+: set-socket-option ( fd level opt -- )
+ [ handle-fd ] 2dip 1 <int> "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 <int>
+ [ getsockname io-error ] 2keep drop ;
+
+M: object (get-remote-address) ( handle local -- sockaddr )
+ [ handle-fd ] dip empty-sockaddr/size <int>
+ [ 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 <int> ] bi*
+ [ accept ] 2keep drop ; inline
+
+M: object (accept) ( server addrspec -- fd sockaddr )
+ 2dup do-accept
+ {
+ { [ over 0 >= ] [ [ 2nip <fd> 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 <int> ! 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" <c-object> ;
+
+M: local make-sockaddr
+ path>> (normalize-path)
+ dup length 1 + max-un-path > [ "Path too long" throw ] when
+ "sockaddr-un" <c-object>
+ 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 <local> ;
--- /dev/null
+Doug Coleman
+Slava Pestov
+Mackenzie Straight
--- /dev/null
+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*" <c-object>
+ [
+ "void*" heap-size
+ "DWORD" <c-object>
+ 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
+
+: <ConnectEx-args> ( 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 <ConnectEx-args>
+ 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
+
+: <AcceptEx-args> ( 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 <void*>
+ 0 <int>
+ f <void*>
+ [ 0 <int> GetAcceptExSockaddrs ] keep *void* ; inline
+
+M: object (accept) ( server addr -- handle sockaddr )
+ [
+ <AcceptEx-args>
+ {
+ [ call-AcceptEx ]
+ [ wait-for-socket drop ]
+ [ sAcceptSocket>> <win32-socket> ]
+ [ 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
+
+: <WSARecvFrom-args> ( 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 )
+ [
+ <WSARecvFrom-args>
+ [ 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
+
+: <WSASendTo-args> ( 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 <uint> >>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 -- )
+ [
+ <WSASendTo-args>
+ [ call-WSASendTo ]
+ [ wait-for-socket drop ]
+ bi
+ ] with-destructors ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+USING: kernel accessors io.sockets io.backend.windows io.backend\r
+windows.winsock system destructors alien.c-types ;\r
+IN: io.sockets.windows\r
+\r
+HOOK: WSASocket-flags io-backend ( -- DWORD )\r
+\r
+TUPLE: win32-socket < win32-file ;\r
+\r
+: <win32-socket> ( handle -- win32-socket )\r
+ win32-socket new-win32-handle ;\r
+\r
+M: win32-socket dispose ( stream -- )\r
+ handle>> closesocket drop ;\r
+\r
+: unspecific-sockaddr/size ( addrspec -- sockaddr len )\r
+ [ empty-sockaddr/size ] [ protocol-family ] bi\r
+ pick set-sockaddr-in-family ;\r
+\r
+: opened-socket ( handle -- win32-socket )\r
+ <win32-socket> |dispose dup add-completion ;\r
+\r
+: open-socket ( addrspec type -- win32-socket )\r
+ [ protocol-family ] dip\r
+ 0 f 0 WSASocket-flags WSASocket\r
+ dup socket-error\r
+ opened-socket ;\r
+\r
+M: object (get-local-address) ( socket addrspec -- sockaddr )\r
+ [ handle>> ] dip empty-sockaddr/size <int>\r
+ [ getsockname socket-error ] 2keep drop ;\r
+\r
+M: object (get-remote-address) ( socket addrspec -- sockaddr )\r
+ [ handle>> ] dip empty-sockaddr/size <int>\r
+ [ getpeername socket-error ] 2keep drop ;\r
+\r
+: bind-socket ( win32-socket sockaddr len -- )\r
+ [ handle>> ] 2dip bind socket-error ;\r
+\r
+M: object ((client)) ( addrspec -- handle )\r
+ [ SOCK_STREAM open-socket ] keep\r
+ [ unspecific-sockaddr/size bind-socket ] [ drop ] 2bi ;\r
+\r
+: server-socket ( addrspec type -- fd )\r
+ [ open-socket ] [ drop ] 2bi\r
+ [ make-sockaddr/size bind-socket ] [ drop ] 2bi ;\r
+\r
+! http://support.microsoft.com/kb/127144\r
+! NOTE: Possibly tweak this because of SYN flood attacks\r
+: listen-backlog ( -- n ) HEX: 7fffffff ; inline\r
+\r
+M: object (server) ( addrspec -- handle )\r
+ [\r
+ SOCK_STREAM server-socket\r
+ dup handle>> listen-backlog listen winsock-return-check\r
+ ] with-destructors ;\r
+\r
+M: windows (datagram) ( addrspec -- handle )\r
+ [ SOCK_DGRAM server-socket ] with-destructors ;\r
+\r
+M: windows addrinfo-error ( n -- )\r
+ winsock-return-check ;\r
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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 ;
-
-: <fd> ( 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 )
- stdin new
- control-write-fd <fd> <output-port> >>control
- size-read-fd <fd> init-fd <input-port> >>size
- data-read-fd <fd> >>data ;
-
-M: unix (init-stdio) ( -- )
- <stdin> <input-port>
- 1 <fd> <output-port>
- 2 <fd> <output-port> ;
-
-! mx io-task for embedding an fd-based mx inside another mx
-TUPLE: mx-port < port mx ;
-
-: <mx-port> ( mx -- port )
- dup fd>> mx-port <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 ;
+++ /dev/null
-Non-blocking I/O and sockets on Unix-like systems
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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 ( -- )
- <kqueue-mx> mx set-global ;
-
-! M: bsd (monitor) ( path recursive? mailbox -- )
-! swap [ "Recursive kqueue monitors not supported" throw ] when
-! <vnode-monitor> ;
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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
-
-: <epoll-mx> ( -- mx )
- epoll-mx new-mx
- max-events epoll_create dup io-error >>fd
- max-events "epoll-event" <struct-array> >>events ;
-
-: make-event ( fd events -- event )
- "epoll-event" <c-object>
- [ 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 ;
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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 ;
+++ /dev/null
-unportable
+++ /dev/null
-! 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"
+++ /dev/null
-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
+++ /dev/null
-! 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 [ <byte-array> ] 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 <fd> init-fd <input-port> ;
-
-: 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 <fd> init-fd <output-port> ;
-
-: 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 <fd> init-fd <output-port> ;
-
-: 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 <file-writer> [
- swap binary <file-reader> [
- 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" <c-object>
- f <void*>
- [ readdir_r 0 = [ (io-error) ] unless ] 2keep
- *void* [ drop f ] unless ;
-
-M: unix >directory-entry ( byte-array -- directory-entry )
- [ dirent-d_name utf8 alien>string ]
- [ dirent-d_type 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 ;
-
-<PRIVATE
-
-: stat-mode ( path -- mode )
- normalize-path file-status stat-st_mode ;
-
-: chmod-set-bit ( path mask ? -- )
- [ dup stat-mode ] 2dip
- [ bitor ] [ unmask ] if chmod io-error ;
-
-GENERIC# file-mode? 1 ( obj mask -- ? )
-
-M: integer file-mode? mask? ;
-M: string file-mode? [ stat-mode ] dip mask? ;
-M: file-info file-mode? [ permissions>> ] 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>> ;
-
-<PRIVATE
-
-: make-timeval-array ( array -- byte-array )
- [ [ "timeval" <c-object> ] 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 ;
+++ /dev/null
-! 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" <c-object> 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 <direct-uint-array> >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" <c-object> 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" <c-array> dup dup length 0 getfsstat io-error
- "statfs" heap-size group
- [ statfs-f_mntonname alien>native-string file-system-info ] map ;
+++ /dev/null
-unportable
+++ /dev/null
-! 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" <c-object> 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 <direct-uint-array> >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" <c-object> 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 <string-reader> csv first >>options ]
- [ 4 swap nth >>frequency ]
- [ 5 swap nth >>pass-number ]
- } cleave ;
-
-: parse-mtab ( -- array )
- [
- "/etc/mtab" utf8 <file-reader>
- 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 ;
+++ /dev/null
-unportable
+++ /dev/null
-! 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 <void*> 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" <c-object> tuck statfs64 io-error ;
-
-M: macosx file-system-statvfs ( normalized-path -- statvfs )
- "statvfs" <c-object> 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 <direct-uint-array> >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 ;
+++ /dev/null
-unportable
+++ /dev/null
-! 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" <c-object> 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 <direct-uint-array> >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" <c-array> dup dup length 0 getvfsstat io-error
- "statvfs" heap-size group
- [ statvfs-f_mntonname utf8 alien>string file-system-info ] map ;
+++ /dev/null
-unportable
+++ /dev/null
-! 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" <c-object> 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 <direct-uint-array> >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" <c-object> 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" <c-array> dup dup length 0 getfsstat io-error
- "statfs" heap-size group
- [ statfs-f_mntonname alien>native-string file-system-info ] map ;
+++ /dev/null
-unportable
+++ /dev/null
-Implementation of reading and writing files on Unix-like systems
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-! 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" ;
+++ /dev/null
-USING: io.unix.bsd io.backend system ;
-
-freebsd set-io-backend
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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
-
-: <kqueue-mx> ( -- mx )
- kqueue-mx new-mx
- kqueue dup io-error >>fd
- max-events "kevent" <struct-array> >>events ;
-
-: make-kevent ( fd filter flags -- event )
- "kevent" <c-object>
- [ 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 ;
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-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
-
-[ ] [
- <process>
- "echo Hello" >>command
- "launcher-test-1" temp-file >>stdout
- try-process
-] unit-test
-
-[ "Hello\n" ] [
- "cat"
- "launcher-test-1" temp-file
- 2array
- ascii <process-reader> contents
-] unit-test
-
-[ ] [
- [ "launcher-test-1" temp-file delete-file ] ignore-errors
-] unit-test
-
-[ ] [
- <process>
- "cat" >>command
- +closed+ >>stdin
- "launcher-test-1" temp-file >>stdout
- try-process
-] unit-test
-
-[ f ] [
- "cat"
- "launcher-test-1" temp-file
- 2array
- ascii <process-reader> contents
-] unit-test
-
-[ ] [
- 2 [
- "launcher-test-1" temp-file binary <file-appender> [
- <process>
- swap >>stdout
- "echo Hello" >>command
- try-process
- ] with-disposal
- ] times
-] unit-test
-
-[ "Hello\nHello\n" ] [
- "cat"
- "launcher-test-1" temp-file
- 2array
- ascii <process-reader> contents
-] unit-test
-
-[ t ] [
- <process>
- "env" >>command
- { { "A" "B" } } >>environment
- ascii <process-reader> lines
- "A=B" swap member?
-] unit-test
-
-[ { "A=B" } ] [
- <process>
- "env" >>command
- { { "A" "B" } } >>environment
- +replace-environment+ >>environment-mode
- ascii <process-reader> lines
-] unit-test
-
-[ "hi\n" ] [
- temp-directory [
- [ "aloha" delete-file ] ignore-errors
- <process>
- { "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 [
- <process>
- "echo hi" >>command
- "append-test" temp-file <appender> >>stdout
- try-process
- ] times
- "append-test" temp-file utf8 file-contents
-] unit-test
-
-[ t ] [ "ls" utf8 <process-stream> contents >boolean ] unit-test
-
-[ "Hello world.\n" ] [
- "cat" utf8 <process-stream> [
- "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 [ <promise> ]
- s [ <promise> ] |
- [
- "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
+++ /dev/null
-! 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 <int> tuck WNOHANG waitpid
- dup 0 <= [
- 2drop t
- ] [
- find-process dup
- [ swap *int code>status notify-exit f ] [ 2drop f ] if
- ] if ;
+++ /dev/null
-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
+++ /dev/null
-! 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 ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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 ( -- )
- <epoll-mx> mx set-global ;
-
-linux set-io-backend
+++ /dev/null
-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 <monitor> "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 <monitor> "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
+++ /dev/null
-! 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 ;
-
-: <linux-monitor> ( wd path mailbox -- monitor )
- linux-monitor new-monitor
- inotify get >>inotify
- watches get >>watches
- swap >>wd ;
-
-: wd>monitor ( wd -- monitor ) watches get at ;
-
-: <inotify> ( -- port/f )
- inotify_init dup 0 < [ drop f ] [ <fd> init-fd <input-port> ] 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
- <linux-monitor> [ ] [ ] [ wd>> ] tri watches get set-at ;
-
-: check-inotify ( -- )
- inotify get [
- "Calling <monitor> outside with-monitors" throw
- ] unless ;
-
-M: linux (monitor) ( path recursive? mailbox -- monitor )
- swap [
- <recursive-monitor>
- ] [
- 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>> <displaced-alien> ;
-
-: 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> [
- [ 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 ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-! 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 ( -- )
- <run-loop-mx> mx set-global ;
-
-macosx set-io-backend
+++ /dev/null
-! 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 <event-stream> >>handle
- ] ;
-
-M: macosx-monitor dispose
- handle>> dispose ;
-
-macosx set-io-backend
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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 ;
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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
-
-: <epoll-mx> ( -- mx )
- epoll-mx new-mx
- max-events epoll_create dup io-error >>fd
- max-events "epoll-event" <struct-array> >>events ;
-
-M: epoll-mx dispose fd>> close-file ;
-
-: make-event ( fd events -- event )
- "epoll-event" <c-object>
- [ 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 ;
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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
-
-: <kqueue-mx> ( -- mx )
- kqueue-mx new-mx
- kqueue dup io-error >>fd
- max-events "kevent" <struct-array> >>events ;
-
-M: kqueue-mx dispose fd>> close-file ;
-
-: make-kevent ( fd filter flags -- event )
- "kevent" <c-object>
- [ 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 ;
+++ /dev/null
-unportable
+++ /dev/null
-! 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 ;
+++ /dev/null
-! 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 ;
-
-: <run-loop-mx> ( -- mx )
- [
- <kqueue-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 ;
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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
-
-: <select-mx> ( -- mx )
- select-mx new-mx
- FD_SETSIZE 8 * <bit-array> >>read-fdset
- FD_SETSIZE 8 * <bit-array> >>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 ;
+++ /dev/null
-unportable
+++ /dev/null
-USING: io.unix.bsd io.backend system ;
-
-netbsd set-io-backend
+++ /dev/null
-unportable
+++ /dev/null
-USING: io.unix.bsd io.backend system ;
-
-openbsd set-io-backend
+++ /dev/null
-unportable
+++ /dev/null
-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 <decoder> ] change
- output-stream [ utf8 <encoder> ] change
- input-stream get lines reverse [ print ] each f
- ]
- "grep ."
- } run-pipeline
-] unit-test
+++ /dev/null
-! 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 <int-array>
- [ underlying>> pipe io-error ]
- [ first2 [ <fd> init-fd ] bi@ io.pipes:pipe boa ] bi ;
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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
-
-: <select-mx> ( -- mx )
- select-mx new-mx
- FD_SETSIZE 8 * <bit-array> >>read-fdset
- FD_SETSIZE 8 * <bit-array> >>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 ;
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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 -- )
- <secure-config>
- "resource:basis/openssl/test/server.pem" >>key-file
- "resource:basis/openssl/test/dh1024.pem" >>dh-file
- "password" >>password
- swap with-secure-context ; inline
+++ /dev/null
-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 ;
-
-\ <secure-config> must-infer
-{ 1 0 } [ [ ] with-secure-context ] must-infer-as
-
-[ ] [ <promise> "port" set ] unit-test
-
-:: server-test ( quot -- )
- [
- [
- "127.0.0.1" 0 <inet4> <secure> ascii <server> [
- 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 )
- <secure-config> [
- "127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> 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
-[ ] [ <promise> "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
-[ ] [ <promise> "port" set ] unit-test
-
-[ ] [ [ drop "hi" write ] server-test ] unit-test
-
-[
- <secure-config> [
- "localhost" "port" get ?promise <inet> <secure> ascii
- <client> drop dispose
- ] with-secure-context
-] [ certificate-verify-error? ] must-fail-with
-
-! Client-side handshake timeout
-[ ] [ <promise> "port" set ] unit-test
-
-[ ] [
- [
- "127.0.0.1" 0 <inet4> ascii <server> [
- 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
-[ ] [ <promise> "port" set ] unit-test
-
-[ ] [
- [
- "127.0.0.1" "port" get ?promise
- <inet4> ascii <client> drop 1 minutes sleep dispose
- ] "Silly client" spawn drop
-] unit-test
-
-[
- 1 seconds secure-socket-timeout [
- [
- "127.0.0.1" 0 <inet4> <secure> ascii <server> [
- 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
-[
- [ ] [ <promise> "port" set ] unit-test
-
- [ ] [
- [
- [
- "127.0.0.1" 0 <inet4> <secure> ascii <server> [
- 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 [
- <secure-config> [
- "127.0.0.1" "port" get ?promise <inet4> <secure>
- ascii <client> drop dispose
- ] with-secure-context
- ] with-variable
- ] [ io-timeout? ] must-fail-with
-
- ! Server socket shutdown timeout
- [ ] [ <promise> "port" set ] unit-test
-
- [ ] [
- [
- [
- "127.0.0.1" "port" get ?promise
- <inet4> <secure> ascii <client> drop 1 minutes sleep dispose
- ] with-test-context
- ] "Silly client" spawn drop
- ] unit-test
-
- [
- 1 seconds secure-socket-timeout [
- [
- "127.0.0.1" 0 <inet4> <secure> ascii <server> [
- dup addr>> addrspec>> port>> "port" get fulfill
- accept drop dispose
- ] with-disposal
- ] with-test-context
- ] with-variable
- ] [ io-timeout? ] must-fail-with
-] drop
+++ /dev/null
-! 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
-: <ssl-socket> ( fd -- ssl )
- [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep <ssl-handle>
- [ handle>> swap dup SSL_set_bio ] keep ;
-
-M: secure ((client)) ( addrspec -- handle )
- addrspec>> ((client)) <ssl-socket> ;
-
-M: secure parse-sockaddr addrspec>> parse-sockaddr <secure> ;
-
-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 <ssl-socket> ] 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
- [ <ssl-socket> ] 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 ;
+++ /dev/null
-unportable
+++ /dev/null
-! 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 <fd> init-fd |dispose ;
-
-: set-socket-option ( fd level opt -- )
- [ handle-fd ] 2dip 1 <int> "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 <int>
- [ getsockname io-error ] 2keep drop ;
-
-M: object (get-remote-address) ( handle local -- sockaddr )
- [ handle-fd ] dip empty-sockaddr/size <int>
- [ 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 <int> ] bi*
- [ accept ] 2keep drop ; inline
-
-M: object (accept) ( server addrspec -- fd sockaddr )
- 2dup do-accept
- {
- { [ over 0 >= ] [ [ 2nip <fd> 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 <int> ! 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" <c-object> ;
-
-M: local make-sockaddr
- path>> (normalize-path)
- dup length 1 + max-un-path > [ "Path too long" throw ] when
- "sockaddr-un" <c-object>
- 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 <local> ;
+++ /dev/null
-Implementation of TCP/IP and UDP/IP sockets on Unix-like systems
+++ /dev/null
-unportable
+++ /dev/null
-Non-blocking I/O and sockets on Unix-like systems
+++ /dev/null
-unportable
+++ /dev/null
-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 <local>
- ascii <server> [
- 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 <local> 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 <local> <datagram> "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 <local> <datagram>
-"d" set
-
-[ ] [
- "hello" >byte-array
- datagram-server <local>
- "d" get send
-] unit-test
-
-[ "olleh" t ] [
- "d" get receive
- datagram-server <local> =
- [ >string ] dip
-] unit-test
-
-[ ] [
- "hello" >byte-array
- datagram-server <local>
- "d" get send
-] unit-test
-
-[ "hello world" t ] [
- "d" get receive
- datagram-server <local> =
- [ >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 <local> <datagram> "d" set ] unit-test
-
-[ B{ 1 2 3 } another-datagram <local> "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 <local> "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 <local>
- input-stream get send
- ] with-file-reader
-] must-fail
+++ /dev/null
-USING: accessors system words sequences vocabs.loader
-io.unix.backend io.unix.files ;
-
-"io.unix." os name>> append require
+++ /dev/null
-Doug Coleman
-Mackenzie Straight
+++ /dev/null
-! 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 <win32-file> ;
-
-: 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 <win32-file>
- GetLastError ERROR_ALREADY_EXISTS = not ;
-
-: set-file-pointer ( handle length method -- )
- [ dupd d>w/w <uint> ] 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> FileArgs
-
-: make-FileArgs ( port -- <FileArgs> )
- {
- [ handle>> check-disposed ]
- [ handle>> handle>> ]
- [ buffer>> ]
- [ buffer>> buffer-length ]
- [ drop "DWORD" <c-object> ]
- [ FileArgs-overlapped ]
- } cleave <FileArgs> ;
-
-: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
- {
- [ hFile>> ]
- [ lpBuffer>> buffer-end ]
- [ lpBuffer>> buffer-capacity ]
- [ lpNumberOfBytesRet>> ]
- [ lpOverlapped>> ]
- } cleave ;
-
-: setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
- {
- [ hFile>> ]
- [ lpBuffer>> buffer@ ]
- [ lpBuffer>> buffer-length ]
- [ lpNumberOfBytesRet>> ]
- [ lpOverlapped>> ]
- } cleave ;
-
-M: windows (file-reader) ( path -- stream )
- open-read <input-port> ;
-
-M: windows (file-writer) ( path -- stream )
- open-write <output-port> ;
-
-M: windows (file-appender) ( path -- stream )
- open-append <output-port> ;
-
-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" <c-object> tuck
- FindFirstFile
- [ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ;
-
-: find-next-file ( path -- WIN32_FIND_DATA/f )
- "WIN32_FIND_DATA" <c-object> tuck
- FindNextFile 0 = [
- GetLastError ERROR_NO_MORE_FILES = [
- win32-error
- ] unless drop f
- ] when ;
-
-M: windows (directory-entries) ( path -- seq )
- "\\" ?tail drop "\\*" append
- find-first-file [ >directory-entry ] dip
- [
- '[
- [ _ find-next-file dup ]
- [ >directory-entry ]
- [ drop ] produce
- over name>> "." = [ nip ] [ swap prefix ] if
- ]
- ] [ '[ _ FindClose win32-error=0/f ] ] bi [ ] cleanup ;
-
-SYMBOLS: +read-only+ +hidden+ +system+
-+archive+ +device+ +normal+ +temporary+
-+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" <c-object> [
- 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" <c-object>
- [ 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+ [ <byte-array> ] keep
- "DWORD" <c-object>
- "DWORD" <c-object>
- "DWORD" <c-object>
- MAX_PATH 1+ [ <byte-array> ] 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" <c-object>
- "ULARGE_INTEGER" <c-object>
- "ULARGE_INTEGER" <c-object>
- [ 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" <c-array> tuck dup length
- 0 <uint> 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+ [ <byte-array> ] keep
- dupd
- FindFirstVolume dup win32-error=0/f
- [ utf16n alien>string ] dip ;
-
-: find-next-volume ( handle -- string/f )
- MAX_PATH 1+ [ <byte-array> 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" <c-object>
- "FILETIME" <c-object>
- "FILETIME" <c-object>
- [ 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 ;
+++ /dev/null
-unportable
+++ /dev/null
-unportable
+++ /dev/null
-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 ;
+++ /dev/null
-Doug Coleman
-Slava Pestov
+++ /dev/null
-IN: io.windows.launcher.tests\r
-USING: tools.test io.windows.launcher ;\r
-\r
-[ "hello world" ] [ { "hello" "world" } join-arguments ] unit-test\r
-\r
-[ "bob \"mac arthur\"" ] [ { "bob" "mac arthur" } join-arguments ] unit-test\r
-\r
-[ "bob mac\\\\arthur" ] [ { "bob" "mac\\\\arthur" } join-arguments ] unit-test\r
-\r
-[ "bob \"mac arthur\\\\\"" ] [ { "bob" "mac arthur\\" } join-arguments ] unit-test\r
+++ /dev/null
-! 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" <c-object>
- "STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
- "PROCESS_INFORMATION" <c-object> >>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: \\ <repetition> 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 <ulong> [ 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 ;
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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 <win32-handle> ;
-
-: 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> 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 <win32-mapped-file>
- ] with-destructors ;
-
-M: windows close-mapped-file ( mapped-file -- )
- [
- [ handle>> &dispose drop ]
- [ address>> UnmapViewOfFile win32-error=0/f ] bi
- ] with-destructors ;
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
-Mackenzie Straight
+++ /dev/null
-Doug Coleman
-Slava Pestov
-Mackenzie Straight
+++ /dev/null
-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> 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* ;
-
-: <completion-port> ( handle existing -- handle )
- f 1 CreateIoCompletionPort dup win32-error=0/f ;
-
-SYMBOL: master-completion-port
-
-: <master-completion-port> ( -- handle )
- INVALID_HANDLE_VALUE f <completion-port> ;
-
-M: winnt add-completion ( win32-handle -- )
- handle>> master-completion-port get-global <completion-port> 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 <int> [ ! bytes
- f <void*> ! key
- f <void*> [ ! 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> 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 ;
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
-Slava Pestov
-Mackenzie Straight
+++ /dev/null
-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
+++ /dev/null
-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" <c-array>
- [ 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 ;
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
-Slava Pestov
-Mackenzie Straight
+++ /dev/null
-USING: io.launcher tools.test calendar accessors environment
-namespaces kernel system arrays io io.files io.encodings.ascii
-sequences parser assocs hashtables math continuations eval ;
-IN: io.windows.launcher.nt.tests
-
-[ ] [
- <process>
- "notepad" >>command
- 1/2 seconds >>timeout
- "notepad" set
-] unit-test
-
-[ f ] [ "notepad" get process-running? ] unit-test
-
-[ f ] [ "notepad" get process-started? ] unit-test
-
-[ ] [ "notepad" [ run-detached ] change ] unit-test
-
-[ "notepad" get wait-for-process ] must-fail
-
-[ t ] [ "notepad" get killed>> ] unit-test
-
-[ f ] [ "notepad" get process-running? ] unit-test
-
-[ ] [
- <process>
- vm "-quiet" "-run=hello-world" 3array >>command
- "out.txt" temp-file >>stdout
- try-process
-] unit-test
-
-[ "Hello world" ] [
- "out.txt" temp-file ascii file-lines first
-] unit-test
-
-[ ] [
- <process>
- vm "-run=listener" 2array >>command
- +closed+ >>stdin
- try-process
-] unit-test
-
-[ ] [
- "resource:basis/io/windows/nt/launcher/test" [
- <process>
- vm "-script" "stderr.factor" 3array >>command
- "out.txt" temp-file >>stdout
- "err.txt" temp-file >>stderr
- try-process
- ] with-directory
-] unit-test
-
-[ "output" ] [
- "out.txt" temp-file ascii file-lines first
-] unit-test
-
-[ "error" ] [
- "err.txt" temp-file ascii file-lines first
-] unit-test
-
-[ ] [
- "resource:basis/io/windows/nt/launcher/test" [
- <process>
- vm "-script" "stderr.factor" 3array >>command
- "out.txt" temp-file >>stdout
- +stdout+ >>stderr
- try-process
- ] with-directory
-] unit-test
-
-[ "outputerror" ] [
- "out.txt" temp-file ascii file-lines first
-] unit-test
-
-[ "output" ] [
- "resource:basis/io/windows/nt/launcher/test" [
- <process>
- vm "-script" "stderr.factor" 3array >>command
- "err2.txt" temp-file >>stderr
- ascii <process-reader> 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" [
- <process>
- vm "-script" "env.factor" 3array >>command
- ascii <process-reader> contents
- ] with-directory eval
-
- os-envs =
-] unit-test
-
-[ t ] [
- "resource:basis/io/windows/nt/launcher/test" [
- <process>
- vm "-script" "env.factor" 3array >>command
- +replace-environment+ >>environment-mode
- os-envs >>environment
- ascii <process-reader> contents
- ] with-directory eval
-
- os-envs =
-] unit-test
-
-[ "B" ] [
- "resource:basis/io/windows/nt/launcher/test" [
- <process>
- vm "-script" "env.factor" 3array >>command
- { { "A" "B" } } >>environment
- ascii <process-reader> contents
- ] with-directory eval
-
- "A" swap at
-] unit-test
-
-[ f ] [
- "resource:basis/io/windows/nt/launcher/test" [
- <process>
- vm "-script" "env.factor" 3array >>command
- { { "USERPROFILE" "XXX" } } >>environment
- +prepend-environment+ >>environment-mode
- ascii <process-reader> contents
- ] with-directory eval
-
- "USERPROFILE" swap at "XXX" =
-] unit-test
-
-2 [
- [ ] [
- <process>
- "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" [
- <process>
- vm "-script" "append.factor" 3array >>command
- "append-test" temp-file <appender> >>stdout
- try-process
- ] with-directory
- ] times
-
- "append-test" temp-file ascii file-contents
-] unit-test
+++ /dev/null
-! 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 <void*> [ ! 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? <win32-file> &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 ;
+++ /dev/null
-unportable
+++ /dev/null
-USE: io\r
-"Hello appender" print\r
+++ /dev/null
-USE: system
-USE: prettyprint
-USE: environment
-os-envs .
+++ /dev/null
-USE: io\r
-USE: namespaces\r
-\r
-"output" write flush\r
-"error" error-stream get stream-write error-stream get stream-flush\r
+++ /dev/null
-Doug Coleman
+++ /dev/null
-IN: io.windows.nt.monitors.tests\r
-USING: io.windows.nt.monitors tools.test ;\r
-\r
-\ fill-queue-thread must-infer\r
+++ /dev/null
-! 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 <uint>
- (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 <displaced-alien>
- (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 <buffered-port>
- recursive? >>recursive
- >>port
- dup [ fill-queue-thread ] curry
- "Windows monitor thread" spawn drop
- ] with-destructors ;
-
-M: win32-monitor dispose
- port>> dispose ;
+++ /dev/null
-unportable
+++ /dev/null
-! 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
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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 ;
+++ /dev/null
-unportable
+++ /dev/null
-USING: alien alien.c-types alien.syntax arrays continuations\r
-destructors generic io.mmap io.ports io.windows io.windows.files\r
-kernel libc math math.bitwise namespaces quotations sequences windows\r
-windows.advapi32 windows.kernel32 io.backend system accessors\r
-io.windows.privileges ;\r
-IN: io.windows.nt.privileges\r
-\r
-TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES\r
-\r
-! Security tokens\r
-! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/\r
-\r
-: (open-process-token) ( handle -- handle )\r
- { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" <c-object>\r
- [ OpenProcessToken win32-error=0/f ] keep *void* ;\r
-\r
-: open-process-token ( -- handle )\r
- #! remember to CloseHandle\r
- GetCurrentProcess (open-process-token) ;\r
-\r
-: with-process-token ( quot -- )\r
- #! quot: ( token-handle -- token-handle )\r
- [ open-process-token ] dip\r
- [ keep ] curry\r
- [ CloseHandle drop ] [ ] cleanup ; inline\r
-\r
-: lookup-privilege ( string -- luid )\r
- [ f ] dip "LUID" <c-object>\r
- [ LookupPrivilegeValue win32-error=0/f ] keep ;\r
-\r
-: make-token-privileges ( name ? -- obj )\r
- "TOKEN_PRIVILEGES" <c-object>\r
- 1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep\r
- "LUID_AND_ATTRIBUTES" malloc-array &free\r
- over set-TOKEN_PRIVILEGES-Privileges\r
-\r
- swap [\r
- SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges\r
- set-LUID_AND_ATTRIBUTES-Attributes\r
- ] when\r
-\r
- [ lookup-privilege ] dip\r
- [\r
- TOKEN_PRIVILEGES-Privileges\r
- set-LUID_AND_ATTRIBUTES-Luid\r
- ] keep ;\r
-\r
-M: winnt set-privilege ( name ? -- )\r
- [\r
- -rot 0 -rot make-token-privileges\r
- dup length f f AdjustTokenPrivileges win32-error=0/f\r
- ] with-process-token ;\r
+++ /dev/null
-unportable
+++ /dev/null
-Doug Coleman
-Slava Pestov
-Mackenzie Straight
+++ /dev/null
-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*" <c-object>
- [
- "void*" heap-size
- "DWORD" <c-object>
- 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
-
-: <ConnectEx-args> ( 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 <ConnectEx-args>
- 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
-
-: <AcceptEx-args> ( 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 <void*>
- 0 <int>
- f <void*>
- [ 0 <int> GetAcceptExSockaddrs ] keep *void* ; inline
-
-M: object (accept) ( server addr -- handle sockaddr )
- [
- <AcceptEx-args>
- {
- [ call-AcceptEx ]
- [ wait-for-socket drop ]
- [ sAcceptSocket>> <win32-socket> ]
- [ 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
-
-: <WSARecvFrom-args> ( 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 )
- [
- <WSARecvFrom-args>
- [ 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
-
-: <WSASendTo-args> ( 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 <uint> >>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 -- )
- [
- <WSASendTo-args>
- [ call-WSASendTo ]
- [ wait-for-socket drop ]
- bi
- ] with-destructors ;
+++ /dev/null
-unportable
+++ /dev/null
-Microsoft Windows XP/Vista native I/O implementation
+++ /dev/null
-unportable
+++ /dev/null
-USING: io.backend kernel continuations sequences\r
-system vocabs.loader combinators ;\r
-IN: io.windows.privileges\r
-\r
-HOOK: set-privilege io-backend ( name ? -- ) inline\r
-\r
-: with-privileges ( seq quot -- )\r
- over [ [ t set-privilege ] each ] curry compose\r
- swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline\r
-\r
-{\r
- { [ os winnt? ] [ "io.windows.nt.privileges" require ] }\r
- { [ os wince? ] [ "io.windows.ce.privileges" require ] }\r
-} cond\r
+++ /dev/null
-unportable
+++ /dev/null
-USING: kernel accessors io.sockets io.windows io.backend\r
-windows.winsock system destructors alien.c-types ;\r
-IN: io.windows.sockets\r
-\r
-HOOK: WSASocket-flags io-backend ( -- DWORD )\r
-\r
-TUPLE: win32-socket < win32-file ;\r
-\r
-: <win32-socket> ( handle -- win32-socket )\r
- win32-socket new-win32-handle ;\r
-\r
-M: win32-socket dispose ( stream -- )\r
- handle>> closesocket drop ;\r
-\r
-: unspecific-sockaddr/size ( addrspec -- sockaddr len )\r
- [ empty-sockaddr/size ] [ protocol-family ] bi\r
- pick set-sockaddr-in-family ;\r
-\r
-: opened-socket ( handle -- win32-socket )\r
- <win32-socket> |dispose dup add-completion ;\r
-\r
-: open-socket ( addrspec type -- win32-socket )\r
- [ protocol-family ] dip\r
- 0 f 0 WSASocket-flags WSASocket\r
- dup socket-error\r
- opened-socket ;\r
-\r
-M: object (get-local-address) ( socket addrspec -- sockaddr )\r
- [ handle>> ] dip empty-sockaddr/size <int>\r
- [ getsockname socket-error ] 2keep drop ;\r
-\r
-M: object (get-remote-address) ( socket addrspec -- sockaddr )\r
- [ handle>> ] dip empty-sockaddr/size <int>\r
- [ getpeername socket-error ] 2keep drop ;\r
-\r
-: bind-socket ( win32-socket sockaddr len -- )\r
- [ handle>> ] 2dip bind socket-error ;\r
-\r
-M: object ((client)) ( addrspec -- handle )\r
- [ SOCK_STREAM open-socket ] keep\r
- [ unspecific-sockaddr/size bind-socket ] [ drop ] 2bi ;\r
-\r
-: server-socket ( addrspec type -- fd )\r
- [ open-socket ] [ drop ] 2bi\r
- [ make-sockaddr/size bind-socket ] [ drop ] 2bi ;\r
-\r
-! http://support.microsoft.com/kb/127144\r
-! NOTE: Possibly tweak this because of SYN flood attacks\r
-: listen-backlog ( -- n ) HEX: 7fffffff ; inline\r
-\r
-M: object (server) ( addrspec -- handle )\r
- [\r
- SOCK_STREAM server-socket\r
- dup handle>> listen-backlog listen winsock-return-check\r
- ] with-destructors ;\r
-\r
-M: windows (datagram) ( addrspec -- handle )\r
- [ SOCK_DGRAM server-socket ] with-destructors ;\r
-\r
-M: windows addrinfo-error ( n -- )\r
- winsock-return-check ;\r
+++ /dev/null
-unportable
+++ /dev/null
-Microsoft Windows native I/O implementation
+++ /dev/null
-unportable
+++ /dev/null
-! 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 ;
-
-: <win32-handle> ( handle -- win32-handle )
- win32-handle new-win32-handle ;
-
-M: win32-handle dispose* ( handle -- )
- handle>> CloseHandle drop ;
-
-TUPLE: win32-file < win32-handle ptr ;
-
-: <win32-file> ( 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?
- <win32-file> |dispose
- dup add-completion ;
-
-: share-mode ( -- fixnum )
- {
- FILE_SHARE_READ
- FILE_SHARE_WRITE
- FILE_SHARE_DELETE
- } flags ; foldable
-
-: default-security-attributes ( -- obj )
- "SECURITY_ATTRIBUTES" <c-object>
- "SECURITY_ATTRIBUTES" heap-size
- over set-SECURITY_ATTRIBUTES-nLength ;
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: namespaces kernel io calendar sequences io.files\r
-io.sockets continuations destructors prettyprint assocs\r
-math.parser words debugger math combinators\r
-concurrency.messaging threads arrays init math.ranges strings\r
-calendar.format io.encodings.utf8 ;\r
+USING: namespaces kernel io io.files io.pathnames io.directories\r
+io.sockets io.encodings.utf8\r
+calendar calendar.format sequences continuations destructors\r
+prettyprint assocs math.parser words debugger math combinators\r
+concurrency.messaging threads arrays init math.ranges strings ;\r
IN: logging.server\r
\r
: log-root ( -- string )\r
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" } ] [
! 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 )
! 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
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 ;
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.
-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
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 )
! 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
IN: tools.deploy.tests\r
-USING: tools.test system io.files kernel tools.deploy.config\r
+USING: tools.test system io.pathnames io.files io.files.info\r
+io.files.temp kernel tools.deploy.config\r
tools.deploy.config.editor tools.deploy.backend math sequences\r
io.launcher arrays namespaces continuations layouts accessors\r
-io.encodings.ascii urls math.parser ;\r
+io.encodings.ascii urls math.parser io.directories ;\r
\r
: shake-and-bake ( vocab -- )\r
[ "test.image" temp-file delete-file ] ignore-errors\r
! 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
} 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 ;
! 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 ;
! 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 ;
! 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
! 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
<PRIVATE
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators kernel system unicode.case
-io.unix.files tools.files generalizations strings
-arrays sequences io.files math.parser unix.groups unix.users
+USING: accessors combinators kernel system unicode.case io.files
+io.files.info io.files.info.unix tools.files generalizations
+strings arrays sequences math.parser unix.groups unix.users
tools.files.private unix.stat math ;
IN: tools.files.unix
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs io.files hashtables kernel namespaces sequences
-vocabs.loader io combinators io.encodings.utf8 calendar accessors
-math.parser io.streams.string ui.tools.operations quotations
-strings arrays prettyprint words vocabs sorting sets
-classes math alien urls splitting ascii ;
+USING: assocs io.files io.pathnames io.directories
+io.encodings.utf8 hashtables kernel namespaces sequences
+vocabs.loader io combinators calendar accessors math.parser
+io.streams.string ui.tools.operations quotations strings arrays
+prettyprint words vocabs sorting sets classes math alien urls
+splitting ascii ;
IN: tools.scaffold
SYMBOL: developer-name
USING: accessors arrays assocs classes classes.builtin
classes.intersection classes.mixin classes.predicate
classes.singleton classes.tuple classes.union combinators
-definitions effects fry generic help help.markup
-help.stylesheet help.topics io io.files io.styles kernel macros
+definitions effects fry generic help help.markup help.stylesheet
+help.topics io io.files io.pathnames io.styles kernel macros
make namespaces prettyprint sequences sets sorting summary
tools.vocabs vocabs vocabs.loader words ;
IN: tools.vocabs.browser
-USING: tools.test tools.vocabs.monitor io.files ;
+USING: tools.test tools.vocabs.monitor io.pathnames ;
IN: tools.vocabs.monitor.tests
[ "kernel" ] [ "core/kernel/kernel.factor" path>vocab ] unit-test
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: threads io.files io.monitors init kernel\r
+USING: threads io.files io.pathnames io.monitors init kernel\r
vocabs vocabs.loader tools.vocabs namespaces continuations\r
sequences splitting assocs command-line concurrency.messaging\r
io.backend sets tr ;\r
! Copyright (C) 2007, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel io io.styles io.files io.encodings.utf8\r
-vocabs.loader vocabs sequences namespaces make math.parser\r
-arrays hashtables assocs memoize summary sorting splitting\r
-combinators source-files debugger continuations compiler.errors\r
-init checksums checksums.crc32 sets accessors generic\r
-definitions words ;\r
+USING: kernel io io.styles io.files io.files.info io.directories\r
+io.pathnames io.encodings.utf8 vocabs.loader vocabs sequences\r
+namespaces make math.parser arrays hashtables assocs memoize\r
+summary sorting splitting combinators source-files debugger\r
+continuations compiler.errors init checksums checksums.crc32\r
+sets accessors generic definitions words ;\r
IN: tools.vocabs\r
\r
: vocab-xref ( vocab quot -- vocabs )\r
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
-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 ;
! 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
! 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 ;
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
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
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
: 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" }
! 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 ;
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
-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
1601 1 1 0 0 0 instant <timestamp> ;
: 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+ ;
: windows-time>FILETIME ( n -- FILETIME )
"FILETIME" <c-object>
[
- [ 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 ;
! Copyright (C) 2007, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: io io.files io.encodings.utf8 namespaces http.server\r
-http.server.responses http.server.static http xmode.code2html\r
-kernel sequences accessors fry ;\r
+USING: io io.files io.pathnames io.encodings.utf8 namespaces\r
+http.server http.server.responses http.server.static http\r
+xmode.code2html kernel sequences accessors fry ;\r
IN: xmode.code2html.responder\r
\r
: <sources> ( root -- responder )\r
! 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
[ B{ CHAR: \n } join ] dip checksum-bytes ;
: checksum-file ( path checksum -- value )
- [ binary <file-reader> ] dip checksum-stream ;
+ #! normalize-path (file-reader) is equivalen to
+ #! binary <file-reader>. 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 ;
io.files.private quotations ;
IN: io.files
-ARTICLE: "file-streams" "Reading and writing files"
+ARTICLE: "io.files" "Reading and writing files"
"File streams:"
{ $subsection <file-reader> }
{ $subsection <file-writer> }
{ $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 <pathname> } ;
-
-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: <file-reader>
-{
- $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." } ;
{ 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 <pathname> } "." } ;
-
-HELP: normalize-path
-{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
-{ $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
-
-HELP: <pathname> ( 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." } ;
-
-
+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 <file-appender> 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 <file-reader>
+ [ 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 <file-reader>
+ [ 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 <file-reader> [
+ "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 <file-writer> 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
[ 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 <file-appender> 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
! 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 )
: with-file-appender ( path encoding quot -- )
[ <file-appender> ] 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 ;
-
-<PRIVATE
-
-: head-path-separator? ( path1 ? -- ?' )
- [
- [ t ] [ first path-separator? ] if-empty
- ] [
- drop f
- ] if ;
-
-: head.? ( path -- ? ) "." ?head head-path-separator? ;
-
-: head..? ( path -- ? ) ".." ?head head-path-separator? ;
-
-: append-path-empty ( path1 path2 -- path' )
- {
- { [ dup head.? ] [
- rest trim-left-separators append-path-empty
- ] }
- { [ dup head..? ] [ drop no-parent-directory ] }
- [ nip ]
- } cond ;
-
-PRIVATE>
-
-: 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
<PRIVATE
HOOK: cd io-backend ( path -- )
PRIVATE>
-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 <file-writer> [
- swap binary <file-reader> [
- 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> 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
"foo" "io.tests" lookup
] unit-test
-[
- "This is a line.\rThis is another line.\r"
-] [
- "resource:core/io/test/mac-os-eol.txt" latin1 <file-reader>
- [ 500 read ] with-input-stream
-] unit-test
-
-[
- 255
-] [
- "resource:core/io/test/binary.txt" latin1 <file-reader>
- [ 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 <file-reader> [
- "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
--- /dev/null
+Slava Pestov
+Doug Coleman
--- /dev/null
+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 <pathname> } "." } ;
+
+HELP: normalize-path
+{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
+{ $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
+
+HELP: <pathname> ( 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 <pathname> } ;
+
+ABOUT: "io.pathnames"
--- /dev/null
+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
--- /dev/null
+! 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 ;
+
+<PRIVATE
+
+: head-path-separator? ( path1 ? -- ?' )
+ [
+ [ t ] [ first path-separator? ] if-empty
+ ] [
+ drop f
+ ] if ;
+
+: head.? ( path -- ? ) "." ?head head-path-separator? ;
+
+: head..? ( path -- ? ) ".." ?head head-path-separator? ;
+
+: append-path-empty ( path1 path2 -- path' )
+ {
+ { [ dup head.? ] [
+ rest trim-left-separators append-path-empty
+ ] }
+ { [ dup head..? ] [ drop no-parent-directory ] }
+ [ nip ]
+ } cond ;
+
+PRIVATE>
+
+: 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> 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
--- /dev/null
+Pathname manipulation
-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
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
-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
! 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
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
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."
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 ;
! 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
! 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
-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 )
! 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
-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
! 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 ( -- )
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 ;
! 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 )
! 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
] 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
! 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 ;
! Copyright (C) 2008 William Schlieper\r
! See http://factorcode.org/license.txt for BSD license.\r
\r
-USING: kernel io.files parser editors sequences ;\r
+USING: kernel io.files io.pathnames parser editors sequences ;\r
\r
IN: irc.ui.load\r
\r
-USING: kernel io io.files io.monitors io.encodings.utf8 ;\r
+USING: kernel io io.files io.pathnames io.monitors io.encodings.utf8 ;\r
IN: log-viewer\r
\r
: read-lines ( stream -- )\r
! 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 ( -- )
! 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 )
! 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 ( -- )
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
! 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 -- )
! 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
! 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 ( -- )
! 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 -- )
! 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 )
! 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 ;
! 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
! 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 ( -- )
! 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
-
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
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 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 )
! 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
-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
-
-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 ( -- )
-
-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
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-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
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
{ $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 <rectangle> perimiter ." }
- { $code "3 <circle> perimiter ." }
+ { $code "100 20 <rectangle> perimeter ." }
+ { $code "3 <circle> perimeter ." }
}
{ $slide "Object system"
"New type, extending existing operations:"
{ $code
": hypotenuse ( x y -- z ) [ sq ] bi@ + sqrt ;"
""
- "M: triangle perimiter"
+ "M: triangle perimeter"
" [ base>> ] [ height>> ] bi"
" [ + ] [ hypotenuse ] 2bi + ;"
}
"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: } }
! 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 ;
! 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
! 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
;;; Code:
+(require 'fuel-base)
+(require 'fuel-log)
+
\f
;;; Default connection:
(add-hook 'comint-redirect-hook
'fuel-con--comint-redirect-hook))
-\f
-;;; 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) ""))
-
\f
;;; Requests handling:
(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))
(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)))))
(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)
(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))))
(require 'fuel-syntax)
(require 'fuel-connection)
+\f
+;;; 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))))
+
+
+\f
+;;; 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))
+
\f
;;; Retort and retort-error datatypes:
(defsubst fuel-eval--error-line-text (err)
(nth 3 (fuel-eval--error-lexer-p err)))
-\f
-;;; 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))
-
-\f
-;;; 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))))
-
-
\f
(provide 'fuel-eval)
;;; fuel-eval.el ends here
(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
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)))
--- /dev/null
+;;; 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 <jao@gnu.org>
+;; 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)
+
+\f
+;;; 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) ""))
+
+\f
+(provide 'fuel-log)
+;;; fuel-log.el ends here
(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)
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,
(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)
"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))))
\f
;;; Minor mode definition:
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>" "<PRIVATE"
"SINGLETON:" "SYMBOL:" "USE:" "VAR:"))))
(defun fuel-syntax--usings-update ()
(save-excursion
- (setq fuel-syntax--usings (list (fuel-syntax--current-vocab)))
+ (let ((in (fuel-syntax--current-vocab)))
+ (setq fuel-syntax--usings (and in (list in))))
(while (re-search-backward fuel-syntax--using-lines-regex nil t)
(dolist (u (split-string (match-string-no-properties 1) nil t))
(push u fuel-syntax--usings)))
return g_pagesize;
}
-void sleep_micros(DWORD usec)
+void sleep_micros(u64 usec)
{
- Sleep(usec);
+ Sleep((DWORD)(usec / 1000));
}
#define STRNCMP wcsncmp
#define STRDUP _wcsdup
-#define FIXNUM_FORMAT "%Id"
#define CELL_FORMAT "%lu"
-#define CELL_HEX_FORMAT "%Ix"
#ifdef WIN64
+ #define CELL_HEX_FORMAT "%Ix"
#define CELL_HEX_PAD_FORMAT "%016Ix"
+ #define FIXNUM_FORMAT "%Id"
#else
+ #define CELL_HEX_FORMAT "%lx"
#define CELL_HEX_PAD_FORMAT "%08lx"
+ #define FIXNUM_FORMAT "%ld"
#endif
-#define FIXNUM_FORMAT "%Id"
#define OPEN_READ(path) _wfopen(path,L"rb")
#define OPEN_WRITE(path) _wfopen(path,L"wb")
void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol);
void ffi_dlclose(F_DLL *dll);
-void sleep_micros(DWORD msec);
+void sleep_micros(u64 msec);
INLINE void init_signals(void) {}
INLINE void early_init(void) {}
projects / factor.git / commitdiff