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

fix group-name word, rename username -> user-name because of symmetry with group-name, use cleave>array in a couple places to eliminate counting items in an array manually

db4
Doug Coleman 2009-01-07 14:53:43 -06:00
parent 64f07fa336
commit 638f1f4ceb
6 changed files with 41 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/tools/files/files.factor
View File

@ -5,6 +5,8 @@ io.directories kernel math.parser sequences system vocabs.loader
calendar math fry prettyprint ;
IN: tools.files
SYMBOLS: permissions file-name nlinks file-size date ;
<PRIVATE
: ls-time ( timestamp -- string )

13
basis/tools/files/unix/unix.factor
View File

@ -3,9 +3,12 @@
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 ;
tools.files.private unix.stat math fry macros ;
IN: tools.files.unix
MACRO: cleave>array ( array -- quot )
dup length '[ _ cleave _ narray ] ;
<PRIVATE
: unix-execute>string ( str bools -- str' )
@ -28,7 +31,7 @@ IN: tools.files.unix
[ other-read? read>string ]
[ other-write? write>string ]
[ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
} cleave 10 narray concat ;
} cleave>array concat ;
: mode>symbol ( mode -- ch )
S_IFMT bitand
@ -49,11 +52,11 @@ M: unix (directory.) ( path -- lines )
{
[ permissions-string ]
[ nlink>> number>string 3 CHAR: \s pad-left ]
! [ uid>> ]
! [ gid>> ]
[ uid>> user-name ]
[ gid>> group-name ]
[ size>> number>string 15 CHAR: \s pad-left ]
[ modified>> ls-timestamp ]
} cleave 4 narray swap suffix " " join
} cleave>array swap suffix " " join
] map
] with-group-cache ] with-user-cache ;

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

@ -43,7 +43,7 @@ PRIVATE>
: group-name ( id -- string )
dup group-cache get [
at
dupd at* [ name>> nip ] [ drop number>string ] if
] [
group-struct group-gr_name
] if*

34
basis/unix/users/users-docs.factor
View File

@ -7,13 +7,13 @@ 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
HELP: effective-user-name
{ $values { "string" string } }
{ $description "Returns the effective username for the current user." } ;
{ $description "Returns the effective user-name for the current user." } ;
HELP: effective-user-id
{ $values { "id" integer } }
{ $description "Returns the effective username id for the current user." } ;
{ $description "Returns the effective user-name id for the current user." } ;
HELP: new-passwd
{ $values { "passwd" passwd } }
@ -31,9 +31,9 @@ HELP: passwd>new-passwd
{ "new-passwd" "a passwd tuple" } }
{ $description "A platform-specific conversion routine from a passwd structure to a passwd tuple." } ;
HELP: real-username
HELP: real-user-name
{ $values { "string" string } }
{ $description "The real username of the current user." } ;
{ $description "The real user-name of the current user." } ;
HELP: real-user-id
{ $values { "id" integer } }
@ -41,34 +41,34 @@ HELP: real-user-id
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." } ;
{ $description "Sets the current effective user given a user-name 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." } ;
{ $description "Sets the current real user given a user-name or a user id." } ;
HELP: user-passwd
{ $values
{ "obj" object }
{ "passwd/f" "passwd or f" } }
{ $description "Returns the passwd tuple given a username string or user id." } ;
{ $description "Returns the passwd tuple given a user-name string or user id." } ;
HELP: username
HELP: user-name
{ $values
{ "id" integer }
{ "string" string } }
{ $description "Returns the username associated with the user id." } ;
{ $description "Returns the user-name associated with the user id." } ;
HELP: user-id
{ $values
{ "string" string }
{ "id" integer } }
{ $description "Returns the user id associated with the username." } ;
{ $description "Returns the user id associated with the user-name." } ;
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." } ;
{ $description "Sets the effective user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ;
HELP: with-user-cache
{ $values
@ -78,11 +78,11 @@ HELP: with-user-cache
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." } ;
{ $description "Sets the real user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ;
{
real-username real-user-id set-real-user
effective-username effective-user-id
real-user-name real-user-id set-real-user
effective-user-name effective-user-id
set-effective-user
} related-words
@ -93,11 +93,11 @@ $nl
{ $subsection all-users }
"Returning a passwd tuple:"
"Real user:"
{ $subsection real-username }
{ $subsection real-user-name }
{ $subsection real-user-id }
{ $subsection set-real-user }
"Effective user:"
{ $subsection effective-username }
{ $subsection effective-user-name }
{ $subsection effective-user-id }
{ $subsection set-effective-user }
"Combinators to change users:"

10
basis/unix/users/users-tests.factor
View File

@ -8,8 +8,8 @@ IN: unix.users.tests
\ all-users must-infer
[ t ] [ real-username string? ] unit-test
[ t ] [ effective-username string? ] unit-test
[ t ] [ real-user-name string? ] unit-test
[ t ] [ effective-user-name string? ] unit-test
[ t ] [ real-user-id integer? ] unit-test
[ t ] [ effective-user-id integer? ] unit-test
@ -17,14 +17,14 @@ IN: unix.users.tests
[ ] [ 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-name [ ] with-real-user ] unit-test
[ ] [ real-user-id [ ] with-real-user ] unit-test
[ ] [ effective-username [ ] with-effective-user ] unit-test
[ ] [ effective-user-name [ ] with-effective-user ] unit-test
[ ] [ effective-user-id [ ] with-effective-user ] unit-test
[ ] [ [ ] with-user-cache ] unit-test
[ "9999999999999999999" ] [ 9999999999999999999 username ] unit-test
[ "9999999999999999999" ] [ 9999999999999999999 user-name ] unit-test
[ f ] [ 89898989898989898989898989898 user-passwd ] unit-test

16
basis/unix/users/users.factor
View File

@ -7,7 +7,7 @@ accessors math.parser fry assocs namespaces continuations
vocabs.loader system ;
IN: unix.users
TUPLE: passwd username password uid gid gecos dir shell ;
TUPLE: passwd user-name password uid gid gecos dir shell ;
HOOK: new-passwd os ( -- passwd )
HOOK: passwd>new-passwd os ( passwd -- new-passwd )
@ -20,7 +20,7 @@ M: unix new-passwd ( -- passwd )
M: unix passwd>new-passwd ( passwd -- seq )
[ new-passwd ] dip
{
[ passwd-pw_name >>username ]
[ passwd-pw_name >>user-name ]
[ passwd-pw_passwd >>password ]
[ passwd-pw_uid >>uid ]
[ passwd-pw_gid >>gid ]
@ -56,9 +56,9 @@ M: integer user-passwd ( id -- passwd/f )
M: string user-passwd ( string -- passwd/f )
getpwnam dup [ passwd>new-passwd ] when ;
: username ( id -- string )
: user-name ( id -- string )
dup user-passwd
[ nip username>> ] [ number>string ] if* ;
[ nip user-name>> ] [ number>string ] if* ;
: user-id ( string -- id )
user-passwd uid>> ;
@ -66,14 +66,14 @@ M: string user-passwd ( string -- passwd/f )
: real-user-id ( -- id )
getuid ; inline
: real-username ( -- string )
real-user-id username ; inline
: real-user-name ( -- string )
real-user-id user-name ; inline
: effective-user-id ( -- id )
geteuid ; inline
: effective-username ( -- string )
effective-user-id username ; inline
: effective-user-name ( -- string )
effective-user-id user-name ; inline
GENERIC: set-real-user ( string/id -- )