Merge branch 'master' into new_codegen
Slava Pestov
commit
af6b8c4e97
|
|
@ -68,8 +68,7 @@ TUPLE: file-responder root hook special allow-listings ;
|
|||
[ <h1> file-name escape-string write </h1> ]
|
||||
[
|
||||
<ul>
|
||||
directory-files
|
||||
[ <li> file. </li> ] assoc-each
|
||||
directory-files [ <li> file. </li> ] each
|
||||
</ul>
|
||||
] bi
|
||||
] simple-page ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
[ ] [
|
||||
<process>
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
USE: system
|
||||
USE: prettyprint
|
||||
USE: environment
|
||||
os-envs .
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ] }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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" } ;
|
||||
|
|
|
|||
|
|
@ -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 ) ;
|
||||
|
|
|
|||
|
|
@ -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 ] }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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
|
||||
|
|
@ -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" <c-object> tuck statfs64 io-error
|
||||
statfs>file-system-info ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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
|
||||
|
|
@ -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 <void*> 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" <c-object> tuck statfs64 io-error
|
||||
statfs64>file-system-info ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -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
|
||||
|
|
@ -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 <reversed>
|
||||
[ 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
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -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 )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
HOOK: cd io-backend ( path -- )
|
||||
|
|
|
|||
|
|
@ -621,6 +621,14 @@ HELP: 2dip
|
|||
{ $code "[ foo bar ] 2dip" }
|
||||
} ;
|
||||
|
||||
HELP: 3dip
|
||||
{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quot" quotation } }
|
||||
{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj1" } ", " { $snippet "obj2" } " and " { $snippet "obj3" } " hidden on the retain stack." }
|
||||
{ $notes "The following are equivalent:"
|
||||
{ $code ">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 }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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"
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: lookup-table ( n -- nth )
|
||||
"./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" nth ; inline
|
||||
|
||||
: to64 ( v n -- string )
|
||||
[ [ -6 shift ] [ 6 2^ 1- bitand lookup-table ] bi ]
|
||||
replicate nip ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
:: passwd-md5 ( magic salt password -- bytes )
|
||||
[let* | final! [ password magic salt 3append
|
||||
salt password tuck 3append md5 checksum-bytes
|
||||
password length
|
||||
[ 16 / ceiling swap <repetition> 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 = ;
|
||||
Loading…
Reference in New Issue