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 ;
"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" } } }
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
{ $values { "assoc" assoc } }
{ $description "Disposes an associative list of statements." } ;
-HELP: db-dispose
-{ $values { "db" db } }
-{ $description "Disposes of all the statements stored in the " { $link db } " object." } ;
-
HELP: statement
{ $description "A " { $snippet "statement" } " stores the information about a statemen, such as the SQL statement text, the in/out parameters, and type information." } ;
{ $code <"
USING: db.sqlite db io.files ;
: with-sqlite-db ( quot -- )
- "my-database.db" temp-file <sqlite-db> swap with-db ;"> }
+ "my-database.db" temp-file <sqlite-db> swap with-db ; inline"> }
"PostgreSQL example combinator:"
{ $code <" USING: db.postgresql db ;
"erg" >>username
"secrets?" >>password
"factor-test" >>database
- swap with-db ;">
+ swap with-db ; inline">
} ;
ABOUT: "db"
: dispose-statements ( assoc -- ) values dispose-each ;
-: db-dispose ( db -- )
+M: db dispose ( db -- )
dup db [
- {
- [ insert-statements>> dispose-statements ]
- [ update-statements>> dispose-statements ]
- [ delete-statements>> dispose-statements ]
- [ handle>> db-close ]
- } cleave
+ [ dispose-statements H{ } clone ] change-insert-statements
+ [ dispose-statements H{ } clone ] change-update-statements
+ [ dispose-statements H{ } clone ] change-delete-statements
+ [ db-close f ] change-handle
+ drop
] with-variable ;
TUPLE: result-set sql in-params out-params handle n max ;
[ password>> ]
} cleave connect-postgres >>handle ;
-M: postgresql-db dispose ( db -- )
- handle>> PQfinish ;
+M: postgresql-db db-close ( handle -- )
+ PQfinish ;
M: postgresql-statement bind-statement* ( statement -- ) drop ;
dup path>> sqlite-open >>handle ;
M: sqlite-db db-close ( handle -- ) sqlite-close ;
-M: sqlite-db dispose ( db -- ) db-dispose ;
TUPLE: sqlite-statement < statement ;
in-params>> [ sqlite-bind-conversion ] with map
] keep bind-statement ;
+ERROR: sqlite-last-id-fail ;
+
: last-insert-id ( -- id )
db get handle>> sqlite3_last_insert_rowid
- dup zero? [ "last-id failed" throw ] when ;
+ dup zero? [ sqlite-last-id-fail ] when ;
M: sqlite-db insert-tuple-set-key ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ;
--- /dev/null
+! 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"
-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
[ "/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
-! 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 )
{ 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 ;
"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 ;
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
{ "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
-USING: alien.syntax ;
+USING: alien.syntax unix.time ;
IN: unix
: FD_SETSIZE 1024 ; inline
{ "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
: 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" } ;
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types math vocabs.loader ;
IN: unix
: FD_SETSIZE 256 ; inline
: 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
--- /dev/null
+! 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" } ;
+
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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"
--- /dev/null
+! 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
--- /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
+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) ;
--- /dev/null
+unportable
: S_IFLNK OCT: 120000 ; inline ! Symbolic link.
: S_IFSOCK OCT: 140000 ; inline ! Socket.
-! File Access Permissions
-: S_ISUID OCT: 0004000 ; inline
-: S_ISGID OCT: 0002000 ; inline
-: S_ISVTX OCT: 0001000 ; inline
-: S_IRUSR OCT: 0000400 ; inline ! r owner
-: S_IWUSR OCT: 0000200 ; inline ! w owner
-: S_IXUSR OCT: 0000100 ; inline ! x owner
-: S_IRGRP OCT: 0000040 ; inline ! r group
-: S_IWGRP OCT: 0000020 ; inline ! w group
-: S_IXGRP OCT: 0000010 ; inline ! x group
-: 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 ) ;
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 ] }
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
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 ) ;
: _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 ) ;
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 ) ;
--- /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: 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"
--- /dev/null
+! 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
--- /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>> ;
+
+: 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
--- /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
[ 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
: parse-tuple-literal ( -- tuple )
scan-word scan {
+ { f [ unexpected-eof ] }
{ "f" [ \ } parse-until boa>tuple ] }
{ "{" [ parse-slot-values assoc>tuple ] }
{ "}" [ new ] }
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces make math sequences layouts
-alien.c-types alien.structs compiler.backend ;
+alien.c-types alien.structs cpu.architecture ;
IN: compiler.alien
-! Common utilities
-
: large-struct? ( ctype -- ? )
- dup c-struct? [
- heap-size struct-small-enough? not
- ] [ drop f ] if ;
+ dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
: alien-parameters ( params -- seq )
dup parameters>>
[ parameter-align drop dup , ] keep stack-size +
] reduce cell align
] { } make ;
-
-: return-size ( ctype -- n )
- #! Amount of space we reserve for a return value.
- dup large-struct? [ heap-size ] [ drop 0 ] if ;
-
-: alien-stack-frame ( params -- n )
- alien-parameters parameter-sizes drop ;
-
-: alien-invoke-frame ( params -- n )
- #! One cell is temporary storage, temp@
- dup return>> return-size
- swap alien-stack-frame +
- cell + ;
HOOK: load-indirect cpu ( obj reg -- )
-HOOK: stack-frame cpu ( frame-size -- n )
-
-: stack-frame* ( -- n )
- \ stack-frame get stack-frame ;
+HOOK: stack-frame-size cpu ( frame-size -- n )
! Set up caller stack frame
HOOK: %prologue cpu ( n -- )
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators hashtables kernel
math fry namespaces make sequences words byte-arrays
-locals layouts
+locals layouts alien.c-types alien.structs
stack-checker.inlining
compiler.intrinsics
compiler.tree
: emit-call ( word -- next )
finalize-phantoms
{
- { [ tail-call? not ] [ 0 ##frame-required ##call iterate-next ] }
+ { [ tail-call? not ] [ ##simple-stack-frame ##call iterate-next ] }
{ [ dup loops get key? ] [ loops get at local-recursive-call ] }
[ ##epilogue ##jump stop-iterating ]
} cond ;
(write-barrier)
} [ t "intrinsic" set-word-prop ] each
-: allot-size ( #call -- n )
+: allot-size ( -- n )
1 phantom-datastack get phantom-input first value>> ;
:: emit-allot ( size type tag -- )
M: #terminate emit-node drop stop-iterating ;
! FFI
+: return-size ( ctype -- n )
+ #! Amount of space we reserve for a return value.
+ {
+ { [ dup c-struct? not ] [ drop 0 ] }
+ { [ dup large-struct? not ] [ drop 2 cells ] }
+ [ heap-size ]
+ } cond ;
+
+: <alien-stack-frame> ( params -- stack-frame )
+ stack-frame new
+ swap
+ [ return>> return-size >>return ]
+ [ alien-parameters parameter-sizes drop >>params ] bi
+ dup [ params>> ] [ return>> ] bi + >>size ;
+
+: alien-stack-frame ( node -- )
+ params>> <alien-stack-frame> ##stack-frame ;
+
+: emit-alien-node ( node quot -- next )
+ [ drop alien-stack-frame ]
+ [ [ params>> ] dip call ] 2bi
+ iterate-next ; inline
+
M: #alien-invoke emit-node
- params>>
- [ alien-invoke-frame ##frame-required ]
- [ ##alien-invoke iterate-next ]
- bi ;
+ [ ##alien-invoke ] emit-alien-node ;
M: #alien-indirect emit-node
- params>>
- [ alien-invoke-frame ##frame-required ]
- [ ##alien-indirect iterate-next ]
- bi ;
+ [ ##alien-indirect ] emit-alien-node ;
M: #alien-callback emit-node
params>> dup xt>> dup
- [ init-phantoms ##alien-callback ] with-cfg-builder
+ [
+ init-phantoms
+ [ ##alien-callback ] emit-alien-node drop
+ ] with-cfg-builder
iterate-next ;
! No-op nodes
V{ } clone >>instructions
V{ } clone >>successors ;
-TUPLE: mr instructions word label frame-size spill-counts ;
+TUPLE: mr instructions word label ;
: <mr> ( instructions word label -- mr )
mr new
INSN: ##inc-d n ;
INSN: ##inc-r n ;
-! Calling convention
-INSN: ##return ;
-
! Subroutine calls
+TUPLE: stack-frame
+{ size integer }
+{ params integer }
+{ return integer }
+{ total-size integer } ;
+
+INSN: ##stack-frame stack-frame ;
+ : ##simple-stack-frame ( -- ) T{ stack-frame } ##stack-frame ;
INSN: ##call word ;
INSN: ##jump word ;
+INSN: ##return ;
+
INSN: ##intrinsic quot defs-vregs uses-vregs ;
! Jump tables
! Instructions used by CFG IR only.
INSN: ##prologue ;
INSN: ##epilogue ;
-INSN: ##frame-required n ;
INSN: ##branch ;
INSN: ##branch-f < ##cond-branch ;
M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
! Instructions used by machine IR only.
-INSN: _prologue ;
-INSN: _epilogue ;
+INSN: _prologue stack-frame ;
+INSN: _epilogue stack-frame ;
INSN: _label id ;
SYMBOL: frame-required?
-SYMBOL: frame-size
-
SYMBOL: spill-counts
: init-stack-frame-builder ( -- )
frame-required? off
- 0 frame-size set ;
+ T{ stack-frame } clone stack-frame set ;
+
+GENERIC: compute-stack-frame* ( insn -- )
-GENERIC: compute-frame-size* ( insn -- )
+: max-stack-frame ( frame1 frame2 -- frame3 )
+ {
+ [ [ size>> ] bi@ max ]
+ [ [ params>> ] bi@ max ]
+ [ [ return>> ] bi@ max ]
+ [ [ total-size>> ] bi@ max ]
+ } cleave
+ stack-frame boa ;
-M: ##frame-required compute-frame-size*
+M: ##stack-frame compute-stack-frame*
frame-required? on
- n>> frame-size [ max ] change ;
+ stack-frame>> stack-frame [ max-stack-frame ] change ;
-M: _spill-integer compute-frame-size*
+M: _spill-integer compute-stack-frame*
drop frame-required? on ;
-M: _spill-float compute-frame-size*
+M: _spill-float compute-stack-frame*
drop frame-required? on ;
-M: insn compute-frame-size* drop ;
+M: insn compute-stack-frame* drop ;
-: compute-frame-size ( insns -- )
- [ compute-frame-size* ] each ;
+: compute-stack-frame ( insns -- )
+ [ compute-stack-frame* ] each ;
GENERIC: insert-pro/epilogues* ( insn -- )
-M: ##frame-required insert-pro/epilogues* drop ;
+M: ##stack-frame insert-pro/epilogues* drop ;
M: ##prologue insert-pro/epilogues*
- drop frame-required? get [ _prologue ] when ;
+ drop frame-required? get [ stack-frame get _prologue ] when ;
M: ##epilogue insert-pro/epilogues*
- drop frame-required? get [ _epilogue ] when ;
+ drop frame-required? get [ stack-frame get _epilogue ] when ;
M: insn insert-pro/epilogues* , ;
[
init-stack-frame-builder
[
- [ compute-frame-size ]
+ [ compute-stack-frame ]
[ insert-pro/epilogues ]
bi
] change-instructions
- frame-size get >>frame-size
] with-scope ;
finalize-contents
finalize-heights
fresh-objects get [
- empty? [ 0 ##frame-required ##gc ] unless
+ empty? [ ##simple-stack-frame ##gc ] unless
] [ delete-all ] bi ;
: init-phantoms ( -- )
: lazy-load ( specs -- seq )
[ length phantom-datastack get phantom-input ] keep
- [ drop ] [
- [
- 2dup second clobbered?
- [ first (eager-load) ] [ first (lazy-load) ] if
- ] 2map
- ] 2bi
- [ substitute-vregs ] keep ;
+ [
+ 2dup second clobbered?
+ [ first (eager-load) ] [ first (lazy-load) ] if
+ ] 2map ;
: load-inputs ( template -- assoc )
[
compiler.codegen.fixup
compiler.cfg
compiler.cfg.instructions
-compiler.cfg.registers ;
+compiler.cfg.registers
+compiler.cfg.builder ;
IN: compiler.codegen
GENERIC: generate-insn ( insn -- )
id>> lookup-label , ;
M: _prologue generate-insn
- drop %prologue ;
+ stack-frame>>
+ [ stack-frame set ]
+ [ dup size>> stack-frame-size >>total-size drop ]
+ [ total-size>> %prologue ]
+ tri ;
M: _epilogue generate-insn
- drop %epilogue ;
+ stack-frame>> total-size>> %epilogue ;
M: ##load-literal generate-insn
[ obj>> ] [ dst>> v>operand ] bi load-literal ;
#! parameters. If the C function is returning a structure,
#! the first parameter is an implicit target area pointer,
#! so we need to use a different offset.
- return>> dup large-struct?
- [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
+ return>> large-struct?
+ [ %prepare-box-struct cell ] [ 0 ] if ;
: objects>registers ( params -- )
#! Generate code for unboxing a list of C types, then
: callback-unwind ( params -- n )
{
- { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
+ { [ dup abi>> "stdcall" = ] [ <alien-stack-frame> size>> ] }
{ [ dup return>> large-struct? ] [ drop 4 ] }
[ drop 0 ]
} cond ;
+++ /dev/null
-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 ;
-
: 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
{
void factorbug(void)
{
+ if(fep_disabled)
+ {
+ printf("Low level debugger disabled\n");
+ exit(1);
+ }
+
open_console();
printf("Starting low level debugger...\n");
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();
void factorbug(void);
void dump_zone(F_ZONE *z);
+bool fep_disabled;
+
DECLARE_PRIMITIVE(die);
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();
}
}
projects / factor.git / commitdiff