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

db4
John Benediktsson 2009-01-13 17:48:56 -08:00
commit 358f66bae6
24 changed files with 287 additions and 138 deletions

View File

@ -1,4 +1,4 @@
USING: kernel tools.test base64 strings ; USING: kernel tools.test base64 strings sequences ;
IN: base64.tests IN: base64.tests
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string [ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string
@ -7,6 +7,7 @@ IN: base64.tests
[ "a" ] [ "a" >base64 base64> >string ] unit-test [ "a" ] [ "a" >base64 base64> >string ] unit-test
[ "ab" ] [ "ab" >base64 base64> >string ] unit-test [ "ab" ] [ "ab" >base64 base64> >string ] unit-test
[ "abc" ] [ "abc" >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 ! From http://en.wikipedia.org/wiki/Base64
[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ] [ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
@ -15,5 +16,11 @@ IN: base64.tests
>base64 >string >base64 >string
] unit-test ] 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
\ base64> must-infer \ base64> must-infer

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. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences io.binary splitting grouping USING: combinators io io.binary io.encodings.binary
accessors ; io.streams.byte-array io.streams.string kernel math namespaces
sequences strings ;
IN: base64 IN: base64
<PRIVATE <PRIVATE
: count-end ( seq quot -- n ) : read1-ignoring ( ignoring -- ch )
trim-right-slice [ seq>> length ] [ to>> ] bi - ; inline 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 ) : ch>base64 ( ch -- ch )
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ; "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
nth ; inline
: base64>ch ( ch -- ch ) : 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 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 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 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> [ be> 4 <reversed> [
-6 * shift HEX: 3f bitand ch>base64 -6 * shift HEX: 3f bitand ch>base64 write1-lines
] with B{ } map-as ; ] with each ; inline
: decode4 ( str -- str ) : encode-pad ( seq n -- )
0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ; [ 3 0 pad-right binary [ encode3 ] with-byte-writer ]
[ 1+ ] bi* head-slice 4 CHAR: = pad-right write-lines ; inline
: >base64-rem ( str -- str ) ERROR: malformed-base64 ;
[ 3 0 pad-right encode3 ] [ length 1+ ] bi
head-slice 4 CHAR: = pad-right ; : decode4 ( seq -- )
[ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
[ [ CHAR: = = ] count ] bi head-slice*
[ write1 ] each ; inline
PRIVATE> PRIVATE>
: >base64 ( seq -- base64 ) : encode-base64 ( -- )
#! cut string into two pieces, convert 3 bytes at a time 3 read dup length {
#! pad string with = when not enough bits { 0 [ drop ] }
dup length dup 3 mod - cut { 3 [ encode3 encode-base64 ] }
[ 3 <groups> [ encode3 ] map concat ] [ encode-pad encode-base64 ]
[ [ "" ] [ >base64-rem ] if-empty ] } case ;
bi* append ;
: base64> ( base64 -- seq ) : encode-base64-lines ( -- )
#! input length must be a multiple of 4 0 column [ encode-base64 ] with-variable ;
[ 4 <groups> [ decode4 ] map concat ]
[ [ CHAR: = = ] count-end ] : decode-base64 ( -- )
bi head* ; "\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 ;

View File

@ -229,8 +229,9 @@ HELP: napply
{ $examples { $examples
"Some core words expressed in terms of " { $link napply } ":" "Some core words expressed in terms of " { $link napply } ":"
{ $table { $table
{ { $link bi@ } { $snippet "1 napply" } } { { $link call } { $snippet "1 napply" } }
{ { $link tri@ } { $snippet "2 napply" } } { { $link bi@ } { $snippet "2 napply" } }
{ { $link tri@ } { $snippet "3 napply" } }
} }
} ; } ;

View File

