diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor
index 3edcfe81cd..208273364c 100644
--- a/basis/http/server/static/static.factor
+++ b/basis/http/server/static/static.factor
@@ -68,8 +68,7 @@ TUPLE: file-responder root hook special allow-listings ;
[
file-name escape-string write
]
[
- directory-files
- [ - file.
] assoc-each
+ directory-files [ - file.
] each
] bi
] simple-page ;
diff --git a/basis/io/monitors/recursive/recursive.factor b/basis/io/monitors/recursive/recursive.factor
index 3cecee2b1e..45979363c9 100644
--- a/basis/io/monitors/recursive/recursive.factor
+++ b/basis/io/monitors/recursive/recursive.factor
@@ -19,7 +19,8 @@ DEFER: add-child-monitor
: add-child-monitors ( path -- )
#! We yield since this directory scan might take a while.
- [
+ dup [
+ [ append-path ] with map
[ add-child-monitor ] each yield
] with-directory-files ;
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/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor
index 05f354a8a8..b929c62e04 100644
--- a/basis/tools/vocabs/vocabs.factor
+++ b/basis/tools/vocabs/vocabs.factor
@@ -212,8 +212,10 @@ M: vocab-link summary vocab-summary ;
] 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 bf426ad867..bd66c5253e 100644
--- a/basis/unix/bsd/bsd.factor
+++ b/basis/unix/bsd/bsd.factor
@@ -83,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 3af6358e94..81885ff141 100644
--- a/basis/unix/bsd/freebsd/freebsd.factor
+++ b/basis/unix/bsd/freebsd/freebsd.factor
@@ -20,16 +20,6 @@ C-STRUCT: dirent
{ "u_int8_t" "d_namlen" }
{ { "char" 256 } "d_name" } ;
-: 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
-
: 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 de2fd4caf0..fb9eb9a621 100644
--- a/basis/unix/bsd/macosx/macosx.factor
+++ b/basis/unix/bsd/macosx/macosx.factor
@@ -39,17 +39,6 @@ C-STRUCT: dirent
{ "__uint8_t" "d_namlen" }
{ { "char" __DARWIN_MAXNAMELEN+1 } "d_name" } ;
-: 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
-
-
: EPERM 1 ; inline
: ENOENT 2 ; inline
: ESRCH 3 ; inline
diff --git a/basis/unix/bsd/netbsd/netbsd.factor b/basis/unix/bsd/netbsd/netbsd.factor
index 6c45811d51..149f35afce 100644
--- a/basis/unix/bsd/netbsd/netbsd.factor
+++ b/basis/unix/bsd/netbsd/netbsd.factor
@@ -14,21 +14,11 @@ C-STRUCT: addrinfo
{ "addrinfo*" "next" } ;
C-STRUCT: dirent
- { "ino_t" "d_fileno" }
+ { "__uint32_t" "d_fileno" }
{ "__uint16_t" "d_reclen" }
- { "__uint16_t" "d_namlen" }
{ "__uint8_t" "d_type" }
- { { "char" 512 } "d_name" } ;
-
-: 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
+ { "__uint8_t" "d_namlen" }
+ { { "char" 256 } "d_name" } ;
: EPERM 1 ; inline
: ENOENT 2 ; inline
diff --git a/basis/unix/bsd/openbsd/openbsd.factor b/basis/unix/bsd/openbsd/openbsd.factor
index f4a7863fdd..a4189775e7 100644
--- a/basis/unix/bsd/openbsd/openbsd.factor
+++ b/basis/unix/bsd/openbsd/openbsd.factor
@@ -20,17 +20,6 @@ C-STRUCT: dirent
{ "__uint8_t" "d_namlen" }
{ { "char" 256 } "d_name" } ;
-: 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
-
-
-
: 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 1df6865d41..4bcab0b477 100644
--- a/basis/unix/stat/linux/linux.factor
+++ b/basis/unix/stat/linux/linux.factor
@@ -1,6 +1,12 @@
-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 ] }
diff --git a/basis/unix/stat/macosx/macosx.factor b/basis/unix/stat/macosx/macosx.factor
index 03301d25b9..49b6709847 100644
--- a/basis/unix/stat/macosx/macosx.factor
+++ b/basis/unix/stat/macosx/macosx.factor
@@ -115,12 +115,6 @@ C-STRUCT: vfsquery
: NFSV2_MAX_FH_SIZE 32 ; inline
: NFS_MAX_FH_SIZE NFSV4_MAX_FH_SIZE ; inline
-! C-STRUCT: fhandle
- ! { "int" "fh_len" }
- ! { { "uchar" NFS_MAX_FH_SIZE } "fh_data" } ;
-
-! TYPEDEF: fhandle fhandle_t
-
: MFSNAMELEN 15 ; inline
: MNAMELEN 90 ; inline
: MFSTYPENAMELEN 16 ; inline
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/core/io/files/files.factor b/core/io/files/files.factor
index 8796834bc7..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 )
+
r >r >r foo bar r> r> r>" }
+ { $code "[ foo bar ] 3dip" }
+} ;
+
HELP: while
{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "body" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
@@ -815,6 +823,7 @@ ARTICLE: "slip-keep-combinators" "The dip, slip and keep combinators"
"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
{ $subsection dip }
{ $subsection 2dip }
+{ $subsection 3dip }
"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
{ $subsection slip }
{ $subsection 2slip }
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index a967eb6a74..fae1922d29 100644
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -59,6 +59,8 @@ DEFER: if
: 2dip ( obj1 obj2 quot -- obj1 obj2 ) -rot 2slip ; inline
+: 3dip ( obj1 obj2 obj3 quot -- obj1 obj2 obj3 ) -roll 3slip ; inline
+
! Keepers
: keep ( x quot -- x ) over slip ; inline
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 = ;