diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 3e3307033a..208273364c 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -59,8 +59,8 @@ TUPLE: file-responder root hook special allow-listings ; \ serve-file NOTICE add-input-logging -: file. ( name dirp -- ) - [ "/" append ] when +: file. ( name -- ) + dup link-info directory? [ "/" append ] when dup escape-string write ; : directory. ( path -- ) @@ -68,8 +68,7 @@ TUPLE: file-responder root hook special allow-listings ; [

file-name escape-string write

] [ ] bi ] simple-page ; diff --git a/basis/io/monitors/recursive/recursive.factor b/basis/io/monitors/recursive/recursive.factor index 383e166214..45979363c9 100644 --- a/basis/io/monitors/recursive/recursive.factor +++ b/basis/io/monitors/recursive/recursive.factor @@ -19,11 +19,14 @@ DEFER: add-child-monitor : add-child-monitors ( path -- ) #! We yield since this directory scan might take a while. - directory* [ first add-child-monitor ] each yield ; + dup [ + [ append-path ] with map + [ add-child-monitor ] each yield + ] with-directory-files ; : add-child-monitor ( path -- ) notify? [ dup { +add-file+ } monitor tget queue-change ] when - qualify-path dup link-info type>> +directory+ eq? [ + qualify-path dup link-info directory? [ [ add-child-monitors ] [ [ diff --git a/basis/io/unix/files/files.factor b/basis/io/unix/files/files.factor index af023e3f13..67da640b71 100644 --- a/basis/io/unix/files/files.factor +++ b/basis/io/unix/files/files.factor @@ -6,7 +6,7 @@ math.bitwise byte-arrays alien combinators calendar io.encodings.binary accessors sequences strings system io.files.private destructors vocabs.loader calendar.unix unix.stat alien.c-types arrays unix.users unix.groups -environment ; +environment fry io.encodings.utf8 alien.strings ; IN: io.unix.files M: unix cwd ( -- path ) @@ -138,6 +138,27 @@ os { { linux [ ] } } case +: with-unix-directory ( path quot -- ) + [ opendir dup [ (io-error) ] unless ] dip + dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline + +: find-next-file ( DIR* -- byte-array ) + "dirent" + f + [ readdir_r 0 = [ (io-error) ] unless ] 2keep + *void* [ drop f ] unless ; + +M: unix >directory-entry ( byte-array -- directory-entry ) + [ dirent-d_name utf8 alien>string ] + [ dirent-d_type ] bi directory-entry boa ; + +M: unix (directory-entries) ( path -- seq ) + [ + '[ _ find-next-file dup ] + [ >directory-entry ] + [ drop ] produce + ] with-unix-directory ; + directory-entry ( byte-array -- directory-entry ) + [ WIN32_FIND_DATA-cFileName utf16n alien>string ] + [ WIN32_FIND_DATA-dwFileAttributes ] + bi directory-entry boa ; + +: find-first-file ( path -- WIN32_FIND_DATA handle ) + "WIN32_FIND_DATA" tuck + FindFirstFile + [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep ; + +: find-next-file ( path -- WIN32_FIND_DATA/f ) + "WIN32_FIND_DATA" tuck + FindNextFile 0 = [ + GetLastError ERROR_NO_MORE_FILES = [ + win32-error + ] unless drop f + ] when ; + +M: windows (directory-entries) ( path -- seq ) + "\\" ?tail drop "\\*" append + find-first-file [ >directory-entry ] dip + [ + '[ + [ _ find-next-file dup ] + [ >directory-entry ] + [ drop ] produce + over name>> "." = [ nip ] [ swap prefix ] if + ] + ] [ '[ _ FindClose win32-error=0/f ] ] bi [ ] cleanup ; SYMBOLS: +read-only+ +hidden+ +system+ +archive+ +device+ +normal+ +temporary+ diff --git a/basis/io/windows/files/unique/unique.factor b/basis/io/windows/files/unique/unique.factor index dcb713df7f..b1bf2bdc1c 100644 --- a/basis/io/windows/files/unique/unique.factor +++ b/basis/io/windows/files/unique/unique.factor @@ -1,6 +1,6 @@ USING: kernel system io.files.unique.backend windows.kernel32 io.windows io.windows.files io.ports windows -destructors ; +destructors environment ; IN: io.windows.files.unique M: windows (make-unique-file) ( path -- ) diff --git a/basis/io/windows/nt/launcher/launcher-tests.factor b/basis/io/windows/nt/launcher/launcher-tests.factor index d5e77caa19..949b0a7961 100644 --- a/basis/io/windows/nt/launcher/launcher-tests.factor +++ b/basis/io/windows/nt/launcher/launcher-tests.factor @@ -1,7 +1,7 @@ -IN: io.windows.launcher.nt.tests -USING: io.launcher tools.test calendar accessors +USING: io.launcher tools.test calendar accessors environment namespaces kernel system arrays io io.files io.encodings.ascii sequences parser assocs hashtables math continuations eval ; +IN: io.windows.launcher.nt.tests [ ] [ diff --git a/basis/io/windows/nt/launcher/test/env.factor b/basis/io/windows/nt/launcher/test/env.factor index a0015f7ea2..503ca7d018 100644 --- a/basis/io/windows/nt/launcher/test/env.factor +++ b/basis/io/windows/nt/launcher/test/env.factor @@ -1,3 +1,4 @@ -USE: system -USE: prettyprint -os-envs . +USE: system +USE: prettyprint +USE: environment +os-envs . diff --git a/basis/logging/server/server.factor b/basis/logging/server/server.factor index d13ae616be..47656e8655 100644 --- a/basis/logging/server/server.factor +++ b/basis/logging/server/server.factor @@ -83,7 +83,7 @@ SYMBOL: log-files : (rotate-logs) ( -- ) (close-logs) - log-root directory [ drop rotate-log ] assoc-each ; + log-root directory-files [ rotate-log ] each ; : log-server-loop ( -- ) receive unclip { diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 1a0f3c5eb2..1332415c49 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -396,8 +396,6 @@ do-primitive alien-invoke alien-indirect alien-callback \ (exists?) { string } { object } define-primitive -\ (directory) { string } { array } define-primitive - \ gc { } { } define-primitive \ gc-stats { } { array } define-primitive diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index 732a6635b7..b929c62e04 100644 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -14,8 +14,7 @@ IN: tools.vocabs : vocab-tests-dir ( vocab -- paths ) dup vocab-dir "tests" append-path vocab-append-path dup [ dup exists? [ - dup directory keys - [ ".factor" tail? ] filter + dup directory-files [ ".factor" tail? ] filter [ append-path ] with map ] [ drop f ] if ] [ drop f ] if ; @@ -208,11 +207,15 @@ M: vocab-link summary vocab-summary ; dup vocab-authors-path set-vocab-file-contents ; : subdirs ( dir -- dirs ) - directory [ second ] filter keys natural-sort ; + [ + [ link-info directory? ] filter + ] with-directory-files natural-sort ; : (all-child-vocabs) ( root name -- vocabs ) - [ vocab-dir append-path subdirs ] keep [ + vocab-dir append-path dup exists? + [ subdirs ] [ drop { } ] if + ] keep [ swap [ "." swap 3append ] with map ] unless-empty ; diff --git a/basis/unix/bsd/bsd.factor b/basis/unix/bsd/bsd.factor index 7bbf2b4fdf..bd66c5253e 100644 --- a/basis/unix/bsd/bsd.factor +++ b/basis/unix/bsd/bsd.factor @@ -3,8 +3,6 @@ USING: alien.syntax combinators system vocabs.loader ; IN: unix -! FreeBSD - : MAXPATHLEN 1024 ; inline : O_RDONLY HEX: 0000 ; inline @@ -85,6 +83,16 @@ C-STRUCT: passwd : SEEK_CUR 1 ; inline : SEEK_END 2 ; inline +: DT_UNKNOWN 0 ; inline +: DT_FIFO 1 ; inline +: DT_CHR 2 ; inline +: DT_DIR 4 ; inline +: DT_BLK 6 ; inline +: DT_REG 8 ; inline +: DT_LNK 10 ; inline +: DT_SOCK 12 ; inline +: DT_WHT 14 ; inline + os { { macosx [ "unix.bsd.macosx" require ] } { freebsd [ "unix.bsd.freebsd" require ] } diff --git a/basis/unix/bsd/freebsd/freebsd.factor b/basis/unix/bsd/freebsd/freebsd.factor index 34f0f0429c..81885ff141 100644 --- a/basis/unix/bsd/freebsd/freebsd.factor +++ b/basis/unix/bsd/freebsd/freebsd.factor @@ -13,6 +13,13 @@ C-STRUCT: addrinfo { "void*" "addr" } { "addrinfo*" "next" } ; +C-STRUCT: dirent + { "u_int32_t" "d_fileno" } + { "u_int16_t" "d_reclen" } + { "u_int8_t" "d_type" } + { "u_int8_t" "d_namlen" } + { { "char" 256 } "d_name" } ; + : EPERM 1 ; inline : ENOENT 2 ; inline : ESRCH 3 ; inline diff --git a/basis/unix/bsd/macosx/macosx.factor b/basis/unix/bsd/macosx/macosx.factor index c41ae6df7d..fb9eb9a621 100644 --- a/basis/unix/bsd/macosx/macosx.factor +++ b/basis/unix/bsd/macosx/macosx.factor @@ -13,6 +13,32 @@ C-STRUCT: addrinfo { "void*" "addr" } { "addrinfo*" "next" } ; +: _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" } ; + +: __DARWIN_MAXPATHLEN 1024 ; inline +: __DARWIN_MAXNAMELEN 255 ; inline +: __DARWIN_MAXNAMELEN+1 255 ; inline + +C-STRUCT: dirent + { "ino_t" "d_ino" } + { "__uint16_t" "d_reclen" } + { "__uint8_t" "d_type" } + { "__uint8_t" "d_namlen" } + { { "char" __DARWIN_MAXNAMELEN+1 } "d_name" } ; + : EPERM 1 ; inline : ENOENT 2 ; inline : ESRCH 3 ; inline @@ -117,18 +143,3 @@ 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 ca42b7840c..149f35afce 100644 --- a/basis/unix/bsd/netbsd/netbsd.factor +++ b/basis/unix/bsd/netbsd/netbsd.factor @@ -13,6 +13,13 @@ C-STRUCT: addrinfo { "void*" "addr" } { "addrinfo*" "next" } ; +C-STRUCT: dirent + { "__uint32_t" "d_fileno" } + { "__uint16_t" "d_reclen" } + { "__uint8_t" "d_type" } + { "__uint8_t" "d_namlen" } + { { "char" 256 } "d_name" } ; + : EPERM 1 ; inline : ENOENT 2 ; inline : ESRCH 3 ; inline diff --git a/basis/unix/bsd/openbsd/openbsd.factor b/basis/unix/bsd/openbsd/openbsd.factor index 31025a47e9..a4189775e7 100644 --- a/basis/unix/bsd/openbsd/openbsd.factor +++ b/basis/unix/bsd/openbsd/openbsd.factor @@ -13,6 +13,13 @@ C-STRUCT: addrinfo { "char*" "canonname" } { "addrinfo*" "next" } ; +C-STRUCT: dirent + { "__uint32_t" "d_fileno" } + { "__uint16_t" "d_reclen" } + { "__uint8_t" "d_type" } + { "__uint8_t" "d_namlen" } + { { "char" 256 } "d_name" } ; + : EPERM 1 ; inline : ENOENT 2 ; inline : ESRCH 3 ; inline diff --git a/basis/unix/linux/fs/fs.factor b/basis/unix/linux/fs/fs.factor index 475d0290a6..6cb9f68934 100644 --- a/basis/unix/linux/fs/fs.factor +++ b/basis/unix/linux/fs/fs.factor @@ -1,6 +1,4 @@ - USING: alien.syntax ; - IN: unix.linux.fs : MS_RDONLY 1 ; ! Mount read-only. @@ -22,4 +20,4 @@ FUNCTION: int mount ! FUNCTION: int umount2 ( char* file, int flags ) ; -FUNCTION: int umount ( char* file ) ; \ No newline at end of file +FUNCTION: int umount ( char* file ) ; diff --git a/basis/unix/linux/linux.factor b/basis/unix/linux/linux.factor index 457d96c7d8..7a77dc9316 100644 --- a/basis/unix/linux/linux.factor +++ b/basis/unix/linux/linux.factor @@ -92,6 +92,13 @@ C-STRUCT: passwd { "char*" "pw_dir" } { "char*" "pw_shell" } ; +C-STRUCT: dirent + { "__ino_t" "d_ino" } + { "__off_t" "d_off" } + { "ushort" "d_reclen" } + { "uchar" "d_type" } + { { "char" 256 } "d_name" } ; + : EPERM 1 ; inline : ENOENT 2 ; inline : ESRCH 3 ; inline diff --git a/basis/unix/stat/linux/32/32.factor b/basis/unix/stat/linux/32/32.factor index 3f6c6ba0e0..00a6239916 100644 --- a/basis/unix/stat/linux/32/32.factor +++ b/basis/unix/stat/linux/32/32.factor @@ -1,6 +1,4 @@ - USING: kernel alien.syntax math ; - IN: unix.stat ! Ubuntu 8.04 32-bit @@ -31,3 +29,14 @@ FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ; : stat ( pathname buf -- int ) 3 -rot __xstat ; : lstat ( pathname buf -- int ) 3 -rot __lxstat ; + +C-STRUCT: statfs + { "long" "f_type" } + { "long" "f_bsize" } + { "long" "f_blocks" } + { "long" "f_bfree" } + { "long" "f_bavail" } + { "long" "f_files" } + { "long" "f_ffree" } + { "fsid_t" "f_fsid" } + { "long" "f_namelen" } ; diff --git a/basis/unix/stat/linux/64/64.factor b/basis/unix/stat/linux/64/64.factor index 088ab8d339..b9d48066fb 100644 --- a/basis/unix/stat/linux/64/64.factor +++ b/basis/unix/stat/linux/64/64.factor @@ -1,6 +1,5 @@ - -USING: kernel alien.syntax math ; - +USING: kernel alien.syntax math sequences unix +alien.c-types arrays accessors combinators ; IN: unix.stat ! Ubuntu 7.10 64-bit @@ -29,3 +28,22 @@ FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ; : stat ( pathname buf -- int ) 1 -rot __xstat ; : lstat ( pathname buf -- int ) 1 -rot __lxstat ; + +TYPEDEF: ssize_t __SWORD_TYPE +TYPEDEF: ulonglong __fsblkcnt64_t +TYPEDEF: ulonglong __fsfilcnt64_t + +C-STRUCT: statfs64 + { "__SWORD_TYPE" "f_type" } + { "__SWORD_TYPE" "f_bsize" } + { "__fsblkcnt64_t" "f_blocks" } + { "__fsblkcnt64_t" "f_bfree" } + { "__fsblkcnt64_t" "f_bavail" } + { "__fsfilcnt64_t" "f_files" } + { "__fsfilcnt64_t" "f_ffree" } + { "__fsid_t" "f_fsid" } + { "__SWORD_TYPE" "f_namelen" } + { "__SWORD_TYPE" "f_frsize" } + { { "__SWORD_TYPE" 5 } "f_spare" } ; + +FUNCTION: int statfs64 ( char* path, statfs64* buf ) ; diff --git a/basis/unix/stat/linux/linux.factor b/basis/unix/stat/linux/linux.factor index 2f4b6174d9..4bcab0b477 100644 --- a/basis/unix/stat/linux/linux.factor +++ b/basis/unix/stat/linux/linux.factor @@ -1,11 +1,14 @@ - -USING: layouts combinators vocabs.loader ; - +USING: alien.syntax layouts combinators vocabs.loader ; IN: unix.stat +C-STRUCT: fsid + { { "int" 2 } "__val" } ; + +TYPEDEF: fsid __fsid_t +TYPEDEF: fsid fsid_t + cell-bits - { +{ { 32 [ "unix.stat.linux.32" require ] } { 64 [ "unix.stat.linux.64" require ] } - } -case +} case diff --git a/basis/unix/stat/macosx/macosx.factor b/basis/unix/stat/macosx/macosx.factor index b2574b474d..49b6709847 100644 --- a/basis/unix/stat/macosx/macosx.factor +++ b/basis/unix/stat/macosx/macosx.factor @@ -1,4 +1,5 @@ -USING: kernel alien.syntax math ; +USING: kernel alien.syntax math unix math.bitwise +alien.c-types alien sequences grouping accessors combinators ; IN: unix.stat ! Mac OS X ppc @@ -30,3 +31,114 @@ FUNCTION: int lstat64 ( char* pathname, stat* buf ) ; : stat ( path buf -- n ) stat64 ; : lstat ( path buf -- n ) lstat64 ; + +: MNT_RDONLY HEX: 00000001 ; inline +: MNT_SYNCHRONOUS HEX: 00000002 ; inline +: MNT_NOEXEC HEX: 00000004 ; inline +: MNT_NOSUID HEX: 00000008 ; inline +: MNT_NODEV HEX: 00000010 ; inline +: MNT_UNION HEX: 00000020 ; inline +: MNT_ASYNC HEX: 00000040 ; inline +: MNT_EXPORTED HEX: 00000100 ; inline +: MNT_QUARANTINE HEX: 00000400 ; inline +: MNT_LOCAL HEX: 00001000 ; inline +: MNT_QUOTA HEX: 00002000 ; inline +: MNT_ROOTFS HEX: 00004000 ; inline +: MNT_DOVOLFS HEX: 00008000 ; inline +: MNT_DONTBROWSE HEX: 00100000 ; inline +: MNT_IGNORE_OWNERSHIP HEX: 00200000 ; inline +: MNT_AUTOMOUNTED HEX: 00400000 ; inline +: MNT_JOURNALED HEX: 00800000 ; inline +: MNT_NOUSERXATTR HEX: 01000000 ; inline +: MNT_DEFWRITE HEX: 02000000 ; inline +: MNT_MULTILABEL HEX: 04000000 ; inline +: MNT_NOATIME HEX: 10000000 ; inline +: MNT_UNKNOWNPERMISSIONS MNT_IGNORE_OWNERSHIP ; inline + +: MNT_VISFLAGMASK ( -- n ) + { + MNT_RDONLY MNT_SYNCHRONOUS MNT_NOEXEC + MNT_NOSUID MNT_NODEV MNT_UNION + MNT_ASYNC MNT_EXPORTED MNT_QUARANTINE + MNT_LOCAL MNT_QUOTA + MNT_ROOTFS MNT_DOVOLFS MNT_DONTBROWSE + MNT_IGNORE_OWNERSHIP MNT_AUTOMOUNTED MNT_JOURNALED + MNT_NOUSERXATTR MNT_DEFWRITE MNT_MULTILABEL MNT_NOATIME + } flags ; inline + +: MNT_UPDATE HEX: 00010000 ; inline +: MNT_RELOAD HEX: 00040000 ; inline +: MNT_FORCE HEX: 00080000 ; inline +: MNT_CMDFLAGS { MNT_UPDATE MNT_RELOAD MNT_FORCE } flags ; inline + +: VFS_GENERIC 0 ; inline +: VFS_NUMMNTOPS 1 ; inline +: VFS_MAXTYPENUM 1 ; inline +: VFS_CONF 2 ; inline +: VFS_SET_PACKAGE_EXTS 3 ; inline + +: MNT_WAIT 1 ; inline +: MNT_NOWAIT 2 ; inline + +: VFS_CTL_VERS1 HEX: 01 ; inline + +: VFS_CTL_STATFS HEX: 00010001 ; inline +: VFS_CTL_UMOUNT HEX: 00010002 ; inline +: VFS_CTL_QUERY HEX: 00010003 ; inline +: VFS_CTL_NEWADDR HEX: 00010004 ; inline +: VFS_CTL_TIMEO HEX: 00010005 ; inline +: VFS_CTL_NOLOCKS HEX: 00010006 ; inline + +C-STRUCT: vfsquery + { "uint32_t" "vq_flags" } + { { "uint32_t" 31 } "vq_spare" } ; + +: VQ_NOTRESP HEX: 0001 ; inline +: VQ_NEEDAUTH HEX: 0002 ; inline +: VQ_LOWDISK HEX: 0004 ; inline +: VQ_MOUNT HEX: 0008 ; inline +: VQ_UNMOUNT HEX: 0010 ; inline +: VQ_DEAD HEX: 0020 ; inline +: VQ_ASSIST HEX: 0040 ; inline +: VQ_NOTRESPLOCK HEX: 0080 ; inline +: VQ_UPDATE HEX: 0100 ; inline +: VQ_FLAG0200 HEX: 0200 ; inline +: VQ_FLAG0400 HEX: 0400 ; inline +: VQ_FLAG0800 HEX: 0800 ; inline +: VQ_FLAG1000 HEX: 1000 ; inline +: VQ_FLAG2000 HEX: 2000 ; inline +: VQ_FLAG4000 HEX: 4000 ; inline +: VQ_FLAG8000 HEX: 8000 ; inline + +: NFSV4_MAX_FH_SIZE 128 ; inline +: NFSV3_MAX_FH_SIZE 64 ; inline +: NFSV2_MAX_FH_SIZE 32 ; inline +: NFS_MAX_FH_SIZE NFSV4_MAX_FH_SIZE ; inline + +: MFSNAMELEN 15 ; inline +: MNAMELEN 90 ; inline +: MFSTYPENAMELEN 16 ; inline + +C-STRUCT: fsid_t + { { "int32_t" 2 } "val" } ; + +C-STRUCT: statfs64 + { "uint32_t" "f_bsize" } + { "int32_t" "f_iosize" } + { "uint64_t" "f_blocks" } + { "uint64_t" "f_bfree" } + { "uint64_t" "f_bavail" } + { "uint64_t" "f_files" } + { "uint64_t" "f_ffree" } + { "fsid_t" "f_fsid" } + { "uid_t" "f_owner" } + { "uint32_t" "f_type" } + { "uint32_t" "f_flags" } + { "uint32_t" "f_fssubtype" } + { { "char" MFSTYPENAMELEN } "f_fstypename" } + { { "char" MAXPATHLEN } "f_mntonname" } + { { "char" MAXPATHLEN } "f_mntfromname" } + { { "uint32_t" 8 } "f_reserved" } ; + +FUNCTION: int statfs64 ( char* path, statfs64* buf ) ; +FUNCTION: int getmntinfo64 ( statfs64** mntbufp, int flags ) ; diff --git a/basis/unix/stat/stat.factor b/basis/unix/stat/stat.factor index 46fe7d98f9..f8ad74c213 100644 --- a/basis/unix/stat/stat.factor +++ b/basis/unix/stat/stat.factor @@ -27,11 +27,7 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ; } case >> : file-status ( pathname -- stat ) - "stat" [ - [ stat ] unix-system-call drop - ] keep ; + "stat" [ [ stat ] unix-system-call drop ] keep ; : link-status ( pathname -- stat ) - "stat" [ - [ lstat ] unix-system-call drop - ] keep ; + "stat" [ [ lstat ] unix-system-call drop ] keep ; diff --git a/basis/unix/statfs/authors.txt b/basis/unix/statfs/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/linux/authors.txt b/basis/unix/statfs/linux/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/linux/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/linux/linux-tests.factor b/basis/unix/statfs/linux/linux-tests.factor new file mode 100644 index 0000000000..549905f081 --- /dev/null +++ b/basis/unix/statfs/linux/linux-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test unix.statfs.linux ; +IN: unix.statfs.linux.tests diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor new file mode 100644 index 0000000000..44c32fd53d --- /dev/null +++ b/basis/unix/statfs/linux/linux.factor @@ -0,0 +1,34 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types combinators kernel io.files unix.stat +math accessors system unix io.backend ; +IN: unix.statfs.linux + +TUPLE: linux-file-system-info < file-system-info +type bsize blocks bfree bavail files ffree fsid +namelen frsize spare ; + +: statfs>file-system-info ( struct -- statfs ) + [ \ linux-file-system-info new ] dip + { + [ + [ statfs64-f_bsize ] + [ statfs64-f_bavail ] bi * >>free-space + ] + [ statfs64-f_type >>type ] + [ statfs64-f_bsize >>bsize ] + [ statfs64-f_blocks >>blocks ] + [ statfs64-f_bfree >>bfree ] + [ statfs64-f_bavail >>bavail ] + [ statfs64-f_files >>files ] + [ statfs64-f_ffree >>ffree ] + [ statfs64-f_fsid >>fsid ] + [ statfs64-f_namelen >>namelen ] + [ statfs64-f_frsize >>frsize ] + [ statfs64-f_spare >>spare ] + } cleave ; + +M: linux file-system-info ( path -- byte-array ) + normalize-path + "statfs64" tuck statfs64 io-error + statfs>file-system-info ; diff --git a/basis/unix/statfs/linux/tags.txt b/basis/unix/statfs/linux/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/linux/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/statfs/macosx/authors.txt b/basis/unix/statfs/macosx/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/unix/statfs/macosx/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/unix/statfs/macosx/macosx-tests.factor b/basis/unix/statfs/macosx/macosx-tests.factor new file mode 100644 index 0000000000..35625e2198 --- /dev/null +++ b/basis/unix/statfs/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.statfs.macosx ; +IN: unix.statfs.macosx.tests diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor new file mode 100644 index 0000000000..60fb1658c5 --- /dev/null +++ b/basis/unix/statfs/macosx/macosx.factor @@ -0,0 +1,52 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types io.encodings.utf8 io.encodings.string +kernel sequences unix.stat accessors unix combinators math +grouping system unix.statfs io.files io.backend alien.strings ; +IN: unix.statfs.macosx + +TUPLE: macosx-file-system-info < file-system-info +block-size io-size blocks blocks-free blocks-available files +files-free file-system-id owner type flags filesystem-subtype +file-system-type-name mount-from ; + +M: macosx mounted* ( -- array ) + f dup 0 getmntinfo64 dup io-error + [ *void* ] dip + "statfs64" heap-size [ * memory>byte-array ] keep group ; + +: statfs64>file-system-info ( byte-array -- file-system-info ) + [ \ macosx-file-system-info new ] dip + { + [ + [ statfs64-f_bavail ] [ statfs64-f_bsize ] bi * + >>free-space + ] + [ statfs64-f_mntonname utf8 alien>string >>mount-on ] + [ statfs64-f_bsize >>block-size ] + + [ statfs64-f_iosize >>io-size ] + [ statfs64-f_blocks >>blocks ] + [ statfs64-f_bfree >>blocks-free ] + [ statfs64-f_bavail >>blocks-available ] + [ statfs64-f_files >>files ] + [ statfs64-f_ffree >>files-free ] + [ statfs64-f_fsid >>file-system-id ] + [ statfs64-f_owner >>owner ] + [ statfs64-f_type >>type ] + [ statfs64-f_flags >>flags ] + [ statfs64-f_fssubtype >>filesystem-subtype ] + [ + statfs64-f_fstypename utf8 alien>string + >>file-system-type-name + ] + [ + statfs64-f_mntfromname + utf8 alien>string >>mount-from + ] + } cleave ; + +M: macosx file-system-info ( path -- file-system-info ) + normalize-path + "statfs64" tuck statfs64 io-error + statfs64>file-system-info ; diff --git a/basis/unix/statfs/macosx/tags.txt b/basis/unix/statfs/macosx/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/macosx/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/statfs/statfs-tests.factor b/basis/unix/statfs/statfs-tests.factor new file mode 100644 index 0000000000..39bc77fc87 --- /dev/null +++ b/basis/unix/statfs/statfs-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test unix.statfs ; +IN: unix.statfs.tests diff --git a/basis/unix/statfs/statfs.factor b/basis/unix/statfs/statfs.factor new file mode 100644 index 0000000000..0d99b57faf --- /dev/null +++ b/basis/unix/statfs/statfs.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: sequences system vocabs.loader combinators accessors +kernel math.order sorting ; +IN: unix.statfs + +TUPLE: mounted block-size io-size blocks blocks-free +blocks-available files files-free file-system-id owner type +flags filesystem-subtype file-system-type-name mount-on +mount-from ; + +HOOK: mounted* os ( -- array ) +HOOK: mounted-struct>mounted os ( byte-array -- mounted ) + +TUPLE: file-system-info root-directory total-free-size total-size ; + +: mounted ( -- array ) + mounted* [ mounted-struct>mounted ] map ; + +: mounted-drive ( path -- mounted/f ) + mounted + [ [ mount-on>> ] bi@ <=> ] sort + [ mount-on>> head? ] with find nip ; + +os { + { linux [ "unix.statfs.linux" require ] } + { macosx [ "unix.statfs.macosx" require ] } + ! { freebsd [ "unix.statfs.freebsd" require ] } + ! { netbsd [ "unix.statfs.netbsd" require ] } + ! { openbsd [ "unix.statfs.openbsd" require ] } +} case diff --git a/basis/unix/statfs/tags.txt b/basis/unix/statfs/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/unix/statfs/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/unix/types/linux/linux.factor b/basis/unix/types/linux/linux.factor index 8822366a3a..f32d8a23c4 100644 --- a/basis/unix/types/linux/linux.factor +++ b/basis/unix/types/linux/linux.factor @@ -1,10 +1,6 @@ - USING: alien.syntax ; - IN: unix.types -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - TYPEDEF: ulonglong __uquad_type TYPEDEF: ulong __ulongword_type TYPEDEF: long __sword_type @@ -13,17 +9,17 @@ TYPEDEF: long __slongword_type TYPEDEF: uint __u32_type TYPEDEF: int __s32_type -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - TYPEDEF: __uquad_type dev_t TYPEDEF: __ulongword_type ino_t +TYPEDEF: ino_t __ino_t TYPEDEF: __u32_type mode_t TYPEDEF: __uword_type nlink_t TYPEDEF: __u32_type uid_t TYPEDEF: __u32_type gid_t TYPEDEF: __slongword_type off_t +TYPEDEF: off_t __off_t TYPEDEF: __slongword_type blksize_t TYPEDEF: __slongword_type blkcnt_t TYPEDEF: __sword_type ssize_t TYPEDEF: __s32_type pid_t -TYPEDEF: __slongword_type time_t \ No newline at end of file +TYPEDEF: __slongword_type time_t diff --git a/basis/unix/types/netbsd/netbsd.factor b/basis/unix/types/netbsd/netbsd.factor index 5b54928d95..3982d1e9f9 100644 --- a/basis/unix/types/netbsd/netbsd.factor +++ b/basis/unix/types/netbsd/netbsd.factor @@ -3,19 +3,6 @@ IN: unix.types ! NetBSD 4.0 -TYPEDEF: short __int16_t -TYPEDEF: ushort __uint16_t -TYPEDEF: int __int32_t -TYPEDEF: uint __uint32_t -TYPEDEF: longlong __int64_t -TYPEDEF: longlong __uint64_t - -TYPEDEF: int int32_t -TYPEDEF: uint uint32_t -TYPEDEF: uint u_int32_t -TYPEDEF: longlong int64_t -TYPEDEF: ulonglong u_int64_t - TYPEDEF: __uint32_t __dev_t TYPEDEF: __uint32_t dev_t TYPEDEF: __uint32_t mode_t diff --git a/basis/unix/types/openbsd/openbsd.factor b/basis/unix/types/openbsd/openbsd.factor index a07e6f1c6a..8938afa936 100644 --- a/basis/unix/types/openbsd/openbsd.factor +++ b/basis/unix/types/openbsd/openbsd.factor @@ -3,19 +3,6 @@ IN: unix.types ! OpenBSD 4.2 -TYPEDEF: short __int16_t -TYPEDEF: ushort __uint16_t -TYPEDEF: int __int32_t -TYPEDEF: uint __uint32_t -TYPEDEF: longlong __int64_t -TYPEDEF: longlong __uint64_t - -TYPEDEF: int int32_t -TYPEDEF: uint u_int32_t -TYPEDEF: uint uint32_t -TYPEDEF: longlong int64_t -TYPEDEF: ulonglong u_int64_t - TYPEDEF: __uint32_t __dev_t TYPEDEF: __uint32_t dev_t TYPEDEF: __uint32_t ino_t diff --git a/basis/unix/types/types.factor b/basis/unix/types/types.factor index 69d07a07f1..968b234b9f 100644 --- a/basis/unix/types/types.factor +++ b/basis/unix/types/types.factor @@ -16,6 +16,11 @@ TYPEDEF: ushort uint16_t TYPEDEF: uint uint32_t TYPEDEF: ulonglong uint64_t +TYPEDEF: uchar u_int8_t +TYPEDEF: ushort u_int16_t +TYPEDEF: uint u_int32_t +TYPEDEF: ulonglong u_int64_t + TYPEDEF: char __int8_t TYPEDEF: short __int16_t TYPEDEF: int __int32_t diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 0963856ea6..d7af214a49 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -81,6 +81,7 @@ FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ; FUNCTION: int chroot ( char* path ) ; FUNCTION: int close ( int fd ) ; +FUNCTION: int closedir ( DIR* dirp ) ; : close-file ( fd -- ) [ close ] unix-system-call drop ; @@ -136,6 +137,8 @@ FUNCTION: int shutdown ( int fd, int how ) ; FUNCTION: int open ( char* path, int flags, int prot ) ; +FUNCTION: DIR* opendir ( char* path ) ; + : open-file ( path flags mode -- fd ) [ open ] unix-system-call ; C-STRUCT: utimbuf @@ -157,6 +160,8 @@ FUNCTION: int pipe ( int* filedes ) ; FUNCTION: void* popen ( char* command, char* type ) ; FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ; +FUNCTION: int readdir_r ( void* dirp, dirent* entry, dirent** result ) ; + FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ; : PATH_MAX 1024 ; inline diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index 31a7cd8c09..bd938fdbad 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -2,9 +2,9 @@ USING: kernel ; IN: windows.errors : ERROR_SUCCESS 0 ; inline +: ERROR_NO_MORE_FILES 18 ; inline : ERROR_HANDLE_EOF 38 ; inline : ERROR_BROKEN_PIPE 109 ; inline : ERROR_ENVVAR_NOT_FOUND 203 ; inline : ERROR_IO_INCOMPLETE 996 ; inline : ERROR_IO_PENDING 997 ; inline - diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 08ae762577..62d4ec9273 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -434,7 +434,6 @@ tuple { "getenv" "kernel.private" } { "setenv" "kernel.private" } { "(exists?)" "io.files.private" } - { "(directory)" "io.files.private" } { "gc" "memory" } { "gc-stats" "memory" } { "save-image" "memory" } diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 8e32c100e0..984598688d 100644 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -55,8 +55,9 @@ ARTICLE: "directories" "Directories" "Home directory:" { $subsection home } "Directory listing:" -{ $subsection directory } -{ $subsection directory* } +{ $subsection directory-entries } +{ $subsection directory-files } +{ $subsection with-directory-files } "Creating directories:" { $subsection make-directory } { $subsection make-directories } @@ -304,23 +305,22 @@ HELP: directory? { $values { "file-info" file-info } { "?" "a boolean" } } { $description "Tests if " { $snippet "file-info" } " is a directory." } ; -HELP: (directory) +HELP: (directory-entries) { $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } } { $description "Outputs the contents of a directory named by " { $snippet "path" } "." } -{ $notes "This is a low-level word, and user code should call " { $link directory } " instead." } ; +{ $notes "This is a low-level word, and user code should call one of the related words instead." } ; -HELP: directory -{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ name dir? }" } " pairs" } } +HELP: directory-entries +{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $link directory-entry } " objects" } } { $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ; -HELP: directory* -{ $values { "path" "a pathname string" } { "seq" "a sequence of " { $snippet "{ path dir? }" } " pairs" } } -{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } -{ $notes "Unlike " { $link directory } ", this word prepends the directory's path to all file names in the list." } ; +HELP: directory-files +{ $values { "path" "a pathname string" } { "seq" "a sequence of filenames" } } +{ $description "Outputs the contents of a directory named by " { $snippet "path" } "." } ; -! HELP: file-modified -! { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } } -! { $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ; +HELP: with-directory-files +{ $values { "path" "a pathname string" } { "quot" quotation } } +{ $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ; HELP: resource-path { $values { "path" "a pathname string" } { "newpath" "a pathname string" } } @@ -329,10 +329,6 @@ HELP: resource-path HELP: pathname { $class-description "Class of path name objects. Path name objects can be created by calling " { $link } "." } ; -HELP: normalize-directory -{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } } -{ $description "Called by the " { $link directory } " word to prepare a pathname before passing it to the " { $link (directory) } " primitive." } ; - HELP: normalize-path { $values { "str" "a pathname string" } { "newstr" "a new pathname string" } } { $description "Called by words such as " { $link } " and " { $link } " to prepare a pathname before passing it to underlying code." } ; diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 0723096519..3104fcdb55 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -151,18 +151,24 @@ USE: debugger.threads "delete-tree-test" temp-file delete-tree ] unit-test -[ { { "kernel" t } } ] [ +[ { "kernel" } ] [ "core" resource-path [ - "." directory [ first "kernel" = ] filter + "." directory-files [ "kernel" = ] filter ] with-directory ] unit-test -[ { { "kernel" t } } ] [ +[ { "kernel" } ] [ "resource:core" [ - "." directory [ first "kernel" = ] filter + "." directory-files [ "kernel" = ] filter ] with-directory ] unit-test +[ { "kernel" } ] [ + "resource:core" [ + [ "kernel" = ] filter + ] with-directory-files +] unit-test + [ ] [ "copy-tree-test/a/b/c" temp-file make-directories ] unit-test diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 6b84073d34..1f6a48b50e 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -153,7 +153,8 @@ PRIVATE> "." last-split1 nip ; ! File info -TUPLE: file-info type size permissions created modified accessed ; +TUPLE: file-info type size permissions created modified +accessed ; HOOK: file-info io-backend ( path -- info ) @@ -181,6 +182,12 @@ SYMBOL: +unknown+ : directory? ( file-info -- ? ) type>> +directory+ = ; +! File-system + +TUPLE: file-system-info mount-on free-space ; + +HOOK: file-system-info os ( path -- file-system-info ) + directory-entry os ( byte-array -- directory-entry ) -: directory* ( path -- seq ) - dup directory [ first2 >r append-path r> 2array ] with map ; +HOOK: (directory-entries) os ( path -- seq ) + +: directory-entries ( path -- seq ) + normalize-path + (directory-entries) + [ name>> { "." ".." } member? not ] filter ; + +: directory-files ( path -- seq ) + directory-entries [ name>> ] map ; + +: with-directory-files ( path quot -- ) + [ "" directory-files ] prepose with-directory ; inline ! Touching files HOOK: touch-file io-backend ( path -- ) @@ -259,12 +269,10 @@ HOOK: delete-directory io-backend ( path -- ) : delete-tree ( path -- ) dup link-info type>> +directory+ = [ - dup directory over [ - [ first delete-tree ] each - ] with-directory delete-directory - ] [ - delete-file - ] if ; + [ [ [ delete-tree ] each ] with-directory-files ] + [ delete-directory ] + bi + ] [ delete-file ] if ; : to-directory ( from to -- from to' ) over file-name append-path ; @@ -303,9 +311,9 @@ DEFER: copy-tree-into { { +symbolic-link+ [ copy-link ] } { +directory+ [ - >r dup directory r> rot [ - [ >r first r> copy-tree-into ] curry each - ] with-directory + swap [ + [ swap copy-tree-into ] with each + ] with-directory-files ] } [ drop copy-file ] } case ; diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index fc6f1465bb..a75b97c040 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -398,7 +398,7 @@ HELP: filter { $description "Applies the quotation to each element in turn, and outputs a new sequence containing the elements of the original sequence for which the quotation output a true value." } ; HELP: filter-here -{ $values { "seq" "a resizable mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "subseq" "a new sequence" } } +{ $values { "seq" "a resizable mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } } { $description "Applies the quotation to each element in turn, and removes elements for which the quotation outputs a false value." } { $side-effects "seq" } ; diff --git a/extra/crypto/passwd-md5/authors.txt b/extra/crypto/passwd-md5/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/crypto/passwd-md5/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/crypto/passwd-md5/passwd-md5-docs.factor b/extra/crypto/passwd-md5/passwd-md5-docs.factor new file mode 100644 index 0000000000..eb8f3e74a9 --- /dev/null +++ b/extra/crypto/passwd-md5/passwd-md5-docs.factor @@ -0,0 +1,34 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax io.streams.string strings ; +IN: crypto.passwd-md5 + +HELP: authenticate-password +{ $values + { "shadow" string } { "password" string } + { "?" "a boolean" } } +{ $description "Encodes the provided password and compares it to the encoded password entry from a shadowed password file." } ; + +HELP: parse-shadow-password +{ $values + { "string" string } + { "magic" string } { "salt" string } { "password" string } } +{ $description "Splits a shadowed password entry into a magic string, a salt, and an encoded password string." } ; + +HELP: passwd-md5 +{ $values + { "magic" string } { "salt" string } { "password" string } + { "bytes" "an md5-shadowed password entry" } } +{ $description "Encodes the password with the given magic string and salt to an MD5-shadow password entry." } ; + +ARTICLE: "crypto.passwd-md5" "MD5 shadow passwords" +"The " { $vocab-link "crypto.passwd-md5" } " vocabulary can encode passwords for use in an MD5 shadow password file." $nl + +"Encoding a password:" +{ $subsection passwd-md5 } +"Parsing a shadowed password entry:" +{ $subsection parse-shadow-password } +"Authenticating against a shadowed password:" +{ $subsection authenticate-password } ; + +ABOUT: "crypto.passwd-md5" diff --git a/extra/crypto/passwd-md5/passwd-md5-tests.factor b/extra/crypto/passwd-md5/passwd-md5-tests.factor new file mode 100644 index 0000000000..a858d8dab5 --- /dev/null +++ b/extra/crypto/passwd-md5/passwd-md5-tests.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test crypto.passwd-md5 ; +IN: crypto.passwd-md5.tests + + +[ "$1$npUpD5oQ$1.X7uXR2QG0FzPifVeZ2o1" ] +[ "$1$" "npUpD5oQ" "factor" passwd-md5 ] unit-test + +[ "$1$Kilak4kR$wlEr5Dv5DcdqPjKjQtt430" ] +[ + "$1$" + "Kilak4kR" + "longpassword12345678901234567890" + passwd-md5 +] unit-test diff --git a/extra/crypto/passwd-md5/passwd-md5.factor b/extra/crypto/passwd-md5/passwd-md5.factor new file mode 100644 index 0000000000..32a913ef23 --- /dev/null +++ b/extra/crypto/passwd-md5/passwd-md5.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel base64 checksums.md5 symbols sequences checksums +locals prettyprint math math.bitwise grouping io combinators +fry make combinators.short-circuit math.functions splitting ; +IN: crypto.passwd-md5 + + + +:: passwd-md5 ( magic salt password -- bytes ) + [let* | final! [ password magic salt 3append + salt password tuck 3append md5 checksum-bytes + password length + [ 16 / ceiling swap concat ] keep + head-slice append + password [ length ] [ first ] bi + '[ [ CHAR: \0 _ ? , ] each-bit ] "" make append + md5 checksum-bytes ] | + 1000 [ + "" swap + { + [ 0 bit? password final ? append ] + [ 3 mod 0 > [ salt append ] when ] + [ 7 mod 0 > [ password append ] when ] + [ 0 bit? final password ? append ] + } cleave md5 checksum-bytes final! + ] each + + magic salt "$" 3append + { 12 0 6 13 1 7 14 2 8 15 3 9 5 4 10 } final nths 3 group + [ first3 [ 16 shift ] [ 8 shift ] bi* + + 4 to64 ] map concat + 11 final nth 2 to64 3append ] ; + +: parse-shadow-password ( string -- magic salt password ) + "$" split harvest first3 [ "$" tuck 3append ] 2dip ; + +: authenticate-password ( shadow password -- ? ) + '[ parse-shadow-password drop _ passwd-md5 ] keep = ; diff --git a/extra/ftp/ftp.factor b/extra/ftp/ftp.factor index b2b5ebc9aa..1fd97df6d5 100644 --- a/extra/ftp/ftp.factor +++ b/extra/ftp/ftp.factor @@ -59,5 +59,5 @@ TUPLE: ftp-response n strings parsed ; 3array " " join ; : directory-list ( -- seq ) - "" directory keys + "" directory-files [ [ link-info ] keep file-info>string ] map ; diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 095e3c3246..8d7a92b0d9 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -3,7 +3,7 @@ USING: assocs html.parser kernel math sequences strings ascii arrays generalizations shuffle unicode.case namespaces make splitting http accessors io combinators http.client urls -urls.encoding fry ; +urls.encoding fry prettyprint ; IN: html.parser.analyzer TUPLE: link attributes clickable ; @@ -19,35 +19,34 @@ TUPLE: link attributes clickable ; '[ _ [ second @ ] find-from rot drop swap 1+ ] [ f 0 ] 2dip times drop first2 ; inline -: find-first-name ( str vector -- i/f tag/f ) - [ >lower ] dip [ name>> = ] with find ; inline +: find-first-name ( vector string -- i/f tag/f ) + >lower '[ name>> _ = ] find ; inline -: find-matching-close ( str vector -- i/f tag/f ) - [ >lower ] dip - [ [ name>> = ] [ closing?>> ] bi and ] with find ; inline +: find-matching-close ( vector string -- i/f tag/f ) + >lower + '[ [ name>> _ = ] [ closing?>> ] bi and ] find ; inline -: find-between* ( i/f tag/f vector -- vector ) - pick integer? [ - rot tail-slice - >r name>> r> - [ find-matching-close drop dup [ 1+ ] when ] keep - swap [ head ] [ first ] if* +: find-between* ( vector i/f tag/f -- vector ) + over integer? [ + [ tail-slice ] [ name>> ] bi* + dupd find-matching-close drop dup [ 1+ ] when + [ head ] [ first ] if* ] [ 3drop V{ } clone ] if ; inline - -: find-between ( i/f tag/f vector -- vector ) + +: find-between ( vector i/f tag/f -- vector ) find-between* dup length 3 >= [ [ rest-slice but-last-slice ] keep like ] when ; inline -: find-between-first ( string vector -- vector' ) - [ find-first-name ] keep find-between ; inline +: find-between-first ( vector string -- vector' ) + dupd find-first-name find-between ; inline : find-between-all ( vector quot -- seq ) - [ [ [ closing?>> not ] bi and ] curry find-all ] curry - [ [ >r first2 r> find-between* ] curry map ] bi ; inline - + dupd + '[ _ [ closing?>> not ] bi and ] find-all + [ first2 find-between* ] with map ; : remove-blank-text ( vector -- vector' ) [ @@ -61,27 +60,40 @@ TUPLE: link attributes clickable ; [ [ [ blank? ] trim ] change-text ] when ] map ; -: find-by-id ( id vector -- vector ) - [ attributes>> "id" swap at = ] with filter ; +: find-by-id ( vector id -- vector' ) + '[ attributes>> "id" at _ = ] find ; + +: find-by-class ( vector id -- vector' ) + '[ attributes>> "class" at _ = ] find ; -: find-by-class ( id vector -- vector ) - [ attributes>> "class" swap at = ] with filter ; +: find-by-name ( vector string -- vector ) + >lower '[ name>> _ = ] find ; -: find-by-name ( str vector -- vector ) - [ >lower ] dip [ name>> = ] with filter ; +: find-by-id-between ( vector string -- vector' ) + dupd + '[ attributes>> "id" swap at _ = ] find find-between* ; + +: find-by-class-between ( vector string -- vector' ) + dupd + '[ attributes>> "class" swap at _ = ] find find-between* ; + +: find-by-class-id-between ( vector class id -- vector' ) + '[ + [ attributes>> "class" swap at _ = ] + [ attributes>> "id" swap at _ = ] bi and + ] dupd find find-between* ; -: find-by-attribute-key ( key vector -- vector ) - [ >lower ] dip - [ attributes>> at ] with filter - sift ; +: find-by-attribute-key ( vector key -- vector' ) + >lower + [ attributes>> at _ = ] filter sift ; -: find-by-attribute-key-value ( value key vector -- vector ) - [ >lower ] dip +: find-by-attribute-key-value ( vector value key -- vector' ) + >lower [ attributes>> at over = ] with filter nip sift ; -: find-first-attribute-key-value ( value key vector -- i/f tag/f ) - [ >lower ] dip +: find-first-attribute-key-value ( vector value key -- i/f tag/f ) + >lower [ attributes>> at over = ] with find rot drop ; : tag-link ( tag -- link/f ) @@ -121,9 +133,9 @@ TUPLE: link attributes clickable ; swap [ >r first2 r> find-between* ] curry map [ [ name>> { "form" "input" } member? ] filter ] map ; -: find-html-objects ( string vector -- vector' ) - [ find-opening-tags-by-name ] keep - [ [ first2 ] dip find-between* ] curry map ; +: find-html-objects ( vector string -- vector' ) + dupd find-opening-tags-by-name + [ first2 find-between* ] curry map ; : form-action ( vector -- string ) [ name>> "form" = ] find nip @@ -150,3 +162,12 @@ TUPLE: link attributes clickable ; : query>assoc* ( str -- hash ) "?" split1 nip query>assoc ; + +: html-class? ( tag string -- ? ) + swap attributes>> "class" swap at = ; + +: html-id? ( tag string -- ? ) + swap attributes>> "id" swap at = ; + +: opening-tag? ( tag -- ? ) + closing?>> not ; diff --git a/extra/io/paths/paths.factor b/extra/io/paths/paths.factor index 58b3518edd..8237e59a1b 100755 --- a/extra/io/paths/paths.factor +++ b/extra/io/paths/paths.factor @@ -7,7 +7,7 @@ IN: io.paths TUPLE: directory-iterator path bfs queue ; : qualified-directory ( path -- seq ) - dup directory [ first2 [ append-path ] dip 2array ] with map ; + dup directory-files [ append-path ] with map ; : push-directory ( path iter -- ) [ qualified-directory ] dip [ @@ -21,7 +21,7 @@ TUPLE: directory-iterator path bfs queue ; : next-file ( iter -- file/f ) dup queue>> deque-empty? [ drop f ] [ - dup queue>> pop-back first2 + dup queue>> pop-back dup link-info directory? [ over push-directory next-file ] [ nip ] if ] if ; diff --git a/extra/shell/shell.factor b/extra/shell/shell.factor index 034cdaba5d..ae9b94ba0e 100644 --- a/extra/shell/shell.factor +++ b/extra/shell/shell.factor @@ -39,7 +39,7 @@ METHOD: expand { variable-expr } expr>> os-env ; METHOD: expand { glob-expr } expr>> dup "*" = - [ drop current-directory get directory [ first ] map ] + [ drop current-directory get directory-files ] [ ] if ; diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 16c51a876b..b833cc8cc2 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -374,15 +374,16 @@ M: revision feed-entry-url id>> revision-url ; { wiki "wiki-common" } >>template ; : init-wiki ( -- ) - "resource:extra/webapps/wiki/initial-content" directory* keys - [ - dup file-name ".txt" ?tail [ - swap ascii file-contents - f - swap >>content - swap >>title - "slava" >>author - now >>date - add-revision - ] [ 2drop ] if - ] each ; + "resource:extra/webapps/wiki/initial-content" [ + [ + dup ".txt" ?tail [ + swap ascii file-contents + f + swap >>content + swap >>title + "slava" >>author + now >>date + add-revision + ] [ 2drop ] if + ] each + ] with-directory-files ; diff --git a/vm/os-freebsd.h b/vm/os-freebsd.h index c535e2d71f..617a6686c2 100644 --- a/vm/os-freebsd.h +++ b/vm/os-freebsd.h @@ -7,6 +7,3 @@ extern int getosreldate(void); #ifndef KERN_PROC_PATHNAME #define KERN_PROC_PATHNAME 12 #endif - -#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN) -#define DIRECTORY_P(file) ((file)->d_type == DT_DIR) diff --git a/vm/os-linux.h b/vm/os-linux.h index 78ecbafd35..8e78595687 100644 --- a/vm/os-linux.h +++ b/vm/os-linux.h @@ -1,8 +1,5 @@ #include -#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN) -#define DIRECTORY_P(file) ((file)->d_type == DT_DIR) - int inotify_init(void); int inotify_add_watch(int fd, const char *name, u32 mask); int inotify_rm_watch(int fd, u32 wd); diff --git a/vm/os-macosx.h b/vm/os-macosx.h index b9686a5a85..216212e973 100644 --- a/vm/os-macosx.h +++ b/vm/os-macosx.h @@ -1,8 +1,6 @@ #define DLLEXPORT __attribute__((visibility("default"))) #define FACTOR_OS_STRING "macosx" #define NULL_DLL "libfactor.dylib" -#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN) -#define DIRECTORY_P(file) ((file)->d_type == DT_DIR) void init_signals(void); void early_init(void); diff --git a/vm/os-openbsd.h b/vm/os-openbsd.h deleted file mode 100644 index af47f7bcea..0000000000 --- a/vm/os-openbsd.h +++ /dev/null @@ -1,2 +0,0 @@ -#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN) -#define DIRECTORY_P(file) ((file)->d_type == DT_DIR) diff --git a/vm/os-solaris.h b/vm/os-solaris.h deleted file mode 100644 index 788a78090b..0000000000 --- a/vm/os-solaris.h +++ /dev/null @@ -1,2 +0,0 @@ -#define UNKNOWN_TYPE_P(file) 1 -#define DIRECTORY_P(file) 0 diff --git a/vm/os-unix.c b/vm/os-unix.c index fa2d5bb40c..4ca62e6623 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -61,44 +61,6 @@ DEFINE_PRIMITIVE(existsp) box_boolean(stat(unbox_char_string(),&sb) >= 0); } -/* Allocates memory */ -CELL parse_dir_entry(struct dirent *file) -{ - CELL name = tag_object(from_char_string(file->d_name)); - if(UNKNOWN_TYPE_P(file)) - return name; - else - { - CELL dirp = tag_boolean(DIRECTORY_P(file)); - return allot_array_2(name,dirp); - } -} - -DEFINE_PRIMITIVE(read_dir) -{ - DIR* dir = opendir(unbox_char_string()); - GROWABLE_ARRAY(result); - REGISTER_ROOT(result); - - if(dir != NULL) - { - struct dirent* file; - - while((file = readdir(dir)) != NULL) - { - CELL pair = parse_dir_entry(file); - GROWABLE_ARRAY_ADD(result,pair); - } - - closedir(dir); - } - - UNREGISTER_ROOT(result); - GROWABLE_ARRAY_TRIM(result); - - dpush(result); -} - F_SEGMENT *alloc_segment(CELL size) { int pagesize = getpagesize(); diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index 4f5778d0c4..54afd1c147 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -8,35 +8,6 @@ s64 current_millis(void) - EPOCH_OFFSET) / 10000; } -DEFINE_PRIMITIVE(os_envs) -{ - GROWABLE_ARRAY(result); - REGISTER_ROOT(result); - - TCHAR *env = GetEnvironmentStrings(); - TCHAR *finger = env; - - for(;;) - { - TCHAR *scan = finger; - while(*scan != '\0') - scan++; - if(scan == finger) - break; - - CELL string = tag_object(from_u16_string(finger)); - GROWABLE_ARRAY_ADD(result,string); - - finger = scan + 1; - } - - FreeEnvironmentStrings(env); - - UNREGISTER_ROOT(result); - GROWABLE_ARRAY_TRIM(result); - dpush(result); -} - long exception_handler(PEXCEPTION_POINTERS pe) { PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord; diff --git a/vm/os-windows.c b/vm/os-windows.c index c36ba59a27..c19aa5c4b5 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -87,21 +87,6 @@ const F_CHAR *vm_executable_path(void) return safe_strdup(full_path); } -void find_file_stat(F_CHAR *path) -{ - // FindFirstFile is the only call that can stat c:\pagefile.sys - WIN32_FIND_DATA st; - HANDLE h; - - if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st))) - dpush(F); - else - { - FindClose(h); - dpush(T); - } -} - DEFINE_PRIMITIVE(existsp) { BY_HANDLE_FILE_INFORMATION bhfi; @@ -136,34 +121,6 @@ DEFINE_PRIMITIVE(existsp) CloseHandle(h); } -DEFINE_PRIMITIVE(read_dir) -{ - HANDLE dir; - WIN32_FIND_DATA find_data; - F_CHAR *path = unbox_u16_string(); - - GROWABLE_ARRAY(result); - REGISTER_ROOT(result); - - if(INVALID_HANDLE_VALUE != (dir = FindFirstFile(path, &find_data))) - { - do - { - CELL name = tag_object(from_u16_string(find_data.cFileName)); - CELL dirp = tag_boolean(find_data.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY); - CELL pair = allot_array_2(name,dirp); - GROWABLE_ARRAY_ADD(result,pair); - } - while (FindNextFile(dir, &find_data)); - FindClose(dir); - } - - UNREGISTER_ROOT(result); - GROWABLE_ARRAY_TRIM(result); - - dpush(result); -} - F_SEGMENT *alloc_segment(CELL size) { char *mem; diff --git a/vm/platform.h b/vm/platform.h index 2f97cb9d1d..21336e88bb 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -55,7 +55,6 @@ #endif #elif defined(__OpenBSD__) #define FACTOR_OS_STRING "openbsd" - #include "os-openbsd.h" #if defined(FACTOR_X86) #include "os-openbsd-x86.32.h" @@ -102,7 +101,6 @@ #error "Unsupported Solaris flavor" #endif - #include "os-solaris.h" #else #error "Unsupported OS" #endif diff --git a/vm/primitives.c b/vm/primitives.c index 39dc2b10d7..94151f6c40 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -57,7 +57,6 @@ void *primitives[] = { primitive_getenv, primitive_setenv, primitive_existsp, - primitive_read_dir, primitive_gc, primitive_gc_stats, primitive_save_image,