From b5cb425708166bce4c86479c57dee27290131812 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 22:10:32 -0600 Subject: [PATCH 01/16] new bitstream api works, refactor time --- basis/bitstreams/bitstreams-tests.factor | 24 +++++++--------- basis/bitstreams/bitstreams.factor | 35 +++++++++++++++--------- 2 files changed, 32 insertions(+), 27 deletions(-) diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor index 2aadf7b02d..d55910b131 100644 --- a/basis/bitstreams/bitstreams-tests.factor +++ b/basis/bitstreams/bitstreams-tests.factor @@ -1,31 +1,27 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors bitstreams io io.streams.string kernel tools.test -grouping compression.lzw multiline byte-arrays ; +grouping compression.lzw multiline byte-arrays io.encodings.binary +io.streams.byte-array ; IN: bitstreams.tests -[ 1 ] +[ 1 t ] [ B{ 254 } read-bit ] unit-test -[ 254 ] +[ 254 8 t ] [ B{ 254 } 8 swap read-bits ] unit-test -[ 4095 ] +[ 4095 12 t ] [ B{ 255 255 } 12 swap read-bits ] unit-test [ B{ 254 } ] [ 254 8 rot - [ write-bits ] keep output>> >byte-array + [ write-bits ] keep stream>> >byte-array ] unit-test +[ 255 8 t ] +[ B{ 255 } binary 8 swap read-bits ] unit-test -/* -[ - -] [ - B{ 7 7 7 8 8 7 7 9 7 } - [ byte-array>bignum >bin 72 CHAR: 0 pad-head 9 group [ bin> ] map ] - [ lzw-compress ] bi -] unit-test -*/ +[ 255 8 f ] +[ B{ 255 } binary 9 swap read-bits ] unit-test diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index ae980795bc..7113b650fd 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -4,7 +4,7 @@ USING: accessors byte-arrays destructors fry io kernel locals math sequences ; IN: bitstreams -TUPLE: bitstream stream current-bits #bits disposed ; +TUPLE: bitstream stream end-of-stream? current-bits #bits disposed ; TUPLE: bitstream-reader < bitstream ; : reset-bitstream ( stream -- stream ) @@ -22,8 +22,12 @@ M: bitstream-reader dispose ( stream -- ) bitstream-reader new-bitstream ; inline : read-next-byte ( bitstream -- bitstream ) - dup stream>> stream-read1 - [ >>current-bits ] [ 8 0 ? >>#bits ] bi ; inline + dup stream>> stream-read1 [ + >>current-bits 8 >>#bits + ] [ + 0 >>#bits + t >>end-of-stream? + ] if* ; : maybe-read-next-byte ( bitstream -- bitstream ) dup #bits>> 0 = [ read-next-byte ] when ; inline @@ -31,17 +35,19 @@ M: bitstream-reader dispose ( stream -- ) : shift-one-bit ( bitstream -- n ) [ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline -: next-bit ( bitstream -- n ) - maybe-read-next-byte [ - shift-one-bit +: next-bit ( bitstream -- n/f ? ) + maybe-read-next-byte + dup end-of-stream?>> [ + drop f ] [ - [ 1- ] change-#bits maybe-read-next-byte drop - ] bi ; inline + [ shift-one-bit ] + [ [ 1- ] change-#bits maybe-read-next-byte drop ] bi + ] if dup >boolean ; -: read-bit ( bitstream -- n ) +: read-bit ( bitstream -- n ? ) dup #bits>> 1 = [ [ current-bits>> 1 bitand ] - [ read-next-byte drop ] bi + [ read-next-byte drop ] bi t ] [ next-bit ] if ; inline @@ -49,9 +55,12 @@ M: bitstream-reader dispose ( stream -- ) : bits>integer ( seq -- n ) 0 [ [ 1 shift ] dip bitor ] reduce ; inline -: read-bits ( width bitstream -- n ) - '[ _ read-bit ] replicate bits>integer ; inline - +: read-bits ( width bitstream -- n width ? ) + [ + '[ _ read-bit drop ] replicate + [ f = ] trim-tail + [ bits>integer ] [ length ] bi + ] 2keep drop over = ; TUPLE: bitstream-writer < bitstream ; From 12ee26566ea3abe8b039d6c4420c08a2c54e9ed6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 22:11:11 -0600 Subject: [PATCH 02/16] working on lzw compression --- basis/compression/lzw/lzw.factor | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor index fe24e97007..67248474d3 100644 --- a/basis/compression/lzw/lzw.factor +++ b/basis/compression/lzw/lzw.factor @@ -110,9 +110,23 @@ ERROR: not-in-table ; : lzw-compress-chars ( lzw -- ) { - [ [ clear-code lzw-compress-char ] [ reset-lzw-compress drop ] bi ] + ! [ [ clear-code lzw-compress-char ] [ drop ] bi ] ! reset-lzw-compress drop ] bi ] + [ + [ clear-code ] dip + [ lzw-bit-width-compress ] + [ output>> write-bits ] bi + ] [ (lzw-compress-chars) ] - [ end-of-information lzw-compress-char ] + [ + [ k>> ] + [ lzw-bit-width-compress ] + [ output>> write-bits ] tri + ] + [ + [ end-of-information ] dip + [ lzw-bit-width-compress ] + [ output>> write-bits ] bi + ] [ ] } cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ; @@ -138,7 +152,7 @@ ERROR: not-in-table ; : add-to-table ( seq lzw -- ) table>> push ; : lzw-read ( lzw -- lzw n ) - [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits ; + [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ; DEFER: lzw-uncompress-char : handle-clear-code ( lzw -- ) From 237f16b4db03d50d03558fa2ad9ec9c9b9ff8169 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 22:13:34 -0600 Subject: [PATCH 03/16] move zlib to zlib.compression and update --- basis/compression/zlib/authors.txt | 1 + basis/compression/zlib/ffi/authors.txt | 1 + basis/compression/zlib/ffi/ffi.factor | 30 +++++++++++++++ basis/compression/zlib/zlib-tests.factor | 9 +++++ basis/compression/zlib/zlib.factor | 48 ++++++++++++++++++++++++ 5 files changed, 89 insertions(+) create mode 100755 basis/compression/zlib/authors.txt create mode 100755 basis/compression/zlib/ffi/authors.txt create mode 100755 basis/compression/zlib/ffi/ffi.factor create mode 100755 basis/compression/zlib/zlib-tests.factor create mode 100755 basis/compression/zlib/zlib.factor diff --git a/basis/compression/zlib/authors.txt b/basis/compression/zlib/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/compression/zlib/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/compression/zlib/ffi/authors.txt b/basis/compression/zlib/ffi/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/compression/zlib/ffi/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/compression/zlib/ffi/ffi.factor b/basis/compression/zlib/ffi/ffi.factor new file mode 100755 index 0000000000..d369c22e4c --- /dev/null +++ b/basis/compression/zlib/ffi/ffi.factor @@ -0,0 +1,30 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.syntax combinators system ; +IN: compression.zlib.ffi + +<< "zlib" { + { [ os winnt? ] [ "zlib1.dll" ] } + { [ os macosx? ] [ "libz.dylib" ] } + { [ os unix? ] [ "libz.so" ] } +} cond "cdecl" add-library >> + +LIBRARY: zlib + +CONSTANT: Z_OK 0 +CONSTANT: Z_STREAM_END 1 +CONSTANT: Z_NEED_DICT 2 +CONSTANT: Z_ERRNO -1 +CONSTANT: Z_STREAM_ERROR -2 +CONSTANT: Z_DATA_ERROR -3 +CONSTANT: Z_MEM_ERROR -4 +CONSTANT: Z_BUF_ERROR -5 +CONSTANT: Z_VERSION_ERROR -6 + +TYPEDEF: void Bytef +TYPEDEF: ulong uLongf +TYPEDEF: ulong uLong + +FUNCTION: int compress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ; +FUNCTION: int compress2 ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen, int level ) ; +FUNCTION: int uncompress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ; diff --git a/basis/compression/zlib/zlib-tests.factor b/basis/compression/zlib/zlib-tests.factor new file mode 100755 index 0000000000..1baeba73d9 --- /dev/null +++ b/basis/compression/zlib/zlib-tests.factor @@ -0,0 +1,9 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel tools.test compression.zlib classes ; +IN: compression.zlib.tests + +: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ; + +[ t ] [ compress-me [ compress uncompress ] keep = ] unit-test +[ t ] [ compress-me compress compressed instance? ] unit-test diff --git a/basis/compression/zlib/zlib.factor b/basis/compression/zlib/zlib.factor new file mode 100755 index 0000000000..7818173498 --- /dev/null +++ b/basis/compression/zlib/zlib.factor @@ -0,0 +1,48 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien alien.c-types alien.syntax byte-arrays combinators +kernel math math.functions sequences system accessors +libc ; +QUALIFIED: compression.zlib.ffi +IN: compression.zlib + +TUPLE: compressed data length ; + +: ( data length -- compressed ) + compressed new + swap >>length + swap >>data ; + +ERROR: zlib-failed n string ; + +: zlib-error-message ( n -- * ) + dup compression.zlib.ffi:Z_ERRNO = [ + drop errno "native libc error" + ] [ + dup { + "no error" "libc_error" + "stream error" "data error" + "memory error" "buffer error" "zlib version error" + } ?nth + ] if zlib-failed ; + +: zlib-error ( n -- ) + dup compression.zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ; + +: compressed-size ( byte-array -- n ) + length 1001/1000 * ceiling 12 + ; + +: compress ( byte-array -- compressed ) + [ + [ compressed-size dup length ] keep [ + dup length compression.zlib.ffi:compress zlib-error + ] 3keep drop *ulong head + ] keep length ; + +: uncompress ( compressed -- byte-array ) + [ + length>> [ ] keep 2dup + ] [ + data>> dup length + compression.zlib.ffi:uncompress zlib-error + ] bi *ulong head ; From 2bb9448ebcbb98acfdbaac7ab6c1536ea907d631 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 12 Feb 2009 22:39:26 -0600 Subject: [PATCH 04/16] add set-basic-auth to http, and make http-request stuff the response body in the error message on failure --- basis/http/client/client-docs.factor | 3 +-- basis/http/client/client.factor | 7 +++++-- basis/http/http-docs.factor | 6 ++++++ basis/http/http-tests.factor | 5 +++++ basis/http/http.factor | 7 ++++++- 5 files changed, 23 insertions(+), 5 deletions(-) diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index 9a8aa48738..0d7f7851e2 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -56,8 +56,7 @@ HELP: http-request HELP: with-http-request { $values { "request" request } { "quot" { $quotation "( chunk -- )" } } { "response" response } } -{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read." } -{ $errors "Throws an error if the HTTP request fails." } ; +{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read. Does not throw an error if the HTTP request fails; to do so, call " { $link check-response } " on the " { $snippet "response" } "." } ; ARTICLE: "http.client.get" "GET requests with the HTTP client" "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:" diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index cc1c67c31e..4099e3d84c 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -141,12 +141,15 @@ ERROR: download-failed response ; : check-response ( response -- response ) dup code>> success? [ download-failed ] unless ; +: check-response-with-body ( response body -- response body ) + [ >>body check-response ] keep ; + : with-http-request ( request quot -- response ) - [ (with-http-request) check-response ] with-destructors ; inline + [ (with-http-request) ] with-destructors ; inline : http-request ( request -- response data ) [ [ % ] with-http-request ] B{ } make - over content-charset>> decode ; + over content-charset>> decode check-response-with-body ; : ( url -- request ) "GET" ; diff --git a/basis/http/http-docs.factor b/basis/http/http-docs.factor index fc3f65fa56..210066176f 100644 --- a/basis/http/http-docs.factor +++ b/basis/http/http-docs.factor @@ -113,6 +113,12 @@ HELP: set-header { $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." } { $side-effects "request/response" } ; +HELP: set-basic-auth +{ $values { "request" request } { "username" string } { "password" string } } +{ $description "Sets the " { $snippet "Authorization" } " header of " { $snippet "request" } " to perform HTTP Basic authentication with the given " { $snippet "username" } " and " { $snippet "password" } "." } +{ $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." } +{ $side-effects "request" } ; + ARTICLE: "http.cookies" "HTTP cookies" "Every " { $link request } " and " { $link response } " instance can contain cookies." $nl diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 49acdb639c..4f685945aa 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -359,3 +359,8 @@ SYMBOL: a ! Test cloning [ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test [ f ] [ <404> dup clone "b" "a" put-cookie drop "a" get-cookie ] unit-test + +! Test basic auth +[ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test + + diff --git a/basis/http/http.factor b/basis/http/http.factor index 2b5414b299..d4acd282f8 100755 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -7,7 +7,8 @@ calendar.format present urls fry io io.encodings io.encodings.iana io.encodings.binary io.encodings.8-bit io.crlf unicode.case unicode.categories -http.parsers ; +http.parsers +base64 ; IN: http : (read-header) ( -- alist ) @@ -142,6 +143,9 @@ cookies ; : set-header ( request/response value key -- request/response ) pick header>> set-at ; +: set-basic-auth ( request username password -- request ) + ":" glue >base64 "Basic " prepend "Authorization" set-header ; + : ( -- request ) request new "1.1" >>version @@ -156,6 +160,7 @@ cookies ; : header ( request/response key -- value ) swap header>> at ; + TUPLE: response version code From 7f8e890f1f05458f8357e218158cea01d7f4a075 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 12 Feb 2009 22:39:48 -0600 Subject: [PATCH 05/16] twitta --- extra/twitter/twitter.factor | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 extra/twitter/twitter.factor diff --git a/extra/twitter/twitter.factor b/extra/twitter/twitter.factor new file mode 100644 index 0000000000..eceb40c1c2 --- /dev/null +++ b/extra/twitter/twitter.factor @@ -0,0 +1,22 @@ +USING: accessors assocs hashtables http http.client json.reader +kernel namespaces urls.encoding ; +IN: twitter + +SYMBOLS: twitter-username twitter-password ; + +: set-twitter-credentials ( username password -- ) + [ twitter-username set ] [ twitter-password set ] bi* ; + +: set-request-twitter-auth ( request -- request ) + twitter-username twitter-password [ get ] bi@ set-basic-auth ; + +: update-post-data ( update -- assoc ) + "status" associate ; + +: tweet* ( string -- result ) + update-post-data "https://twitter.com/statuses/update.json" + set-request-twitter-auth + http-request nip json> ; + +: tweet ( string -- ) tweet* drop ; + From 92f3ae39ad8aaa458253500752f1fb46dfe2d56a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 12 Feb 2009 22:56:46 -0600 Subject: [PATCH 06/16] gotta load urls.secure to use https --- extra/twitter/twitter.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/twitter/twitter.factor b/extra/twitter/twitter.factor index eceb40c1c2..707bcceda6 100644 --- a/extra/twitter/twitter.factor +++ b/extra/twitter/twitter.factor @@ -1,5 +1,5 @@ USING: accessors assocs hashtables http http.client json.reader -kernel namespaces urls.encoding ; +kernel namespaces urls.secure urls.encoding ; IN: twitter SYMBOLS: twitter-username twitter-password ; From f3e8bc12472d409c5c1d27d5c817bd8a664c5ba7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 09:55:38 -0600 Subject: [PATCH 07/16] make hexdump work for byte-vectors --- basis/tools/hexdump/hexdump.factor | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/basis/tools/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor index b646760889..335e32e0a3 100644 --- a/basis/tools/hexdump/hexdump.factor +++ b/basis/tools/hexdump/hexdump.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays io io.streams.string kernel math math.parser -namespaces sequences splitting grouping strings ascii byte-arrays ; +namespaces sequences splitting grouping strings ascii +byte-arrays byte-vectors ; IN: tools.hexdump hex-digits write ] [ >ascii write ] bi nl ; +: hexdump-bytes + [ length write-header ] + [ 16 [ write-hex-line ] each-index ] bi ; + PRIVATE> GENERIC: hexdump. ( byte-array -- ) -M: byte-array hexdump. - [ length write-header ] - [ 16 [ write-hex-line ] each-index ] bi ; +M: byte-array hexdump. hexdump-bytes ; + +M: byte-vector hexdump. hexdump-bytes ; : hexdump ( byte-array -- str ) [ hexdump. ] with-string-writer ; From cd82735dea927dfb4dcc18e7d3416ec0ea57c210 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 09:55:56 -0600 Subject: [PATCH 08/16] remove zlib --- basis/zlib/authors.txt | 1 - basis/zlib/ffi/authors.txt | 1 - basis/zlib/ffi/ffi.factor | 30 ---------------------- basis/zlib/zlib-tests.factor | 9 ------- basis/zlib/zlib.factor | 48 ------------------------------------ 5 files changed, 89 deletions(-) delete mode 100755 basis/zlib/authors.txt delete mode 100755 basis/zlib/ffi/authors.txt delete mode 100755 basis/zlib/ffi/ffi.factor delete mode 100755 basis/zlib/zlib-tests.factor delete mode 100755 basis/zlib/zlib.factor diff --git a/basis/zlib/authors.txt b/basis/zlib/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/zlib/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/zlib/ffi/authors.txt b/basis/zlib/ffi/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/zlib/ffi/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/zlib/ffi/ffi.factor b/basis/zlib/ffi/ffi.factor deleted file mode 100755 index bda2809f56..0000000000 --- a/basis/zlib/ffi/ffi.factor +++ /dev/null @@ -1,30 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax combinators system ; -IN: zlib.ffi - -<< "zlib" { - { [ os winnt? ] [ "zlib1.dll" ] } - { [ os macosx? ] [ "libz.dylib" ] } - { [ os unix? ] [ "libz.so" ] } -} cond "cdecl" add-library >> - -LIBRARY: zlib - -CONSTANT: Z_OK 0 -CONSTANT: Z_STREAM_END 1 -CONSTANT: Z_NEED_DICT 2 -CONSTANT: Z_ERRNO -1 -CONSTANT: Z_STREAM_ERROR -2 -CONSTANT: Z_DATA_ERROR -3 -CONSTANT: Z_MEM_ERROR -4 -CONSTANT: Z_BUF_ERROR -5 -CONSTANT: Z_VERSION_ERROR -6 - -TYPEDEF: void Bytef -TYPEDEF: ulong uLongf -TYPEDEF: ulong uLong - -FUNCTION: int compress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ; -FUNCTION: int compress2 ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen, int level ) ; -FUNCTION: int uncompress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ; diff --git a/basis/zlib/zlib-tests.factor b/basis/zlib/zlib-tests.factor deleted file mode 100755 index 0ac77277dc..0000000000 --- a/basis/zlib/zlib-tests.factor +++ /dev/null @@ -1,9 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel tools.test zlib classes ; -IN: zlib.tests - -: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ; - -[ t ] [ compress-me [ compress uncompress ] keep = ] unit-test -[ t ] [ compress-me compress compressed instance? ] unit-test diff --git a/basis/zlib/zlib.factor b/basis/zlib/zlib.factor deleted file mode 100755 index b40d9c2a98..0000000000 --- a/basis/zlib/zlib.factor +++ /dev/null @@ -1,48 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.syntax byte-arrays combinators -kernel math math.functions sequences system accessors -libc ; -QUALIFIED: zlib.ffi -IN: zlib - -TUPLE: compressed data length ; - -: ( data length -- compressed ) - compressed new - swap >>length - swap >>data ; - -ERROR: zlib-failed n string ; - -: zlib-error-message ( n -- * ) - dup zlib.ffi:Z_ERRNO = [ - drop errno "native libc error" - ] [ - dup { - "no error" "libc_error" - "stream error" "data error" - "memory error" "buffer error" "zlib version error" - } ?nth - ] if zlib-failed ; - -: zlib-error ( n -- ) - dup zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ; - -: compressed-size ( byte-array -- n ) - length 1001/1000 * ceiling 12 + ; - -: compress ( byte-array -- compressed ) - [ - [ compressed-size dup length ] keep [ - dup length zlib.ffi:compress zlib-error - ] 3keep drop *ulong head - ] keep length ; - -: uncompress ( compressed -- byte-array ) - [ - length>> [ ] keep 2dup - ] [ - data>> dup length - zlib.ffi:uncompress zlib-error - ] bi *ulong head ; From 753cfcfd05ccb33af75cea89424b64f82fc54253 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 09:56:22 -0600 Subject: [PATCH 09/16] support .tif, start 96 bpp --- basis/images/images.factor | 14 ++++++++++++-- basis/images/loader/loader.factor | 1 + basis/images/tiff/tiff.factor | 7 ++++--- 3 files changed, 17 insertions(+), 5 deletions(-) diff --git a/basis/images/images.factor b/basis/images/images.factor index 46c0936644..e8f5530706 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors grouping sequences combinators ; +USING: kernel accessors grouping sequences combinators +math specialized-arrays.direct.uint byte-arrays ; IN: images -SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; +SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR +32R32G32B ; TUPLE: image dim component-order byte-order bitmap ; @@ -15,6 +17,14 @@ GENERIC: load-image* ( path tuple -- image ) dup component-order>> { { RGBA [ ] } + { 32R32G32B [ + [ + ! >byte-array + ! dup length 4 /i [ 32 2^ /i ] map + ! >byte-array + ! 4 le> [ 32 2^ /i ] map concat + ] change-bitmap + ] } { BGRA [ [ 4 dup [ [ 0 3 ] dip reverse-here ] each diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index 9e3f901269..6f2ae47c61 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -10,6 +10,7 @@ ERROR: unknown-image-extension extension ; : image-class ( path -- class ) file-extension >lower { { "bmp" [ bitmap-image ] } + { "tif" [ tiff-image ] } { "tiff" [ tiff-image ] } [ unknown-image-extension ] } case ; diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 0b749d0ade..baac3a2dfb 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -276,9 +276,10 @@ ERROR: unhandled-compression compression ; ERROR: unknown-component-order ifd ; : ifd-component-order ( ifd -- byte-order ) - bits-per-sample find-tag sum { - { 32 [ RGBA ] } - { 24 [ RGB ] } + bits-per-sample find-tag { + { { 32 32 32 } [ 32R32G32B ] } + { { 8 8 8 8 } [ RGBA ] } + { { 8 8 8 } [ RGB ] } [ unknown-component-order ] } case ; From 3fb733b53cb07188827246afbe23c78177c2a1cf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 10:16:58 -0600 Subject: [PATCH 10/16] add 48bpp mode to tiff --- basis/images/images.factor | 10 +--------- basis/images/tiff/tiff.factor | 1 + 2 files changed, 2 insertions(+), 9 deletions(-) diff --git a/basis/images/images.factor b/basis/images/images.factor index e8f5530706..41d96a673b 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -5,7 +5,7 @@ math specialized-arrays.direct.uint byte-arrays ; IN: images SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR -32R32G32B ; +16R16G16B 32R32G32B ; TUPLE: image dim component-order byte-order bitmap ; @@ -17,14 +17,6 @@ GENERIC: load-image* ( path tuple -- image ) dup component-order>> { { RGBA [ ] } - { 32R32G32B [ - [ - ! >byte-array - ! dup length 4 /i [ 32 2^ /i ] map - ! >byte-array - ! 4 le> [ 32 2^ /i ] map concat - ] change-bitmap - ] } { BGRA [ [ 4 dup [ [ 0 3 ] dip reverse-here ] each diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index baac3a2dfb..28eee7d98a 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -278,6 +278,7 @@ ERROR: unknown-component-order ifd ; : ifd-component-order ( ifd -- byte-order ) bits-per-sample find-tag { { { 32 32 32 } [ 32R32G32B ] } + { { 16 16 16 } [ 16R16G16B ] } { { 8 8 8 8 } [ RGBA ] } { { 8 8 8 } [ RGB ] } [ unknown-component-order ] From cdc5aa60b0d304c10af3fb2f41c05de7464ef4eb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 10:48:11 -0600 Subject: [PATCH 11/16] add a stack effect to tuple article --- core/classes/tuple/tuple-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 561d0962ff..0469f3564a 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -241,7 +241,7 @@ ARTICLE: "tuple-examples" "Tuple examples" } "An example of using a changer:" { $code - ": positions" + ": positions ( -- seq )" " {" " \"junior programmer\"" " \"senior programmer\"" From fb844f2ac03aa0a03ff8448c7124d7f5bc7ef163 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 13 Feb 2009 11:54:07 -0600 Subject: [PATCH 12/16] twitter timelines --- extra/twitter/twitter.factor | 85 +++++++++++++++++++++++++++++++++--- 1 file changed, 80 insertions(+), 5 deletions(-) diff --git a/extra/twitter/twitter.factor b/extra/twitter/twitter.factor index 707bcceda6..f9806a7c4f 100644 --- a/extra/twitter/twitter.factor +++ b/extra/twitter/twitter.factor @@ -1,9 +1,67 @@ -USING: accessors assocs hashtables http http.client json.reader -kernel namespaces urls.secure urls.encoding ; +USING: accessors assocs combinators hashtables http +http.client json.reader kernel macros namespaces sequences +urls.secure urls.encoding ; IN: twitter SYMBOLS: twitter-username twitter-password ; +TUPLE: twitter-status + created-at + id + text + source + truncated? + in-reply-to-status-id + in-reply-to-user-id + favorited? + user ; +TUPLE: twitter-user + id + name + screen-name + description + location + profile-image-url + url + protected? + followers-count ; + +MACRO: keys-boa ( keys class -- ) + [ [ \ swap \ at [ ] 3sequence ] map \ cleave ] dip \ boa [ ] 4sequence ; + +: ( assoc -- user ) + { + "id" + "name" + "screen_name" + "description" + "location" + "profile_image_url" + "url" + "protected" + "followers_count" + } twitter-user keys-boa ; + +: ( assoc -- tweet ) + clone "user" over [ ] change-at + { + "created_at" + "id" + "text" + "source" + "truncated" + "in_reply_to_status_id" + "in_reply_to_user_id" + "favorited" + "user" + } twitter-status keys-boa ; + +: json>twitter-statuses ( json-array -- tweets ) + json> [ ] map ; + +: json>twitter-status ( json-object -- tweet ) + json> ; + : set-twitter-credentials ( username password -- ) [ twitter-username set ] [ twitter-password set ] bi* ; @@ -13,10 +71,27 @@ SYMBOLS: twitter-username twitter-password ; : update-post-data ( update -- assoc ) "status" associate ; -: tweet* ( string -- result ) +: (tweet) ( string -- json ) update-post-data "https://twitter.com/statuses/update.json" set-request-twitter-auth - http-request nip json> ; + http-request nip ; -: tweet ( string -- ) tweet* drop ; +: tweet* ( string -- tweet ) + (tweet) json>twitter-status ; +: tweet ( string -- ) (tweet) drop ; + +: public-timeline ( -- tweets ) + "https://twitter.com/statuses/public_timeline.json" + set-request-twitter-auth + http-request nip json>twitter-statuses ; + +: friends-timeline ( -- tweets ) + "https://twitter.com/statuses/friends_timeline.json" + set-request-twitter-auth + http-request nip json>twitter-statuses ; + +: user-timeline ( username -- tweets ) + "https://twitter.com/statuses/user_timeline/" ".json" surround + set-request-twitter-auth + http-request nip json>twitter-statuses ; From 435a14f3b654193e16d35c20314189cfde4c7c1c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 11:57:45 -0600 Subject: [PATCH 13/16] add stack effect, oops --- basis/tools/hexdump/hexdump.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor index 335e32e0a3..63b55729fb 100644 --- a/basis/tools/hexdump/hexdump.factor +++ b/basis/tools/hexdump/hexdump.factor @@ -27,7 +27,7 @@ IN: tools.hexdump : write-hex-line ( bytes lineno -- ) write-offset [ >hex-digits write ] [ >ascii write ] bi nl ; -: hexdump-bytes +: hexdump-bytes ( bytes -- ) [ length write-header ] [ 16 [ write-hex-line ] each-index ] bi ; From bd17f149290c3db90493ce1a45363db3461cc70c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 12:12:08 -0600 Subject: [PATCH 14/16] drawing 96bpp images works, add lots of previously unknown ifd fields --- basis/images/images.factor | 23 +++++++++++++++++------ basis/images/tiff/tiff.factor | 23 +++++++++++++++++------ 2 files changed, 34 insertions(+), 12 deletions(-) diff --git a/basis/images/images.factor b/basis/images/images.factor index 41d96a673b..e366dd2700 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -5,7 +5,7 @@ math specialized-arrays.direct.uint byte-arrays ; IN: images SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR -16R16G16B 32R32G32B ; +R16G16B16 R32G32B32 ; TUPLE: image dim component-order byte-order bitmap ; @@ -13,22 +13,32 @@ TUPLE: image dim component-order byte-order bitmap ; GENERIC: load-image* ( path tuple -- image ) +: add-dummy-alpha ( seq -- seq' ) + 3 + [ 255 suffix ] map concat ; + : normalize-component-order ( image -- image ) dup component-order>> { { RGBA [ ] } + { R32G32B32 [ + [ + dup length 4 / + [ bits>float 255.0 * >integer ] map + >byte-array add-dummy-alpha + ] change-bitmap + ] } { BGRA [ [ 4 dup [ [ 0 3 ] dip reverse-here ] each ] change-bitmap ] } - { RGB [ - [ 3 [ 255 suffix ] map concat ] change-bitmap - ] } + { RGB [ [ add-dummy-alpha ] change-bitmap ] } { BGR [ [ - 3 dup [ [ 0 3 ] dip reverse-here ] each - [ 255 suffix ] map concat + 3 + [ [ [ 0 3 ] dip reverse-here ] each ] + [ add-dummy-alpha ] bi ] change-bitmap ] } } case @@ -39,5 +49,6 @@ GENERIC: normalize-scan-line-order ( image -- image ) M: image normalize-scan-line-order ; : normalize-image ( image -- image ) + [ >byte-array ] change-bitmap normalize-component-order normalize-scan-line-order ; diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 28eee7d98a..db5141521d 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -3,7 +3,7 @@ USING: accessors combinators io io.encodings.binary io.files kernel pack endian constructors sequences arrays math.order math.parser prettyprint classes io.binary assocs math math.bitwise byte-arrays -grouping images compression.lzw fry ; +grouping images compression.lzw fry strings ; IN: images.tiff TUPLE: tiff-image < image ; @@ -115,8 +115,9 @@ ERROR: bad-extra-samples n ; SINGLETONS: image-length image-width x-resolution y-resolution rows-per-strip strip-offsets strip-byte-counts bits-per-sample -samples-per-pixel new-subfile-type orientation -unhandled-ifd-entry ; +samples-per-pixel new-subfile-type orientation software +date-time photoshop exif-ifd sub-ifd inter-color-profile +xmp iptc unhandled-ifd-entry ; ERROR: bad-tiff-magic bytes ; : tiff-endianness ( byte-array -- ? ) @@ -185,6 +186,7 @@ ERROR: unknown-ifd-type n ; { 10 [ 8 * ] } { 11 [ 4 * ] } { 12 [ 8 * ] } + { 13 [ 4 * ] } [ unknown-ifd-type ] } case ; @@ -200,6 +202,7 @@ ERROR: bad-small-ifd-type n ; { 8 [ 2 head endian> 16 >signed ] } { 9 [ endian> 32 >signed ] } { 11 [ endian> bits>float ] } + { 13 [ endian> 32 >signed ] } [ bad-small-ifd-type ] } case ; @@ -246,10 +249,18 @@ ERROR: bad-small-ifd-type n ; { 283 [ y-resolution ] } { 284 [ planar-configuration ] } { 296 [ lookup-resolution-unit resolution-unit ] } + { 305 [ >string software ] } + { 306 [ >string date-time ] } { 317 [ lookup-predictor predictor ] } + { 330 [ sub-ifd ] } { 338 [ lookup-extra-samples extra-samples ] } { 339 [ lookup-sample-format sample-format ] } - [ nip unhandled-ifd-entry ] + { 700 [ >string xmp ] } + { 34377 [ photoshop ] } + { 34665 [ exif-ifd ] } + { 33723 [ iptc ] } + { 34675 [ inter-color-profile ] } + [ nip unhandled-ifd-entry swap ] } case ; : process-ifd ( ifd -- ifd ) @@ -277,8 +288,8 @@ ERROR: unknown-component-order ifd ; : ifd-component-order ( ifd -- byte-order ) bits-per-sample find-tag { - { { 32 32 32 } [ 32R32G32B ] } - { { 16 16 16 } [ 16R16G16B ] } + { { 32 32 32 } [ R32G32B32 ] } + { { 16 16 16 } [ R16G16B16 ] } { { 8 8 8 8 } [ RGBA ] } { { 8 8 8 } [ RGB ] } [ unknown-component-order ] From 1424380e5b1490d5df6975359dd24ef2da29134c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Feb 2009 13:04:14 -0600 Subject: [PATCH 15/16] x/y resolution should be a scalar --- basis/images/tiff/tiff.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index db5141521d..674188992a 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -245,8 +245,8 @@ ERROR: bad-small-ifd-type n ; { 277 [ samples-per-pixel ] } { 278 [ rows-per-strip ] } { 279 [ strip-byte-counts ] } - { 282 [ x-resolution ] } - { 283 [ y-resolution ] } + { 282 [ first x-resolution ] } + { 283 [ first y-resolution ] } { 284 [ planar-configuration ] } { 296 [ lookup-resolution-unit resolution-unit ] } { 305 [ >string software ] } From 53f6d394ea3d2e0c3bfe4408cb7c16f82f8002b3 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 13 Feb 2009 13:07:48 -0600 Subject: [PATCH 16/16] let the world know you tweet from factor --- extra/twitter/twitter.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/twitter/twitter.factor b/extra/twitter/twitter.factor index f9806a7c4f..2172d7cf81 100644 --- a/extra/twitter/twitter.factor +++ b/extra/twitter/twitter.factor @@ -3,7 +3,9 @@ http.client json.reader kernel macros namespaces sequences urls.secure urls.encoding ; IN: twitter -SYMBOLS: twitter-username twitter-password ; +SYMBOLS: twitter-username twitter-password twitter-source ; + +twitter-source [ "factor" ] initialize TUPLE: twitter-status created-at @@ -69,7 +71,8 @@ MACRO: keys-boa ( keys class -- ) twitter-username twitter-password [ get ] bi@ set-basic-auth ; : update-post-data ( update -- assoc ) - "status" associate ; + "status" associate + [ twitter-source get "source" ] dip [ set-at ] keep ; : (tweet) ( string -- json ) update-post-data "https://twitter.com/statuses/update.json"