--- /dev/null
+Doug Coleman
--- /dev/null
+! 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 ;
+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 1024
+ [ <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 ;
+
+PRIVATE>
+
+: 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 ;
+
+: 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) ;
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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 ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! 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>> ;
+
+: username-id ( string -- id )
+ user-passwd username>> ;
+
+: real-username-id ( -- string )
+ getuid ; inline
+
+: real-username ( -- string )
+ real-username-id username ; inline
+
+: effective-username-id ( -- string )
+ geteuid username ; inline
+
+: effective-username ( -- string )
+ effective-username-id username ; inline
+
+GENERIC: set-real-username ( string/id -- )
+
+GENERIC: set-effective-username ( string/id -- )
+
+: with-real-username ( string/id quot -- )
+ '[ _ set-real-username @ ]
+ real-username-id '[ _ set-real-username ]
+ [ ] cleanup ; inline
+
+: with-effective-username ( string/id quot -- )
+ '[ _ set-effective-username @ ]
+ effective-username-id '[ _ set-effective-username ]
+ [ ] cleanup ; inline
+
+<PRIVATE
+
+: (set-real-username) ( id -- )
+ setuid io-error ; inline
+
+: (set-effective-username) ( id -- )
+ seteuid io-error ; inline
+
+PRIVATE>
+
+M: string set-real-username ( string -- )
+ username-id (set-real-username) ;
+
+M: integer set-real-username ( id -- )
+ (set-real-username) ;
+
+M: integer set-effective-username ( id -- )
+ (set-effective-username) ;
+
+M: string set-effective-username ( string -- )
+ username-id (set-effective-username) ;
+
+os {
+ { [ dup bsd? ] [ drop "unix.users.bsd" require ] }
+ { [ dup linux? ] [ drop ] }
+} cond
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+! 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 ;
--- /dev/null
+unportable
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types 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
projects / factor.git / commitdiff