From d8e7f0c84ad41d95c91c9998efbaa1fb208caa97 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 Feb 2008 14:01:44 -0600 Subject: [PATCH 1/7] add type conversion to the database library for sqlite and postgresql --- extra/db/postgresql/postgresql.factor | 15 ++++++++++++--- extra/db/sqlite/ffi/ffi.factor | 2 ++ extra/db/sqlite/lib/lib.factor | 8 ++++++++ extra/db/sqlite/sqlite.factor | 3 +++ extra/db/tuples/tuples.factor | 3 +++ 5 files changed, 28 insertions(+), 3 deletions(-) diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index f0a008d065..50704ea974 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -3,7 +3,8 @@ USING: arrays assocs alien alien.syntax continuations io kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi -db.tuples db.types tools.annotations math.ranges ; +db.tuples db.types tools.annotations math.ranges +combinators ; IN: db.postgresql TUPLE: postgresql-db host port pgopts pgtty db user pass ; @@ -52,8 +53,16 @@ M: postgresql-result-set #columns ( result-set -- n ) M: postgresql-result-set row-column ( result-set n -- obj ) >r dup result-set-handle swap result-set-n r> PQgetvalue ; -M: postgresql-result-set row-column ( result-set n -- obj ) - >r dup result-set-handle swap result-set-n r> PQgetvalue ; +M: postgresql-result-set row-column-typed ( result-set n type -- obj ) + >r row-column r> sql-type>factor-type ; + +M: postgresql-result-set sql-type>factor-type ( obj type -- newobj ) + { + { INTEGER [ string>number ] } + { BIG_INTEGER [ string>number ] } + { DOUBLE [ string>number ] } + [ drop ] + } case ; M: postgresql-statement insert-statement ( statement -- id ) query-results [ break 0 row-column ] with-disposal ; diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index 3d37348709..8c957108e1 100755 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/extra/db/sqlite/ffi/ffi.factor @@ -125,6 +125,8 @@ FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ; +FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ; +FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index dfa8a4b2dc..85aa671d4d 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -96,6 +96,14 @@ IN: db.sqlite.lib : sqlite-column ( handle index -- string ) sqlite3_column_text ; +: sqlite-column-typed ( handle index type -- obj ) + { + { INTEGER [ sqlite3_column_int ] } + { BIG_INTEGER [ sqlite3_column_int64 ] } + { TEXT [ sqlite3_column_text ] } + { DOUBLE [ sqlite3_column_double ] } + } case ; + ! TODO : sqlite-row ( handle -- seq ) dup sqlite-#columns [ sqlite-column ] with map ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 298220b3ca..5e1bf0fa6f 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -63,6 +63,9 @@ M: sqlite-result-set #columns ( result-set -- n ) M: sqlite-result-set row-column ( result-set n -- obj ) >r result-set-handle r> sqlite-column ; +M: sqlite-result-set row-column-typed ( result-set n type -- obj ) + >r result-set-handle r> sqlite-column-typed ; + M: sqlite-result-set advance-row ( result-set -- ) [ result-set-handle sqlite-next ] keep set-sqlite-result-set-has-more? ; diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 74726f12aa..9b94c16672 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -46,6 +46,9 @@ HOOK: update-sql* db ( columns table -- sql ) HOOK: delete-sql* db ( columns table -- sql ) HOOK: select-sql* db ( columns table -- sql ) +HOOK: row-column-typed db ( result-set n type -- sql ) +HOOK: sql-type>factor-type db ( obj type -- obj ) + : insert-sql ( columns class -- statement ) db get db-insert-statements [ insert-sql* ] cache-statement ; From be9989cf3d82659cee4814cce10093880b170faf Mon Sep 17 00:00:00 2001 From: sheeple Date: Fri, 15 Feb 2008 14:16:28 -0600 Subject: [PATCH 2/7] More efficient io.unix.select --- extra/io/unix/select/select.factor | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index 06e257a610..9827d4d54f 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -17,14 +17,18 @@ TUPLE: select-mx read-fdset write-fdset ; FD_SETSIZE 8 * over set-select-mx-read-fdset FD_SETSIZE 8 * over set-select-mx-write-fdset ; +: clear-nth ( n seq -- ? ) + [ nth ] 2keep f -rot set-nth ; + : handle-fd ( fd task fdset mx -- ) - roll munge rot nth [ swap handle-io-task ] [ 2drop ] if ; + roll munge rot clear-nth + [ swap handle-io-task ] [ 2drop ] if ; : handle-fdset ( tasks fdset mx -- ) [ handle-fd ] 2curry assoc-each ; : init-fdset ( tasks fdset -- ) - dup clear-bits + ! dup clear-bits [ >r drop t swap munge r> set-nth ] curry assoc-each ; : read-fdset/tasks @@ -33,13 +37,19 @@ TUPLE: select-mx read-fdset write-fdset ; : write-fdset/tasks { mx-writes select-mx-write-fdset } get-slots ; -: init-fdsets ( mx -- read write except ) +: max-fd dup assoc-empty? [ drop 0 ] [ keys supremum ] if ; + +: num-fds ( mx -- n ) + dup mx-reads max-fd swap mx-writes max-fd max 1+ ; + +: init-fdsets ( mx -- nfds read write except ) + [ num-fds ] keep [ read-fdset/tasks tuck init-fdset ] keep write-fdset/tasks tuck init-fdset f ; M: select-mx wait-for-events ( ms mx -- ) - swap >r FD_SETSIZE over init-fdsets r> make-timeval + swap >r dup init-fdsets r> make-timeval select multiplexer-error dup read-fdset/tasks pick handle-fdset dup write-fdset/tasks rot handle-fdset ; From 9faee652c89bdf852412359c9aa19b6cc66f8f8b Mon Sep 17 00:00:00 2001 From: sheeple Date: Fri, 15 Feb 2008 14:16:45 -0600 Subject: [PATCH 3/7] vocabs-profile. now omits type predicates --- extra/tools/profiler/profiler.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/tools/profiler/profiler.factor b/extra/tools/profiler/profiler.factor index 4702431a8f..c35d5a72c8 100755 --- a/extra/tools/profiler/profiler.factor +++ b/extra/tools/profiler/profiler.factor @@ -59,5 +59,7 @@ M: string (profile.) : vocabs-profile. ( -- ) "Call counts for all vocabularies:" print vocabs [ - dup words [ profile-counter ] map sum + dup words + [ "predicating" word-prop not ] subset + [ profile-counter ] map sum ] { } map>assoc counters. ; From 3028416a4c0e17c6c338784c9f0be16806867e7a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 Feb 2008 20:37:54 -0600 Subject: [PATCH 4/7] checking in db before a major overhaul --- extra/db/db.factor | 14 ++++++-------- extra/db/postgresql/postgresql.factor | 10 +++++----- extra/db/sqlite/sqlite.factor | 22 ++++++++++++++------- extra/db/tuples/tuples-tests.factor | 20 +++++++++---------- extra/db/tuples/tuples.factor | 28 +++++++++++++++++---------- 5 files changed, 54 insertions(+), 40 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 3595558dec..d88bbaee03 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -4,12 +4,9 @@ USING: arrays assocs classes continuations kernel math namespaces sequences sequences.lib tuples words strings ; IN: db -TUPLE: db handle insert-statements update-statements delete-statements select-statements ; +TUPLE: db handle insert-statements update-statements delete-statements ; : ( handle -- obj ) - H{ } clone - H{ } clone - H{ } clone - H{ } clone + H{ } clone H{ } clone H{ } clone db construct-boa ; GENERIC: db-open ( db -- ) @@ -23,11 +20,10 @@ HOOK: db-close db ( handle -- ) dup db-insert-statements dispose-statements dup db-update-statements dispose-statements dup db-delete-statements dispose-statements - dup db-select-statements dispose-statements db-handle db-close ] with-variable ; -TUPLE: statement sql params handle bound? ; +TUPLE: statement sql params handle bound? slot-names ; TUPLE: simple-statement ; TUPLE: prepared-statement ; @@ -115,5 +111,7 @@ HOOK: rollback-transaction db ( -- ) dup string? [ [ execute-statement ] with-disposal ] [ - [ [ sql-command ] each ] with-transaction + ! [ + [ sql-command ] each + ! ] with-transaction ] if ; diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 50704ea974..03746bcaa0 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -65,7 +65,7 @@ M: postgresql-result-set sql-type>factor-type ( obj type -- newobj ) } case ; M: postgresql-statement insert-statement ( statement -- id ) - query-results [ break 0 row-column ] with-disposal ; + query-results [ 0 row-column ] with-disposal string>number ; M: postgresql-statement query-results ( query -- result-set ) dup statement-params [ @@ -211,7 +211,7 @@ M: postgresql-db drop-sql ( columns table -- seq ) over native-id? [ drop-function , ] [ 2drop ] if ] { } make ; -M: postgresql-db insert-sql* ( columns table -- sql ) +M: postgresql-db insert-sql* ( columns table -- slot-names sql ) [ "select add_" % % "(" % @@ -219,7 +219,7 @@ M: postgresql-db insert-sql* ( columns table -- sql ) ")" % ] "" make ; -M: postgresql-db update-sql* ( columns table -- sql ) +M: postgresql-db update-sql* ( columns table -- slot-names sql ) [ "update " % % @@ -231,7 +231,7 @@ M: postgresql-db update-sql* ( columns table -- sql ) [ primary-key? ] find nip second dup % " = $" % length 2 + # ] "" make ; -M: postgresql-db delete-sql* ( columns table -- sql ) +M: postgresql-db delete-sql* ( columns table -- slot-names sql ) [ "delete from " % % @@ -239,7 +239,7 @@ M: postgresql-db delete-sql* ( columns table -- sql ) first second % " = $1" % ] "" make ; -M: postgresql-db select-sql* ( columns table -- sql ) +M: postgresql-db select-sql ( columns table -- slot-names sql ) drop ; M: postgresql-db tuple>params ( columns tuple -- obj ) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 5e1bf0fa6f..4eabfc2ecd 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -114,6 +114,10 @@ M: sqlite-db insert-sql* ( columns table -- sql ) ")" % ] "" make ; +: where-primary-key% ( columns -- ) + " where " % + [ primary-key? ] find nip second dup % " = :" % % ; + M: sqlite-db update-sql* ( columns table -- sql ) [ "update " % @@ -121,8 +125,7 @@ M: sqlite-db update-sql* ( columns table -- sql ) " set " % dup remove-id [ ", " % ] [ second dup % " = :" % % ] interleave - " where " % - [ primary-key? ] find nip second dup % " = :" % % + where-primary-key% ] "" make ; M: sqlite-db delete-sql* ( columns table -- sql ) @@ -133,13 +136,18 @@ M: sqlite-db delete-sql* ( columns table -- sql ) first second dup % " = :" % % ] "" make ; -M: sqlite-db select-sql* ( columns table -- sql ) +: select-interval ( interval name -- ) + ; + +: select-sequence ( seq name -- ) + ; + +M: sqlite-db select-sql ( columns table -- sql ) [ "select ROWID, " % - swap [ ", " % ] [ second % ] interleave - " from " % - % - " where ROWID = :ID" % + over [ ", " % ] [ second % ] interleave + " from " % % + " where " % ] "" make ; M: sqlite-db tuple>params ( columns tuple -- obj ) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 72fb6396b5..ea57193750 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -31,7 +31,7 @@ SYMBOL: the-person [ ] [ the-person get update-tuple ] unit-test [ ] [ the-person get delete-tuple ] unit-test - [ ] [ person drop-table ] unit-test ; + ; ! 1 [ ] [ person drop-table ] unit-test ; : test-sqlite ( -- ) "tuples-test.db" resource-path [ @@ -54,17 +54,17 @@ person "PERSON" "billy" 10 3.14 the-person set ! test-sqlite -test-postgresql + test-postgresql -person "PERSON" -{ - { "the-id" "ID" INTEGER +assigned-id+ } - { "the-name" "NAME" { VARCHAR 256 } +not-null+ } - { "the-number" "AGE" INTEGER { +default+ 0 } } - { "real" "REAL" DOUBLE { +default+ 0.3 } } -} define-persistent +! person "PERSON" +! { + ! { "the-id" "ID" INTEGER +assigned-id+ } + ! { "the-name" "NAME" { VARCHAR 256 } +not-null+ } + ! { "the-number" "AGE" INTEGER { +default+ 0 } } + ! { "real" "REAL" DOUBLE { +default+ 0.3 } } +! } define-persistent -1 "billy" 20 6.28 the-person set +! 1 "billy" 20 6.28 the-person set ! test-sqlite ! test-postgresql diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 9b94c16672..be18f71e1b 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -41,13 +41,25 @@ TUPLE: no-slot-named ; HOOK: create-sql db ( columns table -- seq ) HOOK: drop-sql db ( columns table -- seq ) -HOOK: insert-sql* db ( columns table -- sql ) -HOOK: update-sql* db ( columns table -- sql ) -HOOK: delete-sql* db ( columns table -- sql ) -HOOK: select-sql* db ( columns table -- sql ) +HOOK: insert-sql* db ( columns table -- slot-names sql ) +HOOK: update-sql* db ( columns table -- slot-names sql ) +HOOK: delete-sql* db ( columns table -- slot-names sql ) +HOOK: select-sql db ( tuple -- statement ) HOOK: row-column-typed db ( result-set n type -- sql ) HOOK: sql-type>factor-type db ( obj type -- obj ) +HOOK: tuple>params db ( columns tuple -- obj ) + + +HOOK: make-slot-names* db ( quot -- seq ) +HOOK: column-slot-name% db ( spec -- ) +HOOK: column-bind-name% db ( spec -- ) + +: make-slots-names ( quot -- seq str ) + [ make-column-names ] "" make ; inline +: slot-name% ( seq -- ) first % ; +: column-name% ( seq -- ) second % ; +: column-type% ( seq -- ) third % ; : insert-sql ( columns class -- statement ) db get db-insert-statements [ insert-sql* ] cache-statement ; @@ -58,10 +70,6 @@ HOOK: sql-type>factor-type db ( obj type -- obj ) : delete-sql ( columns class -- statement ) db get db-delete-statements [ delete-sql* ] cache-statement ; -: select-sql ( columns class -- statement ) - db get db-select-statements [ select-sql* ] cache-statement ; - -HOOK: tuple>params db ( columns tuple -- obj ) : tuple-statement ( columns tuple quot -- statement ) >r [ tuple>params ] 2keep class r> call @@ -93,8 +101,8 @@ HOOK: tuple>params db ( columns tuple -- obj ) : delete-tuple ( tuple -- ) [ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ; -! : select-tuple ( tuple -- ) - ! [ select-sql ] bind-tuple do-query ; +: select-tuple ( tuple -- ) + [ select-sql ] keep do-query ; : persist ( tuple -- ) dup primary-key [ update-tuple ] [ insert-tuple ] if ; From 3a0b0341bae9ce6b7b7d8cdf516d3fdb37c70a7b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 Feb 2008 21:14:52 -0600 Subject: [PATCH 5/7] fix load error --- extra/db/tuples/tuples.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index be18f71e1b..20cdd8a386 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -56,7 +56,7 @@ HOOK: column-slot-name% db ( spec -- ) HOOK: column-bind-name% db ( spec -- ) : make-slots-names ( quot -- seq str ) - [ make-column-names ] "" make ; inline + [ make-slot-names* ] "" make ; inline : slot-name% ( seq -- ) first % ; : column-name% ( seq -- ) second % ; : column-type% ( seq -- ) third % ; From eaf0d57d6e0ec71bc041293871eccf8549ee516f Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 16 Feb 2008 00:42:53 -0600 Subject: [PATCH 6/7] Fixing XML tests --- extra/xml/tests/soap.factor | 2 +- extra/xml/tests/test.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/xml/tests/soap.factor b/extra/xml/tests/soap.factor index 1cb6d35505..f5934488c6 100644 --- a/extra/xml/tests/soap.factor +++ b/extra/xml/tests/soap.factor @@ -9,6 +9,6 @@ USING: sequences xml kernel arrays xml.utilities io.files tools.test ; [ assemble-data ] map ; [ "http://www.foxnews.com/oreilly/" ] [ - "extra/xml/test/soap.xml" resource-path file>xml + "extra/xml/tests/soap.xml" resource-path file>xml parse-result first first ] unit-test diff --git a/extra/xml/tests/test.factor b/extra/xml/tests/test.factor index 0198ebacb7..871425559b 100644 --- a/extra/xml/tests/test.factor +++ b/extra/xml/tests/test.factor @@ -7,7 +7,7 @@ USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities ! This is insufficient SYMBOL: xml-file -[ ] [ "extra/xml/test/test.xml" resource-path +[ ] [ "extra/xml/tests/test.xml" resource-path [ file>xml ] with-html-entities xml-file set ] unit-test [ "1.0" ] [ xml-file get xml-prolog prolog-version ] unit-test [ f ] [ xml-file get xml-prolog prolog-standalone ] unit-test From c1e7ee6bc620b3c687cdd85c08b7ee51c6186aa7 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 16 Feb 2008 00:52:01 -0600 Subject: [PATCH 7/7] Fixing inverse bug --- extra/inverse/inverse.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 99dddb25f0..4bb620083f 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -100,7 +100,7 @@ M: math-inverse inverse [ drop swap-inverse ] [ pull-inverse ] if ; M: pop-inverse inverse - [ "pop-length" word-prop cut-slice swap ] keep + [ "pop-length" word-prop cut-slice swap >quotation ] keep "pop-inverse" word-prop compose call ; : (undo) ( revquot -- )