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 ; calendar math fry prettyprint ;
IN: tools.files IN: tools.files
SYMBOLS: permissions file-name nlinks file-size date ;
<PRIVATE <PRIVATE
: ls-time ( timestamp -- string ) : 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 USING: accessors combinators kernel system unicode.case io.files
io.files.info io.files.info.unix tools.files generalizations io.files.info io.files.info.unix tools.files generalizations
strings arrays sequences math.parser unix.groups unix.users 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 IN: tools.files.unix
MACRO: cleave>array ( array -- quot )
dup length '[ _ cleave _ narray ] ;
<PRIVATE <PRIVATE
: unix-execute>string ( str bools -- str' ) : unix-execute>string ( str bools -- str' )
@ -28,7 +31,7 @@ IN: tools.files.unix
[ other-read? read>string ] [ other-read? read>string ]
[ other-write? write>string ] [ other-write? write>string ]
[ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ] [ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
} cleave 10 narray concat ; } cleave>array concat ;
: mode>symbol ( mode -- ch ) : mode>symbol ( mode -- ch )
S_IFMT bitand S_IFMT bitand
@ -49,11 +52,11 @@ M: unix (directory.) ( path -- lines )
{ {
[ permissions-string ] [ permissions-string ]
[ nlink>> number>string 3 CHAR: \s pad-left ] [ nlink>> number>string 3 CHAR: \s pad-left ]
! [ uid>> ] [ uid>> user-name ]
! [ gid>> ] [ gid>> group-name ]
[ size>> number>string 15 CHAR: \s pad-left ] [ size>> number>string 15 CHAR: \s pad-left ]
[ modified>> ls-timestamp ] [ modified>> ls-timestamp ]
} cleave 4 narray swap suffix " " join } cleave>array swap suffix " " join
] map ] map
] with-group-cache ] with-user-cache ; ] with-group-cache ] with-user-cache ;

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

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

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

@ -7,13 +7,13 @@ HELP: all-users
{ $values { "seq" sequence } } { $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." } ; { $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 } } { $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 HELP: effective-user-id
{ $values { "id" integer } } { $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 HELP: new-passwd
{ $values { "passwd" passwd } } { $values { "passwd" passwd } }
@ -31,9 +31,9 @@ HELP: passwd>new-passwd
{ "new-passwd" "a passwd tuple" } } { "new-passwd" "a passwd tuple" } }
{ $description "A platform-specific conversion routine from a passwd structure to 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 } } { $values { "string" string } }
{ $description "The real username of the current user." } ; { $description "The real user-name of the current user." } ;
HELP: real-user-id HELP: real-user-id
{ $values { "id" integer } } { $values { "id" integer } }
@ -41,34 +41,34 @@ HELP: real-user-id
HELP: set-effective-user HELP: set-effective-user
{ $values { "string/id" "a string or a user id" } } { $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 HELP: set-real-user
{ $values { "string/id" "a string or a user id" } } { $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 HELP: user-passwd
{ $values { $values
{ "obj" object } { "obj" object }
{ "passwd/f" "passwd or f" } } { "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 { $values
{ "id" integer } { "id" integer }
{ "string" string } } { "string" string } }
{ $description "Returns the username associated with the user id." } ; { $description "Returns the user-name associated with the user id." } ;
HELP: user-id HELP: user-id
{ $values { $values
{ "string" string } { "string" string }
{ "id" integer } } { "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 HELP: with-effective-user
{ $values { $values
{ "string/id" "a string or a uid" } { "quot" quotation } } { "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 HELP: with-user-cache
{ $values { $values
@ -78,11 +78,11 @@ HELP: with-user-cache
HELP: with-real-user HELP: with-real-user
{ $values { $values
{ "string/id" "a string or a uid" } { "quot" quotation } } { "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 real-user-name real-user-id set-real-user
effective-username effective-user-id effective-user-name effective-user-id
set-effective-user set-effective-user
} related-words } related-words
@ -93,11 +93,11 @@ $nl
{ $subsection all-users } { $subsection all-users }
"Returning a passwd tuple:" "Returning a passwd tuple:"
"Real user:" "Real user:"
{ $subsection real-username } { $subsection real-user-name }
{ $subsection real-user-id } { $subsection real-user-id }
{ $subsection set-real-user } { $subsection set-real-user }
"Effective user:" "Effective user:"
{ $subsection effective-username } { $subsection effective-user-name }
{ $subsection effective-user-id } { $subsection effective-user-id }
{ $subsection set-effective-user } { $subsection set-effective-user }
"Combinators to change users:" "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 \ all-users must-infer
[ t ] [ real-username string? ] unit-test [ t ] [ real-user-name string? ] unit-test
[ t ] [ effective-username string? ] unit-test [ t ] [ effective-user-name string? ] unit-test
[ t ] [ real-user-id integer? ] unit-test [ t ] [ real-user-id integer? ] unit-test
[ t ] [ effective-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 [ ] [ real-user-id set-real-user ] unit-test
[ ] [ effective-user-id set-effective-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 [ ] [ 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 [ ] [ effective-user-id [ ] with-effective-user ] unit-test
[ ] [ [ ] with-user-cache ] unit-test [ ] [ [ ] with-user-cache ] unit-test
[ "9999999999999999999" ] [ 9999999999999999999 username ] unit-test [ "9999999999999999999" ] [ 9999999999999999999 user-name ] unit-test
[ f ] [ 89898989898989898989898989898 user-passwd ] 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 ; vocabs.loader system ;
IN: unix.users 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: new-passwd os ( -- passwd )
HOOK: passwd>new-passwd os ( passwd -- new-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 ) M: unix passwd>new-passwd ( passwd -- seq )
[ new-passwd ] dip [ new-passwd ] dip
{ {
[ passwd-pw_name >>username ] [ passwd-pw_name >>user-name ]
[ passwd-pw_passwd >>password ] [ passwd-pw_passwd >>password ]
[ passwd-pw_uid >>uid ] [ passwd-pw_uid >>uid ]
[ passwd-pw_gid >>gid ] [ passwd-pw_gid >>gid ]
@ -56,9 +56,9 @@ M: integer user-passwd ( id -- passwd/f )
M: string user-passwd ( string -- passwd/f ) M: string user-passwd ( string -- passwd/f )
getpwnam dup [ passwd>new-passwd ] when ; getpwnam dup [ passwd>new-passwd ] when ;
: username ( id -- string ) : user-name ( id -- string )
dup user-passwd dup user-passwd
[ nip username>> ] [ number>string ] if* ; [ nip user-name>> ] [ number>string ] if* ;
: user-id ( string -- id ) : user-id ( string -- id )
user-passwd uid>> ; user-passwd uid>> ;
@ -66,14 +66,14 @@ M: string user-passwd ( string -- passwd/f )
: real-user-id ( -- id ) : real-user-id ( -- id )
getuid ; inline getuid ; inline
: real-username ( -- string ) : real-user-name ( -- string )
real-user-id username ; inline real-user-id user-name ; inline
: effective-user-id ( -- id ) : effective-user-id ( -- id )
geteuid ; inline geteuid ; inline
: effective-username ( -- string ) : effective-user-name ( -- string )
effective-user-id username ; inline effective-user-id user-name ; inline
GENERIC: set-real-user ( string/id -- ) GENERIC: set-real-user ( string/id -- )