: init-fd ( fd -- fd )
[
|dispose
- dup fd>> F_SETFL O_NONBLOCK fcntl io-error
- dup fd>> F_SETFD FD_CLOEXEC fcntl io-error
+ dup fd>> F_SETFL O_NONBLOCK [ fcntl ] unix-system-call io-error
+ dup fd>> F_SETFD FD_CLOEXEC [ fcntl ] unix-system-call io-error
] with-destructors ;
: <fd> ( n -- fd )
] if ;
M: unix tell-handle ( handle -- n )
- fd>> 0 SEEK_CUR lseek [ io-error ] [ ] bi ;
+ fd>> 0 SEEK_CUR [ lseek ] unix-system-call [ io-error ] [ ] bi ;
M: unix seek-handle ( n seek-type handle -- )
swap {
{ io:seek-end [ SEEK_END ] }
[ io:bad-seek-type ]
} case
- [ fd>> swap ] dip lseek io-error ;
+ [ fd>> swap ] dip [ lseek ] unix-system-call io-error ;
SYMBOL: +retry+ ! just try the operation again without blocking
SYMBOL: +input+
M: unix find-next-file ( DIR* -- dirent )
dirent <struct>
f <void*>
- [ readdir64_r 0 = [ (io-error) ] unless ] 2keep
+ [ [ readdir64_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep
*void* [ drop f ] unless ;
] if ;
M: unix move-file ( from to -- )
- [ normalize-path ] bi@ rename io-error ;
+ [ normalize-path ] bi@ [ rename ] unix-system-call io-error ;
M: unix delete-file ( path -- ) normalize-path unlink-file ;
M: unix make-directory ( path -- )
- normalize-path OCT: 777 mkdir io-error ;
+ normalize-path OCT: 777 [ mkdir ] unix-system-call io-error ;
M: unix delete-directory ( path -- )
- normalize-path rmdir io-error ;
+ normalize-path [ rmdir ] unix-system-call io-error ;
M: unix copy-file ( from to -- )
[ normalize-path ] bi@ call-next-method ;
: with-unix-directory ( path quot -- )
- [ opendir dup [ (io-error) ] unless ] dip
- dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline
+ [ [ opendir ] unix-system-call dup [ (io-error) ] unless ] dip
+ dupd curry swap '[ _ [ closedir ] unix-system-call io-error ] [ ] cleanup ; inline
HOOK: find-next-file os ( DIR* -- byte-array )
M: unix find-next-file ( DIR* -- byte-array )
dirent <struct>
f <void*>
- [ readdir_r 0 = [ (io-error) ] unless ] 2keep
+ [ [ readdir_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep
*void* [ drop f ] unless ;
: dirent-type>file-type ( ch -- type )
: chmod-set-bit ( path mask ? -- )
[ dup stat-mode ] 2dip
- [ bitor ] [ unmask ] if chmod io-error ;
+ [ bitor ] [ unmask ] if [ chmod ] unix-system-call io-error ;
GENERIC# file-mode? 1 ( obj mask -- ? )
: set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ;
: set-file-permissions ( path n -- )
- [ normalize-path ] dip chmod io-error ;
+ [ normalize-path ] dip [ chmod ] unix-system-call io-error ;
: file-permissions ( path -- n )
normalize-path file-info permissions>> ;
: set-file-times ( path timestamps -- )
#! set access, write
[ normalize-path ] dip
- timestamps>byte-array utimes io-error ;
+ timestamps>byte-array [ utimes ] unix-system-call io-error ;
: set-file-access-time ( path timestamp -- )
f 2array set-file-times ;
f swap 2array set-file-times ;
: set-file-ids ( path uid gid -- )
- [ normalize-path ] 2dip [ -1 or ] bi@ chown io-error ;
+ [ normalize-path ] 2dip [ -1 or ] bi@
+ [ chown ] unix-system-call io-error ;
GENERIC: set-file-user ( path string/id -- )
IN: io.files.links.unix
M: unix make-link ( path1 path2 -- )
- normalize-path symlink io-error ;
+ normalize-path [ symlink ] unix-system-call io-error ;
M: unix make-hard-link ( path1 path2 -- )
- normalize-path link io-error ;
+ normalize-path [ link ] unix-system-call io-error ;
M: unix read-link ( path -- path' )
normalize-path read-symbolic-link ;
IN: io.files.unix
M: unix cwd ( -- path )
- MAXPATHLEN [ <byte-array> ] keep getcwd
+ MAXPATHLEN [ <byte-array> ] keep
+ [ getcwd ] unix-system-call
[ (io-error) ] unless* ;
M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
: open-append ( path -- fd )
[
append-flags file-mode open-file |dispose
- dup 0 SEEK_END lseek io-error
+ dup 0 SEEK_END [ lseek ] unix-system-call io-error
] with-destructors ;
M: unix (file-appender) ( path -- stream )
[ (io-error) ]
} cond ;
-M: object establish-connection ( client-out remote -- )
- [ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi
+M:: object establish-connection ( client-out remote -- )
+ client-out remote
+ [ drop ]
+ [
+ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect
+ ] 2bi
{
{ [ 0 = ] [ drop ] }
+ { [ errno EINTR = ] [ drop client-out remote establish-connection ] }
{ [ errno EINPROGRESS = ] [
[ +output+ wait-for-port ] [ wait-to-connect ] bi
] }
} cond ;
: ?bind-client ( socket -- )
- bind-local-address get [ [ fd>> ] dip make-sockaddr/size bind io-error ] [ drop ] if* ; inline
+ bind-local-address get [
+ [ fd>> ] dip make-sockaddr/size
+ [ bind ] unix-system-call io-error
+ ] [
+ drop
+ ] if* ; inline
M: object ((client)) ( addrspec -- fd )
protocol-family SOCK_STREAM socket-fd
: server-socket-fd ( addrspec type -- fd )
[ dup protocol-family ] dip socket-fd
[ init-server-socket ] keep
- [ handle-fd swap make-sockaddr/size bind io-error ] keep ;
+ [ handle-fd swap make-sockaddr/size [ bind ] unix-system-call io-error ] keep ;
M: object (server) ( addrspec -- handle )
[
! Copyright (C) 2005, 2010 Slava Pestov.
! Copyright (C) 2008 Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.syntax kernel libc sequences
-continuations byte-arrays strings math namespaces system
-combinators combinators.smart vocabs.loader accessors
-stack-checker macros locals generalizations unix.types io vocabs
-classes.struct unix.time alien.libraries ;
+USING: accessors alien alien.c-types alien.libraries
+alien.syntax byte-arrays classes.struct combinators
+combinators.short-circuit combinators.smart continuations
+generalizations io kernel libc locals macros math namespaces
+sequences stack-checker strings system unix.time unix.types
+vocabs vocabs.loader ;
IN: unix
CONSTANT: PROT_NONE 0
ERROR: unix-system-call-error args errno message word ;
+: unix-call-failed? ( ret -- ? )
+ {
+ [ { [ integer? ] [ 0 < ] } 1&& ]
+ [ not ]
+ } 1|| ;
+
MACRO:: unix-system-call ( quot -- )
quot inputs :> n
quot first :> word
+ 0 :> ret!
+ f :> failed!
[
- n ndup quot call dup 0 < [
- drop
+ [
+ n ndup quot call ret!
+ ret {
+ [ unix-call-failed? dup failed! ]
+ [ drop errno EINTR = ]
+ } 1&&
+ ] loop
+ failed [
n narray
errno dup strerror
word unix-system-call-error
] [
- n nnip
+ n ndrop
+ ret
] if
] ;