Merge branch 'master' into new_ui
Slava Pestov
commit
67666b77de
|
|
@ -0,0 +1 @@
|
||||||
|
Doug Coleman
|
||||||
|
|
@ -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 ;
|
||||||
|
|
@ -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 ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Doug Coleman
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Doug Coleman
|
||||||
|
|
@ -0,0 +1,30 @@
|
||||||
|
! Copyright (C) 2009 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: alien alien.syntax combinators system ;
|
||||||
|
IN: compression.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 ) ;
|
||||||
|
|
@ -0,0 +1,9 @@
|
||||||
|
! Copyright (C) 2009 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: kernel tools.test compression.zlib classes ;
|
||||||
|
IN: compression.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
|
||||||
|
|
@ -0,0 +1,48 @@
|
||||||
|
! 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: compression.zlib.ffi
|
||||||
|
IN: compression.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 compression.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 compression.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 compression.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
|
||||||
|
compression.zlib.ffi:uncompress zlib-error
|
||||||
|
] bi *ulong head ;
|
||||||
|
|
@ -11,46 +11,46 @@ IN: db.postgresql.ffi
|
||||||
} cond "cdecl" add-library >>
|
} cond "cdecl" add-library >>
|
||||||
|
|
||||||
! ConnSatusType
|
! ConnSatusType
|
||||||
: CONNECTION_OK HEX: 0 ; inline
|
CONSTANT: CONNECTION_OK HEX: 0
|
||||||
: CONNECTION_BAD HEX: 1 ; inline
|
CONSTANT: CONNECTION_BAD HEX: 1
|
||||||
: CONNECTION_STARTED HEX: 2 ; inline
|
CONSTANT: CONNECTION_STARTED HEX: 2
|
||||||
: CONNECTION_MADE HEX: 3 ; inline
|
CONSTANT: CONNECTION_MADE HEX: 3
|
||||||
: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline
|
CONSTANT: CONNECTION_AWAITING_RESPONSE HEX: 4
|
||||||
: CONNECTION_AUTH_OK HEX: 5 ; inline
|
CONSTANT: CONNECTION_AUTH_OK HEX: 5
|
||||||
: CONNECTION_SETENV HEX: 6 ; inline
|
CONSTANT: CONNECTION_SETENV HEX: 6
|
||||||
: CONNECTION_SSL_STARTUP HEX: 7 ; inline
|
CONSTANT: CONNECTION_SSL_STARTUP HEX: 7
|
||||||
: CONNECTION_NEEDED HEX: 8 ; inline
|
CONSTANT: CONNECTION_NEEDED HEX: 8
|
||||||
|
|
||||||
! PostgresPollingStatusType
|
! PostgresPollingStatusType
|
||||||
: PGRES_POLLING_FAILED HEX: 0 ; inline
|
CONSTANT: PGRES_POLLING_FAILED HEX: 0
|
||||||
: PGRES_POLLING_READING HEX: 1 ; inline
|
CONSTANT: PGRES_POLLING_READING HEX: 1
|
||||||
: PGRES_POLLING_WRITING HEX: 2 ; inline
|
CONSTANT: PGRES_POLLING_WRITING HEX: 2
|
||||||
: PGRES_POLLING_OK HEX: 3 ; inline
|
CONSTANT: PGRES_POLLING_OK HEX: 3
|
||||||
: PGRES_POLLING_ACTIVE HEX: 4 ; inline
|
CONSTANT: PGRES_POLLING_ACTIVE HEX: 4
|
||||||
|
|
||||||
! ExecStatusType;
|
! ExecStatusType;
|
||||||
: PGRES_EMPTY_QUERY HEX: 0 ; inline
|
CONSTANT: PGRES_EMPTY_QUERY HEX: 0
|
||||||
: PGRES_COMMAND_OK HEX: 1 ; inline
|
CONSTANT: PGRES_COMMAND_OK HEX: 1
|
||||||
: PGRES_TUPLES_OK HEX: 2 ; inline
|
CONSTANT: PGRES_TUPLES_OK HEX: 2
|
||||||
: PGRES_COPY_OUT HEX: 3 ; inline
|
CONSTANT: PGRES_COPY_OUT HEX: 3
|
||||||
: PGRES_COPY_IN HEX: 4 ; inline
|
CONSTANT: PGRES_COPY_IN HEX: 4
|
||||||
: PGRES_BAD_RESPONSE HEX: 5 ; inline
|
CONSTANT: PGRES_BAD_RESPONSE HEX: 5
|
||||||
: PGRES_NONFATAL_ERROR HEX: 6 ; inline
|
CONSTANT: PGRES_NONFATAL_ERROR HEX: 6
|
||||||
: PGRES_FATAL_ERROR HEX: 7 ; inline
|
CONSTANT: PGRES_FATAL_ERROR HEX: 7
|
||||||
|
|
||||||
! PGTransactionStatusType;
|
! PGTransactionStatusType;
|
||||||
: PQTRANS_IDLE HEX: 0 ; inline
|
CONSTANT: PQTRANS_IDLE HEX: 0
|
||||||
: PQTRANS_ACTIVE HEX: 1 ; inline
|
CONSTANT: PQTRANS_ACTIVE HEX: 1
|
||||||
: PQTRANS_INTRANS HEX: 2 ; inline
|
CONSTANT: PQTRANS_INTRANS HEX: 2
|
||||||
: PQTRANS_INERROR HEX: 3 ; inline
|
CONSTANT: PQTRANS_INERROR HEX: 3
|
||||||
: PQTRANS_UNKNOWN HEX: 4 ; inline
|
CONSTANT: PQTRANS_UNKNOWN HEX: 4
|
||||||
|
|
||||||
! PGVerbosity;
|
! PGVerbosity;
|
||||||
: PQERRORS_TERSE HEX: 0 ; inline
|
CONSTANT: PQERRORS_TERSE HEX: 0
|
||||||
: PQERRORS_DEFAULT HEX: 1 ; inline
|
CONSTANT: PQERRORS_DEFAULT HEX: 1
|
||||||
: PQERRORS_VERBOSE HEX: 2 ; inline
|
CONSTANT: PQERRORS_VERBOSE HEX: 2
|
||||||
|
|
||||||
: InvalidOid 0 ; inline
|
CONSTANT: InvalidOid 0
|
||||||
|
|
||||||
TYPEDEF: int ConnStatusType
|
TYPEDEF: int ConnStatusType
|
||||||
TYPEDEF: int ExecStatusType
|
TYPEDEF: int ExecStatusType
|
||||||
|
|
@ -348,21 +348,21 @@ FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
|
||||||
FUNCTION: int PQenv2encoding ( ) ;
|
FUNCTION: int PQenv2encoding ( ) ;
|
||||||
|
|
||||||
! From git, include/catalog/pg_type.h
|
! From git, include/catalog/pg_type.h
|
||||||
: BOOL-OID 16 ; inline
|
CONSTANT: BOOL-OID 16
|
||||||
: BYTEA-OID 17 ; inline
|
CONSTANT: BYTEA-OID 17
|
||||||
: CHAR-OID 18 ; inline
|
CONSTANT: CHAR-OID 18
|
||||||
: NAME-OID 19 ; inline
|
CONSTANT: NAME-OID 19
|
||||||
: INT8-OID 20 ; inline
|
CONSTANT: INT8-OID 20
|
||||||
: INT2-OID 21 ; inline
|
CONSTANT: INT2-OID 21
|
||||||
: INT4-OID 23 ; inline
|
CONSTANT: INT4-OID 23
|
||||||
: TEXT-OID 23 ; inline
|
CONSTANT: TEXT-OID 23
|
||||||
: OID-OID 26 ; inline
|
CONSTANT: OID-OID 26
|
||||||
: FLOAT4-OID 700 ; inline
|
CONSTANT: FLOAT4-OID 700
|
||||||
: FLOAT8-OID 701 ; inline
|
CONSTANT: FLOAT8-OID 701
|
||||||
: VARCHAR-OID 1043 ; inline
|
CONSTANT: VARCHAR-OID 1043
|
||||||
: DATE-OID 1082 ; inline
|
CONSTANT: DATE-OID 1082
|
||||||
: TIME-OID 1083 ; inline
|
CONSTANT: TIME-OID 1083
|
||||||
: TIMESTAMP-OID 1114 ; inline
|
CONSTANT: TIMESTAMP-OID 1114
|
||||||
: TIMESTAMPTZ-OID 1184 ; inline
|
CONSTANT: TIMESTAMPTZ-OID 1184
|
||||||
: INTERVAL-OID 1186 ; inline
|
CONSTANT: INTERVAL-OID 1186
|
||||||
: NUMERIC-OID 1700 ; inline
|
CONSTANT: NUMERIC-OID 1700
|
||||||
|
|
|
||||||
|
|
@ -44,11 +44,11 @@ M: retryable execute-statement* ( statement type -- )
|
||||||
] bi attempt-all drop ;
|
] bi attempt-all drop ;
|
||||||
|
|
||||||
: sql-props ( class -- columns table )
|
: sql-props ( class -- columns table )
|
||||||
[ db-columns ] [ db-table ] bi ;
|
[ db-columns ] [ db-table-name ] bi ;
|
||||||
|
|
||||||
: query-make ( class quot -- statements )
|
: query-make ( class quot -- statements )
|
||||||
#! query, input, outputs, secondary queries
|
#! query, input, outputs, secondary queries
|
||||||
over unparse "table" set
|
over db-table-name "table-name" set
|
||||||
[ sql-props ] dip
|
[ sql-props ] dip
|
||||||
[ 0 sql-counter rot with-variable ] curry
|
[ 0 sql-counter rot with-variable ] curry
|
||||||
{ "" { } { } { } } nmake
|
{ "" { } { } { } } nmake
|
||||||
|
|
|
||||||
|
|
@ -13,33 +13,33 @@ IN: db.sqlite.ffi
|
||||||
} cond "cdecl" add-library >>
|
} cond "cdecl" add-library >>
|
||||||
|
|
||||||
! Return values from sqlite functions
|
! Return values from sqlite functions
|
||||||
: SQLITE_OK 0 ; inline ! Successful result
|
CONSTANT: SQLITE_OK 0 ! Successful result
|
||||||
: SQLITE_ERROR 1 ; inline ! SQL error or missing database
|
CONSTANT: SQLITE_ERROR 1 ! SQL error or missing database
|
||||||
: SQLITE_INTERNAL 2 ; inline ! An internal logic error in SQLite
|
CONSTANT: SQLITE_INTERNAL 2 ! An internal logic error in SQLite
|
||||||
: SQLITE_PERM 3 ; inline ! Access permission denied
|
CONSTANT: SQLITE_PERM 3 ! Access permission denied
|
||||||
: SQLITE_ABORT 4 ; inline ! Callback routine requested an abort
|
CONSTANT: SQLITE_ABORT 4 ! Callback routine requested an abort
|
||||||
: SQLITE_BUSY 5 ; inline ! The database file is locked
|
CONSTANT: SQLITE_BUSY 5 ! The database file is locked
|
||||||
: SQLITE_LOCKED 6 ; inline ! A table in the database is locked
|
CONSTANT: SQLITE_LOCKED 6 ! A table in the database is locked
|
||||||
: SQLITE_NOMEM 7 ; inline ! A malloc() failed
|
CONSTANT: SQLITE_NOMEM 7 ! A malloc() failed
|
||||||
: SQLITE_READONLY 8 ; inline ! Attempt to write a readonly database
|
CONSTANT: SQLITE_READONLY 8 ! Attempt to write a readonly database
|
||||||
: SQLITE_INTERRUPT 9 ; inline ! Operation terminated by sqlite_interrupt()
|
CONSTANT: SQLITE_INTERRUPT 9 ! Operation terminated by sqlite_interrupt()
|
||||||
: SQLITE_IOERR 10 ; inline ! Some kind of disk I/O error occurred
|
CONSTANT: SQLITE_IOERR 10 ! Some kind of disk I/O error occurred
|
||||||
: SQLITE_CORRUPT 11 ; inline ! The database disk image is malformed
|
CONSTANT: SQLITE_CORRUPT 11 ! The database disk image is malformed
|
||||||
: SQLITE_NOTFOUND 12 ; inline ! (Internal Only) Table or record not found
|
CONSTANT: SQLITE_NOTFOUND 12 ! (Internal Only) Table or record not found
|
||||||
: SQLITE_FULL 13 ; inline ! Insertion failed because database is full
|
CONSTANT: SQLITE_FULL 13 ! Insertion failed because database is full
|
||||||
: SQLITE_CANTOPEN 14 ; inline ! Unable to open the database file
|
CONSTANT: SQLITE_CANTOPEN 14 ! Unable to open the database file
|
||||||
: SQLITE_PROTOCOL 15 ; inline ! Database lock protocol error
|
CONSTANT: SQLITE_PROTOCOL 15 ! Database lock protocol error
|
||||||
: SQLITE_EMPTY 16 ; inline ! (Internal Only) Database table is empty
|
CONSTANT: SQLITE_EMPTY 16 ! (Internal Only) Database table is empty
|
||||||
: SQLITE_SCHEMA 17 ; inline ! The database schema changed
|
CONSTANT: SQLITE_SCHEMA 17 ! The database schema changed
|
||||||
: SQLITE_TOOBIG 18 ; inline ! Too much data for one row of a table
|
CONSTANT: SQLITE_TOOBIG 18 ! Too much data for one row of a table
|
||||||
: SQLITE_CONSTRAINT 19 ; inline ! Abort due to contraint violation
|
CONSTANT: SQLITE_CONSTRAINT 19 ! Abort due to contraint violation
|
||||||
: SQLITE_MISMATCH 20 ; inline ! Data type mismatch
|
CONSTANT: SQLITE_MISMATCH 20 ! Data type mismatch
|
||||||
: SQLITE_MISUSE 21 ; inline ! Library used incorrectly
|
CONSTANT: SQLITE_MISUSE 21 ! Library used incorrectly
|
||||||
: SQLITE_NOLFS 22 ; inline ! Uses OS features not supported on host
|
CONSTANT: SQLITE_NOLFS 22 ! Uses OS features not supported on host
|
||||||
: SQLITE_AUTH 23 ; inline ! Authorization denied
|
CONSTANT: SQLITE_AUTH 23 ! Authorization denied
|
||||||
: SQLITE_FORMAT 24 ; inline ! Auxiliary database format error
|
CONSTANT: SQLITE_FORMAT 24 ! Auxiliary database format error
|
||||||
: SQLITE_RANGE 25 ; inline ! 2nd parameter to sqlite3_bind out of range
|
CONSTANT: SQLITE_RANGE 25 ! 2nd parameter to sqlite3_bind out of range
|
||||||
: SQLITE_NOTADB 26 ; inline ! File opened that is not a database file
|
CONSTANT: SQLITE_NOTADB 26 ! File opened that is not a database file
|
||||||
|
|
||||||
: sqlite-error-messages ( -- seq ) {
|
: sqlite-error-messages ( -- seq ) {
|
||||||
"Successful result"
|
"Successful result"
|
||||||
|
|
@ -72,32 +72,32 @@ IN: db.sqlite.ffi
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
! Return values from sqlite3_step
|
! Return values from sqlite3_step
|
||||||
: SQLITE_ROW 100 ; inline
|
CONSTANT: SQLITE_ROW 100
|
||||||
: SQLITE_DONE 101 ; inline
|
CONSTANT: SQLITE_DONE 101
|
||||||
|
|
||||||
! Return values from the sqlite3_column_type function
|
! Return values from the sqlite3_column_type function
|
||||||
: SQLITE_INTEGER 1 ; inline
|
CONSTANT: SQLITE_INTEGER 1
|
||||||
: SQLITE_FLOAT 2 ; inline
|
CONSTANT: SQLITE_FLOAT 2
|
||||||
: SQLITE_TEXT 3 ; inline
|
CONSTANT: SQLITE_TEXT 3
|
||||||
: SQLITE_BLOB 4 ; inline
|
CONSTANT: SQLITE_BLOB 4
|
||||||
: SQLITE_NULL 5 ; inline
|
CONSTANT: SQLITE_NULL 5
|
||||||
|
|
||||||
! Values for the 'destructor' parameter of the 'bind' routines.
|
! Values for the 'destructor' parameter of the 'bind' routines.
|
||||||
: SQLITE_STATIC 0 ; inline
|
CONSTANT: SQLITE_STATIC 0
|
||||||
: SQLITE_TRANSIENT -1 ; inline
|
CONSTANT: SQLITE_TRANSIENT -1
|
||||||
|
|
||||||
: SQLITE_OPEN_READONLY HEX: 00000001 ; inline
|
CONSTANT: SQLITE_OPEN_READONLY HEX: 00000001
|
||||||
: SQLITE_OPEN_READWRITE HEX: 00000002 ; inline
|
CONSTANT: SQLITE_OPEN_READWRITE HEX: 00000002
|
||||||
: SQLITE_OPEN_CREATE HEX: 00000004 ; inline
|
CONSTANT: SQLITE_OPEN_CREATE HEX: 00000004
|
||||||
: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008 ; inline
|
CONSTANT: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008
|
||||||
: SQLITE_OPEN_EXCLUSIVE HEX: 00000010 ; inline
|
CONSTANT: SQLITE_OPEN_EXCLUSIVE HEX: 00000010
|
||||||
: SQLITE_OPEN_MAIN_DB HEX: 00000100 ; inline
|
CONSTANT: SQLITE_OPEN_MAIN_DB HEX: 00000100
|
||||||
: SQLITE_OPEN_TEMP_DB HEX: 00000200 ; inline
|
CONSTANT: SQLITE_OPEN_TEMP_DB HEX: 00000200
|
||||||
: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400 ; inline
|
CONSTANT: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400
|
||||||
: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800 ; inline
|
CONSTANT: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800
|
||||||
: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 ; inline
|
CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000
|
||||||
: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 ; inline
|
CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000
|
||||||
: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 ; inline
|
CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000
|
||||||
|
|
||||||
TYPEDEF: void sqlite3
|
TYPEDEF: void sqlite3
|
||||||
TYPEDEF: void sqlite3_stmt
|
TYPEDEF: void sqlite3_stmt
|
||||||
|
|
|
||||||
|
|
@ -95,3 +95,35 @@ things "THINGS" {
|
||||||
things drop-table
|
things drop-table
|
||||||
] with-db
|
] with-db
|
||||||
] unit-test
|
] 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
|
||||||
|
|
|
||||||
|
|
@ -225,11 +225,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
||||||
: insert-trigger ( -- string )
|
: insert-trigger ( -- string )
|
||||||
[
|
[
|
||||||
<"
|
<"
|
||||||
CREATE TRIGGER fki_${table}_${foreign-table}_id
|
CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
|
||||||
BEFORE INSERT ON ${table}
|
BEFORE INSERT ON ${table-name}
|
||||||
FOR EACH ROW BEGIN
|
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 (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||||
END;
|
END;
|
||||||
"> interpolate
|
"> interpolate
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
@ -237,12 +237,12 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
||||||
: insert-trigger-not-null ( -- string )
|
: insert-trigger-not-null ( -- string )
|
||||||
[
|
[
|
||||||
<"
|
<"
|
||||||
CREATE TRIGGER fki_${table}_${foreign-table}_id
|
CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
|
||||||
BEFORE INSERT ON ${table}
|
BEFORE INSERT ON ${table-name}
|
||||||
FOR EACH ROW BEGIN
|
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
|
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;
|
END;
|
||||||
"> interpolate
|
"> interpolate
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
@ -250,11 +250,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
||||||
: update-trigger ( -- string )
|
: update-trigger ( -- string )
|
||||||
[
|
[
|
||||||
<"
|
<"
|
||||||
CREATE TRIGGER fku_${table}_${foreign-table}_id
|
CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
|
||||||
BEFORE UPDATE ON ${table}
|
BEFORE UPDATE ON ${table-name}
|
||||||
FOR EACH ROW BEGIN
|
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 (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||||
END;
|
END;
|
||||||
"> interpolate
|
"> interpolate
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
@ -262,12 +262,12 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
||||||
: update-trigger-not-null ( -- string )
|
: update-trigger-not-null ( -- string )
|
||||||
[
|
[
|
||||||
<"
|
<"
|
||||||
CREATE TRIGGER fku_${table}_${foreign-table}_id
|
CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
|
||||||
BEFORE UPDATE ON ${table}
|
BEFORE UPDATE ON ${table-name}
|
||||||
FOR EACH ROW BEGIN
|
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
|
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;
|
END;
|
||||||
"> interpolate
|
"> interpolate
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
@ -275,11 +275,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
||||||
: delete-trigger-restrict ( -- string )
|
: delete-trigger-restrict ( -- string )
|
||||||
[
|
[
|
||||||
<"
|
<"
|
||||||
CREATE TRIGGER fkd_${table}_${foreign-table}_id
|
CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
|
||||||
BEFORE DELETE ON ${foreign-table}
|
BEFORE DELETE ON ${foreign-table-name}
|
||||||
FOR EACH ROW BEGIN
|
FOR EACH ROW BEGIN
|
||||||
SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"')
|
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} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
|
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
|
||||||
END;
|
END;
|
||||||
"> interpolate
|
"> interpolate
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
@ -287,10 +287,10 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
||||||
: delete-trigger-cascade ( -- string )
|
: delete-trigger-cascade ( -- string )
|
||||||
[
|
[
|
||||||
<"
|
<"
|
||||||
CREATE TRIGGER fkd_${table}_${foreign-table}_id
|
CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
|
||||||
BEFORE DELETE ON ${foreign-table}
|
BEFORE DELETE ON ${foreign-table-name}
|
||||||
FOR EACH ROW BEGIN
|
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;
|
END;
|
||||||
"> interpolate
|
"> interpolate
|
||||||
] with-string-writer ;
|
] with-string-writer ;
|
||||||
|
|
@ -323,7 +323,7 @@ M: sqlite-db-connection compound ( string seq -- new-string )
|
||||||
{ "default" [ first number>string " " glue ] }
|
{ "default" [ first number>string " " glue ] }
|
||||||
{ "references" [
|
{ "references" [
|
||||||
[ >reference-string ] keep
|
[ >reference-string ] keep
|
||||||
first2 [ "foreign-table" set ]
|
first2 [ db-table-name "foreign-table-name" set ]
|
||||||
[ "foreign-table-id" set ] bi*
|
[ "foreign-table-id" set ] bi*
|
||||||
create-sqlite-triggers
|
create-sqlite-triggers
|
||||||
] }
|
] }
|
||||||
|
|
|
||||||
|
|
@ -49,7 +49,7 @@ ERROR: no-slot ;
|
||||||
|
|
||||||
ERROR: not-persistent class ;
|
ERROR: not-persistent class ;
|
||||||
|
|
||||||
: db-table ( class -- object )
|
: db-table-name ( class -- object )
|
||||||
dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
|
dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
|
||||||
|
|
||||||
: db-columns ( class -- object )
|
: db-columns ( class -- object )
|
||||||
|
|
@ -165,7 +165,7 @@ ERROR: no-column column ;
|
||||||
|
|
||||||
: >reference-string ( string pair -- string )
|
: >reference-string ( string pair -- string )
|
||||||
first2
|
first2
|
||||||
[ [ unparse " " glue ] [ db-columns ] bi ] dip
|
[ [ db-table-name " " glue ] [ db-columns ] bi ] dip
|
||||||
swap [ column-name>> = ] with find nip
|
swap [ column-name>> = ] with find nip
|
||||||
[ no-column ] unless*
|
[ no-column ] unless*
|
||||||
column-name>> "(" ")" surround append ;
|
column-name>> "(" ")" surround append ;
|
||||||
|
|
|
||||||
|
|
@ -56,8 +56,7 @@ HELP: http-request
|
||||||
|
|
||||||
HELP: with-http-request
|
HELP: with-http-request
|
||||||
{ $values { "request" request } { "quot" { $quotation "( chunk -- )" } } { "response" response } }
|
{ $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." }
|
{ $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" } "." } ;
|
||||||
{ $errors "Throws an error if the HTTP request fails." } ;
|
|
||||||
|
|
||||||
ARTICLE: "http.client.get" "GET requests with the HTTP client"
|
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:"
|
"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 )
|
: check-response ( response -- response )
|
||||||
dup code>> success? [ download-failed ] unless ;
|
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 ( request quot -- response )
|
||||||
[ (with-http-request) check-response ] with-destructors ; inline
|
[ (with-http-request) ] with-destructors ; inline
|
||||||
|
|
||||||
: http-request ( request -- response data )
|
: http-request ( request -- response data )
|
||||||
[ [ % ] with-http-request ] B{ } make
|
[ [ % ] with-http-request ] B{ } make
|
||||||
over content-charset>> decode ;
|
over content-charset>> decode check-response-with-body ;
|
||||||
|
|
||||||
: <get-request> ( url -- request )
|
: <get-request> ( url -- request )
|
||||||
"GET" <client-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." }
|
{ $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" } ;
|
{ $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"
|
ARTICLE: "http.cookies" "HTTP cookies"
|
||||||
"Every " { $link request } " and " { $link response } " instance can contain cookies."
|
"Every " { $link request } " and " { $link response } " instance can contain cookies."
|
||||||
$nl
|
$nl
|
||||||
|
|
|
||||||
|
|
@ -359,3 +359,8 @@ SYMBOL: a
|
||||||
! Test cloning
|
! Test cloning
|
||||||
[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
|
[ 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
|
[ 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 io.encodings io.encodings.iana io.encodings.binary
|
||||||
io.encodings.8-bit io.crlf
|
io.encodings.8-bit io.crlf
|
||||||
unicode.case unicode.categories
|
unicode.case unicode.categories
|
||||||
http.parsers ;
|
http.parsers
|
||||||
|
base64 ;
|
||||||
IN: http
|
IN: http
|
||||||
|
|
||||||
: (read-header) ( -- alist )
|
: (read-header) ( -- alist )
|
||||||
|
|
@ -142,6 +143,9 @@ cookies ;
|
||||||
: set-header ( request/response value key -- request/response )
|
: set-header ( request/response value key -- request/response )
|
||||||
pick header>> set-at ;
|
pick header>> set-at ;
|
||||||
|
|
||||||
|
: set-basic-auth ( request username password -- request )
|
||||||
|
":" glue >base64 "Basic " prepend "Authorization" set-header ;
|
||||||
|
|
||||||
: <request> ( -- request )
|
: <request> ( -- request )
|
||||||
request new
|
request new
|
||||||
"1.1" >>version
|
"1.1" >>version
|
||||||
|
|
@ -156,6 +160,7 @@ cookies ;
|
||||||
: header ( request/response key -- value )
|
: header ( request/response key -- value )
|
||||||
swap header>> at ;
|
swap header>> at ;
|
||||||
|
|
||||||
|
|
||||||
TUPLE: response
|
TUPLE: response
|
||||||
version
|
version
|
||||||
code
|
code
|
||||||
|
|
|
||||||
|
|
@ -17,8 +17,7 @@ GENERIC: load-image* ( path tuple -- image )
|
||||||
{ RGBA [ ] }
|
{ RGBA [ ] }
|
||||||
{ BGRA [
|
{ BGRA [
|
||||||
[
|
[
|
||||||
[ 4 <sliced-groups> [ [ 0 3 ] dip <slice> reverse-here ] each ]
|
4 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
|
||||||
[ RGBA >>component-order ] bi
|
|
||||||
] change-bitmap
|
] change-bitmap
|
||||||
] }
|
] }
|
||||||
{ RGB [
|
{ RGB [
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,7 @@
|
||||||
USING: accessors combinators io io.encodings.binary io.files kernel
|
USING: accessors combinators io io.encodings.binary io.files kernel
|
||||||
pack endian constructors sequences arrays math.order math.parser
|
pack endian constructors sequences arrays math.order math.parser
|
||||||
prettyprint classes io.binary assocs math math.bitwise byte-arrays
|
prettyprint classes io.binary assocs math math.bitwise byte-arrays
|
||||||
grouping images ;
|
grouping images compression.lzw fry ;
|
||||||
IN: images.tiff
|
IN: images.tiff
|
||||||
|
|
||||||
TUPLE: tiff-image < image ;
|
TUPLE: tiff-image < image ;
|
||||||
|
|
@ -256,6 +256,20 @@ ERROR: bad-small-ifd-type n ;
|
||||||
dup ifd-entries>>
|
dup ifd-entries>>
|
||||||
[ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ;
|
[ 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 )
|
: strips>bitmap ( ifd -- ifd )
|
||||||
dup strips>> concat >>bitmap ;
|
dup strips>> concat >>bitmap ;
|
||||||
|
|
||||||
|
|
@ -284,7 +298,11 @@ ERROR: unknown-component-order ifd ;
|
||||||
<parsed-tiff>
|
<parsed-tiff>
|
||||||
read-header dup endianness>> [
|
read-header dup endianness>> [
|
||||||
read-ifds
|
read-ifds
|
||||||
dup ifds>> [ process-ifd read-strips strips>bitmap drop ] each
|
dup ifds>> [
|
||||||
|
process-ifd read-strips
|
||||||
|
uncompress-strips
|
||||||
|
strips>bitmap drop
|
||||||
|
] each
|
||||||
] with-endianness
|
] with-endianness
|
||||||
] with-file-reader ;
|
] with-file-reader ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -5,8 +5,8 @@ system tools.hexdump io.encodings.binary summary accessors
|
||||||
io.backend byte-arrays ;
|
io.backend byte-arrays ;
|
||||||
IN: tar
|
IN: tar
|
||||||
|
|
||||||
: zero-checksum 256 ; inline
|
CONSTANT: zero-checksum 256
|
||||||
: block-size 512 ; inline
|
CONSTANT: block-size 512
|
||||||
|
|
||||||
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
|
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
|
||||||
linkname magic version uname gname devmajor devminor prefix ;
|
linkname magic version uname gname devmajor devminor prefix ;
|
||||||
|
|
@ -89,8 +89,7 @@ M: unknown-typeflag summary ( obj -- str )
|
||||||
|
|
||||||
! Symlink
|
! Symlink
|
||||||
: typeflag-2 ( header -- )
|
: typeflag-2 ( header -- )
|
||||||
[ name>> ] [ linkname>> ] bi
|
[ name>> ] [ linkname>> ] bi make-link ;
|
||||||
[ make-link ] 2curry ignore-errors ;
|
|
||||||
|
|
||||||
! character special
|
! character special
|
||||||
: typeflag-3 ( header -- ) unknown-typeflag ;
|
: typeflag-3 ( header -- ) unknown-typeflag ;
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,22 @@
|
||||||
|
USING: accessors assocs hashtables http http.client json.reader
|
||||||
|
kernel namespaces urls.encoding ;
|
||||||
|
IN: twitter
|
||||||
|
|
||||||
|
SYMBOLS: twitter-username twitter-password ;
|
||||||
|
|
||||||
|
: 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 ;
|
||||||
|
|
||||||
|
: tweet* ( string -- result )
|
||||||
|
update-post-data "https://twitter.com/statuses/update.json" <post-request>
|
||||||
|
set-request-twitter-auth
|
||||||
|
http-request nip json> ;
|
||||||
|
|
||||||
|
: tweet ( string -- ) tweet* drop ;
|
||||||
|
|
||||||
Loading…
Reference in New Issue