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

db4
Joe Groff 2009-02-13 20:21:42 -06:00
commit 298e75b529
13 changed files with 177 additions and 56 deletions

View File

@ -127,3 +127,41 @@ hi "HELLO" {
hi drop-table hi drop-table
] with-db ] with-db
] unit-test ] 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

View File

@ -1,39 +1,39 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types namespaces io.binary fry USING: alien.c-types namespaces io.binary fry
kernel math ; kernel math grouping sequences ;
IN: endian IN: endian
SINGLETONS: big-endian little-endian ; SINGLETONS: big-endian little-endian ;
: native-endianness ( -- class ) : compute-native-endianness ( -- class )
1 <int> *char 0 = big-endian little-endian ? ; 1 <int> *char 0 = big-endian little-endian ? ;
: >signed ( x n -- y ) : >signed ( x n -- y )
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; 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 SYMBOL: endianness
endianness [ native-endianness get-global ] initialize
\ native-endianness get-global endianness set-global HOOK: >native-endian native-endianness ( obj n -- bytes )
HOOK: >native-endian native-endianness ( obj n -- str )
M: big-endian >native-endian >be ; M: big-endian >native-endian >be ;
M: little-endian >native-endian >le ; 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: big-endian unsigned-native-endian> be> ;
M: little-endian unsigned-native-endian> le> ; M: little-endian unsigned-native-endian> le> ;
: signed-native-endian> ( obj n -- str ) : signed-native-endian> ( obj n -- n' )
[ unsigned-native-endian> ] dip >signed ; [ unsigned-native-endian> ] dip >signed ;
HOOK: >endian endianness ( obj n -- str ) HOOK: >endian endianness ( obj n -- bytes )
M: big-endian >endian >be ; M: big-endian >endian >be ;
@ -45,13 +45,13 @@ M: big-endian endian> be> ;
M: little-endian endian> le> ; M: little-endian endian> le> ;
HOOK: unsigned-endian> endianness ( obj -- str ) HOOK: unsigned-endian> endianness ( obj -- bytes )
M: big-endian unsigned-endian> be> ; M: big-endian unsigned-endian> be> ;
M: little-endian unsigned-endian> le> ; M: little-endian unsigned-endian> le> ;
: signed-endian> ( obj n -- str ) : signed-endian> ( obj n -- bytes )
[ unsigned-endian> ] dip >signed ; [ unsigned-endian> ] dip >signed ;
: with-endianness ( endian quot -- ) : with-endianness ( endian quot -- )
@ -65,3 +65,15 @@ M: little-endian unsigned-endian> le> ;
: with-native-endian ( quot -- ) : with-native-endian ( quot -- )
\ native-endianness get-global swap with-endianness ; inline \ 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

View File

@ -38,7 +38,7 @@ $nl
"If all you want to do is serve files from a directory, the following phrase does the trick:" "If all you want to do is serve files from a directory, the following phrase does the trick:"
{ $code { $code
"USING: namespaces http.server http.server.static ;" "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" "8080 httpd"
} }
{ $subsection "http.server.static.extend" } ; { $subsection "http.server.static.extend" } ;

View File

@ -45,9 +45,8 @@ TUPLE: file-responder root hook special allow-listings ;
[ file-responder get hook>> call ] [ 2drop <304> ] if ; [ file-responder get hook>> call ] [ 2drop <304> ] if ;
: serving-path ( filename -- filename ) : serving-path ( filename -- filename )
file-responder get root>> trim-tail-separators [ file-responder get root>> trim-tail-separators "/" ] dip
"/" "" or trim-head-separators 3append ;
rot "" or trim-head-separators 3append ;
: serve-file ( filename -- response ) : serve-file ( filename -- response )
dup mime-type dup mime-type

View File

@ -105,7 +105,6 @@ ERROR: unknown-component-order bitmap ;
{ {
[ [ width>> ] [ height>> ] bi 2array ] [ [ width>> ] [ height>> ] bi 2array ]
[ bitmap>component-order ] [ bitmap>component-order ]
[ drop little-endian ] ! XXX
[ buffer>> ] [ buffer>> ]
} cleave bitmap-image boa ; } cleave bitmap-image boa ;

View File

@ -1,13 +1,14 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! 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 ; math specialized-arrays.direct.uint byte-arrays
specialized-arrays.direct.ushort ;
IN: images 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 ; R16G16B16 R32G32B32 ;
TUPLE: image dim component-order byte-order bitmap ; TUPLE: image dim component-order bitmap ;
: <image> ( -- image ) image new ; inline : <image> ( -- image ) image new ; inline
@ -28,6 +29,13 @@ GENERIC: load-image* ( path tuple -- image )
>byte-array add-dummy-alpha >byte-array add-dummy-alpha
] change-bitmap ] change-bitmap
] } ] }
{ R16G16B16 [
[
dup length 2 / <direct-ushort-array>
[ -8 shift ] map
>byte-array add-dummy-alpha
] change-bitmap
] }
{ BGRA [ { BGRA [
[ [
4 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each 4 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each

View File

@ -1,9 +1,11 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io io.encodings.binary io.files kernel USING: accessors arrays assocs byte-arrays classes combinators
pack endian constructors sequences arrays math.order math.parser compression.lzw constructors endian fry grouping images io
prettyprint classes io.binary assocs math math.bitwise byte-arrays io.binary io.encodings.ascii io.encodings.binary
grouping images compression.lzw fry strings ; io.encodings.string io.encodings.utf8 io.files kernel math
math.bitwise math.order math.parser pack prettyprint sequences
strings ;
IN: images.tiff IN: images.tiff
TUPLE: tiff-image < image ; TUPLE: tiff-image < image ;
@ -249,13 +251,13 @@ ERROR: bad-small-ifd-type n ;
{ 283 [ first y-resolution ] } { 283 [ first y-resolution ] }
{ 284 [ planar-configuration ] } { 284 [ planar-configuration ] }
{ 296 [ lookup-resolution-unit resolution-unit ] } { 296 [ lookup-resolution-unit resolution-unit ] }
{ 305 [ >string software ] } { 305 [ ascii decode software ] }
{ 306 [ >string date-time ] } { 306 [ ascii decode date-time ] }
{ 317 [ lookup-predictor predictor ] } { 317 [ lookup-predictor predictor ] }
{ 330 [ sub-ifd ] } { 330 [ sub-ifd ] }
{ 338 [ lookup-extra-samples extra-samples ] } { 338 [ lookup-extra-samples extra-samples ] }
{ 339 [ lookup-sample-format sample-format ] } { 339 [ lookup-sample-format sample-format ] }
{ 700 [ >string xmp ] } { 700 [ utf8 decode xmp ] }
{ 34377 [ photoshop ] } { 34377 [ photoshop ] }
{ 34665 [ exif-ifd ] } { 34665 [ exif-ifd ] }
{ 33723 [ iptc ] } { 33723 [ iptc ] }
@ -286,6 +288,18 @@ ERROR: unhandled-compression compression ;
ERROR: unknown-component-order ifd ; 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 ) : ifd-component-order ( ifd -- byte-order )
bits-per-sample find-tag { bits-per-sample find-tag {
{ { 32 32 32 } [ R32G32B32 ] } { { 32 32 32 } [ R32G32B32 ] }
@ -299,7 +313,6 @@ ERROR: unknown-component-order ifd ;
{ {
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
[ ifd-component-order ] [ ifd-component-order ]
[ drop big-endian ] ! XXX
[ bitmap>> ] [ bitmap>> ]
} cleave tiff-image boa ; } cleave tiff-image boa ;
@ -314,7 +327,9 @@ ERROR: unknown-component-order ifd ;
dup ifds>> [ dup ifds>> [
process-ifd read-strips process-ifd read-strips
uncompress-strips uncompress-strips
strips>bitmap drop strips>bitmap
fix-bitmap-endianness
drop
] each ] each
] with-endianness ] with-endianness
] with-file-reader ; ] with-file-reader ;

View File

@ -174,6 +174,8 @@ PRIVATE>
: [XML : [XML
"XML]" [ string>chunk ] parse-def ; parsing "XML]" [ string>chunk ] parse-def ; parsing
<PRIVATE
: remove-blanks ( seq -- newseq ) : remove-blanks ( seq -- newseq )
[ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ; [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ;
@ -241,3 +243,5 @@ M: interpolated [undo-xml]
[undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ; [undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ;
\ interpolate-xml 1 [ undo-xml ] define-pop-inverse \ interpolate-xml 1 [ undo-xml ] define-pop-inverse
PRIVATE>

View File

@ -3,7 +3,7 @@
IN: xml.tests IN: xml.tests
USING: kernel xml tools.test io namespaces make sequences USING: kernel xml tools.test io namespaces make sequences
xml.errors xml.entities.html parser strings xml.data io.files 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 ; sequences.deep accessors io.streams.string ;
! This is insufficient ! This is insufficient
@ -12,8 +12,14 @@ sequences.deep accessors io.streams.string ;
\ string>xml must-infer \ string>xml must-infer
SYMBOL: xml-file 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 [ "1.0" ] [ xml-file get prolog>> version>> ] unit-test
[ f ] [ xml-file get prolog>> standalone>> ] unit-test [ f ] [ xml-file get prolog>> standalone>> ] unit-test
[ "a" ] [ xml-file get space>> ] unit-test [ "a" ] [ xml-file get space>> ] unit-test

View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg ! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: xml
HELP: string>xml HELP: string>xml
@ -16,7 +16,11 @@ HELP: file>xml
{ $values { "filename" string } { "xml" 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." } ; { $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 HELP: read-xml-chunk
{ $values { "stream" "an input stream" } { "seq" "a sequence of elements" } } { $values { "stream" "an input stream" } { "seq" "a sequence of elements" } }
@ -68,6 +72,7 @@ ARTICLE: { "xml" "reading" } "Reading XML"
{ $subsection read-xml-chunk } { $subsection read-xml-chunk }
{ $subsection string>xml-chunk } { $subsection string>xml-chunk }
{ $subsection file>xml } { $subsection file>xml }
{ $subsection bytes>xml }
"To read a DTD:" "To read a DTD:"
{ $subsection read-dtd } { $subsection read-dtd }
{ $subsection file>dtd } { $subsection file>dtd }

View File

@ -4,7 +4,7 @@ USING: accessors arrays io io.encodings.binary io.files
io.streams.string kernel namespaces sequences strings io.encodings.utf8 io.streams.string kernel namespaces sequences strings io.encodings.utf8
xml.data xml.errors xml.elements ascii xml.entities xml.data xml.errors xml.elements ascii xml.entities
xml.writer xml.state xml.autoencoding assocs xml.tokenize 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 IN: xml
<PRIVATE <PRIVATE
@ -184,6 +184,9 @@ PRIVATE>
: file>xml ( filename -- xml ) : file>xml ( filename -- xml )
binary <file-reader> read-xml ; binary <file-reader> read-xml ;
: bytes>xml ( byte-array -- xml )
binary <byte-reader> read-xml ;
: read-dtd ( stream -- dtd ) : read-dtd ( stream -- dtd )
[ [
H{ } clone extra-entities set H{ } clone extra-entities set

View File

@ -1,7 +1,7 @@
! 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: unix alien alien.c-types kernel math sequences strings 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 IN: system-info.linux
: (uname) ( buf -- int ) : (uname) ( buf -- int )
@ -9,7 +9,7 @@ IN: system-info.linux
: uname ( -- seq ) : uname ( -- seq )
65536 "char" <c-array> [ (uname) io-error ] keep 65536 "char" <c-array> [ (uname) io-error ] keep
"\0" split harvest [ >string ] map "\0" split harvest [ utf8 decode ] map
6 "" pad-tail ; 6 "" pad-tail ;
: sysname ( -- string ) uname first ; : sysname ( -- string ) uname first ;

View File

@ -1,12 +1,40 @@
! Copyright (C) 2009 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators hashtables http USING: accessors assocs combinators hashtables http
http.client json.reader kernel macros namespaces sequences http.client json.reader kernel macros namespaces sequences
urls.secure urls.encoding ; urls.secure fry ;
IN: twitter IN: twitter
! Configuration
SYMBOLS: twitter-username twitter-password twitter-source ; SYMBOLS: twitter-username twitter-password twitter-source ;
twitter-source [ "factor" ] initialize twitter-source [ "factor" ] initialize
: set-twitter-credentials ( username password -- )
[ 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 get twitter-password get set-basic-auth ;
: twitter-request ( request -- data )
set-request-twitter-auth
http-request nip ; inline
PRIVATE>
! Data types
TUPLE: twitter-status TUPLE: twitter-status
created-at created-at
id id
@ -28,8 +56,7 @@ TUPLE: twitter-user
protected? protected?
followers-count ; followers-count ;
MACRO: keys-boa ( keys class -- ) <PRIVATE
[ [ \ swap \ at [ ] 3sequence ] map \ cleave ] dip \ boa [ ] 4sequence ;
: <twitter-user> ( assoc -- user ) : <twitter-user> ( assoc -- user )
{ {
@ -64,37 +91,42 @@ MACRO: keys-boa ( keys class -- )
: json>twitter-status ( json-object -- tweet ) : json>twitter-status ( json-object -- tweet )
json> <twitter-status> ; json> <twitter-status> ;
: set-twitter-credentials ( username password -- ) PRIVATE>
[ twitter-username set ] [ twitter-password set ] bi* ;
: set-request-twitter-auth ( request -- request ) ! Updates
twitter-username twitter-password [ get ] bi@ set-basic-auth ; <PRIVATE
: update-post-data ( update -- assoc ) : update-post-data ( update -- assoc )
"status" associate [
[ twitter-source get "source" ] dip [ set-at ] keep ; "status" set
twitter-source get "source" set
] H{ } make-assoc ;
: (tweet) ( string -- json ) : (tweet) ( string -- json )
update-post-data "https://twitter.com/statuses/update.json" <post-request> update-post-data "update" twitter-url
set-request-twitter-auth <post-request> twitter-request ;
http-request nip ;
PRIVATE>
: tweet* ( string -- tweet ) : tweet* ( string -- tweet )
(tweet) json>twitter-status ; (tweet) json>twitter-status ;
: tweet ( string -- ) (tweet) drop ; : tweet ( string -- ) (tweet) drop ;
! Timelines
<PRIVATE
: timeline ( url -- tweets )
twitter-url <get-request>
twitter-request json>twitter-statuses ;
PRIVATE>
: public-timeline ( -- tweets ) : public-timeline ( -- tweets )
"https://twitter.com/statuses/public_timeline.json" <get-request> "public_timeline" timeline ;
set-request-twitter-auth
http-request nip json>twitter-statuses ;
: friends-timeline ( -- tweets ) : friends-timeline ( -- tweets )
"https://twitter.com/statuses/friends_timeline.json" <get-request> "friends_timeline" timeline ;
set-request-twitter-auth
http-request nip json>twitter-statuses ;
: user-timeline ( username -- tweets ) : user-timeline ( username -- tweets )
"https://twitter.com/statuses/user_timeline/" ".json" surround <get-request> "user_timeline/" prepend timeline ;
set-request-twitter-auth
http-request nip json>twitter-statuses ;