Merge branch 'master' into new_ui
commit
056e7aa442
|
@ -127,3 +127,41 @@ hi "HELLO" {
|
|||
hi drop-table
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
TUPLE: show id ;
|
||||
TUPLE: user username data ;
|
||||
TUPLE: watch show user ;
|
||||
|
||||
user "USER" {
|
||||
{ "username" "USERNAME" TEXT +not-null+ +user-assigned-id+ }
|
||||
{ "data" "DATA" TEXT }
|
||||
} define-persistent
|
||||
|
||||
show "SHOW" {
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
} define-persistent
|
||||
|
||||
watch "WATCH" {
|
||||
{ "user" "USER" TEXT +not-null+
|
||||
{ +foreign-id+ user "USERNAME" } +user-assigned-id+ }
|
||||
{ "show" "SHOW" BIG-INTEGER +not-null+
|
||||
{ +foreign-id+ show "ID" } +user-assigned-id+ }
|
||||
} define-persistent
|
||||
|
||||
[ T{ user { username "littledan" } { data "foo" } } ] [
|
||||
test.db [
|
||||
user create-table
|
||||
show create-table
|
||||
watch create-table
|
||||
"littledan" "foo" user boa insert-tuple
|
||||
"mark" "bar" user boa insert-tuple
|
||||
show new insert-tuple
|
||||
show new select-tuple
|
||||
"littledan" f user boa select-tuple
|
||||
watch boa insert-tuple
|
||||
watch new select-tuple
|
||||
user>> f user boa select-tuple
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[ \ swap ensure-table ] must-fail
|
||||
|
|
|
@ -1,39 +1,39 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types namespaces io.binary fry
|
||||
kernel math ;
|
||||
kernel math grouping sequences ;
|
||||
IN: endian
|
||||
|
||||
SINGLETONS: big-endian little-endian ;
|
||||
|
||||
: native-endianness ( -- class )
|
||||
: compute-native-endianness ( -- class )
|
||||
1 <int> *char 0 = big-endian little-endian ? ;
|
||||
|
||||
: >signed ( x n -- y )
|
||||
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
|
||||
|
||||
native-endianness \ native-endianness set-global
|
||||
SYMBOL: native-endianness
|
||||
native-endianness [ compute-native-endianness ] initialize
|
||||
|
||||
SYMBOL: endianness
|
||||
endianness [ native-endianness get-global ] initialize
|
||||
|
||||
\ native-endianness get-global endianness set-global
|
||||
|
||||
HOOK: >native-endian native-endianness ( obj n -- str )
|
||||
HOOK: >native-endian native-endianness ( obj n -- bytes )
|
||||
|
||||
M: big-endian >native-endian >be ;
|
||||
|
||||
M: little-endian >native-endian >le ;
|
||||
|
||||
HOOK: unsigned-native-endian> native-endianness ( obj -- str )
|
||||
HOOK: unsigned-native-endian> native-endianness ( obj -- bytes )
|
||||
|
||||
M: big-endian unsigned-native-endian> be> ;
|
||||
|
||||
M: little-endian unsigned-native-endian> le> ;
|
||||
|
||||
: signed-native-endian> ( obj n -- str )
|
||||
: signed-native-endian> ( obj n -- n' )
|
||||
[ unsigned-native-endian> ] dip >signed ;
|
||||
|
||||
HOOK: >endian endianness ( obj n -- str )
|
||||
HOOK: >endian endianness ( obj n -- bytes )
|
||||
|
||||
M: big-endian >endian >be ;
|
||||
|
||||
|
@ -45,13 +45,13 @@ M: big-endian endian> be> ;
|
|||
|
||||
M: little-endian endian> le> ;
|
||||
|
||||
HOOK: unsigned-endian> endianness ( obj -- str )
|
||||
HOOK: unsigned-endian> endianness ( obj -- bytes )
|
||||
|
||||
M: big-endian unsigned-endian> be> ;
|
||||
|
||||
M: little-endian unsigned-endian> le> ;
|
||||
|
||||
: signed-endian> ( obj n -- str )
|
||||
: signed-endian> ( obj n -- bytes )
|
||||
[ unsigned-endian> ] dip >signed ;
|
||||
|
||||
: with-endianness ( endian quot -- )
|
||||
|
@ -65,3 +65,15 @@ M: little-endian unsigned-endian> le> ;
|
|||
|
||||
: with-native-endian ( quot -- )
|
||||
\ native-endianness get-global swap with-endianness ; inline
|
||||
|
||||
: seq>native-endianness ( seq n -- seq' )
|
||||
native-endianness get-global dup endianness get = [
|
||||
2drop
|
||||
] [
|
||||
[ [ <sliced-groups> ] keep ] dip
|
||||
little-endian = [
|
||||
'[ be> _ >le ] map
|
||||
] [
|
||||
'[ le> _ >be ] map
|
||||
] if concat
|
||||
] if ; inline
|
||||
|
|
|
@ -38,7 +38,7 @@ $nl
|
|||
"If all you want to do is serve files from a directory, the following phrase does the trick:"
|
||||
{ $code
|
||||
"USING: namespaces http.server http.server.static ;"
|
||||
"/var/www/mysite.com/ <static> main-responder set"
|
||||
"\"/var/www/mysite.com/\" <static> main-responder set"
|
||||
"8080 httpd"
|
||||
}
|
||||
{ $subsection "http.server.static.extend" } ;
|
||||
|
|
|
@ -45,9 +45,8 @@ TUPLE: file-responder root hook special allow-listings ;
|
|||
[ file-responder get hook>> call ] [ 2drop <304> ] if ;
|
||||
|
||||
: serving-path ( filename -- filename )
|
||||
file-responder get root>> trim-tail-separators
|
||||
"/"
|
||||
rot "" or trim-head-separators 3append ;
|
||||
[ file-responder get root>> trim-tail-separators "/" ] dip
|
||||
"" or trim-head-separators 3append ;
|
||||
|
||||
: serve-file ( filename -- response )
|
||||
dup mime-type
|
||||
|
|
|
@ -105,7 +105,6 @@ ERROR: unknown-component-order bitmap ;
|
|||
{
|
||||
[ [ width>> ] [ height>> ] bi 2array ]
|
||||
[ bitmap>component-order ]
|
||||
[ drop little-endian ] ! XXX
|
||||
[ buffer>> ]
|
||||
} cleave bitmap-image boa ;
|
||||
|
||||
|
|
|
@ -1,32 +1,52 @@
|
|||
! 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
|
||||
specialized-arrays.direct.ushort ;
|
||||
IN: images
|
||||
|
||||
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;
|
||||
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
|
||||
R16G16B16 R32G32B32 ;
|
||||
|
||||
TUPLE: image dim component-order byte-order bitmap ;
|
||||
TUPLE: image dim component-order bitmap ;
|
||||
|
||||
: <image> ( -- image ) image new ; inline
|
||||
|
||||
GENERIC: load-image* ( path tuple -- image )
|
||||
|
||||
: add-dummy-alpha ( seq -- seq' )
|
||||
3 <sliced-groups>
|
||||
[ 255 suffix ] map concat ;
|
||||
|
||||
: normalize-component-order ( image -- image )
|
||||
dup component-order>>
|
||||
{
|
||||
{ RGBA [ ] }
|
||||
{ R32G32B32 [
|
||||
[
|
||||
dup length 4 / <direct-uint-array>
|
||||
[ bits>float 255.0 * >integer ] map
|
||||
>byte-array add-dummy-alpha
|
||||
] change-bitmap
|
||||
] }
|
||||
{ R16G16B16 [
|
||||
[
|
||||
dup length 2 / <direct-ushort-array>
|
||||
[ -8 shift ] map
|
||||
>byte-array add-dummy-alpha
|
||||
] change-bitmap
|
||||
] }
|
||||
{ BGRA [
|
||||
[
|
||||
4 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
|
||||
] change-bitmap
|
||||
] }
|
||||
{ RGB [
|
||||
[ 3 <sliced-groups> [ 255 suffix ] map concat ] change-bitmap
|
||||
] }
|
||||
{ RGB [ [ add-dummy-alpha ] change-bitmap ] }
|
||||
{ BGR [
|
||||
[
|
||||
3 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
|
||||
[ 255 suffix ] map concat
|
||||
3 <sliced-groups>
|
||||
[ [ [ 0 3 ] dip <slice> reverse-here ] each ]
|
||||
[ add-dummy-alpha ] bi
|
||||
] change-bitmap
|
||||
] }
|
||||
} case
|
||||
|
@ -37,5 +57,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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -1,9 +1,11 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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 ;
|
||||
USING: accessors arrays assocs byte-arrays classes combinators
|
||||
compression.lzw constructors endian fry grouping images io
|
||||
io.binary io.encodings.ascii io.encodings.binary
|
||||
io.encodings.string io.encodings.utf8 io.files kernel math
|
||||
math.bitwise math.order math.parser pack prettyprint sequences
|
||||
strings ;
|
||||
IN: images.tiff
|
||||
|
||||
TUPLE: tiff-image < image ;
|
||||
|
@ -115,8 +117,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 +188,7 @@ ERROR: unknown-ifd-type n ;
|
|||
{ 10 [ 8 * ] }
|
||||
{ 11 [ 4 * ] }
|
||||
{ 12 [ 8 * ] }
|
||||
{ 13 [ 4 * ] }
|
||||
[ unknown-ifd-type ]
|
||||
} case ;
|
||||
|
||||
|
@ -200,6 +204,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 ;
|
||||
|
||||
|
@ -242,14 +247,22 @@ 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 [ ascii decode software ] }
|
||||
{ 306 [ ascii decode 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 [ utf8 decode xmp ] }
|
||||
{ 34377 [ photoshop ] }
|
||||
{ 34665 [ exif-ifd ] }
|
||||
{ 33723 [ iptc ] }
|
||||
{ 34675 [ inter-color-profile ] }
|
||||
[ nip unhandled-ifd-entry swap ]
|
||||
} case ;
|
||||
|
||||
: process-ifd ( ifd -- ifd )
|
||||
|
@ -275,10 +288,24 @@ ERROR: unhandled-compression compression ;
|
|||
|
||||
ERROR: unknown-component-order ifd ;
|
||||
|
||||
: fix-bitmap-endianness ( ifd -- ifd )
|
||||
dup [ bitmap>> ] [ bits-per-sample find-tag ] bi
|
||||
{
|
||||
{ { 32 32 32 32 } [ 4 seq>native-endianness ] }
|
||||
{ { 32 32 32 } [ 4 seq>native-endianness ] }
|
||||
{ { 16 16 16 16 } [ 2 seq>native-endianness ] }
|
||||
{ { 16 16 16 } [ 2 seq>native-endianness ] }
|
||||
{ { 8 8 8 8 } [ ] }
|
||||
{ { 8 8 8 } [ ] }
|
||||
[ unknown-component-order ]
|
||||
} case >>bitmap ;
|
||||
|
||||
: ifd-component-order ( ifd -- byte-order )
|
||||
bits-per-sample find-tag sum {
|
||||
{ 32 [ RGBA ] }
|
||||
{ 24 [ RGB ] }
|
||||
bits-per-sample find-tag {
|
||||
{ { 32 32 32 } [ R32G32B32 ] }
|
||||
{ { 16 16 16 } [ R16G16B16 ] }
|
||||
{ { 8 8 8 8 } [ RGBA ] }
|
||||
{ { 8 8 8 } [ RGB ] }
|
||||
[ unknown-component-order ]
|
||||
} case ;
|
||||
|
||||
|
@ -286,7 +313,6 @@ ERROR: unknown-component-order ifd ;
|
|||
{
|
||||
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
|
||||
[ ifd-component-order ]
|
||||
[ drop big-endian ] ! XXX
|
||||
[ bitmap>> ]
|
||||
} cleave tiff-image boa ;
|
||||
|
||||
|
@ -301,7 +327,9 @@ ERROR: unknown-component-order ifd ;
|
|||
dup ifds>> [
|
||||
process-ifd read-strips
|
||||
uncompress-strips
|
||||
strips>bitmap drop
|
||||
strips>bitmap
|
||||
fix-bitmap-endianness
|
||||
drop
|
||||
] each
|
||||
] with-endianness
|
||||
] with-file-reader ;
|
||||
|
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
@ -26,13 +27,17 @@ IN: tools.hexdump
|
|||
: write-hex-line ( bytes lineno -- )
|
||||
write-offset [ >hex-digits write ] [ >ascii write ] bi nl ;
|
||||
|
||||
: hexdump-bytes ( bytes -- )
|
||||
[ length write-header ]
|
||||
[ 16 <sliced-groups> [ write-hex-line ] each-index ] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: hexdump. ( byte-array -- )
|
||||
|
||||
M: byte-array hexdump.
|
||||
[ length write-header ]
|
||||
[ 16 <sliced-groups> [ 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 ;
|
||||
|
|
|
@ -174,6 +174,8 @@ PRIVATE>
|
|||
: [XML
|
||||
"XML]" [ string>chunk ] parse-def ; parsing
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: remove-blanks ( seq -- newseq )
|
||||
[ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ;
|
||||
|
||||
|
@ -241,3 +243,5 @@ M: interpolated [undo-xml]
|
|||
[undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ;
|
||||
|
||||
\ interpolate-xml 1 [ undo-xml ] define-pop-inverse
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
IN: xml.tests
|
||||
USING: kernel xml tools.test io namespaces make sequences
|
||||
xml.errors xml.entities.html parser strings xml.data io.files
|
||||
xml.traversal continuations assocs
|
||||
xml.traversal continuations assocs io.encodings.binary
|
||||
sequences.deep accessors io.streams.string ;
|
||||
|
||||
! This is insufficient
|
||||
|
@ -12,8 +12,14 @@ sequences.deep accessors io.streams.string ;
|
|||
\ string>xml must-infer
|
||||
|
||||
SYMBOL: xml-file
|
||||
[ ] [ "resource:basis/xml/tests/test.xml"
|
||||
[ file>xml ] with-html-entities xml-file set ] unit-test
|
||||
[ ] [
|
||||
"resource:basis/xml/tests/test.xml"
|
||||
[ file>xml ] with-html-entities xml-file set
|
||||
] unit-test
|
||||
[ t ] [
|
||||
"resource:basis/xml/tests/test.xml" binary file-contents
|
||||
[ bytes>xml ] with-html-entities xml-file get =
|
||||
] unit-test
|
||||
[ "1.0" ] [ xml-file get prolog>> version>> ] unit-test
|
||||
[ f ] [ xml-file get prolog>> standalone>> ] unit-test
|
||||
[ "a" ] [ xml-file get space>> ] unit-test
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2005, 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax xml.data io strings ;
|
||||
USING: help.markup help.syntax xml.data io strings byte-arrays ;
|
||||
IN: xml
|
||||
|
||||
HELP: string>xml
|
||||
|
@ -16,7 +16,11 @@ HELP: file>xml
|
|||
{ $values { "filename" string } { "xml" xml } }
|
||||
{ $description "Opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree. The encoding is automatically detected." } ;
|
||||
|
||||
{ string>xml read-xml file>xml } related-words
|
||||
HELP: bytes>xml
|
||||
{ $values { "byte-array" byte-array } { "xml" xml } }
|
||||
{ $description "Parses a byte array as an XML document. The encoding is automatically detected." } ;
|
||||
|
||||
{ string>xml read-xml file>xml bytes>xml } related-words
|
||||
|
||||
HELP: read-xml-chunk
|
||||
{ $values { "stream" "an input stream" } { "seq" "a sequence of elements" } }
|
||||
|
@ -68,6 +72,7 @@ ARTICLE: { "xml" "reading" } "Reading XML"
|
|||
{ $subsection read-xml-chunk }
|
||||
{ $subsection string>xml-chunk }
|
||||
{ $subsection file>xml }
|
||||
{ $subsection bytes>xml }
|
||||
"To read a DTD:"
|
||||
{ $subsection read-dtd }
|
||||
{ $subsection file>dtd }
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: accessors arrays io io.encodings.binary io.files
|
|||
io.streams.string kernel namespaces sequences strings io.encodings.utf8
|
||||
xml.data xml.errors xml.elements ascii xml.entities
|
||||
xml.writer xml.state xml.autoencoding assocs xml.tokenize
|
||||
combinators.short-circuit xml.name splitting ;
|
||||
combinators.short-circuit xml.name splitting io.streams.byte-array ;
|
||||
IN: xml
|
||||
|
||||
<PRIVATE
|
||||
|
@ -184,6 +184,9 @@ PRIVATE>
|
|||
: file>xml ( filename -- xml )
|
||||
binary <file-reader> read-xml ;
|
||||
|
||||
: bytes>xml ( byte-array -- xml )
|
||||
binary <byte-reader> read-xml ;
|
||||
|
||||
: read-dtd ( stream -- dtd )
|
||||
[
|
||||
H{ } clone extra-entities set
|
||||
|
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
|
@ -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 ) ;
|
|
@ -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
|
|
@ -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 ;
|
||||
|
||||
: <compressed> ( 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 <byte-array> dup length <ulong> ] keep [
|
||||
dup length zlib.ffi:compress zlib-error
|
||||
] 3keep drop *ulong head
|
||||
] keep length <compressed> ;
|
||||
|
||||
: uncompress ( compressed -- byte-array )
|
||||
[
|
||||
length>> [ <byte-array> ] keep <ulong> 2dup
|
||||
] [
|
||||
data>> dup length
|
||||
zlib.ffi:uncompress zlib-error
|
||||
] bi *ulong head ;
|
|
@ -241,7 +241,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
|
|||
}
|
||||
"An example of using a changer:"
|
||||
{ $code
|
||||
": positions"
|
||||
": positions ( -- seq )"
|
||||
" {"
|
||||
" \"junior programmer\""
|
||||
" \"senior programmer\""
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: unix alien alien.c-types kernel math sequences strings
|
||||
io.backend.unix splitting ;
|
||||
io.backend.unix splitting io.encodings.utf8 io.encodings.string ;
|
||||
IN: system-info.linux
|
||||
|
||||
: (uname) ( buf -- int )
|
||||
|
@ -9,7 +9,7 @@ IN: system-info.linux
|
|||
|
||||
: uname ( -- seq )
|
||||
65536 "char" <c-array> [ (uname) io-error ] keep
|
||||
"\0" split harvest [ >string ] map
|
||||
"\0" split harvest [ utf8 decode ] map
|
||||
6 "" pad-tail ;
|
||||
|
||||
: sysname ( -- string ) uname first ;
|
||||
|
|
|
@ -1,22 +1,131 @@
|
|||
USING: accessors assocs hashtables http http.client json.reader
|
||||
kernel namespaces urls.secure urls.encoding ;
|
||||
! Copyright (C) 2009 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs combinators hashtables http
|
||||
http.client json.reader kernel macros namespaces sequences
|
||||
urls.secure fry ;
|
||||
IN: twitter
|
||||
|
||||
SYMBOLS: twitter-username twitter-password ;
|
||||
! Configuration
|
||||
SYMBOLS: twitter-username twitter-password twitter-source ;
|
||||
|
||||
twitter-source [ "factor" ] initialize
|
||||
|
||||
: set-twitter-credentials ( username password -- )
|
||||
[ twitter-username set ] [ twitter-password set ] bi* ;
|
||||
[ twitter-username set ] [ twitter-password set ] bi* ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! Utilities
|
||||
MACRO: keys-boa ( keys class -- )
|
||||
[ [ '[ _ swap at ] ] map ] dip '[ _ cleave _ boa ] ;
|
||||
|
||||
! Twitter requests
|
||||
|
||||
: twitter-url ( string -- url )
|
||||
"https://twitter.com/statuses/" ".json" surround ;
|
||||
|
||||
: set-request-twitter-auth ( request -- request )
|
||||
twitter-username twitter-password [ get ] bi@ set-basic-auth ;
|
||||
twitter-username get twitter-password get set-basic-auth ;
|
||||
|
||||
: twitter-request ( string quot -- data )
|
||||
[ twitter-url ] dip call
|
||||
set-request-twitter-auth
|
||||
http-request nip ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! Data types
|
||||
|
||||
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 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: <twitter-user> ( assoc -- user )
|
||||
{
|
||||
"id"
|
||||
"name"
|
||||
"screen_name"
|
||||
"description"
|
||||
"location"
|
||||
"profile_image_url"
|
||||
"url"
|
||||
"protected"
|
||||
"followers_count"
|
||||
} twitter-user keys-boa ;
|
||||
|
||||
: <twitter-status> ( assoc -- tweet )
|
||||
clone "user" over [ <twitter-user> ] 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> [ <twitter-status> ] map ;
|
||||
|
||||
: json>twitter-status ( json-object -- tweet )
|
||||
json> <twitter-status> ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! Updates
|
||||
<PRIVATE
|
||||
|
||||
: update-post-data ( update -- assoc )
|
||||
"status" associate ;
|
||||
[
|
||||
"status" set
|
||||
twitter-source get "source" set
|
||||
] make-assoc ;
|
||||
|
||||
: tweet* ( string -- result )
|
||||
update-post-data "https://twitter.com/statuses/update.json" <post-request>
|
||||
set-request-twitter-auth
|
||||
http-request nip json> ;
|
||||
: (tweet) ( string -- json )
|
||||
update-post-data "update" [ <post-request> ] twitter-request ;
|
||||
|
||||
: tweet ( string -- ) tweet* drop ;
|
||||
PRIVATE>
|
||||
|
||||
: tweet* ( string -- tweet )
|
||||
(tweet) json>twitter-status ;
|
||||
|
||||
: tweet ( string -- ) (tweet) drop ;
|
||||
|
||||
! Timelines
|
||||
<PRIVATE
|
||||
|
||||
: timeline ( url -- tweets )
|
||||
[ <get-request> ] twitter-request json>twitter-statuses ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: public-timeline ( -- tweets )
|
||||
"public_timeline" timeline ;
|
||||
|
||||
: friends-timeline ( -- tweets )
|
||||
"friends_timeline" timeline ;
|
||||
|
||||
: user-timeline ( username -- tweets )
|
||||
"user_timeline/" prepend timeline ;
|
||||
|
|
Loading…
Reference in New Issue