steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into new_ui

db4
Slava Pestov 2009-02-12 22:51:05 -06:00
parent 52df401f8a e3f531cba4
commit 67666b77de
26 changed files with 648 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
basis/bitstreams/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

27
basis/bitstreams/bitstreams-tests.factor Normal file
View File

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

96
basis/bitstreams/bitstreams.factor Normal file
View File

@ -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
basis/compression/lzw/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

4
basis/compression/lzw/lzw-tests.factor Normal file
View File

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

204
basis/compression/lzw/lzw.factor Normal file
View File

@ -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
basis/compression/zlib/authors.txt Executable file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/compression/zlib/ffi/authors.txt Executable file
View File

@ -0,0 +1 @@
Doug Coleman

30
basis/compression/zlib/ffi/ffi.factor Executable file
View File

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

9
basis/compression/zlib/zlib-tests.factor Executable file
View File

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

48
basis/compression/zlib/zlib.factor Executable file
View File

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

98
basis/db/postgresql/ffi/ffi.factor
View File

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

4
basis/db/queries/queries.factor
View File

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

96
basis/db/sqlite/ffi/ffi.factor
View File

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

32
basis/db/sqlite/sqlite-tests.factor
View File

@ -95,3 +95,35 @@ 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

48
basis/db/sqlite/sqlite.factor
View File

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

4
basis/db/types/types.factor
View File

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

3
basis/http/client/client-docs.factor
View File

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

7
basis/http/client/client.factor
View File

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

6
basis/http/http-docs.factor
View File

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

5
basis/http/http-tests.factor
View File

@ -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
basis/http/http.factor
View File

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

3
basis/images/images.factor
View File

@ -17,8 +17,7 @@ GENERIC: load-image* ( path tuple -- image )
{ RGBA [ ] }
{ BGRA [
[
[ 4 <sliced-groups> [ [ 0 3 ] dip <slice> reverse-here ] each ]
[ RGBA >>component-order ] bi
4 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
] change-bitmap
] }
{ RGB [

22
basis/images/tiff/tiff.factor
View File

@ -3,7 +3,7 @@
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 ;
grouping images compression.lzw fry ;
IN: images.tiff
TUPLE: tiff-image < image ;
@ -256,6 +256,20 @@ ERROR: bad-small-ifd-type n ;
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 ;
@ -284,7 +298,11 @@ ERROR: unknown-component-order ifd ;
<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 drop
] each
] with-endianness
] with-file-reader ;

7
extra/tar/tar.factor
View File

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

22
extra/twitter/twitter.factor Normal file
View File

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