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
] 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

View File

@ -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

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:"
{ $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" } ;

View File

@ -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

View File

@ -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 ;

View File

@ -1,13 +1,14 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
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
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
@ -28,6 +29,13 @@ GENERIC: load-image* ( path tuple -- image )
>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

View File

@ -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 strings ;
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 ;
@ -249,13 +251,13 @@ ERROR: bad-small-ifd-type n ;
{ 283 [ first y-resolution ] }
{ 284 [ planar-configuration ] }
{ 296 [ lookup-resolution-unit resolution-unit ] }
{ 305 [ >string software ] }
{ 306 [ >string date-time ] }
{ 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 ] }
{ 700 [ >string xmp ] }
{ 700 [ utf8 decode xmp ] }
{ 34377 [ photoshop ] }
{ 34665 [ exif-ifd ] }
{ 33723 [ iptc ] }
@ -286,6 +288,18 @@ 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 {
{ { 32 32 32 } [ R32G32B32 ] }
@ -299,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 ;
@ -314,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 ;

View File

@ -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>

View File

@ -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

View File

@ -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 }

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
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

View File

@ -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 ;

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
http.client json.reader kernel macros namespaces sequences
urls.secure urls.encoding ;
urls.secure fry ;
IN: twitter
! Configuration
SYMBOLS: twitter-username twitter-password twitter-source ;
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
created-at
id
@ -28,8 +56,7 @@ TUPLE: twitter-user
protected?
followers-count ;
MACRO: keys-boa ( keys class -- )
[ [ \ swap \ at [ ] 3sequence ] map \ cleave ] dip \ boa [ ] 4sequence ;
<PRIVATE
: <twitter-user> ( assoc -- user )
{
@ -64,37 +91,42 @@ MACRO: keys-boa ( keys class -- )
: json>twitter-status ( json-object -- tweet )
json> <twitter-status> ;
: set-twitter-credentials ( username password -- )
[ twitter-username set ] [ twitter-password set ] bi* ;
PRIVATE>
: set-request-twitter-auth ( request -- request )
twitter-username twitter-password [ get ] bi@ set-basic-auth ;
! Updates
<PRIVATE
: 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 )
update-post-data "https://twitter.com/statuses/update.json" <post-request>
set-request-twitter-auth
http-request nip ;
update-post-data "update" twitter-url
<post-request> twitter-request ;
PRIVATE>
: tweet* ( string -- tweet )
(tweet) json>twitter-status ;
: tweet ( string -- ) (tweet) drop ;
! Timelines
<PRIVATE
: timeline ( url -- tweets )
twitter-url <get-request>
twitter-request json>twitter-statuses ;
PRIVATE>
: public-timeline ( -- tweets )
"https://twitter.com/statuses/public_timeline.json" <get-request>
set-request-twitter-auth
http-request nip json>twitter-statuses ;
"public_timeline" timeline ;
: friends-timeline ( -- tweets )
"https://twitter.com/statuses/friends_timeline.json" <get-request>
set-request-twitter-auth
http-request nip json>twitter-statuses ;
"friends_timeline" timeline ;
: user-timeline ( username -- tweets )
"https://twitter.com/statuses/user_timeline/" ".json" surround <get-request>
set-request-twitter-auth
http-request nip json>twitter-statuses ;
"user_timeline/" prepend timeline ;