From d46764d34612c2232edd78a424d74080171bb7bc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 16:36:29 -0600 Subject: [PATCH 01/15] use CONSTANT: in db --- basis/db/postgresql/ffi/ffi.factor | 98 +++++++++++++++--------------- basis/db/sqlite/ffi/ffi.factor | 96 ++++++++++++++--------------- 2 files changed, 97 insertions(+), 97 deletions(-) diff --git a/basis/db/postgresql/ffi/ffi.factor b/basis/db/postgresql/ffi/ffi.factor index 4358d7f3de..fc407b06bd 100644 --- a/basis/db/postgresql/ffi/ffi.factor +++ b/basis/db/postgresql/ffi/ffi.factor @@ -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 diff --git a/basis/db/sqlite/ffi/ffi.factor b/basis/db/sqlite/ffi/ffi.factor index 9f033a1d3c..341995634e 100644 --- a/basis/db/sqlite/ffi/ffi.factor +++ b/basis/db/sqlite/ffi/ffi.factor @@ -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 From 1f6c50fd9192a2614d88830c5c04eb0d18cab1e3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 16:40:45 -0600 Subject: [PATCH 02/15] use constant in tar, remove ignore-errors --- extra/tar/tar.factor | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index a4413c07b3..37c022fe43 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -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 ; From c4f45e3f74687bf705143a39fd0e861ed7d81dba Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 12 Feb 2009 17:13:01 -0600 Subject: [PATCH 03/15] Fixing bug in db (don't use unparse!), adding still-failing unit test --- basis/db/queries/queries.factor | 2 +- basis/db/sqlite/sqlite-tests.factor | 23 +++++++++++++++++++++++ basis/db/types/types.factor | 2 +- 3 files changed, 25 insertions(+), 2 deletions(-) diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 495c25ea68..c714f43687 100755 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -48,7 +48,7 @@ M: retryable execute-statement* ( statement type -- ) : query-make ( class quot -- statements ) #! query, input, outputs, secondary queries - over unparse "table" set + over db-table "table" set [ sql-props ] dip [ 0 sql-counter rot with-variable ] curry { "" { } { } { } } nmake diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index 69d5f1dd43..657415c048 100644 --- a/basis/db/sqlite/sqlite-tests.factor +++ b/basis/db/sqlite/sqlite-tests.factor @@ -95,3 +95,26 @@ 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 "BAR" { { "slot" "SOMETHING" INTEGER +not-null+ } } define-persistent + +TUPLE: hi bye ; +C: hi +hi "HELLO" +{ { "bye" "BUHBYE" INTEGER { +foreign-id+ foo "SOMETHING" } } } define-persistent + +[ T{ foo { slot 1 } } T{ hi { bye 1 } } ] [ + test.db [ + foo create-table + hi create-table + 1 insert-tuple + f select-tuple + 1 insert-tuple + f select-tuple + hi drop-table + foo drop-table + ] with-db +] unit-test diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index b5a7db987a..51e4b42bdc 100755 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -165,7 +165,7 @@ ERROR: no-column column ; : >reference-string ( string pair -- string ) first2 - [ [ unparse " " glue ] [ db-columns ] bi ] dip + [ [ db-table " " glue ] [ db-columns ] bi ] dip swap [ column-name>> = ] with find nip [ no-column ] unless* column-name>> "(" ")" surround append ; From 8993e0536b2d1e3c5fdbdcd67707bb2388c53c81 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 17:29:31 -0600 Subject: [PATCH 04/15] rename db-table to db-table-name, use db-table-name instead of class name in creating triggers for sqlite --- basis/db/queries/queries.factor | 4 +-- basis/db/sqlite/sqlite.factor | 48 ++++++++++++++++----------------- basis/db/types/types.factor | 4 +-- 3 files changed, 28 insertions(+), 28 deletions(-) diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index c714f43687..2730340bfc 100755 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -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 db-table "table" set + over db-table-name "table-name" set [ sql-props ] dip [ 0 sql-counter rot with-variable ] curry { "" { } { } { } } nmake diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 9b05cf9825..d006145ea8 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -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 ] } diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index 51e4b42bdc..e39a5977ef 100755 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -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 - [ [ db-table " " 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 ; From 745e011ccc11d25e97937fcb8678f2db0f6fc5f6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 17:44:04 -0600 Subject: [PATCH 05/15] add lzw compression --- basis/compression/lzw/authors.txt | 1 + basis/compression/lzw/lzw-tests.factor | 10 ++ basis/compression/lzw/lzw.factor | 190 +++++++++++++++++++++++++ 3 files changed, 201 insertions(+) create mode 100644 basis/compression/lzw/authors.txt create mode 100644 basis/compression/lzw/lzw-tests.factor create mode 100644 basis/compression/lzw/lzw.factor diff --git a/basis/compression/lzw/authors.txt b/basis/compression/lzw/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/compression/lzw/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/compression/lzw/lzw-tests.factor b/basis/compression/lzw/lzw-tests.factor new file mode 100644 index 0000000000..6cb41b97a0 --- /dev/null +++ b/basis/compression/lzw/lzw-tests.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors tools.test compression.lzw ; +IN: compression.lzw.tests + +[ V{ 7 258 8 8 258 6 } ] +[ B{ 7 7 7 8 8 7 7 6 6 } lzw-compress output>> ] unit-test + +[ B{ 7 7 7 8 8 7 7 6 6 } ] +[ V{ 7 258 8 8 258 6 } lzw-uncompress output>> ] unit-test diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor new file mode 100644 index 0000000000..fe24e97007 --- /dev/null +++ b/basis/compression/lzw/lzw.factor @@ -0,0 +1,190 @@ +! 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 ; + +: ( input -- obj ) + lzw new + swap >>input + binary >>output + reset-lzw-compress ; + +: ( 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 ] [ reset-lzw-compress drop ] bi ] + [ (lzw-compress-chars) ] + [ end-of-information lzw-compress-char ] + [ ] + } cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ; + +: lzw-compress ( byte-array -- seq ) + binary + [ 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 ; + +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 + [ lzw-uncompress-char ] [ output>> ] bi ; From 6ffe298189c5c16d0515b696a8d1d6fa0aec57d9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 17:44:15 -0600 Subject: [PATCH 06/15] support lzw uncompression in images.tiff --- basis/images/images.factor | 3 +-- basis/images/tiff/tiff.factor | 22 ++++++++++++++++++++-- 2 files changed, 21 insertions(+), 4 deletions(-) diff --git a/basis/images/images.factor b/basis/images/images.factor index a2d90cc131..46c0936644 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -17,8 +17,7 @@ GENERIC: load-image* ( path tuple -- image ) { RGBA [ ] } { BGRA [ [ - [ 4 [ [ 0 3 ] dip reverse-here ] each ] - [ RGBA >>component-order ] bi + 4 dup [ [ 0 3 ] dip reverse-here ] each ] change-bitmap ] } { RGB [ diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index b4daf675f1..0b749d0ade 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -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 ; 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 ; From 18276a863b81aeca6d6f8fcd6bca29c78f21ac98 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 17:44:43 -0600 Subject: [PATCH 07/15] initial bitstreams checkin --- basis/bitstreams/authors.txt | 1 + basis/bitstreams/bitstreams-tests.factor | 31 +++++++++ basis/bitstreams/bitstreams.factor | 87 ++++++++++++++++++++++++ 3 files changed, 119 insertions(+) create mode 100644 basis/bitstreams/authors.txt create mode 100644 basis/bitstreams/bitstreams-tests.factor create mode 100644 basis/bitstreams/bitstreams.factor diff --git a/basis/bitstreams/authors.txt b/basis/bitstreams/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/bitstreams/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor new file mode 100644 index 0000000000..8fac3f52f9 --- /dev/null +++ b/basis/bitstreams/bitstreams-tests.factor @@ -0,0 +1,31 @@ +! 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 ; +IN: bitstreams.tests + +[ 1 ] +[ B{ 254 } read-bit ] unit-test + +[ 254 ] +[ B{ 254 } 8 swap read-bits ] unit-test + +[ 4095 ] +[ B{ 255 255 } 12 swap read-bits ] unit-test + +[ B{ 254 } ] +[ + 254 8 rot + [ write-bits ] keep stream>> >byte-array +] unit-test + + +/* +[ + +] [ + B{ 7 7 7 8 8 7 7 9 7 } + [ byte-array>bignum >bin 72 CHAR: 0 pad-head 9 group [ bin> ] map ] + [ lzw-compress ] bi +] unit-test +*/ diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor new file mode 100644 index 0000000000..ae980795bc --- /dev/null +++ b/basis/bitstreams/bitstreams.factor @@ -0,0 +1,87 @@ +! 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 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 ; + +: ( stream -- bitstream ) + bitstream-reader new-bitstream ; inline + +: read-next-byte ( bitstream -- bitstream ) + dup stream>> stream-read1 + [ >>current-bits ] [ 8 0 ? >>#bits ] bi ; inline + +: 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 ) + maybe-read-next-byte [ + shift-one-bit + ] [ + [ 1- ] change-#bits maybe-read-next-byte drop + ] bi ; inline + +: read-bit ( bitstream -- n ) + dup #bits>> 1 = [ + [ current-bits>> 1 bitand ] + [ read-next-byte drop ] bi + ] [ + next-bit + ] if ; inline + +: bits>integer ( seq -- n ) + 0 [ [ 1 shift ] dip bitor ] reduce ; inline + +: read-bits ( width bitstream -- n ) + '[ _ read-bit ] replicate bits>integer ; inline + + +TUPLE: bitstream-writer < bitstream ; + +: ( 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 ; From 81d0f52e32d96b5d699608f9332d8d3010252d95 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 21:43:25 -0600 Subject: [PATCH 08/15] remove bad lzw tests, real tests still to come.. --- basis/compression/lzw/lzw-tests.factor | 6 ------ 1 file changed, 6 deletions(-) diff --git a/basis/compression/lzw/lzw-tests.factor b/basis/compression/lzw/lzw-tests.factor index 6cb41b97a0..698e35d87e 100644 --- a/basis/compression/lzw/lzw-tests.factor +++ b/basis/compression/lzw/lzw-tests.factor @@ -2,9 +2,3 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors tools.test compression.lzw ; IN: compression.lzw.tests - -[ V{ 7 258 8 8 258 6 } ] -[ B{ 7 7 7 8 8 7 7 6 6 } lzw-compress output>> ] unit-test - -[ B{ 7 7 7 8 8 7 7 6 6 } ] -[ V{ 7 258 8 8 258 6 } lzw-uncompress output>> ] unit-test From 127ff76c085959ae0e4284016643894d7550d0b7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 21:45:34 -0600 Subject: [PATCH 09/15] add using --- basis/bitstreams/bitstreams-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor index 8fac3f52f9..2aadf7b02d 100644 --- a/basis/bitstreams/bitstreams-tests.factor +++ b/basis/bitstreams/bitstreams-tests.factor @@ -1,7 +1,7 @@ ! 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 ; +grouping compression.lzw multiline byte-arrays ; IN: bitstreams.tests [ 1 ] @@ -16,7 +16,7 @@ IN: bitstreams.tests [ B{ 254 } ] [ 254 8 rot - [ write-bits ] keep stream>> >byte-array + [ write-bits ] keep output>> >byte-array ] unit-test From d09567e31eb83a378d7902a9b70b2a34030379ee Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 12 Feb 2009 21:59:59 -0600 Subject: [PATCH 10/15] Failing test case for db.sqlite --- basis/db/sqlite/sqlite-tests.factor | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor index 657415c048..e05d992014 100644 --- a/basis/db/sqlite/sqlite-tests.factor +++ b/basis/db/sqlite/sqlite-tests.factor @@ -101,20 +101,29 @@ TUPLE: foo slot ; C: foo foo "BAR" { { "slot" "SOMETHING" INTEGER +not-null+ } } define-persistent -TUPLE: hi bye ; +TUPLE: hi bye try ; C: hi -hi "HELLO" -{ { "bye" "BUHBYE" INTEGER { +foreign-id+ foo "SOMETHING" } } } define-persistent +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 } } ] [ +[ T{ foo { slot 1 } } T{ hi { bye 1 } { try 1 } } ] [ test.db [ foo create-table hi create-table 1 insert-tuple f select-tuple - 1 insert-tuple + 1 1 insert-tuple f select-tuple hi drop-table foo drop-table ] with-db ] unit-test + +[ ] [ + test.db [ + hi create-table + hi drop-table + ] with-db +] unit-test From b5cb425708166bce4c86479c57dee27290131812 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 22:10:32 -0600 Subject: [PATCH 11/15] new bitstream api works, refactor time --- basis/bitstreams/bitstreams-tests.factor | 24 +++++++--------- basis/bitstreams/bitstreams.factor | 35 +++++++++++++++--------- 2 files changed, 32 insertions(+), 27 deletions(-) diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor index 2aadf7b02d..d55910b131 100644 --- a/basis/bitstreams/bitstreams-tests.factor +++ b/basis/bitstreams/bitstreams-tests.factor @@ -1,31 +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 ; +grouping compression.lzw multiline byte-arrays io.encodings.binary +io.streams.byte-array ; IN: bitstreams.tests -[ 1 ] +[ 1 t ] [ B{ 254 } read-bit ] unit-test -[ 254 ] +[ 254 8 t ] [ B{ 254 } 8 swap read-bits ] unit-test -[ 4095 ] +[ 4095 12 t ] [ B{ 255 255 } 12 swap read-bits ] unit-test [ B{ 254 } ] [ 254 8 rot - [ write-bits ] keep output>> >byte-array + [ write-bits ] keep stream>> >byte-array ] unit-test +[ 255 8 t ] +[ B{ 255 } binary 8 swap read-bits ] unit-test -/* -[ - -] [ - B{ 7 7 7 8 8 7 7 9 7 } - [ byte-array>bignum >bin 72 CHAR: 0 pad-head 9 group [ bin> ] map ] - [ lzw-compress ] bi -] unit-test -*/ +[ 255 8 f ] +[ B{ 255 } binary 9 swap read-bits ] unit-test diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index ae980795bc..7113b650fd 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -4,7 +4,7 @@ USING: accessors byte-arrays destructors fry io kernel locals math sequences ; IN: bitstreams -TUPLE: bitstream stream current-bits #bits disposed ; +TUPLE: bitstream stream end-of-stream? current-bits #bits disposed ; TUPLE: bitstream-reader < bitstream ; : reset-bitstream ( stream -- stream ) @@ -22,8 +22,12 @@ M: bitstream-reader dispose ( stream -- ) bitstream-reader new-bitstream ; inline : read-next-byte ( bitstream -- bitstream ) - dup stream>> stream-read1 - [ >>current-bits ] [ 8 0 ? >>#bits ] bi ; inline + 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 @@ -31,17 +35,19 @@ M: bitstream-reader dispose ( stream -- ) : shift-one-bit ( bitstream -- n ) [ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline -: next-bit ( bitstream -- n ) - maybe-read-next-byte [ - shift-one-bit +: next-bit ( bitstream -- n/f ? ) + maybe-read-next-byte + dup end-of-stream?>> [ + drop f ] [ - [ 1- ] change-#bits maybe-read-next-byte drop - ] bi ; inline + [ shift-one-bit ] + [ [ 1- ] change-#bits maybe-read-next-byte drop ] bi + ] if dup >boolean ; -: read-bit ( bitstream -- n ) +: read-bit ( bitstream -- n ? ) dup #bits>> 1 = [ [ current-bits>> 1 bitand ] - [ read-next-byte drop ] bi + [ read-next-byte drop ] bi t ] [ next-bit ] if ; inline @@ -49,9 +55,12 @@ M: bitstream-reader dispose ( stream -- ) : bits>integer ( seq -- n ) 0 [ [ 1 shift ] dip bitor ] reduce ; inline -: read-bits ( width bitstream -- n ) - '[ _ read-bit ] replicate bits>integer ; 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 ; From 12ee26566ea3abe8b039d6c4420c08a2c54e9ed6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 22:11:11 -0600 Subject: [PATCH 12/15] working on lzw compression --- basis/compression/lzw/lzw.factor | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor index fe24e97007..67248474d3 100644 --- a/basis/compression/lzw/lzw.factor +++ b/basis/compression/lzw/lzw.factor @@ -110,9 +110,23 @@ ERROR: not-in-table ; : lzw-compress-chars ( lzw -- ) { - [ [ clear-code lzw-compress-char ] [ reset-lzw-compress drop ] bi ] + ! [ [ 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) ] - [ end-of-information lzw-compress-char ] + [ + [ 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 ; @@ -138,7 +152,7 @@ ERROR: not-in-table ; : add-to-table ( seq lzw -- ) table>> push ; : lzw-read ( lzw -- lzw n ) - [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits ; + [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ; DEFER: lzw-uncompress-char : handle-clear-code ( lzw -- ) From 237f16b4db03d50d03558fa2ad9ec9c9b9ff8169 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Feb 2009 22:13:34 -0600 Subject: [PATCH 13/15] move zlib to zlib.compression and update --- basis/compression/zlib/authors.txt | 1 + basis/compression/zlib/ffi/authors.txt | 1 + basis/compression/zlib/ffi/ffi.factor | 30 +++++++++++++++ basis/compression/zlib/zlib-tests.factor | 9 +++++ basis/compression/zlib/zlib.factor | 48 ++++++++++++++++++++++++ 5 files changed, 89 insertions(+) create mode 100755 basis/compression/zlib/authors.txt create mode 100755 basis/compression/zlib/ffi/authors.txt create mode 100755 basis/compression/zlib/ffi/ffi.factor create mode 100755 basis/compression/zlib/zlib-tests.factor create mode 100755 basis/compression/zlib/zlib.factor diff --git a/basis/compression/zlib/authors.txt b/basis/compression/zlib/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/compression/zlib/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/compression/zlib/ffi/authors.txt b/basis/compression/zlib/ffi/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/compression/zlib/ffi/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/compression/zlib/ffi/ffi.factor b/basis/compression/zlib/ffi/ffi.factor new file mode 100755 index 0000000000..d369c22e4c --- /dev/null +++ b/basis/compression/zlib/ffi/ffi.factor @@ -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 ) ; diff --git a/basis/compression/zlib/zlib-tests.factor b/basis/compression/zlib/zlib-tests.factor new file mode 100755 index 0000000000..1baeba73d9 --- /dev/null +++ b/basis/compression/zlib/zlib-tests.factor @@ -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 diff --git a/basis/compression/zlib/zlib.factor b/basis/compression/zlib/zlib.factor new file mode 100755 index 0000000000..7818173498 --- /dev/null +++ b/basis/compression/zlib/zlib.factor @@ -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 ; + +: ( 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 dup length ] keep [ + dup length compression.zlib.ffi:compress zlib-error + ] 3keep drop *ulong head + ] keep length ; + +: uncompress ( compressed -- byte-array ) + [ + length>> [ ] keep 2dup + ] [ + data>> dup length + compression.zlib.ffi:uncompress zlib-error + ] bi *ulong head ; From 2bb9448ebcbb98acfdbaac7ab6c1536ea907d631 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 12 Feb 2009 22:39:26 -0600 Subject: [PATCH 14/15] add set-basic-auth to http, and make http-request stuff the response body in the error message on failure --- basis/http/client/client-docs.factor | 3 +-- basis/http/client/client.factor | 7 +++++-- basis/http/http-docs.factor | 6 ++++++ basis/http/http-tests.factor | 5 +++++ basis/http/http.factor | 7 ++++++- 5 files changed, 23 insertions(+), 5 deletions(-) diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index 9a8aa48738..0d7f7851e2 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -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:" diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index cc1c67c31e..4099e3d84c 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -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 ; : ( url -- request ) "GET" ; diff --git a/basis/http/http-docs.factor b/basis/http/http-docs.factor index fc3f65fa56..210066176f 100644 --- a/basis/http/http-docs.factor +++ b/basis/http/http-docs.factor @@ -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 diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 49acdb639c..4f685945aa 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -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" put-cookie drop "a" get-cookie ] unit-test + +! Test basic auth +[ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test + + diff --git a/basis/http/http.factor b/basis/http/http.factor index 2b5414b299..d4acd282f8 100755 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -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 new "1.1" >>version @@ -156,6 +160,7 @@ cookies ; : header ( request/response key -- value ) swap header>> at ; + TUPLE: response version code From 7f8e890f1f05458f8357e218158cea01d7f4a075 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 12 Feb 2009 22:39:48 -0600 Subject: [PATCH 15/15] twitta --- extra/twitter/twitter.factor | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 extra/twitter/twitter.factor diff --git a/extra/twitter/twitter.factor b/extra/twitter/twitter.factor new file mode 100644 index 0000000000..eceb40c1c2 --- /dev/null +++ b/extra/twitter/twitter.factor @@ -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" + set-request-twitter-auth + http-request nip json> ; + +: tweet ( string -- ) tweet* drop ; +