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
! 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 ;
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 -- )
: 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
"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" } ;
[ file-responder get hook>> call ] [ 2drop <304> ] if ;\r
\r
: serving-path ( filename -- filename )\r
- file-responder get root>> trim-tail-separators\r
- "/"\r
- rot "" or trim-head-separators 3append ;\r
+ [ file-responder get root>> trim-tail-separators "/" ] dip\r
+ "" or trim-head-separators 3append ;\r
\r
: serve-file ( filename -- response )\r
dup mime-type\r
{
[ [ width>> ] [ height>> ] bi 2array ]
[ bitmap>component-order ]
- [ drop little-endian ] ! XXX
[ buffer>> ]
} cleave bitmap-image boa ;
! 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
M: image normalize-scan-line-order ;
: normalize-image ( image -- image )
+ [ >byte-array ] change-bitmap
normalize-component-order
normalize-scan-line-order ;
: image-class ( path -- class )
file-extension >lower {
{ "bmp" [ bitmap-image ] }
+ { "tif" [ tiff-image ] }
{ "tiff" [ tiff-image ] }
[ unknown-image-extension ]
} case ;
! 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 ;
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 -- ? )
{ 10 [ 8 * ] }
{ 11 [ 4 * ] }
{ 12 [ 8 * ] }
+ { 13 [ 4 * ] }
[ unknown-ifd-type ]
} case ;
{ 8 [ 2 head endian> 16 >signed ] }
{ 9 [ endian> 32 >signed ] }
{ 11 [ endian> bits>float ] }
+ { 13 [ endian> 32 >signed ] }
[ bad-small-ifd-type ]
} case ;
{ 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 )
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 ;
{
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
[ ifd-component-order ]
- [ drop big-endian ] ! XXX
[ bitmap>> ]
} cleave tiff-image boa ;
dup ifds>> [
process-ifd read-strips
uncompress-strips
- strips>bitmap drop
+ strips>bitmap
+ fix-bitmap-endianness
+ drop
] each
] with-endianness
] with-file-reader ;
! 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
: 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 ;
: [XML
"XML]" [ string>chunk ] parse-def ; parsing
+<PRIVATE
+
: remove-blanks ( seq -- newseq )
[ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ;
[undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ;
\ interpolate-xml 1 [ undo-xml ] define-pop-inverse
+
+PRIVATE>
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
\ 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
! Copyright (C) 2005, 2009 Daniel Ehrenberg\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.markup help.syntax xml.data io strings ;\r
+USING: help.markup help.syntax xml.data io strings byte-arrays ;\r
IN: xml\r
\r
HELP: string>xml\r
{ $values { "filename" string } { "xml" xml } }\r
{ $description "Opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree. The encoding is automatically detected." } ;\r
\r
-{ string>xml read-xml file>xml } related-words\r
+HELP: bytes>xml\r
+{ $values { "byte-array" byte-array } { "xml" xml } }\r
+{ $description "Parses a byte array as an XML document. The encoding is automatically detected." } ;\r
+\r
+{ string>xml read-xml file>xml bytes>xml } related-words\r
\r
HELP: read-xml-chunk\r
{ $values { "stream" "an input stream" } { "seq" "a sequence of elements" } }\r
{ $subsection read-xml-chunk }\r
{ $subsection string>xml-chunk }\r
{ $subsection file>xml }\r
+ { $subsection bytes>xml }\r
"To read a DTD:"\r
{ $subsection read-dtd }\r
{ $subsection file>dtd }\r
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
: 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
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! 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 ) ;
+++ /dev/null
-! 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
+++ /dev/null
-! 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 ;
}
"An example of using a changer:"
{ $code
- ": positions"
+ ": positions ( -- seq )"
" {"
" \"junior programmer\""
" \"senior programmer\""
! 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 )
: 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 ;
-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 -- json )
+ update-post-data "update" [ <post-request> ] twitter-request ;
+
+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>
-: tweet* ( string -- result )
- update-post-data "https://twitter.com/statuses/update.json" <post-request>
- set-request-twitter-auth
- http-request nip json> ;
+: public-timeline ( -- tweets )
+ "public_timeline" timeline ;
-: tweet ( string -- ) tweet* drop ;
+: friends-timeline ( -- tweets )
+ "friends_timeline" timeline ;
+: user-timeline ( username -- tweets )
+ "user_timeline/" prepend timeline ;
projects / factor.git / commitdiff