Merge branch 'master' into new_codegen
Slava Pestov
commit
2438c78c6c
|
|
@ -96,9 +96,9 @@ M: ppc %epilogue ( n -- )
|
|||
1 1 rot ADDI
|
||||
0 MTLR ;
|
||||
|
||||
: (%call) ( -- ) 11 MTLR BLRL ;
|
||||
: (%call) ( reg -- ) MTLR BLRL ;
|
||||
|
||||
: (%jump) ( -- ) 11 MTCTR BCTR ;
|
||||
: (%jump) ( reg -- ) MTCTR BCTR ;
|
||||
|
||||
: %load-dlsym ( symbol dll register -- )
|
||||
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
|
||||
|
|
@ -117,7 +117,7 @@ M: ppc %dispatch ( -- )
|
|||
"offset" operand "n" operand 1 SRAWI
|
||||
11 11 "offset" operand ADD
|
||||
11 dup 6 cells LWZ
|
||||
(%jump)
|
||||
11 (%jump)
|
||||
] H{
|
||||
{ +input+ { { f "n" } } }
|
||||
{ +scratch+ { { f "offset" } } }
|
||||
|
|
@ -244,17 +244,17 @@ M: ppc %prepare-alien-invoke
|
|||
rs-reg 11 12 STW ;
|
||||
|
||||
M: ppc %alien-invoke ( symbol dll -- )
|
||||
11 %load-dlsym (%call) ;
|
||||
11 %load-dlsym 11 (%call) ;
|
||||
|
||||
M: ppc %alien-callback ( quot -- )
|
||||
3 load-indirect "c_to_factor" f %alien-invoke ;
|
||||
|
||||
M: ppc %prepare-alien-indirect ( -- )
|
||||
"unbox_alien" f %alien-invoke
|
||||
3 11 MR ;
|
||||
13 3 MR ;
|
||||
|
||||
M: ppc %alien-indirect ( -- )
|
||||
(%call) ;
|
||||
13 (%call) ;
|
||||
|
||||
M: ppc %callback-value ( ctype -- )
|
||||
! Save top of data stack
|
||||
|
|
|
|||
|
|
@ -172,7 +172,7 @@ HELP: sql-row-typed
|
|||
HELP: with-db
|
||||
{ $values
|
||||
{ "db" db } { "quot" quotation } }
|
||||
{ $description "Calls the quotation with a database bound to the " { $link db } " symbol. The database called is based on the " { $snippet "class" } " with the " } ;
|
||||
{ $description "Calls the quotation with a database bound to the " { $link db } " symbol. See " { $link "db-custom-database-combinators" } " for help setting up database access." } ;
|
||||
|
||||
HELP: with-transaction
|
||||
{ $values
|
||||
|
|
|
|||
|
|
@ -0,0 +1,277 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes help.markup help.syntax io.streams.string
|
||||
strings math calendar io.files ;
|
||||
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
|
||||
{ "path" "a pathname string" }
|
||||
{ "?" "a boolean" } }
|
||||
{ $description "Tests whether the " { $snippet "group execute" } " bit is set on a file." } ;
|
||||
|
||||
HELP: group-read?
|
||||
{ $values
|
||||
{ "path" "a pathname string" }
|
||||
{ "?" "a boolean" } }
|
||||
{ $description "Tests whether the " { $snippet "group read" } " bit is set on a file." } ;
|
||||
|
||||
HELP: group-write?
|
||||
{ $values
|
||||
{ "path" "a pathname string" }
|
||||
{ "?" "a boolean" } }
|
||||
{ $description "Tests whether the " { $snippet "group write" } " bit is set on a file." } ;
|
||||
|
||||
HELP: other-execute?
|
||||
{ $values
|
||||
{ "path" "a pathname string" }
|
||||
{ "?" "a boolean" } }
|
||||
{ $description "Tests whether the " { $snippet "other execute" } " bit is set on a file." } ;
|
||||
|
||||
HELP: other-read?
|
||||
{ $values
|
||||
{ "path" "a pathname string" }
|
||||
{ "?" "a boolean" } }
|
||||
{ $description "Tests whether the " { $snippet "other read" } " bit is set on a file." } ;
|
||||
|
||||
HELP: other-write?
|
||||
{ $values
|
||||
{ "path" "a pathname string" }
|
||||
{ "?" "a boolean" } }
|
||||
{ $description "Tests whether the " { $snippet "other write" } " bit is set on a file." } ;
|
||||
|
||||
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
|
||||
{ "path" "a pathname string" }
|
||||
{ "?" "a boolean" } }
|
||||
{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file." } ;
|
||||
|
||||
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
|
||||
{ "path" "a pathname string" }
|
||||
{ "?" "a boolean" } }
|
||||
{ $description "Tests whether the " { $snippet "sticky" } " bit of a file is set." } ;
|
||||
|
||||
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
|
||||
{ "path" "a pathname string" }
|
||||
{ "?" "a boolean" } }
|
||||
{ $description "Tests whether the " { $snippet "uid" } " bit of a file is set." } ;
|
||||
|
||||
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
|
||||
{ "path" "a pathname string" }
|
||||
{ "?" "a boolean" } }
|
||||
{ $description "Tests whether the " { $snippet "user execute" } " bit is set on a file." } ;
|
||||
|
||||
HELP: user-read?
|
||||
{ $values
|
||||
{ "path" "a pathname string" }
|
||||
{ "?" "a boolean" } }
|
||||
{ $description "Tests whether the " { $snippet "user read" } " bit is set on a file." } ;
|
||||
|
||||
HELP: user-write?
|
||||
{ $values
|
||||
{ "path" "a pathname string" }
|
||||
{ "?" "a boolean" } }
|
||||
{ $description "Tests whether the " { $snippet "user write" } " bit is set on a file." } ;
|
||||
|
||||
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"
|
||||
|
|
@ -1,4 +1,6 @@
|
|||
USING: tools.test io.files ;
|
||||
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
|
||||
|
|
@ -27,3 +29,109 @@ IN: io.unix.files.tests
|
|||
[ "/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
|
||||
|
||||
[ t ]
|
||||
[ test-file f set-other-write perms OCT: 774 = ] unit-test
|
||||
|
||||
[ t ]
|
||||
[ test-file f set-other-read perms OCT: 770 = ] unit-test
|
||||
|
||||
[ t ]
|
||||
[ test-file f set-group-execute perms OCT: 760 = ] unit-test
|
||||
|
||||
[ t ]
|
||||
[ test-file f set-group-write perms OCT: 740 = ] unit-test
|
||||
|
||||
[ t ]
|
||||
[ test-file f set-group-read perms OCT: 700 = ] unit-test
|
||||
|
||||
[ t ]
|
||||
[ test-file f set-user-execute perms OCT: 600 = ] unit-test
|
||||
|
||||
[ t ]
|
||||
[ test-file f set-user-write perms OCT: 400 = ] unit-test
|
||||
|
||||
[ t ]
|
||||
[ test-file f set-user-read perms OCT: 000 = ] 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
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! 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 ;
|
||||
|
||||
io.files.private destructors vocabs.loader calendar.unix
|
||||
unix.stat alien.c-types arrays unix.users unix.groups ;
|
||||
IN: io.unix.files
|
||||
|
||||
M: unix cwd ( -- path )
|
||||
|
|
@ -136,3 +136,122 @@ os {
|
|||
{ freebsd [ "io.unix.files.bsd" require ] }
|
||||
{ linux [ ] }
|
||||
} case
|
||||
|
||||
<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 ;
|
||||
|
||||
: file-mode? ( path mask -- ? ) [ stat-mode ] dip mask? ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: 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? ( path -- ? ) UID file-mode? ;
|
||||
: gid? ( path -- ? ) GID file-mode? ;
|
||||
: sticky? ( path -- ? ) STICKY file-mode? ;
|
||||
: user-read? ( path -- ? ) USER-READ file-mode? ;
|
||||
: user-write? ( path -- ? ) USER-WRITE file-mode? ;
|
||||
: user-execute? ( path -- ? ) USER-EXECUTE file-mode? ;
|
||||
: group-read? ( path -- ? ) GROUP-READ file-mode? ;
|
||||
: group-write? ( path -- ? ) GROUP-WRITE file-mode? ;
|
||||
: group-execute? ( path -- ? ) GROUP-EXECUTE file-mode? ;
|
||||
: other-read? ( path -- ? ) OTHER-READ file-mode? ;
|
||||
: other-write? ( path -- ? ) OTHER-WRITE file-mode? ;
|
||||
: other-execute? ( path -- ? ) OTHER-EXECUTE file-mode? ;
|
||||
|
||||
: 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 )
|
||||
[ length "timeval" <c-array> ] keep
|
||||
dup length [ over [ pick set-timeval-nth ] [ 2drop ] if ] 2each ;
|
||||
|
||||
: timestamp>timeval ( timestamp -- timeval )
|
||||
unix-1970 time- duration>milliseconds 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 ;
|
||||
|
|
|
|||
|
|
@ -421,7 +421,7 @@ M: lambda-macro definition
|
|||
"lambda" word-prop body>> ;
|
||||
|
||||
M: lambda-macro reset-word
|
||||
[ f "lambda" set-word-prop ] [ call-next-method ] bi ;
|
||||
[ call-next-method ] [ f "lambda" set-word-prop ] bi ;
|
||||
|
||||
INTERSECTION: lambda-method method-body lambda-word ;
|
||||
|
||||
|
|
|
|||
|
|
@ -420,15 +420,25 @@ M: windows-ui-backend do-events
|
|||
style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
|
||||
|
||||
: make-RECT ( world -- RECT )
|
||||
dup window-loc>> { 40 40 } vmax dup rot rect-dim v+
|
||||
dup window-loc>> dup rot rect-dim v+
|
||||
"RECT" <c-object>
|
||||
over first over set-RECT-right
|
||||
swap second over set-RECT-bottom
|
||||
over first over set-RECT-left
|
||||
swap second over set-RECT-top ;
|
||||
|
||||
: default-position-RECT ( RECT -- )
|
||||
dup get-RECT-dimensions [ 2drop ] 2dip
|
||||
CW_USEDEFAULT + pick set-RECT-bottom
|
||||
CW_USEDEFAULT + over set-RECT-right
|
||||
CW_USEDEFAULT over set-RECT-left
|
||||
CW_USEDEFAULT swap set-RECT-top ;
|
||||
|
||||
: make-adjusted-RECT ( rect -- RECT )
|
||||
make-RECT dup adjust-RECT ;
|
||||
make-RECT
|
||||
dup get-RECT-top-left [ zero? ] both? swap
|
||||
dup adjust-RECT
|
||||
swap [ dup default-position-RECT ] when ;
|
||||
|
||||
: create-window ( rect -- hwnd )
|
||||
make-adjusted-RECT
|
||||
|
|
|
|||
|
|
@ -48,6 +48,19 @@ C-STRUCT: sockaddr-un
|
|||
{ "uchar" "family" }
|
||||
{ { "char" 104 } "path" } ;
|
||||
|
||||
C-STRUCT: passwd
|
||||
{ "char*" "pw_name" }
|
||||
{ "char*" "pw_passwd" }
|
||||
{ "uid_t" "pw_uid" }
|
||||
{ "gid_t" "pw_gid" }
|
||||
{ "time_t" "pw_change" }
|
||||
{ "char*" "pw_class" }
|
||||
{ "char*" "pw_gecos" }
|
||||
{ "char*" "pw_dir" }
|
||||
{ "char*" "pw_shell" }
|
||||
{ "time_t" "pw_expire" }
|
||||
{ "int" "pw_fields" } ;
|
||||
|
||||
: max-un-path 104 ; inline
|
||||
|
||||
: SOCK_STREAM 1 ; inline
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: alien.syntax ;
|
||||
USING: alien.syntax unix.time ;
|
||||
IN: unix
|
||||
|
||||
: FD_SETSIZE 1024 ; inline
|
||||
|
|
@ -13,19 +13,6 @@ C-STRUCT: addrinfo
|
|||
{ "void*" "addr" }
|
||||
{ "addrinfo*" "next" } ;
|
||||
|
||||
C-STRUCT: passwd
|
||||
{ "char*" "pw_name" }
|
||||
{ "char*" "pw_passwd" }
|
||||
{ "uid_t" "pw_uid" }
|
||||
{ "gid_t" "pw_gid" }
|
||||
{ "time_t" "pw_change" }
|
||||
{ "char*" "pw_class" }
|
||||
{ "char*" "pw_gecos" }
|
||||
{ "char*" "pw_dir" }
|
||||
{ "char*" "pw_shell" }
|
||||
{ "time_t" "pw_expire" }
|
||||
{ "int" "pw_fields" } ;
|
||||
|
||||
: EPERM 1 ; inline
|
||||
: ENOENT 2 ; inline
|
||||
: ESRCH 3 ; inline
|
||||
|
|
@ -130,3 +117,18 @@ C-STRUCT: passwd
|
|||
: ETIME 101 ; inline
|
||||
: EOPNOTSUPP 102 ; inline
|
||||
: ENOPOLICY 103 ; inline
|
||||
|
||||
: _UTX_USERSIZE 256 ; inline
|
||||
: _UTX_LINESIZE 32 ; inline
|
||||
: _UTX_IDSIZE 4 ; inline
|
||||
: _UTX_HOSTSIZE 256 ; inline
|
||||
|
||||
C-STRUCT: utmpx
|
||||
{ { "char" _UTX_USERSIZE } "ut_user" }
|
||||
{ { "char" _UTX_IDSIZE } "ut_id" }
|
||||
{ { "char" _UTX_LINESIZE } "ut_line" }
|
||||
{ "pid_t" "ut_pid" }
|
||||
{ "short" "ut_type" }
|
||||
{ "timeval" "ut_tv" }
|
||||
{ { "char" _UTX_HOSTSIZE } "ut_host" }
|
||||
{ { "uint" 16 } "ut_pad" } ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: alien.syntax ;
|
||||
USING: alien.syntax alien.c-types math vocabs.loader ;
|
||||
IN: unix
|
||||
|
||||
: FD_SETSIZE 256 ; inline
|
||||
|
|
@ -111,3 +111,24 @@ C-STRUCT: addrinfo
|
|||
: ENOLINK 95 ; inline
|
||||
: EPROTO 96 ; inline
|
||||
: ELAST 96 ; inline
|
||||
|
||||
TYPEDEF: __uint8_t sa_family_t
|
||||
|
||||
: _UTX_USERSIZE 32 ; inline
|
||||
: _UTX_LINESIZE 32 ; inline
|
||||
: _UTX_IDSIZE 4 ; inline
|
||||
: _UTX_HOSTSIZE 256 ; inline
|
||||
|
||||
: _SS_MAXSIZE ( -- n )
|
||||
128 ; inline
|
||||
|
||||
: _SS_ALIGNSIZE ( -- n )
|
||||
"__int64_t" heap-size ; inline
|
||||
|
||||
: _SS_PAD1SIZE ( -- n )
|
||||
_SS_ALIGNSIZE 2 - ; inline
|
||||
|
||||
: _SS_PAD2SIZE ( -- n )
|
||||
_SS_MAXSIZE 2 - _SS_PAD1SIZE - _SS_ALIGNSIZE - ; inline
|
||||
|
||||
"unix.bsd.netbsd.structs" require
|
||||
|
|
|
|||
|
|
@ -0,0 +1,29 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax unix.time ;
|
||||
IN: unix
|
||||
|
||||
C-STRUCT: sockaddr_storage
|
||||
{ "__uint8_t" "ss_len" }
|
||||
{ "sa_family_t" "ss_family" }
|
||||
{ { "char" _SS_PAD1SIZE } "__ss_pad1" }
|
||||
{ "__int64_t" "__ss_align" }
|
||||
{ { "char" _SS_PAD2SIZE } "__ss_pad2" } ;
|
||||
|
||||
C-STRUCT: exit_struct
|
||||
{ "uint16_t" "e_termination" }
|
||||
{ "uint16_t" "e_exit" } ;
|
||||
|
||||
C-STRUCT: utmpx
|
||||
{ { "char" _UTX_USERSIZE } "ut_user" }
|
||||
{ { "char" _UTX_IDSIZE } "ut_id" }
|
||||
{ { "char" _UTX_LINESIZE } "ut_line" }
|
||||
{ { "char" _UTX_HOSTSIZE } "ut_host" }
|
||||
{ "uint16_t" "ut_session" }
|
||||
{ "uint16_t" "ut_type" }
|
||||
{ "pid_t" "ut_pid" }
|
||||
{ "exit_struct" "ut_exit" }
|
||||
{ "sockaddr_storage" "ut_ss" }
|
||||
{ "timeval" "ut_tv" }
|
||||
{ { "uint32_t" 10 } "ut_pad" } ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,108 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax io.streams.string kernel quotations sequences strings math ;
|
||||
IN: unix.groups
|
||||
|
||||
HELP: all-groups
|
||||
{ $values
|
||||
|
||||
{ "seq" sequence } }
|
||||
{ $description "Returns a sequence of " { $link group } " tuples that are platform-dependent and field for field complete with the Unix " { $link group } " structure." } ;
|
||||
|
||||
HELP: effective-group-id
|
||||
{ $values
|
||||
|
||||
{ "string" string } }
|
||||
{ $description "Returns the effective group id for the current user." } ;
|
||||
|
||||
HELP: effective-group-name
|
||||
{ $values
|
||||
|
||||
{ "string" string } }
|
||||
{ $description "Returns the effective group name for the current user." } ;
|
||||
|
||||
HELP: group
|
||||
{ $description "A platform-specific tuple corresponding to every field from the Unix group struct including the group name, the group id, the group passwd, and a list of users in each group." } ;
|
||||
|
||||
HELP: group-cache
|
||||
{ $description "A symbol containing a cache of groups returned from " { $link all-groups } " and indexed by group id. Can be more efficient than using the system call words for many group lookups." } ;
|
||||
|
||||
HELP: group-id
|
||||
{ $values
|
||||
{ "string" string }
|
||||
{ "id" integer } }
|
||||
{ $description "Returns the group id given a group name." } ;
|
||||
|
||||
HELP: group-name
|
||||
{ $values
|
||||
{ "id" integer }
|
||||
{ "string" string } }
|
||||
{ $description "Returns the group name given a group id." } ;
|
||||
|
||||
HELP: group-struct
|
||||
{ $values
|
||||
{ "obj" object }
|
||||
{ "group" "a group struct" } }
|
||||
{ $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ;
|
||||
|
||||
HELP: real-group-id
|
||||
{ $values
|
||||
|
||||
{ "id" integer } }
|
||||
{ $description "Returns the real group id for the current user." } ;
|
||||
|
||||
HELP: real-group-name
|
||||
{ $values
|
||||
|
||||
{ "string" string } }
|
||||
{ $description "Returns the real group name for the current user." } ;
|
||||
|
||||
HELP: set-effective-group
|
||||
{ $values
|
||||
{ "obj" object } }
|
||||
{ $description "Sets the effective group id for the current user." } ;
|
||||
|
||||
HELP: set-real-group
|
||||
{ $values
|
||||
{ "obj" object } }
|
||||
{ $description "Sets the real group id for the current user." } ;
|
||||
|
||||
HELP: user-groups
|
||||
{ $values
|
||||
{ "string/id" "a string or a group id" }
|
||||
{ "seq" sequence } }
|
||||
{ $description "Returns the sequence of groups to which the user belongs." } ;
|
||||
|
||||
HELP: with-effective-group
|
||||
{ $values
|
||||
{ "string/id" "a string or a group id" } { "quot" quotation } }
|
||||
{ $description "Sets the effective group name and calls the quotation. Restors the effective group name on success or on error after the call." } ;
|
||||
|
||||
HELP: with-group-cache
|
||||
{ $values
|
||||
{ "quot" quotation } }
|
||||
{ $description "Iterates over the group file using library calls and creates a cache in the " { $link group-cache } " symbol. The cache is a hashtable indexed by group id. When looking up many groups, this approach is much faster than calling system calls." } ;
|
||||
|
||||
HELP: with-real-group
|
||||
{ $values
|
||||
{ "string/id" "a string or a group id" } { "quot" quotation } }
|
||||
{ $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call." } ;
|
||||
|
||||
ARTICLE: "unix.groups" "unix.groups"
|
||||
"The " { $vocab-link "unix.groups" } " vocabulary contains words that return information about Unix groups."
|
||||
"Listing all groups:"
|
||||
{ $subsection all-groups }
|
||||
"Returning a passwd tuple:"
|
||||
"Real groups:"
|
||||
{ $subsection real-group-name }
|
||||
{ $subsection real-group-id }
|
||||
{ $subsection set-real-group }
|
||||
"Effective groups:"
|
||||
{ $subsection effective-group-name }
|
||||
{ $subsection effective-group-id }
|
||||
{ $subsection set-effective-group }
|
||||
"Combinators to change groups:"
|
||||
{ $subsection with-real-group }
|
||||
{ $subsection with-effective-group } ;
|
||||
|
||||
ABOUT: "unix.groups"
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test unix.groups kernel strings math ;
|
||||
IN: unix.groups.tests
|
||||
|
||||
|
||||
[ ] [ all-groups drop ] unit-test
|
||||
|
||||
\ all-groups must-infer
|
||||
|
||||
[ t ] [ real-group-name string? ] unit-test
|
||||
[ t ] [ effective-group-name string? ] unit-test
|
||||
|
||||
[ t ] [ real-group-id integer? ] unit-test
|
||||
[ t ] [ effective-group-id integer? ] unit-test
|
||||
|
||||
[ ] [ real-group-id set-real-group ] unit-test
|
||||
[ ] [ effective-group-id set-effective-group ] unit-test
|
||||
|
||||
[ ] [ real-group-name [ ] with-real-group ] unit-test
|
||||
[ ] [ real-group-id [ ] with-real-group ] unit-test
|
||||
|
||||
[ ] [ effective-group-name [ ] with-effective-group ] unit-test
|
||||
[ ] [ effective-group-id [ ] with-effective-group ] unit-test
|
||||
|
|
@ -0,0 +1,132 @@
|
|||
! 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
|
||||
combinators.short-circuit byte-arrays combinators qualified
|
||||
accessors math.parser fry assocs namespaces continuations
|
||||
unix.users ;
|
||||
IN: unix.groups
|
||||
|
||||
QUALIFIED: grouping
|
||||
|
||||
TUPLE: group id name passwd members ;
|
||||
|
||||
SYMBOL: group-cache
|
||||
|
||||
GENERIC: group-struct ( obj -- group )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: group-members ( group-struct -- seq )
|
||||
group-gr_mem
|
||||
[ dup { [ ] [ *void* ] } 1&& ]
|
||||
[
|
||||
dup *void* utf8 alien>string
|
||||
[ alien-address "char**" heap-size + <alien> ] dip
|
||||
] [ ] produce nip ;
|
||||
|
||||
: (group-struct) ( id -- group-struct id group-struct byte-array length void* )
|
||||
"group" <c-object> tuck 4096
|
||||
[ <byte-array> ] keep f <void*> ;
|
||||
|
||||
M: integer group-struct ( id -- group )
|
||||
(group-struct) getgrgid_r io-error ;
|
||||
|
||||
M: string group-struct ( string -- group )
|
||||
(group-struct) getgrnam_r 0 = [ (io-error) ] unless ;
|
||||
|
||||
: group-struct>group ( group-struct -- group )
|
||||
[ \ group new ] dip
|
||||
{
|
||||
[ group-gr_name >>name ]
|
||||
[ group-gr_passwd >>passwd ]
|
||||
[ group-gr_gid >>id ]
|
||||
[ group-members >>members ]
|
||||
} cleave ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: group-name ( id -- string )
|
||||
dup group-cache get [
|
||||
at
|
||||
] [
|
||||
group-struct group-gr_name
|
||||
] if*
|
||||
[ nip ] [ number>string ] if* ;
|
||||
|
||||
: group-id ( string -- id )
|
||||
group-struct group-gr_gid ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: >groups ( byte-array n -- groups )
|
||||
[ 4 grouping:group ] dip head-slice [ *uint group-name ] map ;
|
||||
|
||||
: (user-groups) ( string -- seq )
|
||||
#! first group is -1337, legacy unix code
|
||||
-1337 NGROUPS_MAX [ 4 * <byte-array> ] keep
|
||||
<int> [ getgrouplist io-error ] 2keep
|
||||
[ 4 tail-slice ] [ *int 1- ] bi* >groups ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: user-groups ( string/id -- seq )
|
||||
|
||||
M: string user-groups ( string -- seq )
|
||||
(user-groups) ;
|
||||
|
||||
M: integer user-groups ( id -- seq )
|
||||
username (user-groups) ;
|
||||
|
||||
: all-groups ( -- seq )
|
||||
[ getgrent dup ] [ group-struct>group ] [ drop ] produce ;
|
||||
|
||||
: with-group-cache ( quot -- )
|
||||
all-groups [ [ id>> ] keep ] H{ } map>assoc
|
||||
group-cache rot with-variable ; inline
|
||||
|
||||
: real-group-id ( -- id )
|
||||
getgid ; inline
|
||||
|
||||
: real-group-name ( -- string )
|
||||
real-group-id group-name ; inline
|
||||
|
||||
: effective-group-id ( -- string )
|
||||
getegid ; inline
|
||||
|
||||
: effective-group-name ( -- string )
|
||||
effective-group-id group-name ; inline
|
||||
|
||||
GENERIC: set-real-group ( obj -- )
|
||||
|
||||
GENERIC: set-effective-group ( obj -- )
|
||||
|
||||
: with-real-group ( string/id quot -- )
|
||||
'[ _ set-real-group @ ]
|
||||
real-group-id '[ _ set-real-group ] [ ] cleanup ; inline
|
||||
|
||||
: with-effective-group ( string/id quot -- )
|
||||
'[ _ set-effective-group @ ]
|
||||
effective-group-id '[ _ set-effective-group ] [ ] cleanup ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (set-real-group) ( id -- )
|
||||
setgid io-error ; inline
|
||||
|
||||
: (set-effective-group) ( id -- )
|
||||
setegid io-error ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: string set-real-group ( string -- )
|
||||
group-id (set-real-group) ;
|
||||
|
||||
M: integer set-real-group ( id -- )
|
||||
(set-real-group) ;
|
||||
|
||||
M: integer set-effective-group ( id -- )
|
||||
(set-effective-group) ;
|
||||
|
||||
M: string set-effective-group ( string -- )
|
||||
group-id (set-effective-group) ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -8,7 +8,7 @@ C-STRUCT: stat
|
|||
{ "dev_t" "st_dev" }
|
||||
{ "mode_t" "st_mode" }
|
||||
{ "nlink_t" "st_nlink" }
|
||||
{ "ino_t" "st_ino" }
|
||||
{ "ino64_t" "st_ino" }
|
||||
{ "uid_t" "st_uid" }
|
||||
{ "gid_t" "st_gid" }
|
||||
{ "dev_t" "st_rdev" }
|
||||
|
|
|
|||
|
|
@ -1,12 +1,8 @@
|
|||
|
||||
USING: kernel system combinators alien.syntax alien.c-types
|
||||
math io.unix.backend vocabs.loader unix ;
|
||||
|
||||
math io.unix.backend vocabs.loader unix ;
|
||||
IN: unix.stat
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! File Types
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: S_IFMT OCT: 170000 ; ! These bits determine file type.
|
||||
|
||||
|
|
@ -18,54 +14,24 @@ IN: unix.stat
|
|||
: S_IFLNK OCT: 120000 ; inline ! Symbolic link.
|
||||
: S_IFSOCK OCT: 140000 ; inline ! Socket.
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! File Access Permissions
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! Read, write, execute/search by owner
|
||||
: S_IRWXU OCT: 0000700 ; inline ! rwx mask owner
|
||||
: S_IRUSR OCT: 0000400 ; inline ! r owner
|
||||
: S_IWUSR OCT: 0000200 ; inline ! w owner
|
||||
: S_IXUSR OCT: 0000100 ; inline ! x owner
|
||||
! Read, write, execute/search by group
|
||||
: S_IRWXG OCT: 0000070 ; inline ! rwx mask group
|
||||
: S_IRGRP OCT: 0000040 ; inline ! r group
|
||||
: S_IWGRP OCT: 0000020 ; inline ! w group
|
||||
: S_IXGRP OCT: 0000010 ; inline ! x group
|
||||
! Read, write, execute/search by others
|
||||
: S_IRWXO OCT: 0000007 ; inline ! rwx mask other
|
||||
: S_IROTH OCT: 0000004 ; inline ! r other
|
||||
: S_IWOTH OCT: 0000002 ; inline ! w other
|
||||
: S_IXOTH OCT: 0000001 ; inline ! x other
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
FUNCTION: int chmod ( char* path, mode_t mode ) ;
|
||||
|
||||
FUNCTION: int fchmod ( int fd, mode_t mode ) ;
|
||||
|
||||
FUNCTION: int mkdir ( char* path, mode_t mode ) ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
<<
|
||||
os
|
||||
{
|
||||
<< os {
|
||||
{ linux [ "unix.stat.linux" require ] }
|
||||
{ macosx [ "unix.stat.macosx" require ] }
|
||||
{ freebsd [ "unix.stat.freebsd" require ] }
|
||||
{ netbsd [ "unix.stat.netbsd" require ] }
|
||||
{ openbsd [ "unix.stat.openbsd" require ] }
|
||||
}
|
||||
case
|
||||
>>
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
} case >>
|
||||
|
||||
: file-status ( pathname -- stat )
|
||||
"stat" <c-object> dup >r
|
||||
[ stat ] unix-system-call drop
|
||||
r> ;
|
||||
"stat" <c-object> [
|
||||
[ stat ] unix-system-call drop
|
||||
] keep ;
|
||||
|
||||
: link-status ( pathname -- stat )
|
||||
"stat" <c-object> dup >r
|
||||
[ lstat ] unix-system-call drop
|
||||
r> ;
|
||||
"stat" <c-object> [
|
||||
[ lstat ] unix-system-call drop
|
||||
] keep ;
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@ TYPEDEF: __uint32_t uid_t
|
|||
TYPEDEF: __uint32_t gid_t
|
||||
TYPEDEF: __int64_t off_t
|
||||
TYPEDEF: __int64_t blkcnt_t
|
||||
TYPEDEF: __int64_t ino64_t
|
||||
TYPEDEF: __int32_t blksize_t
|
||||
TYPEDEF: long ssize_t
|
||||
TYPEDEF: __int32_t pid_t
|
||||
|
|
|
|||
|
|
@ -3,6 +3,29 @@ system ;
|
|||
IN: unix.types
|
||||
|
||||
TYPEDEF: void* caddr_t
|
||||
TYPEDEF: uint in_addr_t
|
||||
TYPEDEF: uint socklen_t
|
||||
|
||||
TYPEDEF: char int8_t
|
||||
TYPEDEF: short int16_t
|
||||
TYPEDEF: int int32_t
|
||||
TYPEDEF: longlong int64_t
|
||||
|
||||
TYPEDEF: uchar uint8_t
|
||||
TYPEDEF: ushort uint16_t
|
||||
TYPEDEF: uint uint32_t
|
||||
TYPEDEF: ulonglong uint64_t
|
||||
|
||||
TYPEDEF: char __int8_t
|
||||
TYPEDEF: short __int16_t
|
||||
TYPEDEF: int __int32_t
|
||||
TYPEDEF: longlong __int64_t
|
||||
|
||||
TYPEDEF: uchar __uint8_t
|
||||
TYPEDEF: ushort __uint16_t
|
||||
TYPEDEF: uint __uint32_t
|
||||
TYPEDEF: ulonglong __uint64_t
|
||||
|
||||
|
||||
os {
|
||||
{ linux [ "unix.types.linux" require ] }
|
||||
|
|
|
|||
|
|
@ -7,9 +7,6 @@ stack-checker macros locals generalizations unix.types
|
|||
debugger io prettyprint ;
|
||||
IN: unix
|
||||
|
||||
TYPEDEF: uint in_addr_t
|
||||
TYPEDEF: uint socklen_t
|
||||
|
||||
: PROT_NONE 0 ; inline
|
||||
: PROT_READ 1 ; inline
|
||||
: PROT_WRITE 2 ; inline
|
||||
|
|
@ -78,6 +75,8 @@ MACRO:: unix-system-call ( quot -- )
|
|||
FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ;
|
||||
FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ;
|
||||
FUNCTION: int chdir ( char* path ) ;
|
||||
FUNCTION: int chmod ( char* path, mode_t mode ) ;
|
||||
FUNCTION: int fchmod ( int fd, mode_t mode ) ;
|
||||
FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ;
|
||||
FUNCTION: int chroot ( char* path ) ;
|
||||
|
||||
|
|
@ -91,6 +90,7 @@ FUNCTION: int dup2 ( int oldd, int newd ) ;
|
|||
: _exit ( status -- * )
|
||||
#! We throw to give this a terminating stack effect.
|
||||
"int" f "_exit" { "int" } alien-invoke "Exit failed" throw ;
|
||||
FUNCTION: void endpwent ( ) ;
|
||||
FUNCTION: int fchdir ( int fd ) ;
|
||||
FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
|
||||
FUNCTION: int fcntl ( int fd, int cmd, int arg ) ;
|
||||
|
|
@ -108,6 +108,8 @@ FUNCTION: gid_t getgid ;
|
|||
FUNCTION: int getgrgid_r ( gid_t gid, group* grp, char* buffer, size_t bufsize, group** result ) ;
|
||||
FUNCTION: int getgrnam_r ( char* name, group* grp, char* buffer, size_t bufsize, group** result ) ;
|
||||
FUNCTION: passwd* getpwent ( ) ;
|
||||
FUNCTION: passwd* getpwuid ( uid_t uid ) ;
|
||||
FUNCTION: passwd* getpwnam ( char* login ) ;
|
||||
FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsize, passwd** result ) ;
|
||||
FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ;
|
||||
FUNCTION: int getgrouplist ( char* name, int basegid, int* groups, int* ngroups ) ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators accessors kernel unix unix.users
|
||||
system ;
|
||||
IN: unix.users.bsd
|
||||
|
||||
TUPLE: bsd-passwd < passwd change class expire fields ;
|
||||
|
||||
M: bsd new-passwd ( -- bsd-passwd ) bsd-passwd new ;
|
||||
|
||||
M: bsd passwd>new-passwd ( passwd -- bsd-passwd )
|
||||
[ call-next-method ] keep
|
||||
{
|
||||
[ passwd-pw_change >>change ]
|
||||
[ passwd-pw_class >>class ]
|
||||
[ passwd-pw_shell >>shell ]
|
||||
[ passwd-pw_expire >>expire ]
|
||||
[ passwd-pw_fields >>fields ]
|
||||
} cleave ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1,120 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax io.streams.string kernel quotations sequences strings math ;
|
||||
IN: unix.users
|
||||
|
||||
HELP: all-users
|
||||
{ $values
|
||||
|
||||
{ "seq" sequence } }
|
||||
{ $description "Returns a sequence of high-level " { $link passwd } " tuples that are platform-dependent and field for field complete with the Unix " { $link passwd } " structure." } ;
|
||||
|
||||
HELP: effective-username
|
||||
{ $values
|
||||
|
||||
{ "string" string } }
|
||||
{ $description "Returns the effective username for the current user." } ;
|
||||
|
||||
HELP: effective-user-id
|
||||
{ $values
|
||||
|
||||
{ "id" integer } }
|
||||
{ $description "Returns the effective username id for the current user." } ;
|
||||
|
||||
HELP: new-passwd
|
||||
{ $values
|
||||
|
||||
{ "passwd" passwd } }
|
||||
{ $description "Creates a new passwd tuple dependent on the operating system." } ;
|
||||
|
||||
HELP: passwd
|
||||
{ $description "A platform-specific tuple correspding to every field from the Unix passwd struct. BSD passwd structures have four extra slots: " { $slot "change" } ", " { $slot "class" } "," { $slot "expire" } ", " { $slot "fields" } "." } ;
|
||||
|
||||
HELP: passwd-cache
|
||||
{ $description "A symbol storing passwd structures indexed by user-ids when within a " { $link with-passwd-cache } "." } ;
|
||||
|
||||
HELP: passwd>new-passwd
|
||||
{ $values
|
||||
{ "passwd" "a passwd struct" }
|
||||
{ "new-passwd" "a passwd tuple" } }
|
||||
{ $description "A platform-specific conversion routine from a passwd structure to a passwd tuple." } ;
|
||||
|
||||
HELP: real-username
|
||||
{ $values
|
||||
|
||||
{ "string" string } }
|
||||
{ $description "The real username of the current user." } ;
|
||||
|
||||
HELP: real-user-id
|
||||
{ $values
|
||||
|
||||
{ "id" integer } }
|
||||
{ $description "The real user id of the current user." } ;
|
||||
|
||||
HELP: set-effective-user
|
||||
{ $values
|
||||
{ "string/id" "a string or a user id" } }
|
||||
{ $description "Sets the current effective user given a username or a user id." } ;
|
||||
|
||||
HELP: set-real-user
|
||||
{ $values
|
||||
{ "string/id" "a string or a user id" } }
|
||||
{ $description "Sets the current real user given a username or a user id." } ;
|
||||
|
||||
HELP: user-passwd
|
||||
{ $values
|
||||
{ "obj" object }
|
||||
{ "passwd" passwd } }
|
||||
{ $description "Returns the passwd tuple given a username string or user id." } ;
|
||||
|
||||
HELP: username
|
||||
{ $values
|
||||
{ "id" integer }
|
||||
{ "string" string } }
|
||||
{ $description "Returns the username associated with the user id." } ;
|
||||
|
||||
HELP: user-id
|
||||
{ $values
|
||||
{ "string" string }
|
||||
{ "id" integer } }
|
||||
{ $description "Returns the user id associated with the username." } ;
|
||||
|
||||
HELP: with-effective-user
|
||||
{ $values
|
||||
{ "string/id" "a string or a uid" } { "quot" quotation } }
|
||||
{ $description "Sets the effective username and calls the quotation. Restores the current username on success or on error after the call." } ;
|
||||
|
||||
HELP: with-passwd-cache
|
||||
{ $values
|
||||
{ "quot" quotation } }
|
||||
{ $description "Iterates over the password file using library calls and creates a cache in the " { $link passwd-cache } " symbol. The cache is a hashtable indexed by user id. When looking up many users, this approach is much faster than calling system calls." } ;
|
||||
|
||||
HELP: with-real-user
|
||||
{ $values
|
||||
{ "string/id" "a string or a uid" } { "quot" quotation } }
|
||||
{ $description "Sets the real username and calls the quotation. Restores the current username on success or on error after the call." } ;
|
||||
|
||||
{
|
||||
real-username real-user-id set-real-user
|
||||
effective-username effective-user-id
|
||||
set-effective-user
|
||||
} related-words
|
||||
|
||||
ARTICLE: "unix.users" "unix.users"
|
||||
"The " { $vocab-link "unix.users" } " vocabulary contains words that return information about Unix users."
|
||||
"Listing all users:"
|
||||
{ $subsection all-users }
|
||||
"Returning a passwd tuple:"
|
||||
"Real user:"
|
||||
{ $subsection real-username }
|
||||
{ $subsection real-user-id }
|
||||
{ $subsection set-real-user }
|
||||
"Effective user:"
|
||||
{ $subsection effective-username }
|
||||
{ $subsection effective-user-id }
|
||||
{ $subsection set-effective-user }
|
||||
"Combinators to change users:"
|
||||
{ $subsection with-real-user }
|
||||
{ $subsection with-effective-user } ;
|
||||
|
||||
ABOUT: "unix.users"
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test unix.users kernel strings math ;
|
||||
IN: unix.users.tests
|
||||
|
||||
|
||||
[ ] [ all-users drop ] unit-test
|
||||
|
||||
\ all-users must-infer
|
||||
|
||||
[ t ] [ real-username string? ] unit-test
|
||||
[ t ] [ effective-username string? ] unit-test
|
||||
|
||||
[ t ] [ real-user-id integer? ] unit-test
|
||||
[ t ] [ effective-user-id integer? ] unit-test
|
||||
|
||||
[ ] [ real-user-id set-real-user ] unit-test
|
||||
[ ] [ effective-user-id set-effective-user ] unit-test
|
||||
|
||||
[ ] [ real-username [ ] with-real-user ] unit-test
|
||||
[ ] [ real-user-id [ ] with-real-user ] unit-test
|
||||
|
||||
[ ] [ effective-username [ ] with-effective-user ] unit-test
|
||||
[ ] [ effective-user-id [ ] with-effective-user ] unit-test
|
||||
|
|
@ -0,0 +1,114 @@
|
|||
! 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
|
||||
combinators.short-circuit grouping byte-arrays combinators
|
||||
accessors math.parser fry assocs namespaces continuations
|
||||
vocabs.loader system ;
|
||||
IN: unix.users
|
||||
|
||||
TUPLE: passwd username password uid gid gecos dir shell ;
|
||||
|
||||
HOOK: new-passwd os ( -- passwd )
|
||||
HOOK: passwd>new-passwd os ( passwd -- new-passwd )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
M: unix new-passwd ( -- passwd )
|
||||
passwd new ;
|
||||
|
||||
M: unix passwd>new-passwd ( passwd -- seq )
|
||||
[ new-passwd ] dip
|
||||
{
|
||||
[ passwd-pw_name >>username ]
|
||||
[ passwd-pw_passwd >>password ]
|
||||
[ passwd-pw_uid >>uid ]
|
||||
[ passwd-pw_gid >>gid ]
|
||||
[ passwd-pw_gecos >>gecos ]
|
||||
[ passwd-pw_dir >>dir ]
|
||||
[ passwd-pw_shell >>shell ]
|
||||
} cleave ;
|
||||
|
||||
: with-pwent ( quot -- )
|
||||
[ endpwent ] [ ] cleanup ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: all-users ( -- seq )
|
||||
[
|
||||
[ getpwent dup ] [ passwd>new-passwd ] [ drop ] produce
|
||||
] with-pwent ;
|
||||
|
||||
SYMBOL: passwd-cache
|
||||
|
||||
: with-passwd-cache ( quot -- )
|
||||
all-users [ [ uid>> ] keep ] H{ } map>assoc
|
||||
passwd-cache swap with-variable ; inline
|
||||
|
||||
GENERIC: user-passwd ( obj -- passwd )
|
||||
|
||||
M: integer user-passwd ( id -- passwd/f )
|
||||
passwd-cache get
|
||||
[ at ] [ getpwuid passwd>new-passwd ] if* ;
|
||||
|
||||
M: string user-passwd ( string -- passwd/f )
|
||||
getpwnam dup [ passwd>new-passwd ] when ;
|
||||
|
||||
: username ( id -- string )
|
||||
user-passwd username>> ;
|
||||
|
||||
: user-id ( string -- id )
|
||||
user-passwd uid>> ;
|
||||
|
||||
: real-user-id ( -- id )
|
||||
getuid ; inline
|
||||
|
||||
: real-username ( -- string )
|
||||
real-user-id username ; inline
|
||||
|
||||
: effective-user-id ( -- id )
|
||||
geteuid ; inline
|
||||
|
||||
: effective-username ( -- string )
|
||||
effective-user-id username ; inline
|
||||
|
||||
GENERIC: set-real-user ( string/id -- )
|
||||
|
||||
GENERIC: set-effective-user ( string/id -- )
|
||||
|
||||
: with-real-user ( string/id quot -- )
|
||||
'[ _ set-real-user @ ]
|
||||
real-user-id '[ _ set-real-user ]
|
||||
[ ] cleanup ; inline
|
||||
|
||||
: with-effective-user ( string/id quot -- )
|
||||
'[ _ set-effective-user @ ]
|
||||
effective-user-id '[ _ set-effective-user ]
|
||||
[ ] cleanup ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (set-real-user) ( id -- )
|
||||
setuid io-error ; inline
|
||||
|
||||
: (set-effective-user) ( id -- )
|
||||
seteuid io-error ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: string set-real-user ( string -- )
|
||||
user-id (set-real-user) ;
|
||||
|
||||
M: integer set-real-user ( id -- )
|
||||
(set-real-user) ;
|
||||
|
||||
M: integer set-effective-user ( id -- )
|
||||
(set-effective-user) ;
|
||||
|
||||
M: string set-effective-user ( string -- )
|
||||
user-id (set-effective-user) ;
|
||||
|
||||
os {
|
||||
{ [ dup bsd? ] [ drop "unix.users.bsd" require ] }
|
||||
{ [ dup linux? ] [ drop ] }
|
||||
} cond
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test unix.utmpx.macosx ;
|
||||
IN: unix.utmpx.macosx.tests
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax unix.bsd.macosx ;
|
||||
IN: unix.utmpx.macosx
|
||||
|
||||
! empty
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test unix.utmpx.netbsd ;
|
||||
IN: unix.utmpx.netbsd.tests
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax unix.utmpx unix.bsd.netbsd accessors
|
||||
unix.utmpx system kernel unix combinators ;
|
||||
IN: unix.utmpx.netbsd
|
||||
|
||||
TUPLE: netbsd-utmpx-record < utmpx-record termination exit
|
||||
sockaddr ;
|
||||
|
||||
M: netbsd new-utmpx-record ( -- utmpx-record )
|
||||
netbsd-utmpx-record new ;
|
||||
|
||||
M: netbsd utmpx>utmpx-record ( utmpx -- record )
|
||||
[ new-utmpx-record ] keep
|
||||
{
|
||||
[
|
||||
utmpx-ut_exit
|
||||
[ exit_struct-e_termination >>termination ]
|
||||
[ exit_struct-e_exit >>exit ] bi
|
||||
]
|
||||
[ utmpx-ut_ss >>sockaddr ]
|
||||
} cleave ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1,66 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types alien.syntax combinators continuations
|
||||
io.encodings.string io.encodings.utf8 kernel sequences strings
|
||||
unix calendar system accessors unix.time calendar.unix
|
||||
vocabs.loader ;
|
||||
IN: unix.utmpx
|
||||
|
||||
: EMPTY 0 ; inline
|
||||
: RUN_LVL 1 ; inline
|
||||
: BOOT_TIME 2 ; inline
|
||||
: OLD_TIME 3 ; inline
|
||||
: NEW_TIME 4 ; inline
|
||||
: INIT_PROCESS 5 ; inline
|
||||
: LOGIN_PROCESS 6 ; inline
|
||||
: USER_PROCESS 7 ; inline
|
||||
: DEAD_PROCESS 8 ; inline
|
||||
: ACCOUNTING 9 ; inline
|
||||
: SIGNATURE 10 ; inline
|
||||
: SHUTDOWN_TIME 11 ; inline
|
||||
|
||||
FUNCTION: void setutxent ( ) ;
|
||||
FUNCTION: void endutxent ( ) ;
|
||||
FUNCTION: utmpx* getutxent ( ) ;
|
||||
FUNCTION: utmpx* getutxid ( utmpx* id ) ;
|
||||
FUNCTION: utmpx* getutxline ( utmpx* line ) ;
|
||||
FUNCTION: utmpx* pututxline ( utmpx* utx ) ;
|
||||
|
||||
TUPLE: utmpx-record user id line pid type timestamp host ;
|
||||
|
||||
HOOK: new-utmpx-record os ( -- utmpx-record )
|
||||
|
||||
HOOK: utmpx>utmpx-record os ( utmpx -- utmpx-record )
|
||||
|
||||
: memory>string ( alien n -- string )
|
||||
memory>byte-array utf8 decode [ 0 = ] trim-right ;
|
||||
|
||||
M: unix new-utmpx-record
|
||||
utmpx-record new ;
|
||||
|
||||
M: unix utmpx>utmpx-record ( utmpx -- utmpx-record )
|
||||
[ new-utmpx-record ] dip
|
||||
{
|
||||
[ utmpx-ut_user _UTX_USERSIZE memory>string >>user ]
|
||||
[ utmpx-ut_id _UTX_IDSIZE memory>string >>id ]
|
||||
[ utmpx-ut_line _UTX_LINESIZE memory>string >>line ]
|
||||
[ utmpx-ut_pid >>pid ]
|
||||
[ utmpx-ut_type >>type ]
|
||||
[ utmpx-ut_tv timeval>unix-time >>timestamp ]
|
||||
[ utmpx-ut_host _UTX_HOSTSIZE memory>string >>host ]
|
||||
} cleave ;
|
||||
|
||||
: with-utmpx ( quot -- )
|
||||
setutxent [ endutxent ] [ ] cleanup ; inline
|
||||
|
||||
: all-utmpx ( -- seq )
|
||||
[
|
||||
[ getutxent dup ]
|
||||
[ utmpx>utmpx-record ]
|
||||
[ drop ] produce
|
||||
] with-utmpx ;
|
||||
|
||||
os {
|
||||
{ macosx [ "unix.utmpx.macosx" require ] }
|
||||
{ netbsd [ "unix.utmpx.netbsd" require ] }
|
||||
} case
|
||||
|
|
@ -96,3 +96,16 @@ TUPLE: syntax-test bar baz ;
|
|||
[ T{ syntax-test } ] [ T{ syntax-test } ] unit-test
|
||||
[ T{ syntax-test f { 2 3 } { 4 { 5 } } } ]
|
||||
[ T{ syntax-test { bar { 2 3 } } { baz { 4 { 5 } } } } ] unit-test
|
||||
|
||||
! Corner case
|
||||
TUPLE: parsing-corner-case x ;
|
||||
|
||||
[ T{ parsing-corner-case f 3 } ] [
|
||||
{
|
||||
"USE: classes.tuple.parser.tests"
|
||||
"T{ parsing-corner-case"
|
||||
" f"
|
||||
" 3"
|
||||
"}"
|
||||
} "\n" join eval
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -86,6 +86,7 @@ ERROR: bad-literal-tuple ;
|
|||
|
||||
: parse-tuple-literal ( -- tuple )
|
||||
scan-word scan {
|
||||
{ f [ unexpected-eof ] }
|
||||
{ "f" [ \ } parse-until boa>tuple ] }
|
||||
{ "{" [ parse-slot-values assoc>tuple ] }
|
||||
{ "}" [ new ] }
|
||||
|
|
|
|||
|
|
@ -1,8 +0,0 @@
|
|||
USING: calendar io io-internals kernel math namespaces
|
||||
nonblocking-io prettyprint quotations sequences ;
|
||||
IN: libs-io
|
||||
|
||||
: bit-set? ( m n -- ? ) [ bitand ] keep = ;
|
||||
: set-bit ( m bit -- n ) bitor ;
|
||||
: clear-bit ( m bit -- n ) bitnot bitand ;
|
||||
|
||||
|
|
@ -11,219 +11,6 @@ IN: libs-io
|
|||
: SEEK_END 2 ; inline
|
||||
: EEXIST 17 ; inline
|
||||
|
||||
FUNCTION: off_t lseek ( int fildes, off_t offset, int whence ) ;
|
||||
: append-mode
|
||||
O_WRONLY O_APPEND O_CREAT bitor bitor ; foldable
|
||||
|
||||
: open-append ( path -- fd )
|
||||
append-mode file-mode open dup io-error
|
||||
[ 0 SEEK_END lseek io-error ] keep ;
|
||||
|
||||
: touch-mode
|
||||
O_WRONLY O_APPEND O_CREAT O_EXCL bitor bitor bitor ; foldable
|
||||
|
||||
: open-touch ( path -- fd )
|
||||
touch-mode file-mode open
|
||||
[ io-error close t ]
|
||||
[ 2drop err_no EEXIST = [ err_no io-error ] unless -1 ] recover ;
|
||||
|
||||
: <file-appender> ( path -- stream ) open-append <writer> ;
|
||||
|
||||
FUNCTION: int unlink ( char* path ) ;
|
||||
: delete-file ( path -- )
|
||||
unlink io-error ;
|
||||
|
||||
FUNCTION: int mkdir ( char* path, mode_t mode ) ;
|
||||
|
||||
: (create-directory) ( path mode -- )
|
||||
mkdir io-error ;
|
||||
|
||||
: create-directory ( path -- )
|
||||
0 (create-directory) ;
|
||||
|
||||
FUNCTION: int rmdir ( char* path ) ;
|
||||
|
||||
: delete-directory ( path -- )
|
||||
rmdir io-error ;
|
||||
|
||||
FUNCTION: int chroot ( char* path ) ;
|
||||
FUNCTION: int chdir ( char* path ) ;
|
||||
FUNCTION: int fchdir ( int fd ) ;
|
||||
|
||||
FUNCTION: int utimes ( char* path, timeval[2] times ) ;
|
||||
FUNCTION: int futimes ( int id, timeval[2] times ) ;
|
||||
|
||||
TYPEDEF: longlong blkcnt_t
|
||||
TYPEDEF: int blksize_t
|
||||
TYPEDEF: int dev_t
|
||||
TYPEDEF: uint ino_t
|
||||
TYPEDEF: ushort mode_t
|
||||
TYPEDEF: ushort nlink_t
|
||||
TYPEDEF: uint uid_t
|
||||
TYPEDEF: uint gid_t
|
||||
TYPEDEF: longlong quad_t
|
||||
TYPEDEF: ulong u_long
|
||||
|
||||
FUNCTION: int stat ( char* path, stat* sb ) ;
|
||||
|
||||
C-STRUCT: stat
|
||||
{ "dev_t" "dev" } ! device inode resides on
|
||||
{ "ino_t" "ino" } ! inode's number
|
||||
{ "mode_t" "mode" } ! inode protection mode
|
||||
{ "nlink_t" "nlink" } ! number or hard links to the file
|
||||
{ "uid_t" "uid" } ! user-id of owner
|
||||
{ "gid_t" "gid" } ! group-id of owner
|
||||
{ "dev_t" "rdev" } ! device type, for special file inode
|
||||
{ "timespec" "atime" } ! time of last access
|
||||
{ "timespec" "mtime" } ! time of last data modification
|
||||
{ "timespec" "ctime" } ! time of last file status change
|
||||
{ "off_t" "size" } ! file size, in bytes
|
||||
{ "blkcnt_t" "blocks" } ! blocks allocated for file
|
||||
{ "blksize_t" "blksize" } ! optimal file sys I/O ops blocksize
|
||||
{ "u_long" "flags" } ! user defined flags for file
|
||||
{ "u_long" "gen" } ; ! file generation number
|
||||
|
||||
: stat* ( path -- byte-array )
|
||||
"stat" <c-object> [ stat io-error ] keep ;
|
||||
|
||||
: make-timeval-array ( array -- byte-array )
|
||||
[ length "timeval" <c-array> ] keep
|
||||
dup length [ over [ pick set-timeval-nth ] [ 2drop ] if ] 2each ;
|
||||
|
||||
: (set-file-times) ( timestamp timestamp -- alien )
|
||||
[ [ timestamp>timeval ] [ f ] if* ] 2apply 2array
|
||||
make-timeval-array ;
|
||||
|
||||
: set-file-times ( path timestamp timestamp -- )
|
||||
#! set access, write
|
||||
(set-file-times) utimes io-error ;
|
||||
|
||||
: set-file-times* ( fd timestamp timestamp -- )
|
||||
(set-file-times) futimes io-error ;
|
||||
|
||||
|
||||
: set-file-access-time ( path timestamp -- )
|
||||
f set-file-times ;
|
||||
|
||||
: set-file-write-time ( path timestamp -- )
|
||||
>r f r> set-file-times ;
|
||||
|
||||
|
||||
: file-write-time ( path -- timestamp )
|
||||
stat* stat-mtime timespec>timestamp ;
|
||||
|
||||
: file-access-time ( path -- timestamp )
|
||||
stat* stat-atime timespec>timestamp ;
|
||||
|
||||
! File type
|
||||
: S_IFMT OCT: 0170000 ; inline ! type of file
|
||||
: S_IFIFO OCT: 0010000 ; inline ! named pipe (fifo)
|
||||
: S_IFCHR OCT: 0020000 ; inline ! character special
|
||||
: S_IFDIR OCT: 0040000 ; inline ! directory
|
||||
: S_IFBLK OCT: 0060000 ; inline ! block special
|
||||
: S_IFREG OCT: 0100000 ; inline ! regular
|
||||
: S_IFLNK OCT: 0120000 ; inline ! symbolic link
|
||||
: S_IFSOCK OCT: 0140000 ; inline ! socket
|
||||
: S_IFWHT OCT: 0160000 ; inline ! whiteout
|
||||
: S_IFXATTR OCT: 0200000 ; inline ! extended attribute
|
||||
|
||||
! File mode
|
||||
! Read, write, execute/search by owner
|
||||
: S_IRWXU OCT: 0000700 ; inline ! rwx mask owner
|
||||
: S_IRUSR OCT: 0000400 ; inline ! r owner
|
||||
: S_IWUSR OCT: 0000200 ; inline ! w owner
|
||||
: S_IXUSR OCT: 0000100 ; inline ! x owner
|
||||
! Read, write, execute/search by group
|
||||
: S_IRWXG OCT: 0000070 ; inline ! rwx mask group
|
||||
: S_IRGRP OCT: 0000040 ; inline ! r group
|
||||
: S_IWGRP OCT: 0000020 ; inline ! w group
|
||||
: S_IXGRP OCT: 0000010 ; inline ! x group
|
||||
! Read, write, execute/search by others
|
||||
: S_IRWXO OCT: 0000007 ; inline ! rwx mask other
|
||||
: S_IROTH OCT: 0000004 ; inline ! r other
|
||||
: S_IWOTH OCT: 0000002 ; inline ! w other
|
||||
: S_IXOTH OCT: 0000001 ; inline ! x other
|
||||
|
||||
: S_ISUID OCT: 0004000 ; inline ! set user id on execution
|
||||
: S_ISGID OCT: 0002000 ; inline ! set group id on execution
|
||||
: S_ISVTX OCT: 0001000 ; inline ! sticky bit
|
||||
|
||||
FUNCTION: uid_t getuid ;
|
||||
FUNCTION: uid_t geteuid ;
|
||||
|
||||
FUNCTION: gid_t getgid ;
|
||||
FUNCTION: gid_t getegid ;
|
||||
|
||||
FUNCTION: int setuid ( uid_t uid ) ;
|
||||
FUNCTION: int seteuid ( uid_t euid ) ;
|
||||
FUNCTION: int setreuid ( uid_t ruid, uid_t euid ) ;
|
||||
|
||||
FUNCTION: int setgid ( gid_t gid ) ;
|
||||
FUNCTION: int setegid ( gid_t egid ) ;
|
||||
FUNCTION: int setregid ( gid_t rgid, gid_t egid ) ;
|
||||
|
||||
FUNCTION: int issetugid ;
|
||||
|
||||
FUNCTION: int chmod ( char* path, mode_t mode ) ;
|
||||
FUNCTION: int fchmod ( int fd, mode_t mode ) ;
|
||||
|
||||
FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ;
|
||||
FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
|
||||
#! lchown does not follow symbolic links
|
||||
FUNCTION: int lchown ( char* path, uid_t owner, gid_t group ) ;
|
||||
|
||||
FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ;
|
||||
FUNCTION: int setgroups ( int ngroups, gid_t* gidset ) ;
|
||||
|
||||
FUNCTION: int flock ( int fd, int operation ) ;
|
||||
! FUNCTION: int dup ( int oldd ) ;
|
||||
! FUNCTION: int dup2 ( int oldd, int newd ) ;
|
||||
|
||||
FUNCTION: int fcntl ( int fd, int cmd, int arg ) ;
|
||||
FUNCTION: int getdtablesize ;
|
||||
|
||||
: file-mode? ( path mask -- ? )
|
||||
>r stat* stat-mode r> bit-set? ;
|
||||
|
||||
: user-read? ( path -- ? ) S_IRUSR file-mode? ;
|
||||
: user-write? ( path -- ? ) S_IWUSR file-mode? ;
|
||||
: user-execute? ( path -- ? ) S_IXUSR file-mode? ;
|
||||
|
||||
: group-read? ( path -- ? ) S_IRGRP file-mode? ;
|
||||
: group-write? ( path -- ? ) S_IWGRP file-mode? ;
|
||||
: group-execute? ( path -- ? ) S_IXGRP file-mode? ;
|
||||
|
||||
: other-read? ( path -- ? ) S_IROTH file-mode? ;
|
||||
: other-write? ( path -- ? ) S_IWOTH file-mode? ;
|
||||
: other-execute? ( path -- ? ) S_IXOTH file-mode? ;
|
||||
|
||||
: set-uid? ( path -- ? ) S_ISUID bit-set? ;
|
||||
: set-gid? ( path -- ? ) S_ISGID bit-set? ;
|
||||
: set-sticky? ( path -- ? ) S_ISVTX bit-set? ;
|
||||
|
||||
: chmod* ( path mask ? -- )
|
||||
>r >r dup stat* stat-mode r> r> [
|
||||
set-bit
|
||||
] [
|
||||
clear-bit
|
||||
] if chmod io-error ;
|
||||
|
||||
: set-user-read ( path ? -- ) >r S_IRUSR r> chmod* ;
|
||||
: set-user-write ( path ? -- ) >r S_IWUSR r> chmod* ;
|
||||
: set-user-execute ( path ? -- ) >r S_IXUSR r> chmod* ;
|
||||
|
||||
: set-group-read ( path ? -- ) >r S_IRGRP r> chmod* ;
|
||||
: set-group-write ( path ? -- ) >r S_IWGRP r> chmod* ;
|
||||
: set-group-execute ( path ? -- ) >r S_IXGRP r> chmod* ;
|
||||
|
||||
: set-other-read ( path ? -- ) >r S_IROTH r> chmod* ;
|
||||
: set-other-write ( path ? -- ) >r S_IWOTH r> chmod* ;
|
||||
: set-other-execute ( path ? -- ) >r S_IXOTH r> chmod* ;
|
||||
|
||||
: set-uid ( path ? -- ) >r S_ISUID r> chmod* ;
|
||||
: set-gid ( path ? -- ) >r S_ISGID r> chmod* ;
|
||||
: set-sticky ( path ? -- ) >r S_ISVTX r> chmod* ;
|
||||
|
||||
: mode>symbol ( mode -- ch )
|
||||
S_IFMT bitand
|
||||
{
|
||||
|
|
|
|||
|
|
@ -325,6 +325,12 @@ void find_code_references(CELL look_for_)
|
|||
|
||||
void factorbug(void)
|
||||
{
|
||||
if(fep_disabled)
|
||||
{
|
||||
printf("Low level debugger disabled\n");
|
||||
exit(1);
|
||||
}
|
||||
|
||||
open_console();
|
||||
|
||||
printf("Starting low level debugger...\n");
|
||||
|
|
@ -366,6 +372,8 @@ void factorbug(void)
|
|||
dump stacks. This is useful for builder and
|
||||
other cases where Factor is run with stdin
|
||||
redirected to /dev/null */
|
||||
fep_disabled = true;
|
||||
|
||||
print_datastack();
|
||||
print_retainstack();
|
||||
print_callstack();
|
||||
|
|
|
|||
|
|
@ -4,4 +4,6 @@ void dump_generations(void);
|
|||
void factorbug(void);
|
||||
void dump_zone(F_ZONE *z);
|
||||
|
||||
bool fep_disabled;
|
||||
|
||||
DECLARE_PRIMITIVE(die);
|
||||
|
|
|
|||
|
|
@ -57,10 +57,10 @@ void throw_error(CELL error, F_STACK_FRAME *callstack_top)
|
|||
crash. */
|
||||
else
|
||||
{
|
||||
fprintf(stderr,"You have triggered a bug in Factor. Please report.\n");
|
||||
fprintf(stderr,"early_error: ");
|
||||
printf("You have triggered a bug in Factor. Please report.\n");
|
||||
printf("early_error: ");
|
||||
print_obj(error);
|
||||
fprintf(stderr,"\n");
|
||||
printf("\n");
|
||||
factorbug();
|
||||
}
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue