From 2c1f6ee3dd37c8ef92b6df2ad34928d55b8984cc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 19 Sep 2008 22:06:28 -0500 Subject: [PATCH 01/31] apply p1dzkl's patch to let the windows ui cascade new windows instead of putting them all on top of each other. thanks! --- basis/ui/windows/windows.factor | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 345c73bcb9..3e600d2e3c 100644 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -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" 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 From 5cc44e8ad84dd1fc4b0459816e1ec443566e32f7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 7 Oct 2008 13:15:29 -0500 Subject: [PATCH 02/31] move passwd struct from macosx to bsd --- basis/unix/bsd/bsd.factor | 13 +++++++++++++ basis/unix/bsd/macosx/macosx.factor | 13 ------------- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/basis/unix/bsd/bsd.factor b/basis/unix/bsd/bsd.factor index 6934d5b8dc..7bbf2b4fdf 100644 --- a/basis/unix/bsd/bsd.factor +++ b/basis/unix/bsd/bsd.factor @@ -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 diff --git a/basis/unix/bsd/macosx/macosx.factor b/basis/unix/bsd/macosx/macosx.factor index 6582d29687..9b4dd1c53b 100644 --- a/basis/unix/bsd/macosx/macosx.factor +++ b/basis/unix/bsd/macosx/macosx.factor @@ -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 From 9e807a88c6ce3b461b71cdabbd81fb514325233e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 7 Oct 2008 13:16:18 -0500 Subject: [PATCH 03/31] ffi work --- basis/unix/unix.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index a68274f09b..facfa4b9d4 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -9,6 +9,7 @@ IN: unix TYPEDEF: uint in_addr_t TYPEDEF: uint socklen_t +TYPEDEF: int int32_t : PROT_NONE 0 ; inline : PROT_READ 1 ; inline @@ -78,6 +79,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 +94,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 +112,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 ) ; From 6a5dd26c52ff727b72a1dde8d9558bc9ea7e493c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 7 Oct 2008 16:13:29 -0500 Subject: [PATCH 04/31] Working on new codegen again --- unfinished/compiler/alien/alien.factor | 21 +-------- unfinished/compiler/backend/backend.factor | 5 +-- .../compiler/cfg/builder/builder.factor | 44 ++++++++++++++----- unfinished/compiler/cfg/cfg.factor | 2 +- .../cfg/instructions/instructions.factor | 18 +++++--- .../cfg/stack-frame/stack-frame.factor | 38 +++++++++------- unfinished/compiler/cfg/stacks/stacks.factor | 2 +- .../compiler/cfg/templates/templates.factor | 11 ++--- unfinished/compiler/codegen/codegen.factor | 17 ++++--- 9 files changed, 86 insertions(+), 72 deletions(-) diff --git a/unfinished/compiler/alien/alien.factor b/unfinished/compiler/alien/alien.factor index 1d63a06057..e414d6e29b 100644 --- a/unfinished/compiler/alien/alien.factor +++ b/unfinished/compiler/alien/alien.factor @@ -1,15 +1,11 @@ ! 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>> @@ -31,16 +27,3 @@ IN: compiler.alien [ 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 + ; diff --git a/unfinished/compiler/backend/backend.factor b/unfinished/compiler/backend/backend.factor index 2efd22610e..2a516c6ec4 100644 --- a/unfinished/compiler/backend/backend.factor +++ b/unfinished/compiler/backend/backend.factor @@ -33,10 +33,7 @@ GENERIC# load-literal 1 ( obj reg -- ) 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 -- ) diff --git a/unfinished/compiler/cfg/builder/builder.factor b/unfinished/compiler/cfg/builder/builder.factor index ff1ddd9747..c8add3ca09 100755 --- a/unfinished/compiler/cfg/builder/builder.factor +++ b/unfinished/compiler/cfg/builder/builder.factor @@ -2,7 +2,7 @@ ! 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 @@ -107,7 +107,7 @@ SYMBOL: +if-intrinsics+ : 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 ; @@ -235,7 +235,7 @@ M: #dispatch emit-node (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 -- ) @@ -306,21 +306,41 @@ M: #return-recursive emit-node 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 ; + +: ( 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>> ##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 diff --git a/unfinished/compiler/cfg/cfg.factor b/unfinished/compiler/cfg/cfg.factor index 140d406c4c..e32ad47890 100644 --- a/unfinished/compiler/cfg/cfg.factor +++ b/unfinished/compiler/cfg/cfg.factor @@ -19,7 +19,7 @@ successors ; V{ } clone >>instructions V{ } clone >>successors ; -TUPLE: mr instructions word label frame-size spill-counts ; +TUPLE: mr instructions word label ; : ( instructions word label -- mr ) mr new diff --git a/unfinished/compiler/cfg/instructions/instructions.factor b/unfinished/compiler/cfg/instructions/instructions.factor index 9bb576dcb3..3014587edd 100644 --- a/unfinished/compiler/cfg/instructions/instructions.factor +++ b/unfinished/compiler/cfg/instructions/instructions.factor @@ -17,12 +17,19 @@ INSN: ##replace src loc ; 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 @@ -87,7 +94,6 @@ M: ##intrinsic uses-vregs intrinsic-uses-vregs ; ! Instructions used by CFG IR only. INSN: ##prologue ; INSN: ##epilogue ; -INSN: ##frame-required n ; INSN: ##branch ; INSN: ##branch-f < ##cond-branch ; @@ -100,8 +106,8 @@ M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ; 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 ; diff --git a/unfinished/compiler/cfg/stack-frame/stack-frame.factor b/unfinished/compiler/cfg/stack-frame/stack-frame.factor index 56282cfb09..6ec34d37c2 100644 --- a/unfinished/compiler/cfg/stack-frame/stack-frame.factor +++ b/unfinished/compiler/cfg/stack-frame/stack-frame.factor @@ -7,40 +7,47 @@ IN: compiler.cfg.stack-frame 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-frame-size* ( insn -- ) +GENERIC: compute-stack-frame* ( insn -- ) -M: ##frame-required compute-frame-size* +: max-stack-frame ( frame1 frame2 -- frame3 ) + { + [ [ size>> ] bi@ max ] + [ [ params>> ] bi@ max ] + [ [ return>> ] bi@ max ] + [ [ total-size>> ] bi@ max ] + } cleave + stack-frame boa ; + +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* , ; @@ -51,9 +58,8 @@ 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 ; diff --git a/unfinished/compiler/cfg/stacks/stacks.factor b/unfinished/compiler/cfg/stacks/stacks.factor index 39cd942bb2..56be18c107 100755 --- a/unfinished/compiler/cfg/stacks/stacks.factor +++ b/unfinished/compiler/cfg/stacks/stacks.factor @@ -312,7 +312,7 @@ M: loc lazy-store finalize-contents finalize-heights fresh-objects get [ - empty? [ 0 ##frame-required ##gc ] unless + empty? [ ##simple-stack-frame ##gc ] unless ] [ delete-all ] bi ; : init-phantoms ( -- ) diff --git a/unfinished/compiler/cfg/templates/templates.factor b/unfinished/compiler/cfg/templates/templates.factor index 12a56704d0..72e092ad68 100644 --- a/unfinished/compiler/cfg/templates/templates.factor +++ b/unfinished/compiler/cfg/templates/templates.factor @@ -28,13 +28,10 @@ TUPLE: template input output scratch clobber gc ; : 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 ) [ diff --git a/unfinished/compiler/codegen/codegen.factor b/unfinished/compiler/codegen/codegen.factor index 15ebd691bf..fe6b45e88a 100644 --- a/unfinished/compiler/codegen/codegen.factor +++ b/unfinished/compiler/codegen/codegen.factor @@ -10,7 +10,8 @@ compiler.backend compiler.codegen.fixup compiler.cfg compiler.cfg.instructions -compiler.cfg.registers ; +compiler.cfg.registers +compiler.cfg.builder ; IN: compiler.codegen GENERIC: generate-insn ( insn -- ) @@ -71,10 +72,14 @@ M: _label generate-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 ; @@ -276,8 +281,8 @@ M: long-long-type flatten-value-type ( type -- types ) #! 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 @@ -413,7 +418,7 @@ TUPLE: callback-context ; : callback-unwind ( params -- n ) { - { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] } + { [ dup abi>> "stdcall" = ] [ size>> ] } { [ dup return>> large-struct? ] [ drop 4 ] } [ drop 0 ] } cond ; From a10fd92a33df1c2a17ec5a5414114f225679dc8c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 7 Oct 2008 17:18:49 -0500 Subject: [PATCH 05/31] fix lambda-macro reset-word bug --- basis/locals/locals.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index 05ea3cb524..bbcc8a6745 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -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 ; From 9940031cda88a6a872f3842f31afb7128b6c873a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 7 Oct 2008 17:47:20 -0500 Subject: [PATCH 06/31] removed dead code in unmaintained/io --- unmaintained/io/io.factor | 8 -- unmaintained/io/os-unix.factor | 213 --------------------------------- 2 files changed, 221 deletions(-) delete mode 100644 unmaintained/io/io.factor diff --git a/unmaintained/io/io.factor b/unmaintained/io/io.factor deleted file mode 100644 index 24151d96c6..0000000000 --- a/unmaintained/io/io.factor +++ /dev/null @@ -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 ; - diff --git a/unmaintained/io/os-unix.factor b/unmaintained/io/os-unix.factor index 7ae47cda3d..280908b406 100644 --- a/unmaintained/io/os-unix.factor +++ b/unmaintained/io/os-unix.factor @@ -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 ; - -: ( path -- stream ) open-append ; - -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" [ stat io-error ] keep ; - -: make-timeval-array ( array -- byte-array ) - [ length "timeval" ] 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 { From 9228d367a14d3003d67b079b1301bb7c2d708542 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 7 Oct 2008 19:23:35 -0500 Subject: [PATCH 07/31] ffi structs and typedefs --- basis/unix/bsd/macosx/macosx.factor | 15 ++++++++++ basis/unix/bsd/netbsd/netbsd.factor | 45 ++++++++++++++++++++++++++++- basis/unix/stat/stat.factor | 24 +++++++-------- basis/unix/types/types.factor | 23 +++++++++++++++ basis/unix/unix.factor | 4 --- 5 files changed, 94 insertions(+), 17 deletions(-) diff --git a/basis/unix/bsd/macosx/macosx.factor b/basis/unix/bsd/macosx/macosx.factor index 9b4dd1c53b..ed2bdecf61 100644 --- a/basis/unix/bsd/macosx/macosx.factor +++ b/basis/unix/bsd/macosx/macosx.factor @@ -117,3 +117,18 @@ C-STRUCT: addrinfo : 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" } ; diff --git a/basis/unix/bsd/netbsd/netbsd.factor b/basis/unix/bsd/netbsd/netbsd.factor index e646f87116..6bae953938 100644 --- a/basis/unix/bsd/netbsd/netbsd.factor +++ b/basis/unix/bsd/netbsd/netbsd.factor @@ -1,4 +1,4 @@ -USING: alien.syntax ; +USING: alien.syntax alien.c-types math ; IN: unix : FD_SETSIZE 256 ; inline @@ -111,3 +111,46 @@ 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 + +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" } ; diff --git a/basis/unix/stat/stat.factor b/basis/unix/stat/stat.factor index 062ad7e1bb..139f1b1983 100644 --- a/basis/unix/stat/stat.factor +++ b/basis/unix/stat/stat.factor @@ -15,18 +15,18 @@ IN: unix.stat : 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 +: UID OCT: 0004000 ; inline +: GID OCT: 0002000 ; inline +: STICKY OCT: 0001000 ; inline +: USER-READ OCT: 0000400 ; inline ! r owner +: USER-WRITE OCT: 0000200 ; inline ! w owner +: USER-EXECUTE OCT: 0000100 ; inline ! x owner +: GROUP-READ OCT: 0000040 ; inline ! r group +: GROUP-WRITE OCT: 0000020 ; inline ! w group +: GROUP-EXECUTE OCT: 0000010 ; inline ! x group +: OTHER-READ OCT: 0000004 ; inline ! r other +: OTHER-WRITE OCT: 0000002 ; inline ! w other +: OTHER-EXECUTE OCT: 0000001 ; inline ! x other FUNCTION: int chmod ( char* path, mode_t mode ) ; FUNCTION: int fchmod ( int fd, mode_t mode ) ; diff --git a/basis/unix/types/types.factor b/basis/unix/types/types.factor index 0ac2fa608e..69d07a07f1 100644 --- a/basis/unix/types/types.factor +++ b/basis/unix/types/types.factor @@ -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 ] } diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index facfa4b9d4..960115d1a6 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -7,10 +7,6 @@ stack-checker macros locals generalizations unix.types debugger io prettyprint ; IN: unix -TYPEDEF: uint in_addr_t -TYPEDEF: uint socklen_t -TYPEDEF: int int32_t - : PROT_NONE 0 ; inline : PROT_READ 1 ; inline : PROT_WRITE 2 ; inline From 5916fcea75cc23f62cd0c6868803d315cdabafe0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 7 Oct 2008 19:25:05 -0500 Subject: [PATCH 08/31] initial comit of groups, users, and utmpx --- basis/unix/groups/authors.txt | 1 + basis/unix/groups/groups.factor | 123 ++++++++++++++++++++ basis/unix/groups/tags.txt | 1 + basis/unix/users/authors.txt | 1 + basis/unix/users/bsd/authors.txt | 1 + basis/unix/users/bsd/bsd.factor | 19 +++ basis/unix/users/bsd/tags.txt | 1 + basis/unix/users/tags.txt | 1 + basis/unix/users/users.factor | 114 ++++++++++++++++++ basis/unix/utmpx/authors.txt | 1 + basis/unix/utmpx/macosx/authors.txt | 1 + basis/unix/utmpx/macosx/macosx-tests.factor | 4 + basis/unix/utmpx/macosx/macosx.factor | 6 + basis/unix/utmpx/macosx/tags.txt | 1 + basis/unix/utmpx/netbsd/authors.txt | 1 + basis/unix/utmpx/netbsd/netbsd-tests.factor | 4 + basis/unix/utmpx/netbsd/netbsd.factor | 22 ++++ basis/unix/utmpx/netbsd/tags.txt | 1 + basis/unix/utmpx/tags.txt | 1 + basis/unix/utmpx/utmpx.factor | 66 +++++++++++ 20 files changed, 370 insertions(+) create mode 100644 basis/unix/groups/authors.txt create mode 100644 basis/unix/groups/groups.factor create mode 100644 basis/unix/groups/tags.txt create mode 100644 basis/unix/users/authors.txt create mode 100644 basis/unix/users/bsd/authors.txt create mode 100644 basis/unix/users/bsd/bsd.factor create mode 100644 basis/unix/users/bsd/tags.txt create mode 100644 basis/unix/users/tags.txt create mode 100644 basis/unix/users/users.factor create mode 100644 basis/unix/utmpx/authors.txt create mode 100644 basis/unix/utmpx/macosx/authors.txt create mode 100644 basis/unix/utmpx/macosx/macosx-tests.factor create mode 100644 basis/unix/utmpx/macosx/macosx.factor create mode 100644 basis/unix/utmpx/macosx/tags.txt create mode 100644 basis/unix/utmpx/netbsd/authors.txt create mode 100644 basis/unix/utmpx/netbsd/netbsd-tests.factor create mode 100644 basis/unix/utmpx/netbsd/netbsd.factor create mode 100644 basis/unix/utmpx/netbsd/tags.txt create mode 100644 basis/unix/utmpx/tags.txt create mode 100644 basis/unix/utmpx/utmpx.factor diff --git a/basis/unix/groups/authors.txt b/basis/unix/groups/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/unix/groups/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor new file mode 100644 index 0000000000..5a33bfe072 --- /dev/null +++ b/basis/unix/groups/groups.factor @@ -0,0 +1,123 @@ +! 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 ) + +string + [ alien-address "char**" heap-size + ] dip + ] [ ] produce nip ; + +: (group-struct) ( id -- group-struct id group-struct byte-array length void* ) + "group" tuck 1024 + [ ] keep f ; + +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 ; + +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 * ] keep + [ 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 + + + +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) ; diff --git a/basis/unix/groups/tags.txt b/basis/unix/groups/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/groups/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/users/authors.txt b/basis/unix/users/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/unix/users/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/unix/users/bsd/authors.txt b/basis/unix/users/bsd/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/unix/users/bsd/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/unix/users/bsd/bsd.factor b/basis/unix/users/bsd/bsd.factor new file mode 100644 index 0000000000..b3778ced70 --- /dev/null +++ b/basis/unix/users/bsd/bsd.factor @@ -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 ; diff --git a/basis/unix/users/bsd/tags.txt b/basis/unix/users/bsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/users/bsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/users/tags.txt b/basis/unix/users/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/users/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor new file mode 100644 index 0000000000..184312e0ce --- /dev/null +++ b/basis/unix/users/users.factor @@ -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 ) + +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 + + + +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 diff --git a/basis/unix/utmpx/authors.txt b/basis/unix/utmpx/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/unix/utmpx/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/unix/utmpx/macosx/authors.txt b/basis/unix/utmpx/macosx/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/utmpx/macosx/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/utmpx/macosx/macosx-tests.factor b/basis/unix/utmpx/macosx/macosx-tests.factor new file mode 100644 index 0000000000..b0aa97dbca --- /dev/null +++ b/basis/unix/utmpx/macosx/macosx-tests.factor @@ -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 diff --git a/basis/unix/utmpx/macosx/macosx.factor b/basis/unix/utmpx/macosx/macosx.factor new file mode 100644 index 0000000000..92a0d9e3a4 --- /dev/null +++ b/basis/unix/utmpx/macosx/macosx.factor @@ -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 diff --git a/basis/unix/utmpx/macosx/tags.txt b/basis/unix/utmpx/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/utmpx/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/utmpx/netbsd/authors.txt b/basis/unix/utmpx/netbsd/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/utmpx/netbsd/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/utmpx/netbsd/netbsd-tests.factor b/basis/unix/utmpx/netbsd/netbsd-tests.factor new file mode 100644 index 0000000000..5bd0e4622f --- /dev/null +++ b/basis/unix/utmpx/netbsd/netbsd-tests.factor @@ -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 diff --git a/basis/unix/utmpx/netbsd/netbsd.factor b/basis/unix/utmpx/netbsd/netbsd.factor new file mode 100644 index 0000000000..40fce746b1 --- /dev/null +++ b/basis/unix/utmpx/netbsd/netbsd.factor @@ -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 ; diff --git a/basis/unix/utmpx/netbsd/tags.txt b/basis/unix/utmpx/netbsd/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/utmpx/netbsd/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/utmpx/tags.txt b/basis/unix/utmpx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/utmpx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/utmpx/utmpx.factor b/basis/unix/utmpx/utmpx.factor new file mode 100644 index 0000000000..e1756daa00 --- /dev/null +++ b/basis/unix/utmpx/utmpx.factor @@ -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 From 5afbade0a54a6dd5f753ffd413d8b0436e85630f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 7 Oct 2008 19:25:22 -0500 Subject: [PATCH 09/31] setting permissions, file times --- basis/io/unix/files/files.factor | 102 ++++++++++++++++++++++++++++++- 1 file changed, 99 insertions(+), 3 deletions(-) diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index 6ddb74f4a3..ba8f51da4c 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -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,99 @@ os { { freebsd [ "io.unix.files.bsd" require ] } { linux [ ] } } case + + + +: set-uid? ( path -- ? ) UID file-mode? ; +: set-gid? ( path -- ? ) GID file-mode? ; +: set-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 octal-n -- ) + [ normalize-path ] dip chmod io-error ; + + ] 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-write-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-username ( path string/id -- ) + +GENERIC: set-file-group ( path string/id -- ) + +M: integer set-file-username ( path uid -- ) + f set-file-ids ; + +M: string set-file-username ( path string -- ) + username-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-uid ( path -- uid ) normalize-path file-info uid>> ; + +: file-user-name ( path -- string ) file-uid username ; + +: file-gid ( path -- gid ) normalize-path file-info gid>> ; + +: file-group ( path -- string ) file-gid group-name ; From fb23eca0d93df5689faa5e7f57f094d2eef5ffdd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 13:03:55 -0500 Subject: [PATCH 10/31] move file flags to io.unix.files, change some word names for consistency --- basis/io/unix/files/files.factor | 39 +++++++++++++++++++++++++------- basis/unix/stat/stat.factor | 14 ------------ 2 files changed, 31 insertions(+), 22 deletions(-) diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index ba8f51da4c..49510f9841 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -150,9 +150,25 @@ os { PRIVATE> -: set-uid? ( path -- ? ) UID file-mode? ; -: set-gid? ( path -- ? ) GID file-mode? ; -: set-sticky? ( path -- ? ) STICKY file-mode? ; +: 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? ; @@ -176,9 +192,12 @@ PRIVATE> : set-other-write ( path ? -- ) OTHER-WRITE swap chmod-set-bit ; : set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ; -: set-file-permissions ( path octal-n -- ) +: set-file-permissions ( path n -- ) [ normalize-path ] dip chmod io-error ; +: file-permissions ( path -- n ) + normalize-path file-info permissions>> ; + > ; +: file-username-id ( path -- uid ) + normalize-path file-info uid>> ; -: file-user-name ( path -- string ) file-uid username ; +: file-username ( path -- string ) + file-username-id username ; -: file-gid ( path -- gid ) normalize-path file-info gid>> ; +: file-group-id ( path -- gid ) + normalize-path file-info gid>> ; -: file-group ( path -- string ) file-gid group-name ; +: file-group-name ( path -- string ) + file-group-id group-name ; diff --git a/basis/unix/stat/stat.factor b/basis/unix/stat/stat.factor index 139f1b1983..46fe7d98f9 100644 --- a/basis/unix/stat/stat.factor +++ b/basis/unix/stat/stat.factor @@ -14,20 +14,6 @@ IN: unix.stat : S_IFLNK OCT: 120000 ; inline ! Symbolic link. : S_IFSOCK OCT: 140000 ; inline ! Socket. -! File Access Permissions -: UID OCT: 0004000 ; inline -: GID OCT: 0002000 ; inline -: STICKY OCT: 0001000 ; inline -: USER-READ OCT: 0000400 ; inline ! r owner -: USER-WRITE OCT: 0000200 ; inline ! w owner -: USER-EXECUTE OCT: 0000100 ; inline ! x owner -: GROUP-READ OCT: 0000040 ; inline ! r group -: GROUP-WRITE OCT: 0000020 ; inline ! w group -: GROUP-EXECUTE OCT: 0000010 ; inline ! x group -: OTHER-READ OCT: 0000004 ; inline ! r other -: OTHER-WRITE OCT: 0000002 ; inline ! w other -: OTHER-EXECUTE 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 ) ; From 0f891e002bd3801434a7c300af55409d29e1ae60 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 13:04:23 -0500 Subject: [PATCH 11/31] add io.unix.files docs --- basis/io/unix/files/files-docs.factor | 277 ++++++++++++++++++++++++++ 1 file changed, 277 insertions(+) create mode 100644 basis/io/unix/files/files-docs.factor diff --git a/basis/io/unix/files/files-docs.factor b/basis/io/unix/files/files-docs.factor new file mode 100644 index 0000000000..7b4ce10b86 --- /dev/null +++ b/basis/io/unix/files/files-docs.factor @@ -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-username-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-username +{ $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-write-time +{ $values + { "path" "a pathname string" } { "timestamp" timestamp } } +{ $description "Sets a file's last 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 write time:" +{ $subsection set-file-write-time } ; + + +ARTICLE: "unix-file-ids" "Unix file user and group ids" +"Reading file user data:" +{ $subsection file-username-id } +{ $subsection file-username } +"Setting file user data:" +{ $subsection set-file-username } +"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" From 65b891a687cd0558b53cd6ee14d4b835c1e0dcd5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 13:05:00 -0500 Subject: [PATCH 12/31] document unix.users --- basis/unix/users/users-docs.factor | 120 +++++++++++++++++++++++++++++ basis/unix/users/users.factor | 4 +- 2 files changed, 122 insertions(+), 2 deletions(-) create mode 100644 basis/unix/users/users-docs.factor diff --git a/basis/unix/users/users-docs.factor b/basis/unix/users/users-docs.factor new file mode 100644 index 0000000000..caa938f047 --- /dev/null +++ b/basis/unix/users/users-docs.factor @@ -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-username-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-username-id +{ $values + + { "id" integer } } +{ $description "The real user id of the current user." } ; + +HELP: set-effective-username +{ $values + { "string/id" "a string or a user id" } } +{ $description "Sets the current effective username." } ; + +HELP: set-real-username +{ $values + { "string/id" "a string or a user id" } } +{ $description "Sets the current real username." } ; + +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: username-id +{ $values + { "string" string } + { "id" integer } } +{ $description "Returns the user id associated with the username." } ; + +HELP: with-effective-username +{ $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-username +{ $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-username-id set-real-username + effective-username effective-username-id + set-effective-username +} 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-username-id } +{ $subsection set-real-username } +"Effective user:" +{ $subsection effective-username } +{ $subsection effective-username-id } +{ $subsection set-effective-username } +"Combinators to change users:" +{ $subsection with-real-username } +{ $subsection with-effective-username } ; + +ABOUT: "unix.users" diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index 184312e0ce..1b2e414a88 100644 --- a/basis/unix/users/users.factor +++ b/basis/unix/users/users.factor @@ -60,13 +60,13 @@ M: string user-passwd ( string -- passwd/f ) : username-id ( string -- id ) user-passwd username>> ; -: real-username-id ( -- string ) +: real-username-id ( -- id ) getuid ; inline : real-username ( -- string ) real-username-id username ; inline -: effective-username-id ( -- string ) +: effective-username-id ( -- id ) geteuid username ; inline : effective-username ( -- string ) From 1ba5b448d7654b737d9c19bfa7e4457c53ae91ec Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 13:05:16 -0500 Subject: [PATCH 13/31] document unix.groups --- basis/unix/groups/groups-docs.factor | 108 +++++++++++++++++++++++++++ basis/unix/groups/groups.factor | 17 ++++- 2 files changed, 121 insertions(+), 4 deletions(-) create mode 100644 basis/unix/groups/groups-docs.factor diff --git a/basis/unix/groups/groups-docs.factor b/basis/unix/groups/groups-docs.factor new file mode 100644 index 0000000000..ef2631ae3f --- /dev/null +++ b/basis/unix/groups/groups-docs.factor @@ -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" diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index 5a33bfe072..7f3aa9ae98 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -3,7 +3,8 @@ 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 ; +accessors math.parser fry assocs namespaces continuations +unix.users ; IN: unix.groups QUALIFIED: grouping @@ -61,14 +62,22 @@ PRIVATE> : >groups ( byte-array n -- groups ) [ 4 grouping:group ] dip head-slice [ *uint group-name ] map ; -PRIVATE> - -: user-groups ( string -- seq ) +: (user-groups) ( string -- seq ) #! first group is -1337, legacy unix code -1337 NGROUPS_MAX [ 4 * ] keep [ 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 ; From e7e0e7ad695ead652cd4fb68589411e6081cc208 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 13:13:25 -0500 Subject: [PATCH 14/31] fix bugs in unix.users found by adding unit tests. oops --- basis/unix/users/users.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index 1b2e414a88..9545a2c5c6 100644 --- a/basis/unix/users/users.factor +++ b/basis/unix/users/users.factor @@ -58,7 +58,7 @@ M: string user-passwd ( string -- passwd/f ) user-passwd username>> ; : username-id ( string -- id ) - user-passwd username>> ; + user-passwd uid>> ; : real-username-id ( -- id ) getuid ; inline @@ -67,7 +67,7 @@ M: string user-passwd ( string -- passwd/f ) real-username-id username ; inline : effective-username-id ( -- id ) - geteuid username ; inline + geteuid ; inline : effective-username ( -- string ) effective-username-id username ; inline From f026177e2730d95e07afa95b282bea77d3970862 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 13:22:53 -0500 Subject: [PATCH 15/31] add users tests, fix naming inconsistencies --- basis/unix/users/users-docs.factor | 36 +++++++++++----------- basis/unix/users/users-tests.factor | 24 +++++++++++++++ basis/unix/users/users.factor | 46 ++++++++++++++--------------- 3 files changed, 65 insertions(+), 41 deletions(-) create mode 100644 basis/unix/users/users-tests.factor diff --git a/basis/unix/users/users-docs.factor b/basis/unix/users/users-docs.factor index caa938f047..f8586ffc35 100644 --- a/basis/unix/users/users-docs.factor +++ b/basis/unix/users/users-docs.factor @@ -15,7 +15,7 @@ HELP: effective-username { "string" string } } { $description "Returns the effective username for the current user." } ; -HELP: effective-username-id +HELP: effective-user-id { $values { "id" integer } } @@ -45,21 +45,21 @@ HELP: real-username { "string" string } } { $description "The real username of the current user." } ; -HELP: real-username-id +HELP: real-user-id { $values { "id" integer } } { $description "The real user id of the current user." } ; -HELP: set-effective-username +HELP: set-effective-user { $values { "string/id" "a string or a user id" } } -{ $description "Sets the current effective username." } ; +{ $description "Sets the current effective user given a username or a user id." } ; -HELP: set-real-username +HELP: set-real-user { $values { "string/id" "a string or a user id" } } -{ $description "Sets the current real username." } ; +{ $description "Sets the current real user given a username or a user id." } ; HELP: user-passwd { $values @@ -73,13 +73,13 @@ HELP: username { "string" string } } { $description "Returns the username associated with the user id." } ; -HELP: username-id +HELP: user-id { $values { "string" string } { "id" integer } } { $description "Returns the user id associated with the username." } ; -HELP: with-effective-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." } ; @@ -89,15 +89,15 @@ HELP: with-passwd-cache { "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-username +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-username-id set-real-username - effective-username effective-username-id - set-effective-username + real-username real-user-id set-real-user + effective-username effective-user-id + set-effective-user } related-words ARTICLE: "unix.users" "unix.users" @@ -107,14 +107,14 @@ ARTICLE: "unix.users" "unix.users" "Returning a passwd tuple:" "Real user:" { $subsection real-username } -{ $subsection real-username-id } -{ $subsection set-real-username } +{ $subsection real-user-id } +{ $subsection set-real-user } "Effective user:" { $subsection effective-username } -{ $subsection effective-username-id } -{ $subsection set-effective-username } +{ $subsection effective-user-id } +{ $subsection set-effective-user } "Combinators to change users:" -{ $subsection with-real-username } -{ $subsection with-effective-username } ; +{ $subsection with-real-user } +{ $subsection with-effective-user } ; ABOUT: "unix.users" diff --git a/basis/unix/users/users-tests.factor b/basis/unix/users/users-tests.factor new file mode 100644 index 0000000000..a85c322aca --- /dev/null +++ b/basis/unix/users/users-tests.factor @@ -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 diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index 9545a2c5c6..eac771160b 100644 --- a/basis/unix/users/users.factor +++ b/basis/unix/users/users.factor @@ -57,56 +57,56 @@ M: string user-passwd ( string -- passwd/f ) : username ( id -- string ) user-passwd username>> ; -: username-id ( string -- id ) +: user-id ( string -- id ) user-passwd uid>> ; -: real-username-id ( -- id ) +: real-user-id ( -- id ) getuid ; inline : real-username ( -- string ) - real-username-id username ; inline + real-user-id username ; inline -: effective-username-id ( -- id ) +: effective-user-id ( -- id ) geteuid ; inline : effective-username ( -- string ) - effective-username-id username ; inline + effective-user-id username ; inline -GENERIC: set-real-username ( string/id -- ) +GENERIC: set-real-user ( string/id -- ) -GENERIC: set-effective-username ( string/id -- ) +GENERIC: set-effective-user ( string/id -- ) -: with-real-username ( string/id quot -- ) - '[ _ set-real-username @ ] - real-username-id '[ _ set-real-username ] +: with-real-user ( string/id quot -- ) + '[ _ set-real-user @ ] + real-user-id '[ _ set-real-user ] [ ] cleanup ; inline -: with-effective-username ( string/id quot -- ) - '[ _ set-effective-username @ ] - effective-username-id '[ _ set-effective-username ] +: with-effective-user ( string/id quot -- ) + '[ _ set-effective-user @ ] + effective-user-id '[ _ set-effective-user ] [ ] cleanup ; inline -M: string set-real-username ( string -- ) - username-id (set-real-username) ; +M: string set-real-user ( string -- ) + user-id (set-real-user) ; -M: integer set-real-username ( id -- ) - (set-real-username) ; +M: integer set-real-user ( id -- ) + (set-real-user) ; -M: integer set-effective-username ( id -- ) - (set-effective-username) ; +M: integer set-effective-user ( id -- ) + (set-effective-user) ; -M: string set-effective-username ( string -- ) - username-id (set-effective-username) ; +M: string set-effective-user ( string -- ) + user-id (set-effective-user) ; os { { [ dup bsd? ] [ drop "unix.users.bsd" require ] } From e0ad27401e3f874fda887adbfa003b29e0e9bafb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 13:23:23 -0500 Subject: [PATCH 16/31] add groups tests --- basis/unix/groups/groups-tests.factor | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 basis/unix/groups/groups-tests.factor diff --git a/basis/unix/groups/groups-tests.factor b/basis/unix/groups/groups-tests.factor new file mode 100644 index 0000000000..0fdd6ff08d --- /dev/null +++ b/basis/unix/groups/groups-tests.factor @@ -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 From 402126d0389fa528e3098e2f47b4defa51ec6828 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 13:26:43 -0500 Subject: [PATCH 17/31] fix spacing --- basis/unix/groups/groups-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/unix/groups/groups-tests.factor b/basis/unix/groups/groups-tests.factor index 0fdd6ff08d..9e7122fc34 100644 --- a/basis/unix/groups/groups-tests.factor +++ b/basis/unix/groups/groups-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test unix.groups kernel strings math ; +USING: tools.test unix.groups kernel strings math ; IN: unix.groups.tests From e464941d5281481fd48affaab0dd4836b8537eb0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 14:18:50 -0500 Subject: [PATCH 18/31] rename words for consistency, update docs, add unit tests --- basis/io/unix/files/files-docs.factor | 16 ++-- basis/io/unix/files/files-tests.factor | 110 ++++++++++++++++++++++++- basis/io/unix/files/files.factor | 16 ++-- 3 files changed, 125 insertions(+), 17 deletions(-) diff --git a/basis/io/unix/files/files-docs.factor b/basis/io/unix/files/files-docs.factor index 7b4ce10b86..5b5e257c5e 100644 --- a/basis/io/unix/files/files-docs.factor +++ b/basis/io/unix/files/files-docs.factor @@ -28,7 +28,7 @@ HELP: file-username { "string" string } } { $description "Returns the username for a given file." } ; -HELP: file-username-id +HELP: file-user-id { $values { "path" "a pathname string" } { "uid" integer } } @@ -107,15 +107,15 @@ HELP: set-file-times { "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-username +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-write-time +HELP: set-file-modified-time { $values { "path" "a pathname string" } { "timestamp" timestamp } } -{ $description "Sets a file's last write timestamp." } ; +{ $description "Sets a file's last modified timestamp, or write timestamp." } ; HELP: set-gid { $values @@ -251,16 +251,16 @@ ARTICLE: "unix-file-timestamps" "Unix file timestamps" { $subsection set-file-times } "Setting just the last access time:" { $subsection set-file-access-time } -"Setting just the last write time:" -{ $subsection set-file-write-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-username-id } +{ $subsection file-user-id } { $subsection file-username } "Setting file user data:" -{ $subsection set-file-username } +{ $subsection set-file-user } "Reading file group data:" { $subsection file-group-id } { $subsection file-group-name } diff --git a/basis/io/unix/files/files-tests.factor b/basis/io/unix/files/files-tests.factor index 040b191d27..28c25c0964 100644 --- a/basis/io/unix/files/files-tests.factor +++ b/basis/io/unix/files/files-tests.factor @@ -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* = +] unit-test + +[ t ] +[ + test-file now + [ set-file-modified-time ] 2keep + [ file-info modified>> ] + [ [ truncate >integer ] change-second ] 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 diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index 49510f9841..40ef9ad859 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -144,7 +144,7 @@ os { : chmod-set-bit ( path mask ? -- ) [ dup stat-mode ] 2dip - [ set-bit ] [ clear-bit ] if chmod io-error ; + [ bitor ] [ unmask ] if chmod io-error ; : file-mode? ( path mask -- ? ) [ stat-mode ] dip mask? ; @@ -220,22 +220,22 @@ PRIVATE> : set-file-access-time ( path timestamp -- ) f 2array set-file-times ; -: set-file-write-time ( path timestamp -- ) +: 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-username ( path string/id -- ) +GENERIC: set-file-user ( path string/id -- ) GENERIC: set-file-group ( path string/id -- ) -M: integer set-file-username ( path uid -- ) +M: integer set-file-user ( path uid -- ) f set-file-ids ; -M: string set-file-username ( path string -- ) - username-id 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 ; @@ -244,11 +244,11 @@ M: string set-file-group ( path string -- ) group-id f swap set-file-ids ; -: file-username-id ( path -- uid ) +: file-user-id ( path -- uid ) normalize-path file-info uid>> ; : file-username ( path -- string ) - file-username-id username ; + file-user-id username ; : file-group-id ( path -- gid ) normalize-path file-info gid>> ; From 5b86d3a51e5b3cc4e3b2428359ca8e07acfe99c9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 14:40:19 -0500 Subject: [PATCH 19/31] mac bootstrap --- basis/unix/bsd/macosx/macosx.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/unix/bsd/macosx/macosx.factor b/basis/unix/bsd/macosx/macosx.factor index ed2bdecf61..c41ae6df7d 100644 --- a/basis/unix/bsd/macosx/macosx.factor +++ b/basis/unix/bsd/macosx/macosx.factor @@ -1,4 +1,4 @@ -USING: alien.syntax ; +USING: alien.syntax unix.time ; IN: unix : FD_SETSIZE 1024 ; inline From a78636024ca2eec808e8a97562d113ebddde25b8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 14:57:53 -0500 Subject: [PATCH 20/31] don't define structs in the same file as the constants --- basis/unix/bsd/netbsd/structs/structs.factor | 29 ++++++++++++++++++++ basis/unix/bsd/netbsd/structs/tags.txt | 1 + 2 files changed, 30 insertions(+) create mode 100644 basis/unix/bsd/netbsd/structs/structs.factor create mode 100644 basis/unix/bsd/netbsd/structs/tags.txt diff --git a/basis/unix/bsd/netbsd/structs/structs.factor b/basis/unix/bsd/netbsd/structs/structs.factor new file mode 100644 index 0000000000..f1a5ed09c0 --- /dev/null +++ b/basis/unix/bsd/netbsd/structs/structs.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax vocabs.loader ; +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" } ; + diff --git a/basis/unix/bsd/netbsd/structs/tags.txt b/basis/unix/bsd/netbsd/structs/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/bsd/netbsd/structs/tags.txt @@ -0,0 +1 @@ +unportable From 8627a30b6c4be00f34f3497c874693e01c0fcf97 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 14:58:16 -0500 Subject: [PATCH 21/31] remove old structs --- basis/unix/bsd/netbsd/netbsd.factor | 24 +----------------------- 1 file changed, 1 insertion(+), 23 deletions(-) diff --git a/basis/unix/bsd/netbsd/netbsd.factor b/basis/unix/bsd/netbsd/netbsd.factor index 6bae953938..c82259d48a 100644 --- a/basis/unix/bsd/netbsd/netbsd.factor +++ b/basis/unix/bsd/netbsd/netbsd.factor @@ -131,26 +131,4 @@ TYPEDEF: __uint8_t sa_family_t : _SS_PAD2SIZE ( -- n ) _SS_MAXSIZE 2 - _SS_PAD1SIZE - _SS_ALIGNSIZE - ; inline -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" } ; +"unix.bsd.netbsd.structs" require From 967a8375ec93c310b7306494759435ce3a781e00 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 14:59:05 -0500 Subject: [PATCH 22/31] fix using --- basis/unix/bsd/netbsd/netbsd.factor | 2 +- basis/unix/bsd/netbsd/structs/structs.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/unix/bsd/netbsd/netbsd.factor b/basis/unix/bsd/netbsd/netbsd.factor index c82259d48a..ca42b7840c 100644 --- a/basis/unix/bsd/netbsd/netbsd.factor +++ b/basis/unix/bsd/netbsd/netbsd.factor @@ -1,4 +1,4 @@ -USING: alien.syntax alien.c-types math ; +USING: alien.syntax alien.c-types math vocabs.loader ; IN: unix : FD_SETSIZE 256 ; inline diff --git a/basis/unix/bsd/netbsd/structs/structs.factor b/basis/unix/bsd/netbsd/structs/structs.factor index f1a5ed09c0..ced6f6df5d 100644 --- a/basis/unix/bsd/netbsd/structs/structs.factor +++ b/basis/unix/bsd/netbsd/structs/structs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax vocabs.loader ; +USING: alien.syntax ; IN: unix C-STRUCT: sockaddr_storage From b7095ff39ff5eafb0a2e149ffebb909bcb6fb18c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 15:14:08 -0500 Subject: [PATCH 23/31] fix using --- basis/unix/bsd/netbsd/structs/structs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/unix/bsd/netbsd/structs/structs.factor b/basis/unix/bsd/netbsd/structs/structs.factor index ced6f6df5d..dba7590a93 100644 --- a/basis/unix/bsd/netbsd/structs/structs.factor +++ b/basis/unix/bsd/netbsd/structs/structs.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.syntax unix.time ; IN: unix C-STRUCT: sockaddr_storage From 031ebe98b1565f5cc9adbefb278d2bcdb4258531 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 15:57:47 -0500 Subject: [PATCH 24/31] largert group buffer, openbsd apparently keeps the microseconds in their file timestamps. fix unit tests for this --- basis/io/unix/files/files-tests.factor | 4 ++-- basis/unix/groups/groups.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/io/unix/files/files-tests.factor b/basis/io/unix/files/files-tests.factor index 28c25c0964..5a24c1314a 100644 --- a/basis/io/unix/files/files-tests.factor +++ b/basis/io/unix/files/files-tests.factor @@ -92,7 +92,7 @@ prepare-test-file test-file now [ set-file-access-time ] 2keep [ file-info accessed>> ] - [ [ truncate >integer ] change-second ] bi* = + [ [ [ truncate >integer ] change-second ] bi@ ] bi* = ] unit-test [ t ] @@ -100,7 +100,7 @@ prepare-test-file test-file now [ set-file-modified-time ] 2keep [ file-info modified>> ] - [ [ truncate >integer ] change-second ] bi* = + [ [ [ truncate >integer ] change-second ] bi@ ] bi* = ] unit-test [ t ] diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index 7f3aa9ae98..c3af9cc83d 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -26,7 +26,7 @@ GENERIC: group-struct ( obj -- group ) ] [ ] produce nip ; : (group-struct) ( id -- group-struct id group-struct byte-array length void* ) - "group" tuck 1024 + "group" tuck 4096 [ ] keep f ; M: integer group-struct ( id -- group ) From ea69c8996fe9f20f304b8b00af034c15f9f66773 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 8 Oct 2008 19:06:19 -0500 Subject: [PATCH 25/31] use ERROR:, inline database combinator examples --- basis/db/db-docs.factor | 4 ++-- basis/db/sqlite/sqlite.factor | 4 +++- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index 16a8228fca..7c84e6205e 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -285,7 +285,7 @@ ARTICLE: "db-custom-database-combinators" "Custom database combinators" { $code <" USING: db.sqlite db io.files ; : with-sqlite-db ( quot -- ) - "my-database.db" temp-file swap with-db ;"> } + "my-database.db" temp-file swap with-db ; inline"> } "PostgreSQL example combinator:" { $code <" USING: db.postgresql db ; @@ -296,7 +296,7 @@ USING: db.sqlite db io.files ; "erg" >>username "secrets?" >>password "factor-test" >>database - swap with-db ;"> + swap with-db ; inline"> } ; ABOUT: "db" diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 8580b9012c..4aa41483d8 100644 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -87,9 +87,11 @@ M: sqlite-statement bind-tuple ( tuple 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 ; From d2dd7288b3a09fc2c9daae82725b6495bfcd4f3c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 8 Oct 2008 23:43:37 -0500 Subject: [PATCH 26/31] Fix parser bug with multi-line tuple literals --- core/classes/tuple/parser/parser-tests.factor | 13 +++++++++++++ core/classes/tuple/parser/parser.factor | 1 + 2 files changed, 14 insertions(+) diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 17376a594f..6b9a953ab9 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -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 diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index dd78b4ba3e..7888635641 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -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 ] } From 6130aeb88f9a926786ab1419e8a4deebd8d7033b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 9 Oct 2008 00:13:04 -0500 Subject: [PATCH 27/31] Fix fep looping --- vm/debug.c | 8 ++++++++ vm/debug.h | 2 ++ vm/errors.c | 6 +++--- 3 files changed, 13 insertions(+), 3 deletions(-) diff --git a/vm/debug.c b/vm/debug.c index b374aceb9f..0869d6a885 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -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(); diff --git a/vm/debug.h b/vm/debug.h index 2ca6f8944c..547fdba436 100755 --- a/vm/debug.h +++ b/vm/debug.h @@ -4,4 +4,6 @@ void dump_generations(void); void factorbug(void); void dump_zone(F_ZONE *z); +bool fep_disabled; + DECLARE_PRIMITIVE(die); diff --git a/vm/errors.c b/vm/errors.c index f2147041a2..7a23e3e53f 100755 --- a/vm/errors.c +++ b/vm/errors.c @@ -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(); } } From bb6b99868607ada1b51a025238b7eae5843fc050 Mon Sep 17 00:00:00 2001 From: sheeple Date: Thu, 9 Oct 2008 14:04:33 -0500 Subject: [PATCH 28/31] Fix alien-indirect on ppc --- basis/cpu/ppc/architecture/architecture.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor index 357349193e..117ab51fe2 100644 --- a/basis/cpu/ppc/architecture/architecture.factor +++ b/basis/cpu/ppc/architecture/architecture.factor @@ -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 From 7b9a3b61c35c78ba40794a5fac792934fc712293 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Oct 2008 14:07:11 -0500 Subject: [PATCH 29/31] partial fix for db, going to make it use dispose* soon --- basis/db/db.factor | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/basis/db/db.factor b/basis/db/db.factor index bf23005bc2..a124914a35 100644 --- a/basis/db/db.factor +++ b/basis/db/db.factor @@ -6,6 +6,7 @@ tools.walker accessors combinators fry ; IN: db TUPLE: db + disposed handle insert-statements update-statements @@ -24,12 +25,10 @@ HOOK: db-close db ( handle -- ) : 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 + handle>> db-close ] with-variable ; TUPLE: result-set sql in-params out-params handle n max ; From 83f1634219f2a281a27d138466aa007313e6b89d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Oct 2008 15:42:23 -0500 Subject: [PATCH 30/31] clean up dispose a bit --- basis/db/db.factor | 6 +++--- basis/db/postgresql/postgresql.factor | 4 ++-- basis/db/sqlite/sqlite.factor | 1 - 3 files changed, 5 insertions(+), 6 deletions(-) diff --git a/basis/db/db.factor b/basis/db/db.factor index a124914a35..3ee0fe3d09 100644 --- a/basis/db/db.factor +++ b/basis/db/db.factor @@ -6,7 +6,6 @@ tools.walker accessors combinators fry ; IN: db TUPLE: db - disposed handle insert-statements update-statements @@ -23,12 +22,13 @@ HOOK: db-close db ( handle -- ) : dispose-statements ( assoc -- ) values dispose-each ; -: db-dispose ( db -- ) +M: db dispose ( db -- ) dup db [ [ dispose-statements H{ } clone ] change-insert-statements [ dispose-statements H{ } clone ] change-update-statements [ dispose-statements H{ } clone ] change-delete-statements - handle>> db-close + [ db-close f ] change-handle + drop ] with-variable ; TUPLE: result-set sql in-params out-params handle n max ; diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index 08df25c13a..f9c9ea73ec 100644 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -30,8 +30,8 @@ M: postgresql-db db-open ( db -- db ) [ 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 ; diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 4aa41483d8..216f324bbf 100644 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -19,7 +19,6 @@ M: sqlite-db db-open ( db -- db ) dup path>> sqlite-open >>handle ; M: sqlite-db db-close ( handle -- ) sqlite-close ; -M: sqlite-db dispose ( db -- ) db-dispose ; TUPLE: sqlite-statement < statement ; From ace2ce2ce7a069f60239b346af0e4abc108dd88e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 9 Oct 2008 16:40:19 -0500 Subject: [PATCH 31/31] remove old word --- basis/db/db-docs.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index 7c84e6205e..52dc389fe6 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -26,10 +26,6 @@ HELP: dispose-statements { $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." } ;