From 3db9705a9939422d996fec25b2b109a029f73464 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 13 Jan 2009 15:48:59 -0600
Subject: [PATCH 1/6] making directory listing tool configurable, use bi in
io.directories.search
---
basis/io/directories/search/search.factor | 2 +-
basis/tools/files/files-tests.factor | 4 +-
basis/tools/files/files.factor | 96 +++++++++++++++++------
basis/tools/files/unix/unix.factor | 42 ++++++----
basis/tools/files/windows/windows.factor | 21 +++--
5 files changed, 108 insertions(+), 57 deletions(-)
diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor
index d1fdff34f9..f9a0a14d0c 100755
--- a/basis/io/directories/search/search.factor
+++ b/basis/io/directories/search/search.factor
@@ -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 ;
diff --git a/basis/tools/files/files-tests.factor b/basis/tools/files/files-tests.factor
index 6cbc7d192c..aa4273f35f 100644
--- a/basis/tools/files/files-tests.factor
+++ b/basis/tools/files/files-tests.factor
@@ -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
diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor
index 9066f3a219..47c7d57c09 100755
--- a/basis/tools/files/files.factor
+++ b/basis/tools/files/files.factor
@@ -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 ;
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-timestamp ( 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,53 @@ 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-datetime file-time 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 ] }
+ [ 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 +89,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,10 +111,12 @@ 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" ] }
{ [ os windows? ] [ "tools.files.windows" ] }
-} cond require
+} cond require
\ No newline at end of file
diff --git a/basis/tools/files/unix/unix.factor b/basis/tools/files/unix/unix.factor
index 9757db171a..c6bc7fc2c1 100755
--- a/basis/tools/files/unix/unix.factor
+++ b/basis/tools/files/unix/unix.factor
@@ -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,26 @@ 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-datetime file-name } >>specs
+ { { directory-entry>> name>> <=> } } >>sort
+ [ [ list-files ] with-group-cache ] with-user-cache ;
-PRIVATE>
+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 ] }
+ { file-size [ file-info>> size>> 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 ] }
+ { file-datetime [ file-info>> modified>> listing-timestamp ] }
+ { file-time [ file-info>> modified>> listing-time ] }
+ [ call-next-method ]
+ } case ;
+
+PRIVATE>
\ No newline at end of file
diff --git a/basis/tools/files/windows/windows.factor b/basis/tools/files/windows/windows.factor
index 328bb8dc71..3284ec8d8b 100755
--- a/basis/tools/files/windows/windows.factor
+++ b/basis/tools/files/windows/windows.factor
@@ -7,19 +7,16 @@ 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 file-spec>string ( file-listing spec -- string )
+ {
+ { listing-datetime [ modified>> timestamp>ymdhms ] }
+ [ call-next-method ]
+ } case ;
M: windows (directory.) ( entries -- lines )
- [
- dup file-info {
- [ modified>> timestamp>ymdhms ]
- [ directory-or-size ]
- } cleave 2 narray swap suffix " " join
- ] map ;
+ <listing-tool>
+ { file-size file-datetime file-name } >>specs
+ { { directory-entry>> name>> <=> } } >>sort
+ list-files ;
PRIVATE>
From cefd85013cd32713f6db23a2fda5ecf53e6d1dc8 Mon Sep 17 00:00:00 2001
From: "U-FROGGER\\erg" <erg@frogger.(none)>
Date: Tue, 13 Jan 2009 18:44:47 -0600
Subject: [PATCH 2/6] fix file listing on windows, refactor tools.files
cross-platform code
---
basis/tools/files/files.factor | 12 ++++++++----
basis/tools/files/unix/unix.factor | 7 ++-----
basis/tools/files/windows/windows.factor | 10 ++--------
3 files changed, 12 insertions(+), 17 deletions(-)
diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor
index 47c7d57c09..936c682322 100755
--- a/basis/tools/files/files.factor
+++ b/basis/tools/files/files.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays calendar combinators fry io io.directories
io.files.info kernel math math.parser prettyprint sequences system
-vocabs.loader sorting.slots ;
+vocabs.loader sorting.slots calendar.format ;
IN: tools.files
<PRIVATE
@@ -18,7 +18,7 @@ IN: tools.files
[ hour>> ] [ minute>> ] bi
[ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ;
-: listing-timestamp ( timestamp -- string )
+: listing-date ( timestamp -- string )
[ month>> month-abbreviation ]
[ day>> number>string 2 CHAR: \s pad-left ]
[
@@ -36,7 +36,7 @@ IN: tools.files
PRIVATE>
SYMBOLS: file-name file-name/type permissions file-type nlinks file-size
-file-datetime file-time uid gid user group link-target unix-datetime
+file-date file-time file-datetime uid gid user group link-target unix-datetime
directory-or-size ;
TUPLE: listing-tool path specs sort ;
@@ -61,6 +61,10 @@ 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 ;
@@ -119,4 +123,4 @@ percent-used percent-free ;
{
{ [ os unix? ] [ "tools.files.unix" ] }
{ [ os windows? ] [ "tools.files.windows" ] }
-} cond require
\ No newline at end of file
+} cond require
diff --git a/basis/tools/files/unix/unix.factor b/basis/tools/files/unix/unix.factor
index c6bc7fc2c1..e63ab09076 100755
--- a/basis/tools/files/unix/unix.factor
+++ b/basis/tools/files/unix/unix.factor
@@ -47,7 +47,7 @@ IN: tools.files.unix
M: unix (directory.) ( path -- lines )
<listing-tool>
- { permissions nlinks user group file-size file-datetime file-name } >>specs
+ { permissions nlinks user group file-size file-date file-name } >>specs
{ { directory-entry>> name>> <=> } } >>sort
[ [ list-files ] with-group-cache ] with-user-cache ;
@@ -58,14 +58,11 @@ M: unix file-spec>string ( file-listing spec -- string )
] }
{ permissions [ file-info>> permissions-string ] }
{ nlinks [ file-info>> nlink>> number>string ] }
- { file-size [ file-info>> size>> 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 ] }
- { file-datetime [ file-info>> modified>> listing-timestamp ] }
- { file-time [ file-info>> modified>> listing-time ] }
[ call-next-method ]
} case ;
-PRIVATE>
\ No newline at end of file
+PRIVATE>
diff --git a/basis/tools/files/windows/windows.factor b/basis/tools/files/windows/windows.factor
index 3284ec8d8b..f321c2fc7f 100755
--- a/basis/tools/files/windows/windows.factor
+++ b/basis/tools/files/windows/windows.factor
@@ -2,20 +2,14 @@
! 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
-M: windows file-spec>string ( file-listing spec -- string )
- {
- { listing-datetime [ modified>> timestamp>ymdhms ] }
- [ call-next-method ]
- } case ;
-
M: windows (directory.) ( entries -- lines )
<listing-tool>
- { file-size file-datetime file-name } >>specs
+ { file-datetime directory-or-size file-name } >>specs
{ { directory-entry>> name>> <=> } } >>sort
list-files ;
From 3b679cf2beba0436a366ef92c34e1aaba955689b Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Tue, 13 Jan 2009 18:50:16 -0600
Subject: [PATCH 3/6] Base64 works with streams, ignores newlines in inputs and
can output newlines when appropriate
---
basis/base64/base64-tests.factor | 9 +++-
basis/base64/base64.factor | 88 ++++++++++++++++++++++----------
2 files changed, 69 insertions(+), 28 deletions(-)
diff --git a/basis/base64/base64-tests.factor b/basis/base64/base64-tests.factor
index 9958e7943f..dcc4aa5240 100644
--- a/basis/base64/base64-tests.factor
+++ b/basis/base64/base64-tests.factor
@@ -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
diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor
index e3033a2bde..ce35419cbf 100644
--- a/basis/base64/base64.factor
+++ b/basis/base64/base64.factor
@@ -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 ;
\ No newline at end of file
From c47f8feaab6b2753271117a3ba1a2a573423d7ac Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 13 Jan 2009 19:09:47 -0600
Subject: [PATCH 4/6] Clean up scroller code, and fix a cosmetic issue
---
basis/ui/gadgets/scrollers/scrollers.factor | 11 +++---
basis/ui/gadgets/viewports/viewports.factor | 39 +++++++++++++--------
2 files changed, 30 insertions(+), 20 deletions(-)
diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor
index 37f6e83e0c..93f6b8bb40 100644
--- a/basis/ui/gadgets/scrollers/scrollers.factor
+++ b/basis/ui/gadgets/scrollers/scrollers.factor
@@ -37,13 +37,14 @@ scroller H{
new-frame
t >>root?
<scroller-model> >>model
- faint-boundary
- dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add
- dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
+ dup model>> dependencies>>
+ [ first <x-slider> [ >>x ] [ @bottom grid-add ] bi ]
+ [ second <y-slider> [ >>y ] [ @right grid-add ] bi ] bi
- tuck model>> <viewport> >>viewport
- dup viewport>> @center grid-add ; inline
+ tuck model>> <viewport> [ >>viewport ] [ @center grid-add ] bi
+
+ faint-boundary ; inline
: <scroller> ( gadget -- scroller ) scroller new-scroller ;
diff --git a/basis/ui/gadgets/viewports/viewports.factor b/basis/ui/gadgets/viewports/viewports.factor
index f01ef3bf42..73782a1e3d 100644
--- a/basis/ui/gadgets/viewports/viewports.factor
+++ b/basis/ui/gadgets/viewports/viewports.factor
@@ -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.
-IN: ui.gadgets.viewports
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 ;
: find-viewport ( gadget -- viewport )
[ viewport? ] find-parent ;
+: viewport-padding ( -- padding )
+ viewport-gap 2 v*n scroller-border v+ ;
+
: 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 new-gadget
@@ -21,11 +26,11 @@ TUPLE: viewport < gadget ;
swap add-gadget ;
M: viewport layout*
- [
- [ rect-dim viewport-gap 2 v*n v- ]
+ [ gadget-child ] [
+ [ dim>> viewport-padding v- ]
[ gadget-child pref-dim ]
bi vmax
- ] [ gadget-child ] bi (>>dim) ;
+ ] bi >>dim drop ;
M: viewport focusable-child*
gadget-child ;
@@ -37,13 +42,17 @@ M: viewport pref-dim* viewport-dim ;
M: viewport model-changed
nip
- dup relayout-1
- dup scroller-value
- vneg viewport-gap v+
- swap gadget-child (>>loc) ;
+ [ relayout-1 ]
+ [
+ [ gadget-child ]
+ [
+ scroller-value vneg
+ viewport-gap v+
+ scroller-border v+
+ ] bi
+ >>loc drop
+ ] bi ;
: visible-dim ( gadget -- dim )
dup parent>> viewport?
- [ parent>> rect-dim viewport-gap 2 v*n v- ]
- [ rect-dim ]
- if ;
+ [ parent>> rect-dim viewport-gap 2 v*n v- ] [ dim>> ] if ;
From 85c6efa7185fc247cdf4eb743c37be7c4f1c258e Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Tue, 13 Jan 2009 19:13:01 -0600
Subject: [PATCH 5/6] SMTP supports Unicode subjects and contents
---
basis/smtp/smtp-tests.factor | 5 ++++-
basis/smtp/smtp.factor | 23 ++++++++++++++++++-----
2 files changed, 22 insertions(+), 6 deletions(-)
diff --git a/basis/smtp/smtp-tests.factor b/basis/smtp/smtp-tests.factor
index e3638bd969..8a9107b905 100644
--- a/basis/smtp/smtp-tests.factor
+++ b/basis/smtp/smtp-tests.factor
@@ -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>" }
}
diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor
index c17db13b01..2ffc2e6db3 100644
--- a/basis/smtp/smtp.factor
+++ b/basis/smtp/smtp.factor
@@ -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 -- )
[
From 1f29e128c1a9dd3efb55ef4541e3f48fe9e62420 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 13 Jan 2009 19:25:44 -0600
Subject: [PATCH 6/6] io.styles refactoring introduced a load error in
io.streams.null; fix that, add docs, and remove unused with-null-stream
---
basis/io/streams/null/null-docs.factor | 28 +++++++++++++++++++
basis/io/streams/null/null-tests.factor | 0
basis/io/streams/null/null.factor | 19 ++++---------
basis/io/styles/styles-tests.factor | 8 ++++++
.../stack-checker/stack-checker-tests.factor | 5 ----
core/strings/strings-tests.factor | 2 +-
6 files changed, 43 insertions(+), 19 deletions(-)
create mode 100644 basis/io/streams/null/null-docs.factor
create mode 100644 basis/io/streams/null/null-tests.factor
create mode 100644 basis/io/styles/styles-tests.factor
diff --git a/basis/io/streams/null/null-docs.factor b/basis/io/streams/null/null-docs.factor
new file mode 100644
index 0000000000..19bf8251c2
--- /dev/null
+++ b/basis/io/streams/null/null-docs.factor
@@ -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"
\ No newline at end of file
diff --git a/basis/io/streams/null/null-tests.factor b/basis/io/streams/null/null-tests.factor
new file mode 100644
index 0000000000..e69de29bb2
diff --git a/basis/io/streams/null/null.factor b/basis/io/streams/null/null.factor
index 191c8dce91..a2224ef306 100644
--- a/basis/io/streams/null/null.factor
+++ b/basis/io/streams/null/null.factor
@@ -1,22 +1,19 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: kernel io io.timeouts io.styles destructors ;
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 set-timeout 2drop ;
-TUPLE: null-reader < null-stream ;
-
M: null-reader stream-readln drop f ;
M: null-reader stream-read1 drop f ;
M: null-reader stream-read-until 2drop f f ;
M: null-reader stream-read 2drop f ;
-TUPLE: null-writer < null-stream ;
-
M: null-writer stream-write1 2drop ;
M: null-writer stream-write 2drop ;
M: null-writer stream-nl drop ;
@@ -28,11 +25,7 @@ M: null-writer make-cell-stream nip ;
M: null-writer stream-write-table 3drop ;
: with-null-reader ( quot -- )
- T{ null-reader } swap with-input-stream* ; inline
+ null-reader swap with-input-stream* ; inline
: with-null-writer ( quot -- )
- T{ 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
+ null-writer swap with-output-stream* ; inline
\ No newline at end of file
diff --git a/basis/io/styles/styles-tests.factor b/basis/io/styles/styles-tests.factor
new file mode 100644
index 0000000000..86c3681c2a
--- /dev/null
+++ b/basis/io/styles/styles-tests.factor
@@ -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
\ No newline at end of file
diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor
index 7b2a6d2d83..4d7295042c 100644
--- a/basis/stack-checker/stack-checker-tests.factor
+++ b/basis/stack-checker/stack-checker-tests.factor
@@ -416,12 +416,7 @@ DEFER: bar
\ stream-write must-infer
\ stream-write1 must-infer
\ stream-nl must-infer
-\ stream-format must-infer
-\ stream-write-table must-infer
\ stream-flush must-infer
-\ make-span-stream must-infer
-\ make-block-stream must-infer
-\ make-cell-stream must-infer
! Test stream utilities
\ lines must-infer
diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor
index 078785178b..810e9051d8 100644
--- a/core/strings/strings-tests.factor
+++ b/core/strings/strings-tests.factor
@@ -108,7 +108,7 @@ unit-test
] times
.
] times
- ] with-null-stream
+ ] with-null-writer
] unit-test
[ t ] [