Merge branch 'master' into regexp
Daniel Ehrenberg
commit
7d096f019b
|
|
@ -1,6 +1,13 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.complex.functor sequences kernel ;
|
||||
USING: alien.c-types alien.structs alien.complex.functor accessors
|
||||
sequences kernel ;
|
||||
IN: alien.complex
|
||||
|
||||
<< { "float" "double" } [ dup "complex-" prepend define-complex-type ] each >>
|
||||
<<
|
||||
{ "float" "double" } [ dup "complex-" prepend define-complex-type ] each
|
||||
|
||||
! This overrides the fact that small structures are never returned
|
||||
! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
|
||||
"complex-float" c-type t >>return-in-registers? drop
|
||||
>>
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors arrays assocs generic hashtables kernel kernel.private
|
||||
math namespaces parser sequences strings words libc fry
|
||||
alien.c-types alien.structs.fields cpu.architecture math.order
|
||||
quotations ;
|
||||
quotations byte-arrays ;
|
||||
IN: alien.structs
|
||||
|
||||
TUPLE: struct-type
|
||||
|
|
@ -13,11 +13,14 @@ fields
|
|||
{ boxer-quot callable }
|
||||
{ unboxer-quot callable }
|
||||
{ getter callable }
|
||||
{ setter callable } ;
|
||||
{ setter callable }
|
||||
return-in-registers? ;
|
||||
|
||||
M: struct-type c-type ;
|
||||
|
||||
M: struct-type heap-size size>> ;
|
||||
|
||||
M: struct-type c-type-class drop object ;
|
||||
M: struct-type c-type-class drop byte-array ;
|
||||
|
||||
M: struct-type c-type-align align>> ;
|
||||
|
||||
|
|
@ -37,7 +40,7 @@ M: struct-type box-parameter
|
|||
[ %box-large-struct ] [ box-parameter ] if-value-struct ;
|
||||
|
||||
: if-small-struct ( c-type true false -- ? )
|
||||
[ dup struct-small-enough? ] 2dip '[ f swap @ ] if ; inline
|
||||
[ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
|
||||
|
||||
M: struct-type unbox-return
|
||||
[ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
|
||||
|
|
|
|||
|
|
@ -0,0 +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 io.encodings.binary
|
||||
io.streams.byte-array ;
|
||||
IN: bitstreams.tests
|
||||
|
||||
[ 1 t ]
|
||||
[ B{ 254 } <string-reader> <bitstream-reader> read-bit ] unit-test
|
||||
|
||||
[ 254 8 t ]
|
||||
[ B{ 254 } <string-reader> <bitstream-reader> 8 swap read-bits ] unit-test
|
||||
|
||||
[ 4095 12 t ]
|
||||
[ B{ 255 255 } <string-reader> <bitstream-reader> 12 swap read-bits ] unit-test
|
||||
|
||||
[ B{ 254 } ]
|
||||
[
|
||||
<string-writer> <bitstream-writer> 254 8 rot
|
||||
[ write-bits ] keep stream>> >byte-array
|
||||
] unit-test
|
||||
|
||||
[ 255 8 t ]
|
||||
[ B{ 255 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
|
||||
|
||||
[ 255 8 f ]
|
||||
[ B{ 255 } binary <byte-reader> <bitstream-reader> 9 swap read-bits ] unit-test
|
||||
|
|
@ -0,0 +1,96 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors byte-arrays destructors fry io kernel locals
|
||||
math sequences ;
|
||||
IN: bitstreams
|
||||
|
||||
TUPLE: bitstream stream end-of-stream? current-bits #bits disposed ;
|
||||
TUPLE: bitstream-reader < bitstream ;
|
||||
|
||||
: reset-bitstream ( stream -- stream )
|
||||
0 >>#bits 0 >>current-bits ; inline
|
||||
|
||||
: new-bitstream ( stream class -- bitstream )
|
||||
new
|
||||
swap >>stream
|
||||
reset-bitstream ; inline
|
||||
|
||||
M: bitstream-reader dispose ( stream -- )
|
||||
stream>> dispose ;
|
||||
|
||||
: <bitstream-reader> ( stream -- bitstream )
|
||||
bitstream-reader new-bitstream ; inline
|
||||
|
||||
: read-next-byte ( bitstream -- bitstream )
|
||||
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
|
||||
|
||||
: shift-one-bit ( bitstream -- n )
|
||||
[ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline
|
||||
|
||||
: next-bit ( bitstream -- n/f ? )
|
||||
maybe-read-next-byte
|
||||
dup end-of-stream?>> [
|
||||
drop f
|
||||
] [
|
||||
[ shift-one-bit ]
|
||||
[ [ 1- ] change-#bits maybe-read-next-byte drop ] bi
|
||||
] if dup >boolean ;
|
||||
|
||||
: read-bit ( bitstream -- n ? )
|
||||
dup #bits>> 1 = [
|
||||
[ current-bits>> 1 bitand ]
|
||||
[ read-next-byte drop ] bi t
|
||||
] [
|
||||
next-bit
|
||||
] if ; inline
|
||||
|
||||
: bits>integer ( seq -- n )
|
||||
0 [ [ 1 shift ] dip bitor ] reduce ; 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 ;
|
||||
|
||||
: <bitstream-writer> ( stream -- bitstream )
|
||||
bitstream-writer new-bitstream ; inline
|
||||
|
||||
: write-bit ( n bitstream -- )
|
||||
[ 1 shift bitor ] change-current-bits
|
||||
[ 1+ ] change-#bits
|
||||
dup #bits>> 8 = [
|
||||
[ [ current-bits>> ] [ stream>> stream-write1 ] bi ]
|
||||
[ reset-bitstream drop ] bi
|
||||
] [
|
||||
drop
|
||||
] if ; inline
|
||||
|
||||
ERROR: invalid-bit-width n ;
|
||||
|
||||
:: write-bits ( n width bitstream -- )
|
||||
n 0 < [ n invalid-bit-width ] when
|
||||
n 0 = [
|
||||
width [ 0 bitstream write-bit ] times
|
||||
] [
|
||||
width n log2 1+ dup :> n-length - [ 0 bitstream write-bit ] times
|
||||
n-length [
|
||||
n-length swap - 1- neg n swap shift 1 bitand
|
||||
bitstream write-bit
|
||||
] each
|
||||
] if ;
|
||||
|
||||
: flush-bits ( bitstream -- ) stream>> stream-flush ;
|
||||
|
||||
: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ;
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: help.markup help.syntax io io.files io.pathnames ;
|
||||
USING: help.markup help.syntax io io.files io.pathnames strings ;
|
||||
IN: bootstrap.image
|
||||
|
||||
ARTICLE: "bootstrap.image" "Bootstrapping new images"
|
||||
|
|
@ -14,7 +14,7 @@ $nl
|
|||
ABOUT: "bootstrap.image"
|
||||
|
||||
HELP: make-image
|
||||
{ $values { "arch" "a string" } }
|
||||
{ $values { "arch" string } }
|
||||
{ $description "Creates a bootstrap image from sources, where " { $snippet "architecture" } " is one of the following:"
|
||||
{ $code "x86.32" "x86.64" "ppc" "arm" }
|
||||
{ $code "x86.32" "unix-x86.64" "winnt-x86.64" "macosx-ppc" "linux-ppc" }
|
||||
"The new image file is written to the " { $link resource-path } " and is named " { $snippet "boot." { $emphasis "architecture" } ".image" } "." } ;
|
||||
|
|
|
|||
|
|
@ -44,4 +44,6 @@ IN: combinators.smart.tests
|
|||
|
||||
\ nested-smart-combo-test must-infer
|
||||
|
||||
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
|
||||
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
|
||||
|
||||
[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
|
||||
|
|
@ -21,6 +21,12 @@ MACRO: reduce-outputs ( quot operation -- newquot )
|
|||
: sum-outputs ( quot -- n )
|
||||
[ + ] reduce-outputs ; inline
|
||||
|
||||
MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
|
||||
[ dup infer out>> ] 2dip
|
||||
[ swap '[ _ _ napply ] ]
|
||||
[ [ 1 [-] ] dip n*quot ] bi-curry* bi
|
||||
'[ @ @ @ ] ;
|
||||
|
||||
MACRO: append-outputs-as ( quot exemplar -- newquot )
|
||||
[ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ alien.c-types alien.structs cpu.architecture ;
|
|||
IN: compiler.alien
|
||||
|
||||
: large-struct? ( ctype -- ? )
|
||||
dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
|
||||
dup c-struct? [ return-struct-in-registers? not ] [ drop f ] if ;
|
||||
|
||||
: alien-parameters ( params -- seq )
|
||||
dup parameters>>
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors tools.test compression.lzw ;
|
||||
IN: compression.lzw.tests
|
||||
|
|
@ -0,0 +1,204 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs bitstreams byte-vectors combinators io
|
||||
io.encodings.binary io.streams.byte-array kernel math sequences
|
||||
vectors ;
|
||||
IN: compression.lzw
|
||||
|
||||
CONSTANT: clear-code 256
|
||||
CONSTANT: end-of-information 257
|
||||
|
||||
TUPLE: lzw input output end-of-input? table count k omega omega-k #bits
|
||||
code old-code ;
|
||||
|
||||
SYMBOL: table-full
|
||||
|
||||
ERROR: index-too-big n ;
|
||||
|
||||
: lzw-bit-width ( n -- n' )
|
||||
{
|
||||
{ [ dup 510 <= ] [ drop 9 ] }
|
||||
{ [ dup 1022 <= ] [ drop 10 ] }
|
||||
{ [ dup 2046 <= ] [ drop 11 ] }
|
||||
{ [ dup 4094 <= ] [ drop 12 ] }
|
||||
[ drop table-full ]
|
||||
} cond ;
|
||||
|
||||
: lzw-bit-width-compress ( lzw -- n )
|
||||
count>> lzw-bit-width ;
|
||||
|
||||
: lzw-bit-width-uncompress ( lzw -- n )
|
||||
table>> length lzw-bit-width ;
|
||||
|
||||
: initial-compress-table ( -- assoc )
|
||||
258 iota [ [ 1vector ] keep ] H{ } map>assoc ;
|
||||
|
||||
: initial-uncompress-table ( -- seq )
|
||||
258 iota [ 1vector ] V{ } map-as ;
|
||||
|
||||
: reset-lzw ( lzw -- lzw )
|
||||
257 >>count
|
||||
V{ } clone >>omega
|
||||
V{ } clone >>omega-k
|
||||
9 >>#bits ;
|
||||
|
||||
: reset-lzw-compress ( lzw -- lzw )
|
||||
f >>k
|
||||
initial-compress-table >>table reset-lzw ;
|
||||
|
||||
: reset-lzw-uncompress ( lzw -- lzw )
|
||||
initial-uncompress-table >>table reset-lzw ;
|
||||
|
||||
: <lzw-compress> ( input -- obj )
|
||||
lzw new
|
||||
swap >>input
|
||||
binary <byte-writer> <bitstream-writer> >>output
|
||||
reset-lzw-compress ;
|
||||
|
||||
: <lzw-uncompress> ( input -- obj )
|
||||
lzw new
|
||||
swap >>input
|
||||
BV{ } clone >>output
|
||||
reset-lzw-uncompress ;
|
||||
|
||||
: push-k ( lzw -- lzw )
|
||||
[ ]
|
||||
[ k>> ]
|
||||
[ omega>> clone [ push ] keep ] tri >>omega-k ;
|
||||
|
||||
: omega-k-in-table? ( lzw -- ? )
|
||||
[ omega-k>> ] [ table>> ] bi key? ;
|
||||
|
||||
ERROR: not-in-table ;
|
||||
|
||||
: write-output ( lzw -- )
|
||||
[
|
||||
[ omega>> ] [ table>> ] bi at* [ not-in-table ] unless
|
||||
] [
|
||||
[ lzw-bit-width-compress ]
|
||||
[ output>> write-bits ] bi
|
||||
] bi ;
|
||||
|
||||
: omega-k>omega ( lzw -- lzw )
|
||||
dup omega-k>> clone >>omega ;
|
||||
|
||||
: k>omega ( lzw -- lzw )
|
||||
dup k>> 1vector >>omega ;
|
||||
|
||||
: add-omega-k ( lzw -- )
|
||||
[ [ 1+ ] change-count count>> ]
|
||||
[ omega-k>> clone ]
|
||||
[ table>> ] tri set-at ;
|
||||
|
||||
: lzw-compress-char ( lzw k -- )
|
||||
>>k push-k dup omega-k-in-table? [
|
||||
omega-k>omega drop
|
||||
] [
|
||||
[ write-output ]
|
||||
[ add-omega-k ]
|
||||
[ k>omega drop ] tri
|
||||
] if ;
|
||||
|
||||
: (lzw-compress-chars) ( lzw -- )
|
||||
dup lzw-bit-width-compress table-full = [
|
||||
drop
|
||||
] [
|
||||
dup input>> stream-read1
|
||||
[ [ lzw-compress-char ] [ drop (lzw-compress-chars) ] 2bi ]
|
||||
[ t >>end-of-input? drop ] if*
|
||||
] if ;
|
||||
|
||||
: lzw-compress-chars ( lzw -- )
|
||||
{
|
||||
! [ [ 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) ]
|
||||
[
|
||||
[ 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 ;
|
||||
|
||||
: lzw-compress ( byte-array -- seq )
|
||||
binary <byte-reader> <lzw-compress>
|
||||
[ lzw-compress-chars ] [ output>> stream>> ] bi ;
|
||||
|
||||
: lookup-old-code ( lzw -- vector )
|
||||
[ old-code>> ] [ table>> ] bi nth ;
|
||||
|
||||
: lookup-code ( lzw -- vector )
|
||||
[ code>> ] [ table>> ] bi nth ;
|
||||
|
||||
: code-in-table? ( lzw -- ? )
|
||||
[ code>> ] [ table>> length ] bi < ;
|
||||
|
||||
: code>old-code ( lzw -- lzw )
|
||||
dup code>> >>old-code ;
|
||||
|
||||
: write-code ( lzw -- )
|
||||
[ lookup-code ] [ output>> ] bi push-all ;
|
||||
|
||||
: add-to-table ( seq lzw -- ) table>> push ;
|
||||
|
||||
: lzw-read ( lzw -- lzw n )
|
||||
[ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ;
|
||||
|
||||
DEFER: lzw-uncompress-char
|
||||
: handle-clear-code ( lzw -- )
|
||||
reset-lzw-uncompress
|
||||
lzw-read dup end-of-information = [
|
||||
2drop
|
||||
] [
|
||||
>>code
|
||||
[ write-code ]
|
||||
[ code>old-code ] bi
|
||||
lzw-uncompress-char
|
||||
] if ;
|
||||
|
||||
: handle-uncompress-code ( lzw -- lzw )
|
||||
dup code-in-table? [
|
||||
[ write-code ]
|
||||
[
|
||||
[
|
||||
[ lookup-old-code ]
|
||||
[ lookup-code first ] bi suffix
|
||||
] [ add-to-table ] bi
|
||||
] [ code>old-code ] tri
|
||||
] [
|
||||
[
|
||||
[ lookup-old-code dup first suffix ] keep
|
||||
[ output>> push-all ] [ add-to-table ] 2bi
|
||||
] [ code>old-code ] bi
|
||||
] if ;
|
||||
|
||||
: lzw-uncompress-char ( lzw -- )
|
||||
lzw-read [
|
||||
>>code
|
||||
dup code>> end-of-information = [
|
||||
drop
|
||||
] [
|
||||
dup code>> clear-code = [
|
||||
handle-clear-code
|
||||
] [
|
||||
handle-uncompress-code
|
||||
lzw-uncompress-char
|
||||
] if
|
||||
] if
|
||||
] [
|
||||
drop
|
||||
] if* ;
|
||||
|
||||
: lzw-uncompress ( seq -- byte-array )
|
||||
binary <byte-reader> <bitstream-reader>
|
||||
<lzw-uncompress> [ lzw-uncompress-char ] [ output>> ] bi ;
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.syntax combinators system ;
|
||||
IN: zlib.ffi
|
||||
IN: compression.zlib.ffi
|
||||
|
||||
<< "zlib" {
|
||||
{ [ os winnt? ] [ "zlib1.dll" ] }
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel tools.test zlib classes ;
|
||||
IN: zlib.tests
|
||||
USING: kernel tools.test compression.zlib classes ;
|
||||
IN: compression.zlib.tests
|
||||
|
||||
: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ;
|
||||
|
||||
|
|
@ -3,8 +3,8 @@
|
|||
USING: alien alien.c-types alien.syntax byte-arrays combinators
|
||||
kernel math math.functions sequences system accessors
|
||||
libc ;
|
||||
QUALIFIED: zlib.ffi
|
||||
IN: zlib
|
||||
QUALIFIED: compression.zlib.ffi
|
||||
IN: compression.zlib
|
||||
|
||||
TUPLE: compressed data length ;
|
||||
|
||||
|
|
@ -16,7 +16,7 @@ TUPLE: compressed data length ;
|
|||
ERROR: zlib-failed n string ;
|
||||
|
||||
: zlib-error-message ( n -- * )
|
||||
dup zlib.ffi:Z_ERRNO = [
|
||||
dup compression.zlib.ffi:Z_ERRNO = [
|
||||
drop errno "native libc error"
|
||||
] [
|
||||
dup {
|
||||
|
|
@ -27,7 +27,7 @@ ERROR: zlib-failed n string ;
|
|||
] if zlib-failed ;
|
||||
|
||||
: zlib-error ( n -- )
|
||||
dup zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ;
|
||||
dup compression.zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ;
|
||||
|
||||
: compressed-size ( byte-array -- n )
|
||||
length 1001/1000 * ceiling 12 + ;
|
||||
|
|
@ -35,7 +35,7 @@ ERROR: zlib-failed n string ;
|
|||
: compress ( byte-array -- compressed )
|
||||
[
|
||||
[ compressed-size <byte-array> dup length <ulong> ] keep [
|
||||
dup length zlib.ffi:compress zlib-error
|
||||
dup length compression.zlib.ffi:compress zlib-error
|
||||
] 3keep drop *ulong head
|
||||
] keep length <compressed> ;
|
||||
|
||||
|
|
@ -44,5 +44,5 @@ ERROR: zlib-failed n string ;
|
|||
length>> [ <byte-array> ] keep <ulong> 2dup
|
||||
] [
|
||||
data>> dup length
|
||||
zlib.ffi:uncompress zlib-error
|
||||
compression.zlib.ffi:uncompress zlib-error
|
||||
] bi *ulong head ;
|
||||
|
|
@ -152,7 +152,7 @@ HOOK: %loop-entry cpu ( -- )
|
|||
HOOK: small-enough? cpu ( n -- ? )
|
||||
|
||||
! Is this structure small enough to be returned in registers?
|
||||
HOOK: struct-small-enough? cpu ( c-type -- ? )
|
||||
HOOK: return-struct-in-registers? cpu ( c-type -- ? )
|
||||
|
||||
! Do we pass this struct by value or hidden reference?
|
||||
HOOK: value-struct? cpu ( c-type -- ? )
|
||||
|
|
|
|||
|
|
@ -659,7 +659,7 @@ M: ppc %callback-value ( ctype -- )
|
|||
|
||||
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
|
||||
|
||||
M: ppc struct-small-enough? ( size -- ? ) drop f ;
|
||||
M: ppc return-struct-in-registers? ( c-type -- ? ) drop f ;
|
||||
|
||||
M: ppc %box-small-struct
|
||||
drop "No small structs" throw ;
|
||||
|
|
|
|||
|
|
@ -48,9 +48,12 @@ M: x86.32 %alien-invoke (CALL) rel-dlsym ;
|
|||
|
||||
M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
|
||||
|
||||
M: x86.32 struct-small-enough? ( size -- ? )
|
||||
heap-size { 1 2 4 8 } member?
|
||||
os { linux netbsd solaris } member? not and ;
|
||||
M: x86.32 return-struct-in-registers? ( c-type -- ? )
|
||||
c-type
|
||||
[ return-in-registers?>> ]
|
||||
[ heap-size { 1 2 4 8 } member? ] bi
|
||||
os { linux netbsd solaris } member? not
|
||||
and or ;
|
||||
|
||||
: struct-return@ ( n -- operand )
|
||||
[ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ M: struct-type flatten-value-type ( type -- seq )
|
|||
flatten-small-struct
|
||||
] if ;
|
||||
|
||||
M: x86.64 struct-small-enough? ( size -- ? )
|
||||
M: x86.64 return-struct-in-registers? ( c-type -- ? )
|
||||
heap-size 2 cells <= ;
|
||||
|
||||
M: x86.64 dummy-stack-params? f ;
|
||||
|
|
|
|||
|
|
@ -10,7 +10,8 @@ M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
|
|||
|
||||
M: x86.64 reserved-area-size 4 cells ;
|
||||
|
||||
M: x86.64 struct-small-enough? heap-size { 1 2 4 8 } member? ;
|
||||
M: x86.64 return-struct-in-registers? ( c-type -- ? )
|
||||
heap-size { 1 2 4 8 } member? ;
|
||||
|
||||
M: x86.64 value-struct? heap-size { 1 2 4 8 } member? ;
|
||||
|
||||
|
|
|
|||
|
|
@ -11,46 +11,46 @@ IN: db.postgresql.ffi
|
|||
} cond "cdecl" add-library >>
|
||||
|
||||
! ConnSatusType
|
||||
: CONNECTION_OK HEX: 0 ; inline
|
||||
: CONNECTION_BAD HEX: 1 ; inline
|
||||
: CONNECTION_STARTED HEX: 2 ; inline
|
||||
: CONNECTION_MADE HEX: 3 ; inline
|
||||
: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline
|
||||
: CONNECTION_AUTH_OK HEX: 5 ; inline
|
||||
: CONNECTION_SETENV HEX: 6 ; inline
|
||||
: CONNECTION_SSL_STARTUP HEX: 7 ; inline
|
||||
: CONNECTION_NEEDED HEX: 8 ; inline
|
||||
CONSTANT: CONNECTION_OK HEX: 0
|
||||
CONSTANT: CONNECTION_BAD HEX: 1
|
||||
CONSTANT: CONNECTION_STARTED HEX: 2
|
||||
CONSTANT: CONNECTION_MADE HEX: 3
|
||||
CONSTANT: CONNECTION_AWAITING_RESPONSE HEX: 4
|
||||
CONSTANT: CONNECTION_AUTH_OK HEX: 5
|
||||
CONSTANT: CONNECTION_SETENV HEX: 6
|
||||
CONSTANT: CONNECTION_SSL_STARTUP HEX: 7
|
||||
CONSTANT: CONNECTION_NEEDED HEX: 8
|
||||
|
||||
! PostgresPollingStatusType
|
||||
: PGRES_POLLING_FAILED HEX: 0 ; inline
|
||||
: PGRES_POLLING_READING HEX: 1 ; inline
|
||||
: PGRES_POLLING_WRITING HEX: 2 ; inline
|
||||
: PGRES_POLLING_OK HEX: 3 ; inline
|
||||
: PGRES_POLLING_ACTIVE HEX: 4 ; inline
|
||||
CONSTANT: PGRES_POLLING_FAILED HEX: 0
|
||||
CONSTANT: PGRES_POLLING_READING HEX: 1
|
||||
CONSTANT: PGRES_POLLING_WRITING HEX: 2
|
||||
CONSTANT: PGRES_POLLING_OK HEX: 3
|
||||
CONSTANT: PGRES_POLLING_ACTIVE HEX: 4
|
||||
|
||||
! ExecStatusType;
|
||||
: PGRES_EMPTY_QUERY HEX: 0 ; inline
|
||||
: PGRES_COMMAND_OK HEX: 1 ; inline
|
||||
: PGRES_TUPLES_OK HEX: 2 ; inline
|
||||
: PGRES_COPY_OUT HEX: 3 ; inline
|
||||
: PGRES_COPY_IN HEX: 4 ; inline
|
||||
: PGRES_BAD_RESPONSE HEX: 5 ; inline
|
||||
: PGRES_NONFATAL_ERROR HEX: 6 ; inline
|
||||
: PGRES_FATAL_ERROR HEX: 7 ; inline
|
||||
CONSTANT: PGRES_EMPTY_QUERY HEX: 0
|
||||
CONSTANT: PGRES_COMMAND_OK HEX: 1
|
||||
CONSTANT: PGRES_TUPLES_OK HEX: 2
|
||||
CONSTANT: PGRES_COPY_OUT HEX: 3
|
||||
CONSTANT: PGRES_COPY_IN HEX: 4
|
||||
CONSTANT: PGRES_BAD_RESPONSE HEX: 5
|
||||
CONSTANT: PGRES_NONFATAL_ERROR HEX: 6
|
||||
CONSTANT: PGRES_FATAL_ERROR HEX: 7
|
||||
|
||||
! PGTransactionStatusType;
|
||||
: PQTRANS_IDLE HEX: 0 ; inline
|
||||
: PQTRANS_ACTIVE HEX: 1 ; inline
|
||||
: PQTRANS_INTRANS HEX: 2 ; inline
|
||||
: PQTRANS_INERROR HEX: 3 ; inline
|
||||
: PQTRANS_UNKNOWN HEX: 4 ; inline
|
||||
CONSTANT: PQTRANS_IDLE HEX: 0
|
||||
CONSTANT: PQTRANS_ACTIVE HEX: 1
|
||||
CONSTANT: PQTRANS_INTRANS HEX: 2
|
||||
CONSTANT: PQTRANS_INERROR HEX: 3
|
||||
CONSTANT: PQTRANS_UNKNOWN HEX: 4
|
||||
|
||||
! PGVerbosity;
|
||||
: PQERRORS_TERSE HEX: 0 ; inline
|
||||
: PQERRORS_DEFAULT HEX: 1 ; inline
|
||||
: PQERRORS_VERBOSE HEX: 2 ; inline
|
||||
CONSTANT: PQERRORS_TERSE HEX: 0
|
||||
CONSTANT: PQERRORS_DEFAULT HEX: 1
|
||||
CONSTANT: PQERRORS_VERBOSE HEX: 2
|
||||
|
||||
: InvalidOid 0 ; inline
|
||||
CONSTANT: InvalidOid 0
|
||||
|
||||
TYPEDEF: int ConnStatusType
|
||||
TYPEDEF: int ExecStatusType
|
||||
|
|
@ -348,21 +348,21 @@ FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
|
|||
FUNCTION: int PQenv2encoding ( ) ;
|
||||
|
||||
! From git, include/catalog/pg_type.h
|
||||
: BOOL-OID 16 ; inline
|
||||
: BYTEA-OID 17 ; inline
|
||||
: CHAR-OID 18 ; inline
|
||||
: NAME-OID 19 ; inline
|
||||
: INT8-OID 20 ; inline
|
||||
: INT2-OID 21 ; inline
|
||||
: INT4-OID 23 ; inline
|
||||
: TEXT-OID 23 ; inline
|
||||
: OID-OID 26 ; inline
|
||||
: FLOAT4-OID 700 ; inline
|
||||
: FLOAT8-OID 701 ; inline
|
||||
: VARCHAR-OID 1043 ; inline
|
||||
: DATE-OID 1082 ; inline
|
||||
: TIME-OID 1083 ; inline
|
||||
: TIMESTAMP-OID 1114 ; inline
|
||||
: TIMESTAMPTZ-OID 1184 ; inline
|
||||
: INTERVAL-OID 1186 ; inline
|
||||
: NUMERIC-OID 1700 ; inline
|
||||
CONSTANT: BOOL-OID 16
|
||||
CONSTANT: BYTEA-OID 17
|
||||
CONSTANT: CHAR-OID 18
|
||||
CONSTANT: NAME-OID 19
|
||||
CONSTANT: INT8-OID 20
|
||||
CONSTANT: INT2-OID 21
|
||||
CONSTANT: INT4-OID 23
|
||||
CONSTANT: TEXT-OID 23
|
||||
CONSTANT: OID-OID 26
|
||||
CONSTANT: FLOAT4-OID 700
|
||||
CONSTANT: FLOAT8-OID 701
|
||||
CONSTANT: VARCHAR-OID 1043
|
||||
CONSTANT: DATE-OID 1082
|
||||
CONSTANT: TIME-OID 1083
|
||||
CONSTANT: TIMESTAMP-OID 1114
|
||||
CONSTANT: TIMESTAMPTZ-OID 1184
|
||||
CONSTANT: INTERVAL-OID 1186
|
||||
CONSTANT: NUMERIC-OID 1700
|
||||
|
|
|
|||
|
|
@ -44,11 +44,11 @@ M: retryable execute-statement* ( statement type -- )
|
|||
] bi attempt-all drop ;
|
||||
|
||||
: sql-props ( class -- columns table )
|
||||
[ db-columns ] [ db-table ] bi ;
|
||||
[ db-columns ] [ db-table-name ] bi ;
|
||||
|
||||
: query-make ( class quot -- statements )
|
||||
#! query, input, outputs, secondary queries
|
||||
over unparse "table" set
|
||||
over db-table-name "table-name" set
|
||||
[ sql-props ] dip
|
||||
[ 0 sql-counter rot with-variable ] curry
|
||||
{ "" { } { } { } } nmake
|
||||
|
|
|
|||
|
|
@ -13,33 +13,33 @@ IN: db.sqlite.ffi
|
|||
} cond "cdecl" add-library >>
|
||||
|
||||
! Return values from sqlite functions
|
||||
: SQLITE_OK 0 ; inline ! Successful result
|
||||
: SQLITE_ERROR 1 ; inline ! SQL error or missing database
|
||||
: SQLITE_INTERNAL 2 ; inline ! An internal logic error in SQLite
|
||||
: SQLITE_PERM 3 ; inline ! Access permission denied
|
||||
: SQLITE_ABORT 4 ; inline ! Callback routine requested an abort
|
||||
: SQLITE_BUSY 5 ; inline ! The database file is locked
|
||||
: SQLITE_LOCKED 6 ; inline ! A table in the database is locked
|
||||
: SQLITE_NOMEM 7 ; inline ! A malloc() failed
|
||||
: SQLITE_READONLY 8 ; inline ! Attempt to write a readonly database
|
||||
: SQLITE_INTERRUPT 9 ; inline ! Operation terminated by sqlite_interrupt()
|
||||
: SQLITE_IOERR 10 ; inline ! Some kind of disk I/O error occurred
|
||||
: SQLITE_CORRUPT 11 ; inline ! The database disk image is malformed
|
||||
: SQLITE_NOTFOUND 12 ; inline ! (Internal Only) Table or record not found
|
||||
: SQLITE_FULL 13 ; inline ! Insertion failed because database is full
|
||||
: SQLITE_CANTOPEN 14 ; inline ! Unable to open the database file
|
||||
: SQLITE_PROTOCOL 15 ; inline ! Database lock protocol error
|
||||
: SQLITE_EMPTY 16 ; inline ! (Internal Only) Database table is empty
|
||||
: SQLITE_SCHEMA 17 ; inline ! The database schema changed
|
||||
: SQLITE_TOOBIG 18 ; inline ! Too much data for one row of a table
|
||||
: SQLITE_CONSTRAINT 19 ; inline ! Abort due to contraint violation
|
||||
: SQLITE_MISMATCH 20 ; inline ! Data type mismatch
|
||||
: SQLITE_MISUSE 21 ; inline ! Library used incorrectly
|
||||
: SQLITE_NOLFS 22 ; inline ! Uses OS features not supported on host
|
||||
: SQLITE_AUTH 23 ; inline ! Authorization denied
|
||||
: SQLITE_FORMAT 24 ; inline ! Auxiliary database format error
|
||||
: SQLITE_RANGE 25 ; inline ! 2nd parameter to sqlite3_bind out of range
|
||||
: SQLITE_NOTADB 26 ; inline ! File opened that is not a database file
|
||||
CONSTANT: SQLITE_OK 0 ! Successful result
|
||||
CONSTANT: SQLITE_ERROR 1 ! SQL error or missing database
|
||||
CONSTANT: SQLITE_INTERNAL 2 ! An internal logic error in SQLite
|
||||
CONSTANT: SQLITE_PERM 3 ! Access permission denied
|
||||
CONSTANT: SQLITE_ABORT 4 ! Callback routine requested an abort
|
||||
CONSTANT: SQLITE_BUSY 5 ! The database file is locked
|
||||
CONSTANT: SQLITE_LOCKED 6 ! A table in the database is locked
|
||||
CONSTANT: SQLITE_NOMEM 7 ! A malloc() failed
|
||||
CONSTANT: SQLITE_READONLY 8 ! Attempt to write a readonly database
|
||||
CONSTANT: SQLITE_INTERRUPT 9 ! Operation terminated by sqlite_interrupt()
|
||||
CONSTANT: SQLITE_IOERR 10 ! Some kind of disk I/O error occurred
|
||||
CONSTANT: SQLITE_CORRUPT 11 ! The database disk image is malformed
|
||||
CONSTANT: SQLITE_NOTFOUND 12 ! (Internal Only) Table or record not found
|
||||
CONSTANT: SQLITE_FULL 13 ! Insertion failed because database is full
|
||||
CONSTANT: SQLITE_CANTOPEN 14 ! Unable to open the database file
|
||||
CONSTANT: SQLITE_PROTOCOL 15 ! Database lock protocol error
|
||||
CONSTANT: SQLITE_EMPTY 16 ! (Internal Only) Database table is empty
|
||||
CONSTANT: SQLITE_SCHEMA 17 ! The database schema changed
|
||||
CONSTANT: SQLITE_TOOBIG 18 ! Too much data for one row of a table
|
||||
CONSTANT: SQLITE_CONSTRAINT 19 ! Abort due to contraint violation
|
||||
CONSTANT: SQLITE_MISMATCH 20 ! Data type mismatch
|
||||
CONSTANT: SQLITE_MISUSE 21 ! Library used incorrectly
|
||||
CONSTANT: SQLITE_NOLFS 22 ! Uses OS features not supported on host
|
||||
CONSTANT: SQLITE_AUTH 23 ! Authorization denied
|
||||
CONSTANT: SQLITE_FORMAT 24 ! Auxiliary database format error
|
||||
CONSTANT: SQLITE_RANGE 25 ! 2nd parameter to sqlite3_bind out of range
|
||||
CONSTANT: SQLITE_NOTADB 26 ! File opened that is not a database file
|
||||
|
||||
: sqlite-error-messages ( -- seq ) {
|
||||
"Successful result"
|
||||
|
|
@ -72,32 +72,32 @@ IN: db.sqlite.ffi
|
|||
} ;
|
||||
|
||||
! Return values from sqlite3_step
|
||||
: SQLITE_ROW 100 ; inline
|
||||
: SQLITE_DONE 101 ; inline
|
||||
CONSTANT: SQLITE_ROW 100
|
||||
CONSTANT: SQLITE_DONE 101
|
||||
|
||||
! Return values from the sqlite3_column_type function
|
||||
: SQLITE_INTEGER 1 ; inline
|
||||
: SQLITE_FLOAT 2 ; inline
|
||||
: SQLITE_TEXT 3 ; inline
|
||||
: SQLITE_BLOB 4 ; inline
|
||||
: SQLITE_NULL 5 ; inline
|
||||
CONSTANT: SQLITE_INTEGER 1
|
||||
CONSTANT: SQLITE_FLOAT 2
|
||||
CONSTANT: SQLITE_TEXT 3
|
||||
CONSTANT: SQLITE_BLOB 4
|
||||
CONSTANT: SQLITE_NULL 5
|
||||
|
||||
! Values for the 'destructor' parameter of the 'bind' routines.
|
||||
: SQLITE_STATIC 0 ; inline
|
||||
: SQLITE_TRANSIENT -1 ; inline
|
||||
CONSTANT: SQLITE_STATIC 0
|
||||
CONSTANT: SQLITE_TRANSIENT -1
|
||||
|
||||
: SQLITE_OPEN_READONLY HEX: 00000001 ; inline
|
||||
: SQLITE_OPEN_READWRITE HEX: 00000002 ; inline
|
||||
: SQLITE_OPEN_CREATE HEX: 00000004 ; inline
|
||||
: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008 ; inline
|
||||
: SQLITE_OPEN_EXCLUSIVE HEX: 00000010 ; inline
|
||||
: SQLITE_OPEN_MAIN_DB HEX: 00000100 ; inline
|
||||
: SQLITE_OPEN_TEMP_DB HEX: 00000200 ; inline
|
||||
: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400 ; inline
|
||||
: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800 ; inline
|
||||
: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 ; inline
|
||||
: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 ; inline
|
||||
: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 ; inline
|
||||
CONSTANT: SQLITE_OPEN_READONLY HEX: 00000001
|
||||
CONSTANT: SQLITE_OPEN_READWRITE HEX: 00000002
|
||||
CONSTANT: SQLITE_OPEN_CREATE HEX: 00000004
|
||||
CONSTANT: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008
|
||||
CONSTANT: SQLITE_OPEN_EXCLUSIVE HEX: 00000010
|
||||
CONSTANT: SQLITE_OPEN_MAIN_DB HEX: 00000100
|
||||
CONSTANT: SQLITE_OPEN_TEMP_DB HEX: 00000200
|
||||
CONSTANT: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400
|
||||
CONSTANT: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800
|
||||
CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000
|
||||
CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000
|
||||
CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000
|
||||
|
||||
TYPEDEF: void sqlite3
|
||||
TYPEDEF: void sqlite3_stmt
|
||||
|
|
|
|||
|
|
@ -95,3 +95,73 @@ things "THINGS" {
|
|||
things drop-table
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
! Tables can have different names than the name of the tuple
|
||||
TUPLE: foo slot ;
|
||||
C: <foo> foo
|
||||
foo "BAR" { { "slot" "SOMETHING" INTEGER +not-null+ } } define-persistent
|
||||
|
||||
TUPLE: hi bye try ;
|
||||
C: <hi> hi
|
||||
hi "HELLO" {
|
||||
{ "bye" "BUHBYE" INTEGER { +foreign-id+ foo "SOMETHING" } }
|
||||
{ "try" "RETHROW" INTEGER { +foreign-id+ foo "SOMETHING" } }
|
||||
} define-persistent
|
||||
|
||||
[ T{ foo { slot 1 } } T{ hi { bye 1 } { try 1 } } ] [
|
||||
test.db [
|
||||
foo create-table
|
||||
hi create-table
|
||||
1 <foo> insert-tuple
|
||||
f <foo> select-tuple
|
||||
1 1 <hi> insert-tuple
|
||||
f <hi> select-tuple
|
||||
hi drop-table
|
||||
foo drop-table
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
test.db [
|
||||
hi create-table
|
||||
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
|
||||
|
|
|
|||
|
|
@ -225,11 +225,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
: insert-trigger ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fki_${table}_${foreign-table}_id
|
||||
BEFORE INSERT ON ${table}
|
||||
CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
|
||||
BEFORE INSERT ON ${table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
|
@ -237,12 +237,12 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
: insert-trigger-not-null ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fki_${table}_${foreign-table}_id
|
||||
BEFORE INSERT ON ${table}
|
||||
CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
|
||||
BEFORE INSERT ON ${table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
|
||||
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
|
||||
WHERE NEW.${foreign-table-id} IS NOT NULL
|
||||
AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
|
@ -250,11 +250,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
: update-trigger ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fku_${table}_${foreign-table}_id
|
||||
BEFORE UPDATE ON ${table}
|
||||
CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
|
||||
BEFORE UPDATE ON ${table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
|
@ -262,12 +262,12 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
: update-trigger-not-null ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fku_${table}_${foreign-table}_id
|
||||
BEFORE UPDATE ON ${table}
|
||||
CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
|
||||
BEFORE UPDATE ON ${table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
|
||||
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
|
||||
WHERE NEW.${foreign-table-id} IS NOT NULL
|
||||
AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
|
@ -275,11 +275,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
: delete-trigger-restrict ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fkd_${table}_${foreign-table}_id
|
||||
BEFORE DELETE ON ${foreign-table}
|
||||
CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
|
||||
BEFORE DELETE ON ${foreign-table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
|
||||
SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
|
@ -287,10 +287,10 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
: delete-trigger-cascade ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fkd_${table}_${foreign-table}_id
|
||||
BEFORE DELETE ON ${foreign-table}
|
||||
CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
|
||||
BEFORE DELETE ON ${foreign-table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id};
|
||||
DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
|
@ -323,7 +323,7 @@ M: sqlite-db-connection compound ( string seq -- new-string )
|
|||
{ "default" [ first number>string " " glue ] }
|
||||
{ "references" [
|
||||
[ >reference-string ] keep
|
||||
first2 [ "foreign-table" set ]
|
||||
first2 [ db-table-name "foreign-table-name" set ]
|
||||
[ "foreign-table-id" set ] bi*
|
||||
create-sqlite-triggers
|
||||
] }
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ ERROR: no-slot ;
|
|||
|
||||
ERROR: not-persistent class ;
|
||||
|
||||
: db-table ( class -- object )
|
||||
: db-table-name ( class -- object )
|
||||
dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
|
||||
|
||||
: db-columns ( class -- object )
|
||||
|
|
@ -165,7 +165,7 @@ ERROR: no-column column ;
|
|||
|
||||
: >reference-string ( string pair -- string )
|
||||
first2
|
||||
[ [ unparse " " glue ] [ db-columns ] bi ] dip
|
||||
[ [ db-table-name " " glue ] [ db-columns ] bi ] dip
|
||||
swap [ column-name>> = ] with find nip
|
||||
[ no-column ] unless*
|
||||
column-name>> "(" ")" surround append ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser lexer kernel namespaces sequences definitions
|
||||
io.files io.backend io.pathnames io summary continuations
|
||||
tools.crossref tools.vocabs prettyprint source-files assocs
|
||||
vocabs vocabs.loader splitting accessors ;
|
||||
vocabs vocabs.loader splitting accessors debugger prettyprint
|
||||
help.topics ;
|
||||
IN: editors
|
||||
|
||||
TUPLE: no-edit-hook ;
|
||||
|
|
@ -29,11 +30,21 @@ SYMBOL: edit-hook
|
|||
[ (normalize-path) ] dip edit-hook get-global
|
||||
[ call ] [ no-edit-hook edit-location ] if* ;
|
||||
|
||||
ERROR: cannot-find-source definition ;
|
||||
|
||||
M: cannot-find-source error.
|
||||
"Cannot find source for ``" write
|
||||
definition>> pprint-short
|
||||
"''" print ;
|
||||
|
||||
: edit ( defspec -- )
|
||||
where [ first2 edit-location ] when* ;
|
||||
dup where
|
||||
[ first2 edit-location ]
|
||||
[ dup word-link? [ name>> edit ] [ cannot-find-source ] if ]
|
||||
?if ;
|
||||
|
||||
: edit-vocab ( name -- )
|
||||
vocab-source-path 1 edit-location ;
|
||||
>vocab-link edit ;
|
||||
|
||||
GENERIC: error-file ( error -- 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
|
||||
|
|
|
|||
|
|
@ -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:"
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: <get-request> ( url -- request )
|
||||
"GET" <client-request> ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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" <cookie> put-cookie drop "a" get-cookie ] unit-test
|
||||
|
||||
! Test basic auth
|
||||
[ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ <request> "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
request new
|
||||
"1.1" >>version
|
||||
|
|
@ -156,6 +160,7 @@ cookies ;
|
|||
: header ( request/response key -- value )
|
||||
swap header>> at ;
|
||||
|
||||
|
||||
TUPLE: response
|
||||
version
|
||||
code
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,51 +0,0 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel grouping fry sequences combinators
|
||||
math ;
|
||||
IN: images.backend
|
||||
|
||||
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;
|
||||
|
||||
TUPLE: image dim component-order bitmap ;
|
||||
|
||||
TUPLE: normalized-image < image ;
|
||||
|
||||
GENERIC: load-image* ( path tuple -- image )
|
||||
|
||||
GENERIC: >image ( object -- image )
|
||||
|
||||
: no-op ( -- ) ;
|
||||
|
||||
: normalize-component-order ( image -- image )
|
||||
dup component-order>>
|
||||
{
|
||||
{ RGBA [ no-op ] }
|
||||
{ BGRA [
|
||||
[
|
||||
[ 4 <sliced-groups> [ [ 0 3 ] dip <slice> reverse-here ] each ]
|
||||
[ RGBA >>component-order ] bi
|
||||
] change-bitmap
|
||||
] }
|
||||
{ RGB [
|
||||
[ 3 <sliced-groups> [ 255 suffix ] map concat ] change-bitmap
|
||||
] }
|
||||
{ BGR [
|
||||
[
|
||||
3 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
|
||||
[ 255 suffix ] map concat
|
||||
] change-bitmap
|
||||
] }
|
||||
} case RGBA >>component-order ;
|
||||
|
||||
GENERIC: normalize-scan-line-order ( image -- image )
|
||||
|
||||
M: image normalize-scan-line-order ;
|
||||
: normalize-image ( image -- image )
|
||||
normalize-component-order
|
||||
normalize-scan-line-order ;
|
||||
|
||||
: new-image ( dim component-order bitmap class -- image )
|
||||
new
|
||||
swap >>bitmap
|
||||
swap >>component-order
|
||||
swap >>dim ; inline
|
||||
|
|
@ -3,16 +3,16 @@ io.files io.files.unique kernel tools.test ;
|
|||
IN: images.bitmap.tests
|
||||
|
||||
: test-bitmap24 ( -- path )
|
||||
"resource:extra/images/test-images/thiswayup24.bmp" ;
|
||||
"resource:basis/images/test-images/thiswayup24.bmp" ;
|
||||
|
||||
: test-bitmap8 ( -- path )
|
||||
"resource:extra/images/test-images/rgb8bit.bmp" ;
|
||||
"resource:basis/images/test-images/rgb8bit.bmp" ;
|
||||
|
||||
: test-bitmap4 ( -- path )
|
||||
"resource:extra/images/test-images/rgb4bit.bmp" ;
|
||||
"resource:basis/images/test-images/rgb4bit.bmp" ;
|
||||
|
||||
: test-bitmap1 ( -- path )
|
||||
"resource:extra/images/test-images/1bit.bmp" ;
|
||||
"resource:basis/images/test-images/1bit.bmp" ;
|
||||
|
||||
[ t ]
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,10 +1,9 @@
|
|||
! Copyright (C) 2007, 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.c-types arrays byte-arrays columns
|
||||
combinators fry grouping io io.binary io.encodings.binary
|
||||
io.files kernel libc macros math math.bitwise math.functions
|
||||
namespaces opengl opengl.gl prettyprint sequences strings
|
||||
summary ui ui.gadgets.panes images.backend ;
|
||||
combinators fry grouping io io.binary io.encodings.binary io.files
|
||||
kernel macros math math.bitwise math.functions namespaces sequences
|
||||
strings images endian summary ;
|
||||
IN: images.bitmap
|
||||
|
||||
TUPLE: bitmap-image < image ;
|
||||
|
|
@ -102,12 +101,12 @@ ERROR: unknown-component-order bitmap ;
|
|||
[ unknown-component-order ]
|
||||
} case ;
|
||||
|
||||
M: bitmap >image ( bitmap -- bitmap-image )
|
||||
: >image ( bitmap -- bitmap-image )
|
||||
{
|
||||
[ [ width>> ] [ height>> ] bi 2array ]
|
||||
[ bitmap>component-order ]
|
||||
[ buffer>> ]
|
||||
} cleave bitmap-image new-image ;
|
||||
} cleave bitmap-image boa ;
|
||||
|
||||
M: bitmap-image load-image* ( path bitmap -- bitmap-image )
|
||||
drop load-bitmap >image ;
|
||||
|
|
|
|||
|
|
@ -1,21 +1,62 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: constructors kernel splitting unicode.case combinators
|
||||
accessors images.bitmap images.tiff images.backend io.backend
|
||||
io.pathnames ;
|
||||
USING: kernel accessors grouping sequences combinators
|
||||
math specialized-arrays.direct.uint byte-arrays
|
||||
specialized-arrays.direct.ushort ;
|
||||
IN: images
|
||||
|
||||
ERROR: unknown-image-extension extension ;
|
||||
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
|
||||
R16G16B16 R32G32B32 ;
|
||||
|
||||
: image-class ( path -- class )
|
||||
file-extension >lower {
|
||||
{ "bmp" [ bitmap-image ] }
|
||||
{ "tiff" [ tiff-image ] }
|
||||
[ unknown-image-extension ]
|
||||
} case ;
|
||||
TUPLE: image dim component-order bitmap ;
|
||||
|
||||
: load-image ( path -- image )
|
||||
dup image-class new load-image* ;
|
||||
: <image> ( -- image ) image new ; inline
|
||||
|
||||
: <image> ( path -- image )
|
||||
load-image normalize-image ;
|
||||
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 [ [ add-dummy-alpha ] change-bitmap ] }
|
||||
{ BGR [
|
||||
[
|
||||
3 <sliced-groups>
|
||||
[ [ [ 0 3 ] dip <slice> reverse-here ] each ]
|
||||
[ add-dummy-alpha ] bi
|
||||
] change-bitmap
|
||||
] }
|
||||
} case
|
||||
RGBA >>component-order ;
|
||||
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: constructors kernel splitting unicode.case combinators
|
||||
accessors images.bitmap images.tiff images io.backend
|
||||
io.pathnames ;
|
||||
IN: images.loader
|
||||
|
||||
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 ;
|
||||
|
||||
: load-image ( path -- image )
|
||||
dup image-class new load-image* normalize-image ;
|
||||
|
Before Width: | Height: | Size: 1.6 KiB After Width: | Height: | Size: 1.6 KiB |
|
Before Width: | Height: | Size: 5.2 KiB After Width: | Height: | Size: 5.2 KiB |
|
Before Width: | Height: | Size: 11 KiB After Width: | Height: | Size: 11 KiB |
|
Before Width: | Height: | Size: 59 KiB After Width: | Height: | Size: 59 KiB |
|
|
@ -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.backend ;
|
||||
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,51 +247,93 @@ 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 )
|
||||
dup ifd-entries>>
|
||||
[ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ;
|
||||
|
||||
ERROR: unhandled-compression compression ;
|
||||
|
||||
: (uncompress-strips) ( strips compression -- uncompressed-strips )
|
||||
{
|
||||
{ compression-none [ ] }
|
||||
{ compression-lzw [ [ lzw-uncompress ] map ] }
|
||||
[ unhandled-compression ]
|
||||
} case ;
|
||||
|
||||
: uncompress-strips ( ifd -- ifd )
|
||||
dup '[
|
||||
_ compression find-tag (uncompress-strips)
|
||||
] change-strips ;
|
||||
|
||||
: strips>bitmap ( ifd -- ifd )
|
||||
dup strips>> concat >>bitmap ;
|
||||
|
||||
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 ;
|
||||
|
||||
M: ifd >image ( ifd -- image )
|
||||
: ifd>image ( ifd -- image )
|
||||
{
|
||||
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
|
||||
[ ifd-component-order ]
|
||||
[ bitmap>> ]
|
||||
} cleave tiff-image new-image ;
|
||||
} cleave tiff-image boa ;
|
||||
|
||||
M: parsed-tiff >image ( image -- image )
|
||||
ifds>> [ >image ] map first ;
|
||||
: tiff>image ( image -- image )
|
||||
ifds>> [ ifd>image ] map first ;
|
||||
|
||||
: load-tiff ( path -- parsed-tiff )
|
||||
binary [
|
||||
<parsed-tiff>
|
||||
read-header dup endianness>> [
|
||||
read-ifds
|
||||
dup ifds>> [ process-ifd read-strips strips>bitmap drop ] each
|
||||
dup ifds>> [
|
||||
process-ifd read-strips
|
||||
uncompress-strips
|
||||
strips>bitmap
|
||||
fix-bitmap-endianness
|
||||
drop
|
||||
] each
|
||||
] with-endianness
|
||||
] with-file-reader ;
|
||||
|
||||
! tiff files can store several images -- we just take the first for now
|
||||
M: tiff-image load-image* ( path tiff-image -- image )
|
||||
drop load-tiff >image ;
|
||||
drop load-tiff tiff>image ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -241,7 +241,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
|
|||
}
|
||||
"An example of using a changer:"
|
||||
{ $code
|
||||
": positions"
|
||||
": positions ( -- seq )"
|
||||
" {"
|
||||
" \"junior programmer\""
|
||||
" \"senior programmer\""
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel.private slots.private math.private
|
||||
classes.tuple.private ;
|
||||
|
|
@ -51,7 +51,7 @@ DEFER: if
|
|||
|
||||
! Default
|
||||
: ?if ( default cond true false -- )
|
||||
pick [ roll 2drop call ] [ 2nip call ] if ; inline
|
||||
pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline
|
||||
|
||||
! Slippers and dippers.
|
||||
! Not declared inline because the compiler special-cases them
|
||||
|
|
@ -138,6 +138,69 @@ DEFER: if
|
|||
: 2tri@ ( u v w y x z quot -- )
|
||||
dup dup 2tri* ; inline
|
||||
|
||||
! Quotation building
|
||||
: 2curry ( obj1 obj2 quot -- curry )
|
||||
curry curry ; inline
|
||||
|
||||
: 3curry ( obj1 obj2 obj3 quot -- curry )
|
||||
curry curry curry ; inline
|
||||
|
||||
: with ( param obj quot -- obj curry )
|
||||
swapd [ swapd call ] 2curry ; inline
|
||||
|
||||
: prepose ( quot1 quot2 -- compose )
|
||||
swap compose ; inline
|
||||
|
||||
! Curried cleavers
|
||||
<PRIVATE
|
||||
|
||||
: [curry] ( quot -- quot' ) [ curry ] curry ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: bi-curry ( x p q -- p' q' ) [ [curry] ] bi@ bi ; inline
|
||||
|
||||
: tri-curry ( x p q r -- p' q' r' ) [ [curry] ] tri@ tri ; inline
|
||||
|
||||
: bi-curry* ( x y p q -- p' q' ) [ [curry] ] bi@ bi* ; inline
|
||||
|
||||
: tri-curry* ( x y z p q r -- p' q' r' ) [ [curry] ] tri@ tri* ; inline
|
||||
|
||||
: bi-curry@ ( x y q -- p' q' ) [curry] bi@ ; inline
|
||||
|
||||
: tri-curry@ ( x y z q -- p' q' r' ) [curry] tri@ ; inline
|
||||
|
||||
! Booleans
|
||||
: not ( obj -- ? ) [ f ] [ t ] if ; inline
|
||||
|
||||
: and ( obj1 obj2 -- ? ) over ? ; inline
|
||||
|
||||
: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline
|
||||
|
||||
: or ( obj1 obj2 -- ? ) dupd ? ; inline
|
||||
|
||||
: xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline
|
||||
|
||||
: both? ( x y quot -- ? ) bi@ and ; inline
|
||||
|
||||
: either? ( x y quot -- ? ) bi@ or ; inline
|
||||
|
||||
: most ( x y quot -- z )
|
||||
[ 2dup ] dip call [ drop ] [ nip ] if ; inline
|
||||
|
||||
! Loops
|
||||
: loop ( pred: ( -- ? ) -- )
|
||||
[ call ] keep [ loop ] curry when ; inline recursive
|
||||
|
||||
: do ( pred body tail -- pred body tail )
|
||||
over 3dip ; inline
|
||||
|
||||
: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
|
||||
[ pick 3dip [ do while ] 3curry ] keep if ; inline recursive
|
||||
|
||||
: until ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
|
||||
[ [ not ] compose ] 2dip while ; inline
|
||||
|
||||
! Object protocol
|
||||
GENERIC: hashcode* ( depth obj -- code )
|
||||
|
||||
|
|
@ -171,50 +234,6 @@ GENERIC: new ( class -- tuple )
|
|||
|
||||
GENERIC: boa ( ... class -- tuple )
|
||||
|
||||
! Quotation building
|
||||
: 2curry ( obj1 obj2 quot -- curry )
|
||||
curry curry ; inline
|
||||
|
||||
: 3curry ( obj1 obj2 obj3 quot -- curry )
|
||||
curry curry curry ; inline
|
||||
|
||||
: with ( param obj quot -- obj curry )
|
||||
swapd [ swapd call ] 2curry ; inline
|
||||
|
||||
: prepose ( quot1 quot2 -- compose )
|
||||
swap compose ; inline
|
||||
|
||||
! Booleans
|
||||
: not ( obj -- ? ) [ f ] [ t ] if ; inline
|
||||
|
||||
: and ( obj1 obj2 -- ? ) over ? ; inline
|
||||
|
||||
: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline
|
||||
|
||||
: or ( obj1 obj2 -- ? ) dupd ? ; inline
|
||||
|
||||
: xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline
|
||||
|
||||
: both? ( x y quot -- ? ) bi@ and ; inline
|
||||
|
||||
: either? ( x y quot -- ? ) bi@ or ; inline
|
||||
|
||||
: most ( x y quot -- z )
|
||||
[ 2dup ] dip call [ drop ] [ nip ] if ; inline
|
||||
|
||||
! Loops
|
||||
: loop ( pred: ( -- ? ) -- )
|
||||
dup slip swap [ loop ] [ drop ] if ; inline recursive
|
||||
|
||||
: do ( pred body tail -- pred body tail )
|
||||
over 3dip ; inline
|
||||
|
||||
: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
|
||||
[ pick 3dip [ do while ] 3curry ] keep if ; inline recursive
|
||||
|
||||
: until ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
|
||||
[ [ not ] compose ] 2dip while ; inline
|
||||
|
||||
! Error handling -- defined early so that other files can
|
||||
! throw errors before continuations are loaded
|
||||
: throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors images images.backend io.pathnames kernel
|
||||
USING: accessors images images.loader io.pathnames kernel
|
||||
namespaces opengl opengl.gl sequences strings ui ui.gadgets
|
||||
ui.gadgets.panes ui.render ;
|
||||
IN: images.viewer
|
||||
|
|
@ -23,15 +23,15 @@ M: image-gadget draw-gadget* ( gadget -- )
|
|||
swap >>image ;
|
||||
|
||||
: image-window ( path -- gadget )
|
||||
[ <image> <image-gadget> dup ] [ open-window ] bi ;
|
||||
[ load-image <image-gadget> dup ] [ open-window ] bi ;
|
||||
|
||||
GENERIC: image. ( object -- )
|
||||
|
||||
: default-image. ( path -- )
|
||||
<image-gadget> gadget. ;
|
||||
|
||||
M: string image. ( image -- ) <image> default-image. ;
|
||||
M: string image. ( image -- ) load-image default-image. ;
|
||||
|
||||
M: pathname image. ( image -- ) <image> default-image. ;
|
||||
M: pathname image. ( image -- ) load-image default-image. ;
|
||||
|
||||
M: image image. ( image -- ) default-image. ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -5,8 +5,8 @@ system tools.hexdump io.encodings.binary summary accessors
|
|||
io.backend byte-arrays ;
|
||||
IN: tar
|
||||
|
||||
: zero-checksum 256 ; inline
|
||||
: block-size 512 ; inline
|
||||
CONSTANT: zero-checksum 256
|
||||
CONSTANT: block-size 512
|
||||
|
||||
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
|
||||
linkname magic version uname gname devmajor devminor prefix ;
|
||||
|
|
@ -89,8 +89,7 @@ M: unknown-typeflag summary ( obj -- str )
|
|||
|
||||
! Symlink
|
||||
: typeflag-2 ( header -- )
|
||||
[ name>> ] [ linkname>> ] bi
|
||||
[ make-link ] 2curry ignore-errors ;
|
||||
[ name>> ] [ linkname>> ] bi make-link ;
|
||||
|
||||
! character special
|
||||
: typeflag-3 ( header -- ) unknown-typeflag ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,100 @@
|
|||
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 twitter-source ;
|
||||
|
||||
twitter-source [ "factor" ] initialize
|
||||
|
||||
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 ;
|
||||
|
||||
: <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> ;
|
||||
|
||||
: 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
|
||||
[ twitter-source get "source" ] dip [ set-at ] keep ;
|
||||
|
||||
: (tweet) ( string -- json )
|
||||
update-post-data "https://twitter.com/statuses/update.json" <post-request>
|
||||
set-request-twitter-auth
|
||||
http-request nip ;
|
||||
|
||||
: tweet* ( string -- tweet )
|
||||
(tweet) json>twitter-status ;
|
||||
|
||||
: tweet ( string -- ) (tweet) drop ;
|
||||
|
||||
: public-timeline ( -- tweets )
|
||||
"https://twitter.com/statuses/public_timeline.json" <get-request>
|
||||
set-request-twitter-auth
|
||||
http-request nip json>twitter-statuses ;
|
||||
|
||||
: friends-timeline ( -- tweets )
|
||||
"https://twitter.com/statuses/friends_timeline.json" <get-request>
|
||||
set-request-twitter-auth
|
||||
http-request nip json>twitter-statuses ;
|
||||
|
||||
: user-timeline ( username -- tweets )
|
||||
"https://twitter.com/statuses/user_timeline/" ".json" surround <get-request>
|
||||
set-request-twitter-auth
|
||||
http-request nip json>twitter-statuses ;
|
||||
|
|
@ -4,7 +4,7 @@ USING: accessors colors arrays kernel sequences math byte-arrays
|
|||
namespaces grouping fry cap images.bitmap
|
||||
ui.gadgets ui.gadgets.packs ui.gadgets.borders ui.gadgets.grids
|
||||
ui.gadgets.grid-lines ui.gadgets.labels ui.gadgets.buttons
|
||||
ui.render ui opengl opengl.gl images ;
|
||||
ui.render ui opengl opengl.gl images images.loader ;
|
||||
IN: ui.render.test
|
||||
|
||||
SINGLETON: line-test
|
||||
|
|
@ -38,7 +38,7 @@ SYMBOL: render-output
|
|||
screenshot
|
||||
[ render-output set-global ]
|
||||
[
|
||||
"resource:extra/ui/render/test/reference.bmp" <image>
|
||||
"resource:extra/ui/render/test/reference.bmp" load-image
|
||||
bitmap= "is perfect" "needs work" ?
|
||||
"Your UI rendering " prepend
|
||||
message-window
|
||||
|
|
|
|||
Loading…
Reference in New Issue