@ -1,4 +1,4 @@
USING: tools.test generalizations kernel math arrays sequences ; USING: tools.test generalizations kernel math arrays sequences ascii ;
IN: generalizations.tests IN: generalizations.tests
{ 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test { 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test
@ -28,6 +28,8 @@ IN: generalizations.tests
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
[ "HELLO" ] [ "hello" [ >upper ] 1 napply ] unit-test
[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test [ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test
[ [ dup 2^ 2array ] 5 napply ] must-infer [ [ dup 2^ 2array ] 5 napply ] must-infer

View File

@ -73,10 +73,8 @@ MACRO: ncleave ( quots n -- )
[ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
compose ; compose ;
MACRO: napply ( n -- ) MACRO: napply ( quot n -- )
2 [a,b] swap <repetition> spread>quot ;
[ [ 1- ] [ ] bi '[ _ ntuck _ nslip ] ]
map concat >quotation [ call ] append ;
MACRO: mnswap ( m n -- ) MACRO: mnswap ( m n -- )
1+ '[ _ -nrot ] <repetition> spread>quot ; 1+ '[ _ -nrot ] <repetition> spread>quot ;

View File

@ -3,7 +3,7 @@
! Copyright (C) 2004 Chris Double. ! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io kernel namespaces prettyprint quotations USING: io io.styles kernel namespaces prettyprint quotations
sequences strings words xml.entities compiler.units effects sequences strings words xml.entities compiler.units effects
urls math math.parser combinators present fry ; urls math math.parser combinators present fry ;

View File

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

View File

@ -0,0 +1,28 @@
USING: io help.markup help.syntax quotations ;
IN: io.streams.null
HELP: null-reader
{ $class-description "Singleton class of null reader streams." } ;
HELP: null-writer
{ $class-description "Singleton class of null writer streams." } ;
HELP: with-null-reader
{ $values { "quot" quotation } }
{ $description "Calls the quotation with " { $link input-stream } " rebound to a " { $link null-reader } " which always produces EOF." } ;
HELP: with-null-writer
{ $values { "quot" quotation } }
{ $description "Calls the quotation with " { $link output-stream } " rebound to a " { $link null-writer } " which ignores all output." } ;
ARTICLE: "io.streams.null" "Null streams"
"The " { $vocab-link "io.streams.null" } " vocabulary implements a pair of streams which are useful for testing. The null reader always yields EOF and the null writer ignores all output. Conceptually, they are similar to " { $snippet "/dev/null" } " on a Unix system."
$nl
"Null readers:"
{ $subsection null-reader }
{ $subsection with-null-writer }
"Null writers:"
{ $subsection null-writer }
{ $subsection with-null-reader } ;
ABOUT: "io.streams.null"

View File

View File

@ -1,22 +1,19 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel io io.timeouts io.styles destructors ;
IN: io.streams.null IN: io.streams.null
USING: kernel io io.timeouts io.streams.duplex destructors ;
TUPLE: null-stream ; SINGLETONS: null-reader null-writer ;
UNION: null-stream null-reader null-writer ;
M: null-stream dispose drop ; M: null-stream dispose drop ;
M: null-stream set-timeout 2drop ; M: null-stream set-timeout 2drop ;
TUPLE: null-reader < null-stream ;
M: null-reader stream-readln drop f ; M: null-reader stream-readln drop f ;
M: null-reader stream-read1 drop f ; M: null-reader stream-read1 drop f ;
M: null-reader stream-read-until 2drop f f ; M: null-reader stream-read-until 2drop f f ;
M: null-reader stream-read 2drop f ; M: null-reader stream-read 2drop f ;
TUPLE: null-writer < null-stream ;
M: null-writer stream-write1 2drop ; M: null-writer stream-write1 2drop ;
M: null-writer stream-write 2drop ; M: null-writer stream-write 2drop ;
M: null-writer stream-nl drop ; M: null-writer stream-nl drop ;
@ -28,11 +25,7 @@ M: null-writer make-cell-stream nip ;
M: null-writer stream-write-table 3drop ; M: null-writer stream-write-table 3drop ;
: with-null-reader ( quot -- ) : with-null-reader ( quot -- )
T{ null-reader } swap with-input-stream* ; inline null-reader swap with-input-stream* ; inline
: with-null-writer ( quot -- ) : with-null-writer ( quot -- )
T{ null-writer } swap with-output-stream* ; inline null-writer swap with-output-stream* ; inline
: with-null-stream ( quot -- )
T{ duplex-stream f T{ null-reader } T{ null-writer } }
swap with-stream* ; inline

View File

@ -0,0 +1,8 @@
IN: io.styles.tests
USING: io.styles tools.test ;
\ stream-format must-infer
\ stream-write-table must-infer
\ make-span-stream must-infer
\ make-block-stream must-infer
\ make-cell-stream must-infer

View File

@ -15,7 +15,7 @@ IN: smtp.tests
[ { "hello" "." "world" } validate-message ] must-fail [ { "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 "hello\nworld" [ send-body ] with-string-writer
] unit-test ] 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>" } { "From" "Doug <erg@factorcode.org>" }
{ "MIME-Version" "1.0" }
{ "Subject" "Factor rules" } { "Subject" "Factor rules" }
{ "To" "Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>" } { "To" "Slava <slava@factorcode.org>, Ed <dharmatech@factorcode.org>" }
} }

View File

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

View File

@ -416,12 +416,7 @@ DEFER: bar
\ stream-write must-infer \ stream-write must-infer
\ stream-write1 must-infer \ stream-write1 must-infer
\ stream-nl must-infer \ stream-nl must-infer
\ stream-format must-infer
\ stream-write-table must-infer
\ stream-flush must-infer \ stream-flush must-infer
\ make-span-stream must-infer
\ make-block-stream must-infer
\ make-cell-stream must-infer
! Test stream utilities ! Test stream utilities
\ lines must-infer \ lines must-infer

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. ! See http://factorcode.org/license.txt for BSD license.
USING: tools.test tools.files strings kernel ; USING: tools.test tools.files strings kernel ;
IN: tools.files.tests IN: tools.files.tests
\ directory. must-infer
[ ] [ "" directory. ] unit-test [ ] [ "" directory. ] unit-test
[ ] [ file-systems. ] unit-test [ ] [ file-systems. ] unit-test

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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators io io.files io.files.info USING: accessors arrays calendar combinators fry io io.directories
io.directories kernel math.parser sequences system vocabs.loader io.files.info kernel math math.parser prettyprint sequences system
calendar math fry prettyprint ; vocabs.loader sorting.slots calendar.format ;
IN: tools.files IN: tools.files
SYMBOLS: permissions file-name nlinks file-size date ;
<PRIVATE <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 [ hour>> ] [ minute>> ] bi
[ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ; [ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ;
: ls-timestamp ( timestamp -- string ) : listing-date ( timestamp -- string )
[ month>> month-abbreviation ] [ month>> month-abbreviation ]
[ day>> number>string 2 CHAR: \s pad-left ] [ day>> number>string 2 CHAR: \s pad-left ]
[ [
dup year>> dup now year>> = dup year>> dup now year>> =
[ drop ls-time ] [ nip number>string ] if [ drop listing-time ] [ nip number>string ] if
5 CHAR: \s pad-left 5 CHAR: \s pad-left
] tri 3array " " join ; ] tri 3array " " join ;
@ -28,12 +33,57 @@ SYMBOLS: permissions file-name nlinks file-size date ;
: execute>string ( ? -- string ) "x" "-" ? ; inline : execute>string ( ? -- string ) "x" "-" ? ; inline
HOOK: (directory.) os ( path -- lines )
PRIVATE> PRIVATE>
: directory. ( path -- ) SYMBOLS: file-name file-name/type permissions file-type nlinks file-size
[ (directory.) ] with-directory-files [ print ] each ; 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 SYMBOLS: device-name mount-point type
available-space free-space used-space total-space available-space free-space used-space total-space
@ -43,16 +93,16 @@ percent-used percent-free ;
: file-system-spec ( file-system-info obj -- str ) : file-system-spec ( file-system-info obj -- str )
{ {
{ device-name [ device-name>> [ "" ] unless* ] } { device-name [ device-name>> "" or ] }
{ mount-point [ mount-point>> [ "" ] unless* ] } { mount-point [ mount-point>> "" or ] }
{ type [ type>> [ "" ] unless* ] } { type [ type>> "" or ] }
{ available-space [ available-space>> [ 0 ] unless* ] } { available-space [ available-space>> 0 or ] }
{ free-space [ free-space>> [ 0 ] unless* ] } { free-space [ free-space>> 0 or ] }
{ used-space [ used-space>> [ 0 ] unless* ] } { used-space [ used-space>> 0 or ] }
{ total-space [ total-space>> [ 0 ] unless* ] } { total-space [ total-space>> 0 or ] }
{ percent-used [ { percent-used [
[ used-space>> ] [ total-space>> ] bi [ used-space>> ] [ total-space>> ] bi
[ [ 0 ] unless* ] bi@ dup 0 = [ 0 or ] bi@ dup 0 =
[ 2drop 0 ] [ / percent ] if [ 2drop 0 ] [ / percent ] if
] } ] }
} case ; } case ;
@ -65,8 +115,10 @@ percent-used percent-free ;
[ [ unparse ] map ] bi prefix simple-table. ; [ [ unparse ] map ] bi prefix simple-table. ;
: file-systems. ( -- ) : 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" ] } { [ os unix? ] [ "tools.files.unix" ] }

View File

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

View File

@ -2,24 +2,15 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar.format combinators io.files USING: accessors calendar.format combinators io.files
kernel math.parser sequences splitting system tools.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 IN: tools.files.windows
<PRIVATE <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 ) M: windows (directory.) ( entries -- lines )
[ <listing-tool>
dup file-info { { file-datetime directory-or-size file-name } >>specs
[ modified>> timestamp>ymdhms ] { { directory-entry>> name>> <=> } } >>sort
[ directory-or-size ] list-files ;
} cleave 2 narray swap suffix " " join
] map ;
PRIVATE> PRIVATE>

View File

@ -37,13 +37,14 @@ scroller H{
new-frame new-frame
t >>root? t >>root?
<scroller-model> >>model <scroller-model> >>model
faint-boundary
dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add dup model>> dependencies>>
dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add [ first <x-slider> [ >>x ] [ @bottom grid-add ] bi ]
[ second <y-slider> [ >>y ] [ @right grid-add ] bi ] bi
tuck model>> <viewport> >>viewport tuck model>> <viewport> [ >>viewport ] [ @center grid-add ] bi
dup viewport>> @center grid-add ; inline
faint-boundary ; inline
: <scroller> ( gadget -- scroller ) scroller new-scroller ; : <scroller> ( gadget -- scroller ) scroller new-scroller ;

View File

@ -1,18 +1,23 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: ui.gadgets.viewports
USING: accessors arrays ui.gadgets ui.gadgets.borders USING: accessors arrays ui.gadgets ui.gadgets.borders
kernel math namespaces sequences models math.vectors math.geometry.rect ; kernel math namespaces sequences models math.vectors
math.geometry.rect ;
IN: ui.gadgets.viewports
: viewport-gap { 3 3 } ; inline CONSTANT: viewport-gap { 3 3 }
CONSTANT: scroller-border { 1 1 }
TUPLE: viewport < gadget ; TUPLE: viewport < gadget ;
: find-viewport ( gadget -- viewport ) : find-viewport ( gadget -- viewport )
[ viewport? ] find-parent ; [ viewport? ] find-parent ;
: viewport-padding ( -- padding )
viewport-gap 2 v*n scroller-border v+ ;
: viewport-dim ( viewport -- dim ) : viewport-dim ( viewport -- dim )
gadget-child pref-dim viewport-gap 2 v*n v+ ; gadget-child pref-dim viewport-padding v+ ;
: <viewport> ( content model -- viewport ) : <viewport> ( content model -- viewport )
viewport new-gadget viewport new-gadget
@ -21,11 +26,11 @@ TUPLE: viewport < gadget ;
swap add-gadget ; swap add-gadget ;
M: viewport layout* M: viewport layout*
[ [ gadget-child ] [
[ rect-dim viewport-gap 2 v*n v- ] [ dim>> viewport-padding v- ]
[ gadget-child pref-dim ] [ gadget-child pref-dim ]
bi vmax bi vmax
] [ gadget-child ] bi (>>dim) ; ] bi >>dim drop ;
M: viewport focusable-child* M: viewport focusable-child*
gadget-child ; gadget-child ;
@ -37,13 +42,17 @@ M: viewport pref-dim* viewport-dim ;
M: viewport model-changed M: viewport model-changed
nip nip
dup relayout-1 [ relayout-1 ]
dup scroller-value [
vneg viewport-gap v+ [ gadget-child ]
swap gadget-child (>>loc) ; [
scroller-value vneg
viewport-gap v+
scroller-border v+
] bi
>>loc drop
] bi ;
: visible-dim ( gadget -- dim ) : visible-dim ( gadget -- dim )
dup parent>> viewport? dup parent>> viewport?
[ parent>> rect-dim viewport-gap 2 v*n v- ] [ parent>> rect-dim viewport-gap 2 v*n v- ] [ dim>> ] if ;
[ rect-dim ]
if ;

View File

@ -2,6 +2,10 @@ USING: help.markup help.syntax io.streams.string quotations
strings math regexp regexp.backend ; strings math regexp regexp.backend ;
IN: validators IN: validators
HELP: v-checkbox
{ $values { "str" string } }
{ $description "Converts the string value of a checkbox component (either \"on\" or \"off\") to a boolean value." } ;
HELP: v-captcha HELP: v-captcha
{ $values { "str" string } } { $values { "str" string } }
{ $description "Throws a validation error if the string is non-empty. This is used to create bait fields for spam-bots to fill in." } ; { $description "Throws a validation error if the string is non-empty. This is used to create bait fields for spam-bots to fill in." } ;
@ -99,6 +103,7 @@ $nl
{ $subsection v-one-line } { $subsection v-one-line }
{ $subsection v-one-word } { $subsection v-one-word }
{ $subsection v-captcha } { $subsection v-captcha }
{ $subsection v-checkbox }
"More complex validators:" "More complex validators:"
{ $subsection v-email } { $subsection v-email }
{ $subsection v-url } { $subsection v-url }

View File

@ -10,6 +10,9 @@ namespaces assocs ;
[ "hello" ] [ "hello" v-one-word ] unit-test [ "hello" ] [ "hello" v-one-word ] unit-test
[ "hello world" v-one-word ] must-fail [ "hello world" v-one-word ] must-fail
[ t ] [ "on" v-checkbox ] unit-test
[ f ] [ "off" v-checkbox ] unit-test
[ "foo" v-number ] must-fail [ "foo" v-number ] must-fail
[ 123 ] [ "123" v-number ] unit-test [ 123 ] [ "123" v-number ] unit-test
[ 123 ] [ "123" v-integer ] unit-test [ 123 ] [ "123" v-integer ] unit-test

View File

@ -5,6 +5,9 @@ math.parser math.ranges assocs regexp unicode.categories arrays
hashtables words classes quotations xmode.catalog ; hashtables words classes quotations xmode.catalog ;
IN: validators IN: validators
: v-checkbox ( str -- ? )
"on" = ;
: v-default ( str def -- str/def ) : v-default ( str def -- str/def )
over empty? spin ? ; over empty? spin ? ;

View File

@ -108,7 +108,7 @@ unit-test
] times ] times
. .
] times ] times
] with-null-stream ] with-null-writer
] unit-test ] unit-test
[ t ] [ [ t ] [