steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2009-01-13 19:26:25 -06:00
parent 1f29e128c1 a40af2bd87
commit b169b803d2
9 changed files with 194 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
basis/base64/base64-tests.factor
View File

@ -1,4 +1,4 @@
USING: kernel tools.test base64 strings ;
USING: kernel tools.test base64 strings sequences ;
IN: base64.tests
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string
@ -7,6 +7,7 @@ IN: base64.tests
[ "a" ] [ "a" >base64 base64> >string ] unit-test
[ "ab" ] [ "ab" >base64 base64> >string ] unit-test
[ "abc" ] [ "abc" >base64 base64> >string ] unit-test
[ "abcde" ] [ "abcde" >base64 3 cut "\r\n" swap 3append base64> >string ] unit-test
! From http://en.wikipedia.org/wiki/Base64
[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
@ -15,5 +16,11 @@ IN: base64.tests
>base64 >string
] unit-test
[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlz\r\nIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2Yg\r\ndGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGlu\r\ndWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRo\r\nZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
[
"Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
>base64-lines >string
] unit-test
\ >base64 must-infer
\ base64> must-infer

88
basis/base64/base64.factor
View File

@ -1,16 +1,22 @@
! Copyright (C) 2008 Doug Coleman.
! Copyright (C) 2008 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences io.binary splitting grouping
accessors ;
USING: combinators io io.binary io.encodings.binary
io.streams.byte-array io.streams.string kernel math namespaces
sequences strings ;
IN: base64
<PRIVATE
: count-end ( seq quot -- n )
trim-right-slice [ seq>> length ] [ to>> ] bi - ; inline
: read1-ignoring ( ignoring -- ch )
read1 2dup swap member? [ drop read1-ignoring ] [ nip ] if ;
: read-ignoring ( ignoring n -- str )
[ drop read1-ignoring ] with map harvest
[ f ] [ >string ] if-empty ;
: ch>base64 ( ch -- ch )
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ;
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
nth ; inline
: base64>ch ( ch -- ch )
{
@ -19,32 +25,60 @@ IN: base64
f 0 f f f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
22 23 24 25 f f f f f f 26 27 28 29 30 31 32 33 34 35 36 37 38 39
40 41 42 43 44 45 46 47 48 49 50 51
} nth ;
} nth ; inline
: encode3 ( seq -- seq )
SYMBOL: column
: write1-lines ( ch -- )
write1
column get [
1+ [ 76 = [ "\r\n" write ] when ]
[ 76 mod column set ] bi
] when* ;
: write-lines ( str -- )
[ write1-lines ] each ;
: encode3 ( seq -- )
be> 4 <reversed> [
-6 * shift HEX: 3f bitand ch>base64
] with B{ } map-as ;
-6 * shift HEX: 3f bitand ch>base64 write1-lines
] with each ; inline
: decode4 ( str -- str )
0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ;
: encode-pad ( seq n -- )
[ 3 0 pad-right binary [ encode3 ] with-byte-writer ]
[ 1+ ] bi* head-slice 4 CHAR: = pad-right write-lines ; inline
: >base64-rem ( str -- str )
[ 3 0 pad-right encode3 ] [ length 1+ ] bi
head-slice 4 CHAR: = pad-right ;
ERROR: malformed-base64 ;
: decode4 ( seq -- )
[ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
[ [ CHAR: = = ] count ] bi head-slice*
[ write1 ] each ; inline
PRIVATE>
: >base64 ( seq -- base64 )
#! cut string into two pieces, convert 3 bytes at a time
#! pad string with = when not enough bits
dup length dup 3 mod - cut
[ 3 <groups> [ encode3 ] map concat ]
[ [ "" ] [ >base64-rem ] if-empty ]
bi* append ;
: encode-base64 ( -- )
3 read dup length {
{ 0 [ drop ] }
{ 3 [ encode3 encode-base64 ] }
[ encode-pad encode-base64 ]
} case ;
: base64> ( base64 -- seq )
#! input length must be a multiple of 4
[ 4 <groups> [ decode4 ] map concat ]
[ [ CHAR: = = ] count-end ]
bi head* ;
: encode-base64-lines ( -- )
0 column [ encode-base64 ] with-variable ;
: decode-base64 ( -- )
"\n\r" 4 read-ignoring dup length {
{ 0 [ drop ] }
{ 4 [ decode4 decode-base64 ] }
[ malformed-base64 ]
} case ;
: >base64 ( str -- base64 )
binary [ [ encode-base64 ] with-string-reader ] with-byte-writer ;
: base64> ( base64 -- str )
[ binary [ decode-base64 ] with-byte-reader ] with-string-writer ;
: >base64-lines ( str -- base64 )
binary [ [ encode-base64-lines ] with-string-reader ] with-byte-writer ;

2
basis/io/directories/search/search.factor
View File

@ -14,7 +14,7 @@ TUPLE: directory-iterator path bfs queue ;
: push-directory ( path iter -- )
[ qualified-directory ] dip [
dup queue>> swap bfs>>
[ queue>> ] [ bfs>> ] bi
[ push-front ] [ push-back ] if
] curry each ;

5
basis/smtp/smtp-tests.factor
View File

@ -15,7 +15,7 @@ IN: smtp.tests
[ { "hello" "." "world" } validate-message ] must-fail
[ "hello\r\nworld\r\n.\r\n" ] [
[ "aGVsbG8Kd29ybGQ=\r\n.\r\n" ] [
"hello\nworld" [ send-body ] with-string-writer
] unit-test
@ -50,7 +50,10 @@ IN: smtp.tests
[
{
{ "Content-Transfer-Encoding" "base64" }
{ "Content-Type" "Text/plain; charset=utf-8" }
{ "From" "Doug <erg@factorcode.org>" }
{ "MIME-Version" "1.0" }
{ "Subject" "Factor rules" }
{ "To" "Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>" }
}

23
basis/smtp/smtp.factor
View File

@ -92,9 +92,8 @@ M: message-contains-dot summary ( obj -- string )
[ message-contains-dot ] when ;
: send-body ( body -- )
string-lines
validate-message
[ write crlf ] each
utf8 encode
>base64-lines write crlf
"." command ;
: quit ( -- )
@ -167,6 +166,13 @@ M: plain-auth send-auth
: auth ( -- ) smtp-auth get send-auth ;
: encode-header ( string -- string' )
dup aux>> [
"=?utf-8?B?"
swap utf8 encode >base64
"?=" 3append
] when ;
ERROR: invalid-header-string string ;
: validate-header ( string -- string' )
@ -175,7 +181,7 @@ ERROR: invalid-header-string string ;
: write-header ( key value -- )
[ validate-header write ]
[ ": " write validate-header write ] bi* crlf ;
[ ": " write validate-header encode-header write ] bi* crlf ;
: write-headers ( assoc -- )
[ write-header ] assoc-each ;
@ -195,6 +201,13 @@ ERROR: invalid-header-string string ;
! This could be much smarter.
" " split1-last swap or "<" ?head drop ">" ?tail drop ;
: utf8-mime-header ( -- alist )
{
{ "MIME-Version" "1.0" }
{ "Content-Transfer-Encoding" "base64" }
{ "Content-Type" "Text/plain; charset=utf-8" }
} ;
: email>headers ( email -- hashtable )
[
{
@ -205,7 +218,7 @@ ERROR: invalid-header-string string ;
} cleave
now timestamp>rfc822 "Date" set
message-id "Message-Id" set
] { } make-assoc ;
] { } make-assoc utf8-mime-header append ;
: (send-email) ( headers email -- )
[

4
basis/tools/files/files-tests.factor
View File

@ -1,10 +1,8 @@
! Copyright (C) 2008 Your name.
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test tools.files strings kernel ;
IN: tools.files.tests
\ directory. must-infer
[ ] [ "" directory. ] unit-test
[ ] [ file-systems. ] unit-test

98
basis/tools/files/files.factor
View File

@ -1,24 +1,29 @@
! Copyright (C) 2008 Doug Coleman.
! Copyright (C) 2008, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators io io.files io.files.info
io.directories kernel math.parser sequences system vocabs.loader
calendar math fry prettyprint ;
USING: accessors arrays calendar combinators fry io io.directories
io.files.info kernel math math.parser prettyprint sequences system
vocabs.loader sorting.slots calendar.format ;
IN: tools.files
SYMBOLS: permissions file-name nlinks file-size date ;
<PRIVATE
: ls-time ( timestamp -- string )
: dir-or-size ( file-info -- str )
dup directory? [
drop "<DIR>" 20 CHAR: \s pad-right
] [
size>> number>string 20 CHAR: \s pad-left
] if ;
: listing-time ( timestamp -- string )
[ hour>> ] [ minute>> ] bi
[ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ;
: ls-timestamp ( timestamp -- string )
: listing-date ( timestamp -- string )
[ month>> month-abbreviation ]
[ day>> number>string 2 CHAR: \s pad-left ]
[
dup year>> dup now year>> =
[ drop ls-time ] [ nip number>string ] if
[ drop listing-time ] [ nip number>string ] if
5 CHAR: \s pad-left
] tri 3array " " join ;
@ -28,12 +33,57 @@ SYMBOLS: permissions file-name nlinks file-size date ;
: execute>string ( ? -- string ) "x" "-" ? ; inline
HOOK: (directory.) os ( path -- lines )
PRIVATE>
: directory. ( path -- )
[ (directory.) ] with-directory-files [ print ] each ;
SYMBOLS: file-name file-name/type permissions file-type nlinks file-size
file-date file-time file-datetime uid gid user group link-target unix-datetime
directory-or-size ;
TUPLE: listing-tool path specs sort ;
TUPLE: file-listing directory-entry file-info ;
C: <file-listing> file-listing
: <listing-tool> ( path -- listing-tool )
listing-tool new
swap >>path
{ file-name } >>specs ;
: list-slow? ( listing-tool -- ? )
specs>> { file-name } sequence= not ;
ERROR: unknown-file-spec symbol ;
HOOK: file-spec>string os ( file-listing spec -- string )
M: object file-spec>string ( file-listing spec -- string )
{
{ file-name [ directory-entry>> name>> ] }
{ directory-or-size [ file-info>> dir-or-size ] }
{ file-size [ file-info>> size>> number>string ] }
{ file-date [ file-info>> modified>> listing-date ] }
{ file-time [ file-info>> modified>> listing-time ] }
{ file-datetime [ file-info>> modified>> timestamp>ymdhms ] }
[ unknown-file-spec ]
} case ;
: list-files-fast ( listing-tool -- array )
path>> [ [ name>> 1array ] map ] with-directory-entries ; inline
: list-files-slow ( listing-tool -- array )
[ path>> ] [ sort>> ] [ specs>> ] tri '[
[ dup name>> file-info file-listing boa ] map
_ [ sort-by-slots ] when*
[ _ [ file-spec>string ] with map ] map
] with-directory-entries ; inline
: list-files ( listing-tool -- array )
dup list-slow? [ list-files-slow ] [ list-files-fast ] if ; inline
HOOK: (directory.) os ( path -- lines )
: directory. ( path -- ) (directory.) simple-table. ;
SYMBOLS: device-name mount-point type
available-space free-space used-space total-space
@ -43,16 +93,16 @@ percent-used percent-free ;
: file-system-spec ( file-system-info obj -- str )
{
{ device-name [ device-name>> [ "" ] unless* ] }
{ mount-point [ mount-point>> [ "" ] unless* ] }
{ type [ type>> [ "" ] unless* ] }
{ available-space [ available-space>> [ 0 ] unless* ] }
{ free-space [ free-space>> [ 0 ] unless* ] }
{ used-space [ used-space>> [ 0 ] unless* ] }
{ total-space [ total-space>> [ 0 ] unless* ] }
{ device-name [ device-name>> "" or ] }
{ mount-point [ mount-point>> "" or ] }
{ type [ type>> "" or ] }
{ available-space [ available-space>> 0 or ] }
{ free-space [ free-space>> 0 or ] }
{ used-space [ used-space>> 0 or ] }
{ total-space [ total-space>> 0 or ] }
{ percent-used [
[ used-space>> ] [ total-space>> ] bi
[ [ 0 ] unless* ] bi@ dup 0 =
[ 0 or ] bi@ dup 0 =
[ 2drop 0 ] [ / percent ] if
] }
} case ;
@ -65,8 +115,10 @@ percent-used percent-free ;
[ [ unparse ] map ] bi prefix simple-table. ;
: file-systems. ( -- )
{ device-name available-space free-space used-space total-space percent-used mount-point }
print-file-systems ;
{
device-name available-space free-space used-space
total-space percent-used mount-point
} print-file-systems ;
{
{ [ os unix? ] [ "tools.files.unix" ] }

37
basis/tools/files/unix/unix.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel system unicode.case io.files
io.files.info io.files.info.unix tools.files generalizations
io.files.info io.files.info.unix generalizations
strings arrays sequences math.parser unix.groups unix.users
tools.files.private unix.stat math fry macros combinators.smart ;
tools.files.private unix.stat math fry macros combinators.smart
io.files.info.unix io tools.files math.order prettyprint ;
IN: tools.files.unix
<PRIVATE
@ -45,19 +46,23 @@ IN: tools.files.unix
} cond ;
M: unix (directory.) ( path -- lines )
[ [
[
dup file-info [
{
[ permissions-string ]
[ nlink>> number>string 3 CHAR: \s pad-left ]
[ uid>> user-name ]
[ gid>> group-name ]
[ size>> number>string 15 CHAR: \s pad-left ]
[ modified>> ls-timestamp ]
} cleave
] output>array swap suffix " " join
] map
] with-group-cache ] with-user-cache ;
<listing-tool>
{ permissions nlinks user group file-size file-date file-name } >>specs
{ { directory-entry>> name>> <=> } } >>sort
[ [ list-files ] with-group-cache ] with-user-cache ;
M: unix file-spec>string ( file-listing spec -- string )
{
{ file-name/type [
directory-entry>> [ name>> ] [ file-type>trailing ] bi append
] }
{ permissions [ file-info>> permissions-string ] }
{ nlinks [ file-info>> nlink>> number>string ] }
{ user [ file-info>> uid>> user-name ] }
{ group [ file-info>> gid>> group-name ] }
{ uid [ file-info>> uid>> number>string ] }
{ gid [ file-info>> gid>> number>string ] }
[ call-next-method ]
} case ;
PRIVATE>

19
basis/tools/files/windows/windows.factor
View File

@ -2,24 +2,15 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar.format combinators io.files
kernel math.parser sequences splitting system tools.files
generalizations tools.files.private io.files.info ;
generalizations tools.files.private io.files.info math.order ;
IN: tools.files.windows
<PRIVATE
: directory-or-size ( file-info -- str )
dup directory? [
drop "<DIR>" 20 CHAR: \s pad-right
] [
size>> number>string 20 CHAR: \s pad-left
] if ;
M: windows (directory.) ( entries -- lines )
[
dup file-info {
[ modified>> timestamp>ymdhms ]
[ directory-or-size ]
} cleave 2 narray swap suffix " " join
] map ;
<listing-tool>
{ file-datetime directory-or-size file-name } >>specs
{ { directory-entry>> name>> <=> } } >>sort
list-files ;
PRIVATE>