From defc1cfae97329b0aade66049093235a32485601 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 15 Apr 2008 21:55:26 -0500
Subject: [PATCH 01/20] fix sql
---
extra/db/sql/sql-tests.factor | 2 +-
extra/db/sql/sql.factor | 34 +++++++++++++++++-----------------
2 files changed, 18 insertions(+), 18 deletions(-)
diff --git a/extra/db/sql/sql-tests.factor b/extra/db/sql/sql-tests.factor
index 488026fcc7..db69d71a84 100644
--- a/extra/db/sql/sql-tests.factor
+++ b/extra/db/sql/sql-tests.factor
@@ -28,7 +28,7 @@ TUPLE: person name age ;
{ select
{ columns "salary" }
{ from "staff" }
- { where { "branchno" "b003" } }
+ { where { "branchno" = "b003" } }
}
}
{ "branchno" > 3 } }
diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor
index 26e8429efd..b0ec7aaf34 100755
--- a/extra/db/sql/sql.factor
+++ b/extra/db/sql/sql.factor
@@ -27,23 +27,23 @@ DEFER: sql%
: sql-array% ( array -- )
unclip
{
- { columns [ "," (sql-interleave) ] }
- { from [ "from" "," sql-interleave ] }
- { where [ "where" "and" sql-interleave ] }
- { group-by [ "group by" "," sql-interleave ] }
- { having [ "having" "," sql-interleave ] }
- { order-by [ "order by" "," sql-interleave ] }
- { offset [ "offset" sql% sql% ] }
- { limit [ "limit" sql% sql% ] }
- { select [ "(select" sql% sql% ")" sql% ] }
- { table [ sql% ] }
- { set [ "set" "," sql-interleave ] }
- { values [ "values(" sql% "," (sql-interleave) ")" sql% ] }
- { count [ "count" sql-function, ] }
- { sum [ "sum" sql-function, ] }
- { avg [ "avg" sql-function, ] }
- { min [ "min" sql-function, ] }
- { max [ "max" sql-function, ] }
+ { \ columns [ "," (sql-interleave) ] }
+ { \ from [ "from" "," sql-interleave ] }
+ { \ where [ "where" "and" sql-interleave ] }
+ { \ group-by [ "group by" "," sql-interleave ] }
+ { \ having [ "having" "," sql-interleave ] }
+ { \ order-by [ "order by" "," sql-interleave ] }
+ { \ offset [ "offset" sql% sql% ] }
+ { \ limit [ "limit" sql% sql% ] }
+ { \ select [ "(select" sql% sql% ")" sql% ] }
+ { \ table [ sql% ] }
+ { \ set [ "set" "," sql-interleave ] }
+ { \ values [ break "values(" sql% "," (sql-interleave) ")" sql% ] }
+ { \ count [ "count" sql-function, ] }
+ { \ sum [ "sum" sql-function, ] }
+ { \ avg [ "avg" sql-function, ] }
+ { \ min [ "min" sql-function, ] }
+ { \ max [ "max" sql-function, ] }
[ sql% [ sql% ] each ]
} case ;
From 336e30b054d6d8d6353c5c2a4431d69c7a659c66 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 17 Apr 2008 19:43:07 -0500
Subject: [PATCH 02/20] add interval queries for sqlite
---
extra/db/db.factor | 4 +-
extra/db/sql/sql-tests.factor | 2 +-
extra/db/sql/sql.factor | 11 +++--
extra/db/sqlite/lib/lib.factor | 5 ++-
extra/db/sqlite/sqlite.factor | 68 ++++++++++++++++++++++-------
extra/db/tuples/tuples-tests.factor | 41 ++++++++++++++---
extra/db/types/types.factor | 2 +
7 files changed, 103 insertions(+), 30 deletions(-)
diff --git a/extra/db/db.factor b/extra/db/db.factor
index baf4e9db5a..533f238f04 100755
--- a/extra/db/db.factor
+++ b/extra/db/db.factor
@@ -11,7 +11,7 @@ TUPLE: db
update-statements
delete-statements ;
-: construct-db ( class -- obj )
+: new-db ( class -- obj )
new
H{ } clone >>insert-statements
H{ } clone >>update-statements
@@ -20,7 +20,7 @@ TUPLE: db
GENERIC: make-db* ( seq class -- db )
: make-db ( seq class -- db )
- construct-db make-db* ;
+ new-db make-db* ;
GENERIC: db-open ( db -- db )
HOOK: db-close db ( handle -- )
diff --git a/extra/db/sql/sql-tests.factor b/extra/db/sql/sql-tests.factor
index db69d71a84..cab7b83ced 100644
--- a/extra/db/sql/sql-tests.factor
+++ b/extra/db/sql/sql-tests.factor
@@ -1,7 +1,7 @@
USING: kernel namespaces db.sql sequences math ;
IN: db.sql.tests
-TUPLE: person name age ;
+! TUPLE: person name age ;
: insert-1
{ insert
{ table "person" }
diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor
index b0ec7aaf34..d7ef986ea6 100755
--- a/extra/db/sql/sql.factor
+++ b/extra/db/sql/sql.factor
@@ -55,15 +55,18 @@ TUPLE: no-sql-match ;
{ [ dup number? ] [ number>string sql% ] }
{ [ dup symbol? ] [ unparse sql% ] }
{ [ dup word? ] [ unparse sql% ] }
+ { [ dup quotation? ] [ call ] }
[ T{ no-sql-match } throw ]
} cond ;
: parse-sql ( obj -- sql in-spec out-spec in out )
[
unclip {
- { insert [ "insert into" sql% ] }
- { update [ "update" sql% ] }
- { delete [ "delete" sql% ] }
- { select [ "select" sql% ] }
+ { \ create [ "create table" sql% ] }
+ { \ drop [ "drop table" sql% ] }
+ { \ insert [ "insert into" sql% ] }
+ { \ update [ "update" sql% ] }
+ { \ delete [ "delete" sql% ] }
+ { \ select [ "select" sql% ] }
} case [ sql% ] each
] { "" { } { } { } { } } nmake ;
diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor
index e66accd7e9..b6221e5a1e 100755
--- a/extra/db/sqlite/lib/lib.factor
+++ b/extra/db/sqlite/lib/lib.factor
@@ -4,7 +4,7 @@ USING: alien.c-types arrays assocs kernel math math.parser
namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary
-tools.walker ;
+tools.walker io.backend ;
IN: db.sqlite.lib
: sqlite-error ( n -- * )
@@ -23,7 +23,8 @@ IN: db.sqlite.lib
[ sqlite-error ]
} cond ;
-: sqlite-open ( filename -- db )
+: sqlite-open ( path -- db )
+ normalize-path
"void*" <c-object>
[ sqlite3_open sqlite-check-result ] keep *void* ;
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index 11c0150cd2..02bf314a0a 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -4,8 +4,9 @@ USING: alien arrays assocs classes compiler db
hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings classes.tuple alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
-words combinators.lib db.types combinators
+words combinators.lib db.types combinators math.intervals
io namespaces.lib accessors ;
+USE: tools.walker
IN: db.sqlite
TUPLE: sqlite-db < db path ;
@@ -54,16 +55,20 @@ M: sqlite-statement bind-statement* ( statement -- )
[ statement-bind-params ] [ statement-handle ] bi
sqlite-bind ;
+GENERIC: sqlite-bind-conversion ( tuple obj -- array )
+
+M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
+ [ column-name>> ":" prepend ]
+ [ slot-name>> rot get-slot-named ]
+ [ type>> ] tri 3array ;
+
+M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
+ nip [ key>> ] [ value>> ] [ type>> ] tri 3array ;
+
M: sqlite-statement bind-tuple ( tuple statement -- )
[
- in-params>>
- [
- [ column-name>> ":" prepend ]
- [ slot-name>> rot get-slot-named ]
- [ type>> ] tri 3array
- ] with map
- ] keep
- bind-statement ;
+ in-params>> [ sqlite-bind-conversion ] with map
+ ] keep bind-statement ;
: last-insert-id ( -- id )
db get db-handle sqlite3_last_insert_rowid
@@ -129,13 +134,46 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
<insert-native-statement> ;
+M: sqlite-db bind% ( spec -- )
+ dup 1, column-name>> ":" prepend 0% ;
+
: where-primary-key% ( specs -- )
" where " 0%
find-primary-key dup column-name>> 0% " = " 0% bind% ;
-: where-clause ( specs -- )
- " where " 0%
- [ " and " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave ;
+! : where-object ( tuple specs -- )
+ ! [ dup column-name>> get-slot-named ] keep
+ ! dup column-name>> 0% " = " 0% bind% ;
+
+GENERIC: where-object ( specs obj -- )
+
+: interval-comparison ( ? str -- str )
+ "from" = " >" " <" ? swap [ "= " append ] when ;
+
+: where-interval ( spec val ? from/to -- )
+ roll [
+ column-name>>
+ [ 0% interval-comparison 0% ]
+ [ ":" spin 3append dup 0% ] 2bi
+ swap
+ ] [
+ type>>
+ ] bi literal-bind boa 1, ;
+
+M: interval where-object ( specs obj -- )
+ [ from>> first2 "from" where-interval " and " 0% ]
+ [ to>> first2 "to" where-interval ] 2bi ;
+
+M: object where-object ( specs obj -- )
+ drop
+ dup column-name>> 0% " = " 0% bind% ;
+
+: where-clause ( tuple specs -- )
+ " where " 0% [
+ " and " 0%
+ ] [
+ 2dup slot-name>> swap get-slot-named where-object
+ ] interleave drop ;
M: sqlite-db <update-tuple-statement> ( class -- statement )
[
@@ -158,9 +196,6 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
! : select-interval ( interval name -- ) ;
! : select-sequence ( seq name -- ) ;
-M: sqlite-db bind% ( spec -- )
- dup 1, column-name>> ":" prepend 0% ;
-
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[
"select " 0%
@@ -168,8 +203,9 @@ M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[ dup column-name>> 0% 2, ] interleave
" from " 0% 0%
+ dupd
[ slot-name>> swap get-slot-named ] with subset
- dup empty? [ drop ] [ where-clause ] if ";" 0%
+ dup empty? [ 2drop ] [ where-clause ] if ";" 0%
] sqlite-make ;
M: sqlite-db modifier-table ( -- hashtable )
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 951ded32ea..36a8d4cd3f 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -233,12 +233,43 @@ TUPLE: exam id name score ;
[ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
[
- T{ exam f 3 "Kenny" 60 }
- T{ exam f 4 "Cartman" 41 }
- ] [ T{ exam f 4 f T{ interval f { 0 t } { 70 t } } } select-tuples ] unit-test
- ;
+ {
+ T{ exam f 3 "Kenny" 60 }
+ T{ exam f 4 "Cartman" 41 }
+ }
+ ] [
+ T{ exam f f f T{ interval f { 0 t } { 70 t } } } select-tuples
+ ] unit-test
-! [ test-ranges ] test-sqlite
+ [
+ { }
+ ] [
+ T{ exam f T{ interval f { 3 f } { 4 f } } f } select-tuples
+ ] unit-test
+ [
+ {
+ T{ exam f 4 "Cartman" 41 }
+ }
+ ] [
+ T{ exam f T{ interval f { 3 f } { 4 t } } f } select-tuples
+ ] unit-test
+ [
+ {
+ T{ exam f 3 "Kenny" 60 }
+ }
+ ] [
+ T{ exam f T{ interval f { 3 t } { 4 f } } f } select-tuples
+ ] unit-test
+ [
+ {
+ T{ exam f 3 "Kenny" 60 }
+ T{ exam f 4 "Cartman" 41 }
+ }
+ ] [
+ T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples
+ ] unit-test ;
+
+[ test-ranges ] test-sqlite
TUPLE: secret n message ;
C: <secret> secret
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index 98bc451a6f..bea81f422b 100755
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -15,6 +15,8 @@ HOOK: compound-type db ( str n -- hash )
TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
+TUPLE: literal-bind key value type ;
+
SINGLETON: +native-id+
SINGLETON: +assigned-id+
SINGLETON: +random-id+
From afaab57f8356b77e7dd9547ecf46bd6e8f8ac638 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 18 Apr 2008 12:43:21 -0500
Subject: [PATCH 03/20] interval, range queries in sqlite
---
extra/db/sqlite/sqlite.factor | 62 +++++++++++++++++------------
extra/db/tuples/tuples-tests.factor | 28 +++++++++++--
extra/db/tuples/tuples.factor | 3 ++
extra/db/types/types.factor | 4 +-
4 files changed, 67 insertions(+), 30 deletions(-)
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index 02bf314a0a..de5c245517 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -5,7 +5,7 @@ hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings classes.tuple alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators math.intervals
-io namespaces.lib accessors ;
+io namespaces.lib accessors vectors math.ranges ;
USE: tools.walker
IN: db.sqlite
@@ -104,7 +104,8 @@ M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
: sqlite-make ( class quot -- )
>r sql-props r>
- { "" { } { } } nmake <simple-statement> ; inline
+ [ 0 sql-counter rot with-variable ] { "" { } { } } nmake
+ <simple-statement> ; inline
M: sqlite-db create-sql-statement ( class -- statement )
[
@@ -134,6 +135,12 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
<insert-native-statement> ;
+M: sqlite-db bind# ( spec obj -- )
+ >r
+ [ column-name>> ":" swap next-sql-counter 3append dup 0% ]
+ [ type>> ] bi
+ r> <literal-bind> 1, ;
+
M: sqlite-db bind% ( spec -- )
dup 1, column-name>> ":" prepend 0% ;
@@ -141,38 +148,44 @@ M: sqlite-db bind% ( spec -- )
" where " 0%
find-primary-key dup column-name>> 0% " = " 0% bind% ;
-! : where-object ( tuple specs -- )
- ! [ dup column-name>> get-slot-named ] keep
- ! dup column-name>> 0% " = " 0% bind% ;
-
-GENERIC: where-object ( specs obj -- )
+GENERIC: where ( specs obj -- )
: interval-comparison ( ? str -- str )
"from" = " >" " <" ? swap [ "= " append ] when ;
-: where-interval ( spec val ? from/to -- )
- roll [
- column-name>>
- [ 0% interval-comparison 0% ]
- [ ":" spin 3append dup 0% ] 2bi
- swap
- ] [
- type>>
- ] bi literal-bind boa 1, ;
+: where-interval ( spec obj from/to -- )
+ pick column-name>> 0%
+ >r first2 r> interval-comparison 0%
+ bind# ;
-M: interval where-object ( specs obj -- )
- [ from>> first2 "from" where-interval " and " 0% ]
- [ to>> first2 "to" where-interval ] 2bi ;
+: in-parens ( quot -- )
+ "(" 0% call ")" 0% ; inline
-M: object where-object ( specs obj -- )
- drop
- dup column-name>> 0% " = " 0% bind% ;
+M: interval where ( spec obj -- )
+ [
+ [ from>> "from" where-interval " and " 0% ]
+ [ to>> "to" where-interval ] 2bi
+ ] in-parens ;
+
+M: sequence where ( spec obj -- )
+ [
+ [ " or " 0% ] [ dupd where ] interleave drop
+ ] in-parens ;
+
+: object-where ( spec obj -- )
+ over column-name>> 0% " = " 0% bind# ;
+
+M: object where ( spec obj -- ) object-where ;
+
+M: integer where ( spec obj -- ) object-where ;
+
+M: string where ( spec obj -- ) object-where ;
: where-clause ( tuple specs -- )
" where " 0% [
" and " 0%
] [
- 2dup slot-name>> swap get-slot-named where-object
+ 2dup slot-name>> swap get-slot-named where
] interleave drop ;
M: sqlite-db <update-tuple-statement> ( class -- statement )
@@ -193,9 +206,6 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
dup column-name>> 0% " = " 0% bind%
] sqlite-make ;
-! : select-interval ( interval name -- ) ;
-! : select-sequence ( seq name -- ) ;
-
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[
"select " 0%
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 36a8d4cd3f..691cc6f687 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel tools.test db db.tuples
-db.types continuations namespaces math
+db.types continuations namespaces math math.ranges
prettyprint tools.walker db.sqlite calendar
math.intervals db.postgresql ;
IN: db.tuples.tests
@@ -217,7 +217,7 @@ TUPLE: serialize-me id data ;
TUPLE: exam id name score ;
-: test-ranges ( -- )
+: test-intervals ( -- )
exam "EXAM"
{
{ "id" "ID" +native-id+ }
@@ -267,9 +267,31 @@ TUPLE: exam id name score ;
}
] [
T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples
+ ] unit-test
+
+ [
+ {
+ T{ exam f 1 "Kyle" 100 }
+ T{ exam f 2 "Stan" 80 }
+ }
+ ] [
+ T{ exam f f { "Stan" "Kyle" } } select-tuples
+ ] unit-test
+
+ [
+ {
+ T{ exam f 1 "Kyle" 100 }
+ T{ exam f 2 "Stan" 80 }
+ T{ exam f 3 "Kenny" 60 }
+ }
+ ] [
+ T{ exam f T{ range f 1 3 1 } } select-tuples
] unit-test ;
-[ test-ranges ] test-sqlite
+[ test-intervals ] test-sqlite
+
+: test-ranges
+ ;
TUPLE: secret n message ;
C: <secret> secret
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index 311f18daa9..32431b4ddc 100755
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@ -22,6 +22,9 @@ IN: db.tuples
class db-columns find-primary-key sql-spec-slot-name
] keep set-slot-named ;
+SYMBOL: sql-counter
+: next-sql-counter sql-counter [ inc ] [ get ] bi number>string ;
+
! returns a sequence of prepared-statements
HOOK: create-sql-statement db ( class -- obj )
HOOK: drop-sql-statement db ( class -- obj )
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index bea81f422b..9959e894a7 100755
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -15,7 +15,8 @@ HOOK: compound-type db ( str n -- hash )
TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
-TUPLE: literal-bind key value type ;
+TUPLE: literal-bind key type value ;
+C: <literal-bind> literal-bind
SINGLETON: +native-id+
SINGLETON: +assigned-id+
@@ -132,6 +133,7 @@ TUPLE: no-sql-modifier ;
dup empty? [ " " prepend ] unless ;
HOOK: bind% db ( spec -- )
+HOOK: bind# db ( spec obj -- )
: offset-of-slot ( str obj -- n )
class "slots" word-prop slot-named slot-spec-offset ;
From 6044cc4b3905a7c4b9a30a241f7c31e8032949b8 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 18 Apr 2008 16:01:31 -0500
Subject: [PATCH 04/20] make throwable, nonthrowable, retryable a type
---
extra/db/db.factor | 60 +++++++++++++++++++--------
extra/db/postgresql/postgresql.factor | 2 +-
extra/db/sqlite/sqlite.factor | 8 ++--
extra/db/tuples/tuples-tests.factor | 16 ++++---
4 files changed, 55 insertions(+), 31 deletions(-)
diff --git a/extra/db/db.factor b/extra/db/db.factor
index 533f238f04..7a28dea558 100755
--- a/extra/db/db.factor
+++ b/extra/db/db.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations kernel math
namespaces sequences sequences.lib classes.tuple words strings
-tools.walker accessors ;
+tools.walker accessors combinators.lib ;
IN: db
TUPLE: db
@@ -36,26 +36,47 @@ HOOK: db-close db ( handle -- )
] with-variable ;
! TUPLE: sql sql in-params out-params ;
-TUPLE: statement handle sql in-params out-params bind-params bound? ;
+TUPLE: statement handle sql in-params out-params bind-params bound? type quot ;
TUPLE: simple-statement < statement ;
TUPLE: prepared-statement < statement ;
-TUPLE: nonthrowable-statement < statement ;
-TUPLE: throwable-statement < statement ;
+
+SINGLETON: throwable
+SINGLETON: nonthrowable
+SINGLETON: retryable
+
+: make-throwable ( obj -- obj' )
+ dup sequence? [
+ [ make-throwable ] map
+ ] [
+ throwable >>type
+ ] if ;
: make-nonthrowable ( obj -- obj' )
dup sequence? [
[ make-nonthrowable ] map
] [
- nonthrowable-statement construct-delegate
+ nonthrowable >>type
] if ;
+: make-retryable ( obj quot -- obj' )
+ over sequence? [
+ [ make-retryable ] curry map
+ ] [
+ >>quot
+ retryable >>type
+ ] if ;
+
+: handle-random-id ( statement -- )
+ drop ;
+
TUPLE: result-set sql in-params out-params handle n max ;
: construct-statement ( sql in out class -- statement )
new
swap >>out-params
swap >>in-params
- swap >>sql ;
+ swap >>sql
+ throwable >>type ;
HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
@@ -70,20 +91,25 @@ GENERIC# row-column-typed 1 ( result-set column -- sql )
GENERIC: advance-row ( result-set -- )
GENERIC: more-rows? ( result-set -- ? )
-GENERIC: execute-statement ( statement -- )
+GENERIC: execute-statement* ( statement type -- )
-M: throwable-statement execute-statement ( statement -- )
- dup sequence? [
- [ execute-statement ] each
- ] [
- query-results dispose
- ] if ;
+M: throwable execute-statement* ( statement type -- )
+ drop query-results dispose ;
-M: nonthrowable-statement execute-statement ( statement -- )
- dup sequence? [
- [ execute-statement ] each
- ] [
+M: nonthrowable execute-statement* ( statement type -- )
+ drop [ query-results dispose ] [ 2drop ] recover ;
+
+M: retryable execute-statement* ( statement type -- )
+ [
+ dup dup quot>> call
[ query-results dispose ] [ 2drop ] recover
+ ] curry 10 retry ;
+
+: execute-statement ( statement -- )
+ dup sequence? [
+ [ execute-statement ] each
+ ] [
+ dup type>> execute-statement*
] if ;
: bind-statement ( obj statement -- )
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index 322143e7a2..9dfa123952 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -11,7 +11,7 @@ IN: db.postgresql
TUPLE: postgresql-db < db
host port pgopts pgtty db user pass ;
-TUPLE: postgresql-statement < throwable-statement ;
+TUPLE: postgresql-statement < statement ;
TUPLE: postgresql-result-set < result-set ;
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index de5c245517..e2ea28fe9a 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -20,7 +20,7 @@ M: sqlite-db db-open ( db -- db )
M: sqlite-db db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ;
-TUPLE: sqlite-statement < throwable-statement ;
+TUPLE: sqlite-statement < statement ;
TUPLE: sqlite-result-set < result-set has-more? ;
@@ -105,7 +105,8 @@ M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
: sqlite-make ( class quot -- )
>r sql-props r>
[ 0 sql-counter rot with-variable ] { "" { } { } } nmake
- <simple-statement> ; inline
+ <simple-statement>
+ dup handle-random-id ; inline
M: sqlite-db create-sql-statement ( class -- statement )
[
@@ -223,7 +224,6 @@ M: sqlite-db modifier-table ( -- hashtable )
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
{ +random-id+ "primary key" }
- ! { +nonnative-id+ "primary key" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
{ +default+ "default" }
@@ -236,7 +236,7 @@ M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ;
M: sqlite-db compound-type ( str seq -- str' )
over {
{ "default" [ first number>string join-space ] }
- [ 2drop ] ! "no sqlite compound data type" 3array throw ]
+ [ 2drop ]
} case ;
M: sqlite-db type-table ( -- assoc )
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 691cc6f687..56e401d5ec 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -308,15 +308,13 @@ C: <secret> secret
[ ] [ T{ secret } select-tuples ] unit-test
;
-
-
-! [ test-random-id ] test-sqlite
- [ native-person-schema test-tuples ] test-sqlite
- [ assigned-person-schema test-tuples ] test-sqlite
- [ assigned-person-schema test-repeated-insert ] test-sqlite
- [ native-person-schema test-tuples ] test-postgresql
- [ assigned-person-schema test-tuples ] test-postgresql
- [ assigned-person-schema test-repeated-insert ] test-postgresql
+[ test-random-id ] test-sqlite
+[ native-person-schema test-tuples ] test-sqlite
+[ assigned-person-schema test-tuples ] test-sqlite
+[ assigned-person-schema test-repeated-insert ] test-sqlite
+[ native-person-schema test-tuples ] test-postgresql
+[ assigned-person-schema test-tuples ] test-postgresql
+[ assigned-person-schema test-repeated-insert ] test-postgresql
! \ insert-tuple must-infer
! \ update-tuple must-infer
From b257640f97885aade8e4364216de9d233d7cddc3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 19 Apr 2008 19:27:46 -0500
Subject: [PATCH 05/20] remove ?head*
---
extra/sequences/lib/lib.factor | 3 ---
1 file changed, 3 deletions(-)
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 15983329d6..6bc6c706cf 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -197,9 +197,6 @@ USE: continuations
>r >r 0 max r> r>
[ length tuck min >r min r> ] keep subseq ;
-: ?head* ( seq n -- seq/f ) (head) ?subseq ;
-: ?tail* ( seq n -- seq/f ) (tail) ?subseq ;
-
: accumulator ( quot -- quot vec )
V{ } clone [ [ push ] curry compose ] keep ; inline
From a81aaa61009f3d84983b1004e94f925f466d4ea7 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 19 Apr 2008 19:27:54 -0500
Subject: [PATCH 06/20] add random-id, still needs to retry if insert fails
---
extra/db/db.factor | 6 +--
extra/db/sql/sql.factor | 6 +--
extra/db/sqlite/ffi/ffi.factor | 10 ++++-
extra/db/sqlite/lib/lib.factor | 17 ++++++--
extra/db/sqlite/sqlite.factor | 34 +++++++++++++--
extra/db/tuples/tuples-tests.factor | 57 +++++++++++++++++++++----
extra/db/tuples/tuples.factor | 23 ++++++-----
extra/db/types/types.factor | 64 ++++++++++++++++++-----------
8 files changed, 158 insertions(+), 59 deletions(-)
diff --git a/extra/db/db.factor b/extra/db/db.factor
index 7a28dea558..ce6232f414 100755
--- a/extra/db/db.factor
+++ b/extra/db/db.factor
@@ -36,7 +36,7 @@ HOOK: db-close db ( handle -- )
] with-variable ;
! TUPLE: sql sql in-params out-params ;
-TUPLE: statement handle sql in-params out-params bind-params bound? type quot ;
+TUPLE: statement handle sql in-params out-params bind-params bound? type ;
TUPLE: simple-statement < statement ;
TUPLE: prepared-statement < statement ;
@@ -62,13 +62,9 @@ SINGLETON: retryable
over sequence? [
[ make-retryable ] curry map
] [
- >>quot
retryable >>type
] if ;
-: handle-random-id ( statement -- )
- drop ;
-
TUPLE: result-set sql in-params out-params handle n max ;
: construct-statement ( sql in out class -- statement )
diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor
index d7ef986ea6..4561424a9d 100755
--- a/extra/db/sql/sql.factor
+++ b/extra/db/sql/sql.factor
@@ -38,7 +38,7 @@ DEFER: sql%
{ \ select [ "(select" sql% sql% ")" sql% ] }
{ \ table [ sql% ] }
{ \ set [ "set" "," sql-interleave ] }
- { \ values [ break "values(" sql% "," (sql-interleave) ")" sql% ] }
+ { \ values [ "values(" sql% "," (sql-interleave) ")" sql% ] }
{ \ count [ "count" sql-function, ] }
{ \ sum [ "sum" sql-function, ] }
{ \ avg [ "avg" sql-function, ] }
@@ -47,7 +47,7 @@ DEFER: sql%
[ sql% [ sql% ] each ]
} case ;
-TUPLE: no-sql-match ;
+ERROR: no-sql-match ;
: sql% ( obj -- )
{
{ [ dup string? ] [ " " 0% 0% ] }
@@ -56,7 +56,7 @@ TUPLE: no-sql-match ;
{ [ dup symbol? ] [ unparse sql% ] }
{ [ dup word? ] [ unparse sql% ] }
{ [ dup quotation? ] [ call ] }
- [ T{ no-sql-match } throw ]
+ [ no-sql-match ]
} cond ;
: parse-sql ( obj -- sql in-spec out-spec in out )
diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor
index c724025874..6b94c02c65 100755
--- a/extra/db/sqlite/ffi/ffi.factor
+++ b/extra/db/sqlite/ffi/ffi.factor
@@ -3,7 +3,7 @@
! An interface to the sqlite database. Tested against sqlite v3.1.3.
! Not all functions have been wrapped.
USING: alien compiler kernel math namespaces sequences strings alien.syntax
- system combinators ;
+ system combinators alien.c-types ;
IN: db.sqlite.ffi
<< "sqlite" {
@@ -112,11 +112,14 @@ FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppSt
FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
-FUNCTION: sqlite3_int64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
+FUNCTION: sqlite3_uint64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ;
FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ;
+: sqlite3-bind-uint64 ( pStmt index in64 -- int )
+ "int" "sqlite" "sqlite3_bind_int64"
+ { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ;
FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
@@ -126,6 +129,9 @@ 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 ) ;
+: sqlite3-column-uint64 ( pStmt col -- uint64 )
+ "sqlite3_uint64" "sqlite" "sqlite3_column_int64"
+ { "sqlite3_stmt*" "int" } alien-invoke ;
FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor
index b6221e5a1e..61070b078b 100755
--- a/extra/db/sqlite/lib/lib.factor
+++ b/extra/db/sqlite/lib/lib.factor
@@ -52,6 +52,9 @@ IN: db.sqlite.lib
: sqlite-bind-int64 ( handle i n -- )
sqlite3_bind_int64 sqlite-check-result ;
+: sqlite-bind-uint64 ( handle i n -- )
+ sqlite3-bind-uint64 sqlite-check-result ;
+
: sqlite-bind-double ( handle i x -- )
sqlite3_bind_double sqlite-check-result ;
@@ -69,7 +72,10 @@ IN: db.sqlite.lib
parameter-index sqlite-bind-int ;
: sqlite-bind-int64-by-name ( handle name int64 -- )
- parameter-index sqlite-bind-int ;
+ parameter-index sqlite-bind-int64 ;
+
+: sqlite-bind-uint64-by-name ( handle name int64 -- )
+ parameter-index sqlite-bind-uint64 ;
: sqlite-bind-double-by-name ( handle name double -- )
parameter-index sqlite-bind-double ;
@@ -86,6 +92,8 @@ IN: db.sqlite.lib
{
{ INTEGER [ sqlite-bind-int-by-name ] }
{ BIG-INTEGER [ sqlite-bind-int64-by-name ] }
+ { SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] }
+ { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] }
{ TEXT [ sqlite-bind-text-by-name ] }
{ VARCHAR [ sqlite-bind-text-by-name ] }
{ DOUBLE [ sqlite-bind-double-by-name ] }
@@ -99,6 +107,7 @@ IN: db.sqlite.lib
sqlite-bind-blob-by-name
] }
{ +native-id+ [ sqlite-bind-int-by-name ] }
+ { +random-id+ [ sqlite-bind-int64-by-name ] }
{ NULL [ sqlite-bind-null-by-name ] }
[ no-sql-type ]
} case ;
@@ -121,10 +130,12 @@ IN: db.sqlite.lib
: sqlite-column-typed ( handle index type -- obj )
dup array? [ first ] when
{
- { +native-id+ [ sqlite3_column_int64 ] }
- { +random-id+ [ sqlite3_column_int64 ] }
+ { +native-id+ [ sqlite3_column_int64 ] }
+ { +random-id+ [ sqlite3-column-uint64 ] }
{ INTEGER [ sqlite3_column_int ] }
{ BIG-INTEGER [ sqlite3_column_int64 ] }
+ { SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] }
+ { UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] }
{ DOUBLE [ sqlite3_column_double ] }
{ TEXT [ sqlite3_column_text ] }
{ VARCHAR [ sqlite3_column_text ] }
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index e2ea28fe9a..5f8247f67b 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -5,7 +5,8 @@ hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings classes.tuple alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators math.intervals
-io namespaces.lib accessors vectors math.ranges ;
+io namespaces.lib accessors vectors math.ranges random
+math.bitfields.lib ;
USE: tools.walker
IN: db.sqlite
@@ -65,6 +66,9 @@ M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
nip [ key>> ] [ value>> ] [ type>> ] tri 3array ;
+M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
+ nip [ key>> ] [ quot>> call ] [ type>> ] tri 3array ;
+
M: sqlite-statement bind-tuple ( tuple statement -- )
[
in-params>> [ sqlite-bind-conversion ] with map
@@ -105,8 +109,7 @@ M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
: sqlite-make ( class quot -- )
>r sql-props r>
[ 0 sql-counter rot with-variable ] { "" { } { } } nmake
- <simple-statement>
- dup handle-random-id ; inline
+ <simple-statement> ;
M: sqlite-db create-sql-statement ( class -- statement )
[
@@ -129,7 +132,21 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
maybe-remove-id
dup [ ", " 0% ] [ column-name>> 0% ] interleave
") values(" 0%
- [ ", " 0% ] [ bind% ] interleave
+ [ ", " 0% ] [
+ dup type>> +random-id+ = [
+break
+ dup modifiers>> find-random-generator
+ [
+ [
+ column-name>> ":" prepend
+ dup 0% random-id-quot
+ ] with-random
+ ] curry
+ [ type>> ] bi 10 <generator-bind> 1,
+ ] [
+ bind%
+ ] if
+ ] interleave
");" 0%
] sqlite-make ;
@@ -219,6 +236,9 @@ M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
dup empty? [ 2drop ] [ where-clause ] if ";" 0%
] sqlite-make ;
+M: sqlite-db random-id-quot ( -- quot )
+ [ 64 [ 2^ random ] keep 1 - set-bit ] ;
+
M: sqlite-db modifier-table ( -- hashtable )
H{
{ +native-id+ "primary key" }
@@ -229,6 +249,9 @@ M: sqlite-db modifier-table ( -- hashtable )
{ +default+ "default" }
{ +null+ "null" }
{ +not-null+ "not null" }
+ { system-random-generator "" }
+ { secure-random-generator "" }
+ { random-generator "" }
} ;
M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ;
@@ -244,6 +267,9 @@ M: sqlite-db type-table ( -- assoc )
{ +native-id+ "integer primary key" }
{ +random-id+ "integer primary key" }
{ INTEGER "integer" }
+ { BIG-INTEGER "bigint" }
+ { SIGNED-BIG-INTEGER "bigint" }
+ { UNSIGNED-BIG-INTEGER "bigint" }
{ TEXT "text" }
{ VARCHAR "text" }
{ DATE "date" }
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 56e401d5ec..083cf059c9 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.files kernel tools.test db db.tuples
+USING: io.files kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges
-prettyprint tools.walker db.sqlite calendar
-math.intervals db.postgresql ;
+prettyprint tools.walker db.sqlite calendar sequences
+math.intervals db.postgresql accessors random math.bitfields.lib ;
IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real
@@ -290,8 +290,37 @@ TUPLE: exam id name score ;
[ test-intervals ] test-sqlite
-: test-ranges
- ;
+TUPLE: bignum-test id m n o ;
+: <bignum-test> ( m n o -- obj )
+ bignum-test new
+ swap >>o
+ swap >>n
+ swap >>m ;
+
+: test-bignum
+ bignum-test "BIGNUM_TEST"
+ {
+ { "id" "ID" +native-id+ }
+ { "m" "M" BIG-INTEGER }
+ { "n" "N" UNSIGNED-BIG-INTEGER }
+ { "o" "O" SIGNED-BIG-INTEGER }
+ } define-persistent
+ [ bignum-test drop-table ] ignore-errors
+ [ ] [ bignum-test ensure-table ] unit-test
+ [ ] [ 63 2^ dup dup <bignum-test> insert-tuple ] unit-test
+
+ [ T{ bignum-test f 1
+ -9223372036854775808 9223372036854775808 -9223372036854775808 } ]
+ [ T{ bignum-test f 1 } select-tuple ] unit-test ;
+
+[ test-bignum ] test-sqlite
+
+TUPLE: does-not-persist ;
+
+[
+ [ does-not-persist create-sql-statement ]
+ [ class \ not-persistent = ] must-fail-with
+] test-sqlite
TUPLE: secret n message ;
C: <secret> secret
@@ -299,14 +328,26 @@ C: <secret> secret
: test-random-id
secret "SECRET"
{
- { "n" "ID" +random-id+ }
+ { "n" "ID" +random-id+ system-random-generator }
{ "message" "MESSAGE" TEXT }
} define-persistent
[ ] [ secret ensure-table ] unit-test
+
[ ] [ f "kilroy was here" <secret> insert-tuple ] unit-test
- [ ] [ T{ secret } select-tuples ] unit-test
- ;
+
+ [ ] [ f "kilroy was here2" <secret> insert-tuple ] unit-test
+
+ [ ] [ f "kilroy was here3" <secret> insert-tuple ] unit-test
+
+ [ t ] [
+ T{ secret } select-tuples
+ first message>> "kilroy was here" head?
+ ] unit-test
+
+ [ t ] [
+ T{ secret } select-tuples length 3 =
+ ] unit-test ;
[ test-random-id ] test-sqlite
[ native-person-schema test-tuples ] test-sqlite
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index 32431b4ddc..e0b4fce2f3 100755
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@ -13,9 +13,16 @@ IN: db.tuples
"db-columns" set-word-prop
"db-relations" set-word-prop ;
-: db-table ( class -- obj ) "db-table" word-prop ;
-: db-columns ( class -- obj ) "db-columns" word-prop ;
-: db-relations ( class -- obj ) "db-relations" word-prop ;
+ERROR: not-persistent ;
+
+: db-table ( class -- obj )
+ "db-table" word-prop [ not-persistent ] unless* ;
+
+: db-columns ( class -- obj )
+ "db-columns" word-prop ;
+
+: db-relations ( class -- obj )
+ "db-relations" word-prop ;
: set-primary-key ( key tuple -- )
[
@@ -61,7 +68,7 @@ HOOK: insert-tuple* db ( tuple statement -- )
] curry 2each ;
: sql-props ( class -- columns table )
- dup db-columns swap db-table ;
+ [ db-columns ] [ db-table ] bi ;
: with-disposals ( seq quot -- )
over sequence? [
@@ -88,17 +95,13 @@ HOOK: insert-tuple* db ( tuple statement -- )
[ bind-tuple ] 2keep insert-tuple* ;
: insert-nonnative ( tuple -- )
-! TODO logic here for unique ids
dup class
db get db-insert-statements [ <insert-nonnative-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: insert-tuple ( tuple -- )
- dup class db-columns find-primary-key nonnative-id? [
- insert-nonnative
- ] [
- insert-native
- ] if ;
+ dup class db-columns find-primary-key nonnative-id?
+ [ insert-nonnative ] [ insert-native ] if ;
: update-tuple ( tuple -- )
dup class
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index 9959e894a7..b8855ce296 100755
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -4,7 +4,7 @@ USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep sequences.lib
words namespaces tools.walker slots slots.private classes
mirrors classes.tuple combinators calendar.format symbols
-classes.singleton ;
+classes.singleton accessors quotations random ;
IN: db.types
HOOK: modifier-table db ( -- hash )
@@ -12,12 +12,16 @@ HOOK: compound-modifier db ( str seq -- hash )
HOOK: type-table db ( -- hash )
HOOK: create-type-table db ( -- hash )
HOOK: compound-type db ( str n -- hash )
+HOOK: random-id-quot db ( -- quot )
-TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
+TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
TUPLE: literal-bind key type value ;
C: <literal-bind> literal-bind
+TUPLE: generator-bind key quot type retries ;
+C: <generator-bind> generator-bind
+
SINGLETON: +native-id+
SINGLETON: +assigned-id+
SINGLETON: +random-id+
@@ -27,6 +31,15 @@ UNION: +nonnative-id+ +random-id+ +assigned-id+ ;
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
+foreign-id+ +has-many+ ;
+: find-random-generator ( seq -- obj )
+ [
+ {
+ random-generator
+ system-random-generator
+ secure-random-generator
+ } member?
+ ] find nip [ system-random-generator ] unless* ;
+
: primary-key? ( spec -- ? )
sql-spec-primary-key +primary-key+? ;
@@ -51,26 +64,27 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
-SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR
-DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ;
+: handle-random-id ( statement -- )
+ dup in-params>> [ type>> +random-id+ = ] find drop >boolean [
+ retryable >>type
+ random-id-quot >>quot
+ ] when drop ;
+
+SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
+DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
+FACTOR-BLOB NULL ;
: spec>tuple ( class spec -- tuple )
- [ ?first3 ] keep 3 ?tail*
- {
- set-sql-spec-class
- set-sql-spec-slot-name
- set-sql-spec-column-name
- set-sql-spec-type
- set-sql-spec-modifiers
- } sql-spec construct
+ 3 f pad-right
+ [ first3 ] keep 3 tail
+ sql-spec new
+ swap >>modifiers
+ swap >>type
+ swap >>column-name
+ swap >>slot-name
+ swap >>class
dup normalize-spec ;
-TUPLE: no-sql-type ;
-: no-sql-type ( -- * ) T{ no-sql-type } throw ;
-
-TUPLE: no-sql-modifier ;
-: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ;
-
: number>string* ( n/str -- str )
dup number? [ number>string ] when ;
@@ -88,13 +102,15 @@ TUPLE: no-sql-modifier ;
! PostgreSQL Types:
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
+ERROR: unknown-modifier ;
+
: lookup-modifier ( obj -- str )
- dup array? [
- unclip lookup-modifier swap compound-modifier
- ] [
- modifier-table at*
- [ "unknown modifier" throw ] unless
- ] if ;
+ {
+ { [ dup array? ] [ unclip lookup-modifier swap compound-modifier ] }
+ [ modifier-table at* [ unknown-modifier ] unless ]
+ } cond ;
+
+ERROR: no-sql-type ;
: lookup-type* ( obj -- str )
dup array? [
From 9b5351e81f4b6b4e46da33aedaae748be135b10a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 19 Apr 2008 19:28:25 -0500
Subject: [PATCH 07/20] remove extra using
---
extra/db/sqlite/sqlite.factor | 2 --
1 file changed, 2 deletions(-)
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index 5f8247f67b..093a705b0d 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -7,7 +7,6 @@ continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators math.intervals
io namespaces.lib accessors vectors math.ranges random
math.bitfields.lib ;
-USE: tools.walker
IN: db.sqlite
TUPLE: sqlite-db < db path ;
@@ -134,7 +133,6 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
") values(" 0%
[ ", " 0% ] [
dup type>> +random-id+ = [
-break
dup modifiers>> find-random-generator
[
[
From 896c920d85008304c9896ca0daf46e91b9faadea Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 19 Apr 2008 22:09:36 -0500
Subject: [PATCH 08/20] retryable statements actually retry now
---
extra/db/db.factor | 15 +-----------
extra/db/sqlite/ffi/ffi.factor | 3 ++-
extra/db/sqlite/lib/lib.factor | 4 +++-
extra/db/sqlite/sqlite.factor | 24 ++++++++++++-------
extra/db/tuples/tuples-tests.factor | 2 +-
extra/db/tuples/tuples.factor | 36 ++++++++++++++++++++++++++++-
extra/db/types/types.factor | 8 +------
7 files changed, 59 insertions(+), 33 deletions(-)
diff --git a/extra/db/db.factor b/extra/db/db.factor
index ce6232f414..82193ed467 100755
--- a/extra/db/db.factor
+++ b/extra/db/db.factor
@@ -42,7 +42,6 @@ TUPLE: prepared-statement < statement ;
SINGLETON: throwable
SINGLETON: nonthrowable
-SINGLETON: retryable
: make-throwable ( obj -- obj' )
dup sequence? [
@@ -58,13 +57,6 @@ SINGLETON: retryable
nonthrowable >>type
] if ;
-: make-retryable ( obj quot -- obj' )
- over sequence? [
- [ make-retryable ] curry map
- ] [
- retryable >>type
- ] if ;
-
TUPLE: result-set sql in-params out-params handle n max ;
: construct-statement ( sql in out class -- statement )
@@ -78,6 +70,7 @@ HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
GENERIC: prepare-statement ( statement -- )
GENERIC: bind-statement* ( statement -- )
+GENERIC: low-level-bind ( statement -- )
GENERIC: bind-tuple ( tuple statement -- )
GENERIC: query-results ( query -- result-set )
GENERIC: #rows ( result-set -- n )
@@ -95,12 +88,6 @@ M: throwable execute-statement* ( statement type -- )
M: nonthrowable execute-statement* ( statement type -- )
drop [ query-results dispose ] [ 2drop ] recover ;
-M: retryable execute-statement* ( statement type -- )
- [
- dup dup quot>> call
- [ query-results dispose ] [ 2drop ] recover
- ] curry 10 retry ;
-
: execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each
diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor
index 6b94c02c65..4b5a019fca 100755
--- a/extra/db/sqlite/ffi/ffi.factor
+++ b/extra/db/sqlite/ffi/ffi.factor
@@ -108,7 +108,7 @@ LIBRARY: sqlite
FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ;
-FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
+FUNCTION: int sqlite3_prepare_v2 ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
@@ -123,6 +123,7 @@ FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64
FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
+FUNCTION: int sqlite3_clear_bindings ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ;
FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ;
diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor
index 61070b078b..b6078fc983 100755
--- a/extra/db/sqlite/lib/lib.factor
+++ b/extra/db/sqlite/lib/lib.factor
@@ -33,7 +33,7 @@ IN: db.sqlite.lib
: sqlite-prepare ( db sql -- handle )
dup length "void*" <c-object> "void*" <c-object>
- [ sqlite3_prepare sqlite-check-result ] 2keep
+ [ sqlite3_prepare_v2 sqlite-check-result ] 2keep
drop *void* ;
: sqlite-bind-parameter-index ( handle name -- index )
@@ -114,6 +114,8 @@ IN: db.sqlite.lib
: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
+: sqlite-clear-bindings ( handle -- )
+ sqlite3_clear_bindings sqlite-check-result ;
: sqlite-#columns ( query -- int ) sqlite3_column_count ;
: sqlite-column ( handle index -- string ) sqlite3_column_text ;
: sqlite-column-name ( handle index -- string ) sqlite3_column_name ;
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index 093a705b0d..6dc394abd9 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -7,6 +7,7 @@ continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators math.intervals
io namespaces.lib accessors vectors math.ranges random
math.bitfields.lib ;
+USE: tools.walker
IN: db.sqlite
TUPLE: sqlite-db < db path ;
@@ -43,17 +44,21 @@ M: sqlite-statement dispose ( statement -- )
M: sqlite-result-set dispose ( result-set -- )
f >>handle drop ;
-: sqlite-bind ( triples handle -- )
- swap [ first3 sqlite-bind-type ] with each ;
-
: reset-statement ( statement -- )
sqlite-maybe-prepare handle>> sqlite-reset ;
+: reset-bindings ( statement -- )
+ sqlite-maybe-prepare
+ handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
+
+M: sqlite-statement low-level-bind ( statement -- )
+ [ statement-bind-params ] [ statement-handle ] bi
+ swap [ first3 sqlite-bind-type ] with each ;
+
M: sqlite-statement bind-statement* ( statement -- )
sqlite-maybe-prepare
- dup statement-bound? [ dup reset-statement ] when
- [ statement-bind-params ] [ statement-handle ] bi
- sqlite-bind ;
+ dup statement-bound? [ dup reset-bindings ] when
+ low-level-bind ;
GENERIC: sqlite-bind-conversion ( tuple obj -- array )
@@ -140,13 +145,16 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
dup 0% random-id-quot
] with-random
] curry
- [ type>> ] bi 10 <generator-bind> 1,
+ [ type>> ] bi <generator-bind> 1,
] [
bind%
] if
] interleave
");" 0%
- ] sqlite-make ;
+ ] sqlite-make
+ dup in-params>> [ generator-bind? ] contains? [
+ make-retryable
+ ] when ;
M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
<insert-native-statement> ;
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 083cf059c9..2eb31ebe18 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -346,7 +346,7 @@ C: <secret> secret
] unit-test
[ t ] [
- T{ secret } select-tuples length 3 =
+ T{ secret } select-tuples dup . length 3 =
] unit-test ;
[ test-random-id ] test-sqlite
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index e0b4fce2f3..1b1e48ddee 100755
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes db kernel namespaces
-classes.tuple words sequences slots math
+classes.tuple words sequences slots math accessors
math.parser io prettyprint db.types continuations
mirrors sequences.lib tools.walker combinators.lib ;
IN: db.tuples
@@ -49,6 +49,40 @@ HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
HOOK: insert-tuple* db ( tuple statement -- )
+SINGLETON: retryable
+
+: make-retryable ( obj -- obj' )
+ dup sequence? [
+ [ make-retryable ] map
+ ] [
+ retryable >>type
+ ] if ;
+
+: regenerate-params ( statement -- statement )
+ dup
+ [ bind-params>> ] [ in-params>> ] bi
+ [
+ dup generator-bind? [
+ quot>> call over set-second
+ ] [
+ drop
+ ] if
+ ] 2map >>bind-params ;
+
+: handle-random-id ( statement -- )
+ dup in-params>> [ type>> +random-id+ = ] find drop >boolean [
+ retryable >>type
+ random-id-quot >>quot
+ ] when drop ;
+
+M: retryable execute-statement* ( statement type -- )
+ drop
+ [
+ [ query-results dispose t ]
+ [ ]
+ [ regenerate-params bind-statement* f ] cleanup
+ ] curry 10 retry drop ;
+
: resulting-tuple ( row out-params -- tuple )
dup first sql-spec-class new [
[
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index b8855ce296..9f111a42e4 100755
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -19,7 +19,7 @@ TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
TUPLE: literal-bind key type value ;
C: <literal-bind> literal-bind
-TUPLE: generator-bind key quot type retries ;
+TUPLE: generator-bind key quot type ;
C: <generator-bind> generator-bind
SINGLETON: +native-id+
@@ -64,12 +64,6 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
-: handle-random-id ( statement -- )
- dup in-params>> [ type>> +random-id+ = ] find drop >boolean [
- retryable >>type
- random-id-quot >>quot
- ] when drop ;
-
SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
FACTOR-BLOB NULL ;
From 4184a3ce549e1c21a8889d22ae77d4a5deff7edd Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 19 Apr 2008 23:18:12 -0500
Subject: [PATCH 09/20] partial conversion of postgres
---
extra/db/postgresql/lib/lib.factor | 10 ++++++--
extra/db/postgresql/postgresql.factor | 35 ++++++++++++++++-----------
extra/db/sqlite/sqlite.factor | 15 +++++++-----
extra/db/tuples/tuples-tests.factor | 4 ++-
extra/db/types/types.factor | 3 +--
5 files changed, 42 insertions(+), 25 deletions(-)
diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor
index bfe7dab3ce..cd3d619326 100755
--- a/extra/db/postgresql/lib/lib.factor
+++ b/extra/db/postgresql/lib/lib.factor
@@ -5,7 +5,7 @@ quotations sequences db.postgresql.ffi alien alien.c-types
db.types tools.walker ascii splitting math.parser combinators
libc shuffle calendar.format byte-arrays destructors prettyprint
accessors strings serialize io.encodings.binary
-io.streams.byte-array ;
+io.streams.byte-array inspector ;
IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f )
@@ -28,7 +28,13 @@ IN: db.postgresql.lib
: postgresql-error ( res -- res )
dup [ postgresql-error-message throw ] unless ;
-: postgresql-result-ok? ( n -- ? )
+ERROR: postgresql-result-null ;
+
+M: postgresql-result-null summary ( obj -- str )
+ drop "PQexec returned f." ;
+
+: postgresql-result-ok? ( res -- ? )
+ [ postgresql-result-null ] unless*
PQresultStatus
PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ;
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index 9dfa123952..d0eb390888 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -5,7 +5,7 @@ kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators sequences.lib classes locals words tools.walker
-namespaces.lib accessors ;
+namespaces.lib accessors random ;
IN: db.postgresql
TUPLE: postgresql-db < db
@@ -43,10 +43,9 @@ M: postgresql-statement bind-statement* ( statement -- )
drop ;
M: postgresql-statement bind-tuple ( tuple statement -- )
- [
- statement-in-params
- [ sql-spec-slot-name swap get-slot-named ] with map
- ] keep set-statement-bind-params ;
+ tuck in-params>>
+ [ slot-name>> swap get-slot-named ] with map
+ >>bind-params drop ;
M: postgresql-result-set #rows ( result-set -- n )
handle>> PQntuples ;
@@ -55,11 +54,11 @@ M: postgresql-result-set #columns ( result-set -- n )
handle>> PQnfields ;
M: postgresql-result-set row-column ( result-set column -- obj )
- >r dup result-set-handle swap result-set-n r> pq-get-string ;
+ >r [ handle>> ] [ n>> ] bi r> pq-get-string ;
M: postgresql-result-set row-column-typed ( result-set column -- obj )
dup pick result-set-out-params nth sql-spec-type
- >r >r [ result-set-handle ] [ result-set-n ] bi r> r> postgresql-column-typed ;
+ >r >r [ handle>> ] [ result-set-n ] bi r> r> postgresql-column-typed ;
M: postgresql-statement query-results ( query -- result-set )
dup statement-bind-params [
@@ -82,7 +81,7 @@ M: postgresql-statement dispose ( query -- )
f swap set-statement-handle ;
M: postgresql-result-set dispose ( result-set -- )
- dup result-set-handle PQclear
+ dup handle>> PQclear
0 0 f roll {
set-result-set-n set-result-set-max set-result-set-handle
} set-slots ;
@@ -90,7 +89,7 @@ M: postgresql-result-set dispose ( result-set -- )
M: postgresql-statement prepare-statement ( statement -- )
[
>r db get handle>> "" r>
- dup statement-sql swap statement-in-params
+ [ sql>> ] [ in-params>> ] bi
length f PQprepare postgresql-error
] keep set-statement-handle ;
@@ -115,7 +114,10 @@ SYMBOL: postgresql-counter
postgresql-counter [ inc ] keep get 0# ;
M: postgresql-db bind% ( spec -- )
- 1, bind-name% ;
+ bind-name% 1, ;
+
+M: postgresql-db bind# ( spec obj -- )
+ >r bind-name% f swap type>> r> <literal-bind> 1, ;
: postgresql-make ( class quot -- )
>r sql-props r>
@@ -125,11 +127,10 @@ M: postgresql-db bind% ( spec -- )
: create-table-sql ( class -- statement )
[
"create table " 0% 0%
- "(" 0%
- [ ", " 0% ] [
- dup sql-spec-column-name 0%
+ "(" 0% [ ", " 0% ] [
+ dup column-name>> 0%
" " 0%
- dup sql-spec-type t lookup-type 0%
+ dup type>> t lookup-type 0%
modifiers 0%
] interleave ");" 0%
] postgresql-make ;
@@ -250,6 +251,7 @@ M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
M: postgresql-db type-table ( -- hash )
H{
{ +native-id+ "integer" }
+ { +random-id+ "bigint" }
{ TEXT "text" }
{ VARCHAR "varchar" }
{ INTEGER "integer" }
@@ -265,6 +267,7 @@ M: postgresql-db type-table ( -- hash )
M: postgresql-db create-type-table ( -- hash )
H{
{ +native-id+ "serial primary key" }
+ { +random-id+ "bigint primary key" }
} ;
: postgresql-compound ( str n -- newstr )
@@ -286,12 +289,16 @@ M: postgresql-db modifier-table ( -- hashtable )
H{
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
+ { +random-id+ "primary key" }
{ +foreign-id+ "references" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
{ +default+ "default" }
{ +null+ "null" }
{ +not-null+ "not null" }
+ { system-random-generator "" }
+ { secure-random-generator "" }
+ { random-generator "" }
} ;
M: postgresql-db compound-type ( str n -- newstr )
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index 6dc394abd9..f361e18c48 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -110,10 +110,16 @@ M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ;
M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
+
+: maybe-make-retryable ( statement -- statement )
+ dup in-params>> [ generator-bind? ] contains? [
+ make-retryable
+ ] when ;
+
: sqlite-make ( class quot -- )
>r sql-props r>
[ 0 sql-counter rot with-variable ] { "" { } { } } nmake
- <simple-statement> ;
+ <simple-statement> maybe-make-retryable ;
M: sqlite-db create-sql-statement ( class -- statement )
[
@@ -124,7 +130,7 @@ M: sqlite-db create-sql-statement ( class -- statement )
dup type>> t lookup-type 0%
modifiers 0%
] interleave ");" 0%
- ] sqlite-make ;
+ ] sqlite-make dup sql>> . ;
M: sqlite-db drop-sql-statement ( class -- statement )
[ "drop table " 0% 0% ";" 0% drop ] sqlite-make ;
@@ -151,10 +157,7 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
] if
] interleave
");" 0%
- ] sqlite-make
- dup in-params>> [ generator-bind? ] contains? [
- make-retryable
- ] when ;
+ ] sqlite-make ;
M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
<insert-native-statement> ;
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 2eb31ebe18..038197d864 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -346,13 +346,15 @@ C: <secret> secret
] unit-test
[ t ] [
- T{ secret } select-tuples dup . length 3 =
+ T{ secret } select-tuples length 3 =
] unit-test ;
[ test-random-id ] test-sqlite
[ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-repeated-insert ] test-sqlite
+
+[ test-random-id ] test-postgresql
[ native-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-repeated-insert ] test-postgresql
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index 9f111a42e4..41db970b12 100755
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -110,8 +110,7 @@ ERROR: no-sql-type ;
dup array? [
first lookup-type*
] [
- type-table at*
- [ no-sql-type ] unless
+ type-table at* [ no-sql-type ] unless
] if ;
: lookup-create-type ( obj -- str )
From 3be408184ce053ff31229cd0b693444ee220d4c1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 19 Apr 2008 23:41:48 -0500
Subject: [PATCH 10/20] remove most of the old setters
---
extra/db/postgresql/lib/lib.factor | 36 +++++++---------
extra/db/postgresql/postgresql.factor | 60 ++++++++++++++-------------
2 files changed, 45 insertions(+), 51 deletions(-)
diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor
index cd3d619326..bb4c6872fb 100755
--- a/extra/db/postgresql/lib/lib.factor
+++ b/extra/db/postgresql/lib/lib.factor
@@ -23,7 +23,7 @@ IN: db.postgresql.lib
"\n" split [ [ blank? ] trim ] map "\n" join ;
: postgresql-error-message ( -- str )
- db get db-handle (postgresql-error-message) ;
+ db get handle>> (postgresql-error-message) ;
: postgresql-error ( res -- res )
dup [ postgresql-error-message throw ] unless ;
@@ -43,7 +43,7 @@ M: postgresql-result-null summary ( obj -- str )
dup PQstatus zero? [ (postgresql-error-message) throw ] unless ;
: do-postgresql-statement ( statement -- res )
- db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [
+ db get handle>> swap sql>> PQexec dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw
] unless ;
@@ -64,25 +64,19 @@ M: postgresql-result-null summary ( obj -- str )
} case ;
: param-types ( statement -- seq )
- statement-in-params
- [ sql-spec-type type>oid ] map
- >c-uint-array ;
+ in-params>> [ type>> type>oid ] map >c-uint-array ;
: malloc-byte-array/length
[ malloc-byte-array dup free-always ] [ length ] bi ;
-
: param-values ( statement -- seq seq2 )
- [ statement-bind-params ]
- [ statement-in-params ] bi
+ [ bind-params>> ] [ in-params>> ] bi
[
- sql-spec-type {
+ type>> {
{ FACTOR-BLOB [
- dup [
- object>bytes
- malloc-byte-array/length ] [ 0 ] if ] }
- { BLOB [
- dup [ malloc-byte-array/length ] [ 0 ] if ] }
+ dup [ object>bytes malloc-byte-array/length ] [ 0 ] if
+ ] }
+ { BLOB [ dup [ malloc-byte-array/length ] [ 0 ] if ] }
[
drop number>string* dup [
malloc-char-string dup free-always
@@ -96,22 +90,20 @@ M: postgresql-result-null summary ( obj -- str )
] if ;
: param-formats ( statement -- seq )
- statement-in-params
- [ sql-spec-type type>param-format ] map
- >c-uint-array ;
+ in-params>> [ type>> type>param-format ] map >c-uint-array ;
: do-postgresql-bound-statement ( statement -- res )
[
- >r db get db-handle r>
+ >r db get handle>> r>
{
- [ statement-sql ]
- [ statement-bind-params length ]
+ [ sql>> ]
+ [ bind-params>> length ]
[ param-types ]
[ param-values ]
[ param-formats ]
} cleave
0 PQexecParams dup postgresql-result-ok? [
- dup postgresql-result-error-message swap PQclear throw
+ [ postgresql-result-error-message ] [ PQclear ] bi throw
] unless
] with-destructors ;
@@ -120,7 +112,7 @@ M: postgresql-result-null summary ( obj -- str )
: pq-get-string ( handle row column -- obj )
3dup PQgetvalue alien>char-string
- dup "" = [ >r pq-get-is-null f r> ? ] [ 3nip ] if ;
+ dup empty? [ >r pq-get-is-null f r> ? ] [ 3nip ] if ;
: pq-get-number ( handle row column -- obj )
pq-get-string dup [ string>number ] when ;
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index d0eb390888..f13bceddd3 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -57,11 +57,11 @@ M: postgresql-result-set row-column ( result-set column -- obj )
>r [ handle>> ] [ n>> ] bi r> pq-get-string ;
M: postgresql-result-set row-column-typed ( result-set column -- obj )
- dup pick result-set-out-params nth sql-spec-type
- >r >r [ handle>> ] [ result-set-n ] bi r> r> postgresql-column-typed ;
+ dup pick out-params>> nth type>>
+ >r >r [ handle>> ] [ n>> ] bi r> r> postgresql-column-typed ;
M: postgresql-statement query-results ( query -- result-set )
- dup statement-bind-params [
+ dup bind-params>> [
over [ bind-statement ] keep
do-postgresql-bound-statement
] [
@@ -71,27 +71,29 @@ M: postgresql-statement query-results ( query -- result-set )
dup init-result-set ;
M: postgresql-result-set advance-row ( result-set -- )
- dup result-set-n 1+ swap set-result-set-n ;
+ [ 1+ ] change-n drop ;
M: postgresql-result-set more-rows? ( result-set -- ? )
- dup result-set-n swap result-set-max < ;
+ [ n>> ] [ max>> ] bi < ;
M: postgresql-statement dispose ( query -- )
- dup statement-handle PQclear
- f swap set-statement-handle ;
+ dup handle>> PQclear
+ f >>handle drop ;
M: postgresql-result-set dispose ( result-set -- )
- dup handle>> PQclear
- 0 0 f roll {
- set-result-set-n set-result-set-max set-result-set-handle
- } set-slots ;
+ [ handle>> PQclear ]
+ [
+ 0 >>n
+ 0 >>max
+ f >>handle drop
+ ] bi ;
M: postgresql-statement prepare-statement ( statement -- )
- [
- >r db get handle>> "" r>
- [ sql>> ] [ in-params>> ] bi
- length f PQprepare postgresql-error
- ] keep set-statement-handle ;
+ dup
+ >r db get handle>> "" r>
+ [ sql>> ] [ in-params>> ] bi
+ length f PQprepare postgresql-error
+ >>handle drop ;
M: postgresql-db <simple-statement> ( sql in out -- statement )
<postgresql-statement> ;
@@ -111,7 +113,7 @@ M: postgresql-db rollback-transaction ( -- )
SYMBOL: postgresql-counter
: bind-name% ( -- )
CHAR: $ 0,
- postgresql-counter [ inc ] keep get 0# ;
+ postgresql-counter [ inc ] [ get 0# ] bi ;
M: postgresql-db bind% ( spec -- )
bind-name% 1, ;
@@ -142,7 +144,7 @@ M: postgresql-db bind# ( spec obj -- )
"(" 0%
over [ "," 0% ]
[
- sql-spec-type f lookup-type 0%
+ type>> f lookup-type 0%
] interleave
")" 0%
" returns bigint as '" 0%
@@ -150,7 +152,7 @@ M: postgresql-db bind# ( spec obj -- )
"insert into " 0%
dup 0%
"(" 0%
- over [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
+ over [ ", " 0% ] [ column-name>> 0% ] interleave
") values(" 0%
swap [ ", " 0% ] [ drop bind-name% ] interleave
"); " 0%
@@ -169,7 +171,7 @@ M: postgresql-db create-sql-statement ( class -- seq )
"drop function add_" 0% 0%
"(" 0%
remove-id
- [ ", " 0% ] [ sql-spec-type f lookup-type 0% ] interleave
+ [ ", " 0% ] [ type>> f lookup-type 0% ] interleave
");" 0%
] postgresql-make ;
@@ -199,7 +201,7 @@ M: postgresql-db <insert-nonnative-statement> ( class -- statement )
[
"insert into " 0% 0%
"(" 0%
- dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
+ dup [ ", " 0% ] [ column-name>> 0% ] interleave
")" 0%
" values(" 0%
@@ -216,10 +218,10 @@ M: postgresql-db <update-tuple-statement> ( class -- statement )
" set " 0%
dup remove-id
[ ", " 0% ]
- [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
+ [ dup column-name>> 0% " = " 0% bind% ] interleave
" where " 0%
find-primary-key
- dup sql-spec-column-name 0% " = " 0% bind%
+ dup column-name>> 0% " = " 0% bind%
] postgresql-make ;
M: postgresql-db <delete-tuple-statement> ( class -- statement )
@@ -227,7 +229,7 @@ M: postgresql-db <delete-tuple-statement> ( class -- statement )
"delete from " 0% 0%
" where " 0%
find-primary-key
- dup sql-spec-column-name 0% " = " 0% bind%
+ dup column-name>> 0% " = " 0% bind%
] postgresql-make ;
M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
@@ -235,16 +237,16 @@ M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
! tuple columns table
"select " 0%
over [ ", " 0% ]
- [ dup sql-spec-column-name 0% 2, ] interleave
+ [ dup column-name>> 0% 2, ] interleave
" from " 0% 0%
- [ sql-spec-slot-name swap get-slot-named ] with subset
+ [ slot-name>> swap get-slot-named ] with subset
dup empty? [
drop
] [
" where " 0%
[ " and " 0% ]
- [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
+ [ dup column-name>> 0% " = " 0% bind% ] interleave
] if ";" 0%
] postgresql-make ;
@@ -276,8 +278,8 @@ M: postgresql-db create-type-table ( -- hash )
{ "varchar" [ first number>string paren append ] }
{ "references" [
first2 >r [ unparse join-space ] keep db-columns r>
- swap [ sql-spec-slot-name = ] with find nip
- sql-spec-column-name paren append
+ swap [ slot-name>> = ] with find nip
+ column-name>> paren append
] }
[ "no compound found" 3array throw ]
} case ;
From b0ddc983efc3ad7555fe4b77291a7e7bfcfc384e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 19 Apr 2008 23:48:07 -0500
Subject: [PATCH 11/20] more refactoring
---
extra/db/postgresql/lib/lib.factor | 3 +--
extra/db/postgresql/postgresql.factor | 8 +++++---
2 files changed, 6 insertions(+), 5 deletions(-)
diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor
index bb4c6872fb..56bfc29be8 100755
--- a/extra/db/postgresql/lib/lib.factor
+++ b/extra/db/postgresql/lib/lib.factor
@@ -44,7 +44,7 @@ M: postgresql-result-null summary ( obj -- str )
: do-postgresql-statement ( statement -- res )
db get handle>> swap sql>> PQexec dup postgresql-result-ok? [
- dup postgresql-result-error-message swap PQclear throw
+ [ postgresql-result-error-message ] [ PQclear ] bi throw
] unless ;
: type>oid ( symbol -- n )
@@ -165,4 +165,3 @@ M: postgresql-malloc-destructor dispose ( obj -- )
dup [ bytes>object ] when ] }
[ no-sql-type ]
} case ;
- ! PQgetlength PQgetisnull
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index f13bceddd3..bcf71ea95f 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -53,12 +53,15 @@ M: postgresql-result-set #rows ( result-set -- n )
M: postgresql-result-set #columns ( result-set -- n )
handle>> PQnfields ;
+: result-handle-n ( result-set -- handle n )
+ [ handle>> ] [ n>> ] bi ;
+
M: postgresql-result-set row-column ( result-set column -- obj )
- >r [ handle>> ] [ n>> ] bi r> pq-get-string ;
+ >r result-handle-n r> pq-get-string ;
M: postgresql-result-set row-column-typed ( result-set column -- obj )
dup pick out-params>> nth type>>
- >r >r [ handle>> ] [ n>> ] bi r> r> postgresql-column-typed ;
+ >r >r result-handle-n r> r> postgresql-column-typed ;
M: postgresql-statement query-results ( query -- result-set )
dup bind-params>> [
@@ -234,7 +237,6 @@ M: postgresql-db <delete-tuple-statement> ( class -- statement )
M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
[
- ! tuple columns table
"select " 0%
over [ ", " 0% ]
[ dup column-name>> 0% 2, ] interleave
From 7293a4f4f8013ce6af452e6921d46f40d91680b3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 20 Apr 2008 00:20:21 -0500
Subject: [PATCH 12/20] clean up the tuples tests
---
extra/db/tuples/tuples-tests.factor | 36 ++++++++++++++++-------------
1 file changed, 20 insertions(+), 16 deletions(-)
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 038197d864..0648f9b254 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -212,9 +212,6 @@ TUPLE: serialize-me id data ;
{ T{ serialize-me f 1 H{ { 1 2 } } } }
] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
-[ test-serialize ] test-sqlite
-! [ test-serialize ] test-postgresql
-
TUPLE: exam id name score ;
: test-intervals ( -- )
@@ -288,8 +285,6 @@ TUPLE: exam id name score ;
T{ exam f T{ range f 1 3 1 } } select-tuples
] unit-test ;
-[ test-intervals ] test-sqlite
-
TUPLE: bignum-test id m n o ;
: <bignum-test> ( m n o -- obj )
bignum-test new
@@ -313,15 +308,6 @@ TUPLE: bignum-test id m n o ;
-9223372036854775808 9223372036854775808 -9223372036854775808 } ]
[ T{ bignum-test f 1 } select-tuple ] unit-test ;
-[ test-bignum ] test-sqlite
-
-TUPLE: does-not-persist ;
-
-[
- [ does-not-persist create-sql-statement ]
- [ class \ not-persistent = ] must-fail-with
-] test-sqlite
-
TUPLE: secret n message ;
C: <secret> secret
@@ -349,15 +335,33 @@ C: <secret> secret
T{ secret } select-tuples length 3 =
] unit-test ;
-[ test-random-id ] test-sqlite
[ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-repeated-insert ] test-sqlite
+[ test-bignum ] test-sqlite
+[ test-serialize ] test-sqlite
+[ test-intervals ] test-sqlite
+[ test-random-id ] test-sqlite
-[ test-random-id ] test-postgresql
[ native-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-repeated-insert ] test-postgresql
+[ test-bignum ] test-sqlite
+[ test-serialize ] test-postgresql
+! [ test-intervals ] test-postgresql
+! [ test-random-id ] test-postgresql
+
+TUPLE: does-not-persist ;
+
+[
+ [ does-not-persist create-sql-statement ]
+ [ class \ not-persistent = ] must-fail-with
+] test-sqlite
+
+[
+ [ does-not-persist create-sql-statement ]
+ [ class \ not-persistent = ] must-fail-with
+] test-postgresql
! \ insert-tuple must-infer
! \ update-tuple must-infer
From 89a728f645cf92f9482716c811ef411edca78f3b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 20 Apr 2008 00:52:05 -0500
Subject: [PATCH 13/20] about to consolidate sql types/create types/modifiers
---
extra/db/postgresql/postgresql.factor | 30 +++++++++++----------------
extra/db/sqlite/sqlite.factor | 16 +++++++-------
extra/db/types/types.factor | 7 +++----
3 files changed, 22 insertions(+), 31 deletions(-)
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index bcf71ea95f..5f98720de0 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -93,7 +93,7 @@ M: postgresql-result-set dispose ( result-set -- )
M: postgresql-statement prepare-statement ( statement -- )
dup
- >r db get handle>> "" r>
+ >r db get handle>> f r>
[ sql>> ] [ in-params>> ] bi
length f PQprepare postgresql-error
>>handle drop ;
@@ -274,21 +274,6 @@ M: postgresql-db create-type-table ( -- hash )
{ +random-id+ "bigint primary key" }
} ;
-: postgresql-compound ( str n -- newstr )
- over {
- { "default" [ first number>string join-space ] }
- { "varchar" [ first number>string paren append ] }
- { "references" [
- first2 >r [ unparse join-space ] keep db-columns r>
- swap [ slot-name>> = ] with find nip
- column-name>> paren append
- ] }
- [ "no compound found" 3array throw ]
- } case ;
-
-M: postgresql-db compound-modifier ( str seq -- newstr )
- postgresql-compound ;
-
M: postgresql-db modifier-table ( -- hashtable )
H{
{ +native-id+ "primary key" }
@@ -305,5 +290,14 @@ M: postgresql-db modifier-table ( -- hashtable )
{ random-generator "" }
} ;
-M: postgresql-db compound-type ( str n -- newstr )
- postgresql-compound ;
+M: postgresql-db compound ( str obj -- str' )
+ over {
+ { "default" [ first number>string join-space ] }
+ { "varchar" [ first number>string paren append ] }
+ { "references" [
+ first2 >r [ unparse join-space ] keep db-columns r>
+ swap [ slot-name>> = ] with find nip
+ column-name>> paren append
+ ] }
+ [ "no compound found" 3array throw ]
+ } case ;
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index f361e18c48..fb3fbe92be 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -110,7 +110,6 @@ M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ;
M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
-
: maybe-make-retryable ( statement -- statement )
dup in-params>> [ generator-bind? ] contains? [
make-retryable
@@ -263,14 +262,6 @@ M: sqlite-db modifier-table ( -- hashtable )
{ random-generator "" }
} ;
-M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ;
-
-M: sqlite-db compound-type ( str seq -- str' )
- over {
- { "default" [ first number>string join-space ] }
- [ 2drop ]
- } case ;
-
M: sqlite-db type-table ( -- assoc )
H{
{ +native-id+ "integer primary key" }
@@ -291,3 +282,10 @@ M: sqlite-db type-table ( -- assoc )
} ;
M: sqlite-db create-type-table ( symbol -- str ) type-table ;
+
+M: sqlite-db compound ( str seq -- str' )
+ over {
+ { "default" [ first number>string join-space ] }
+ [ 2drop ]
+ } case ;
+
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index 41db970b12..80e11e7afb 100755
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -8,10 +8,9 @@ classes.singleton accessors quotations random ;
IN: db.types
HOOK: modifier-table db ( -- hash )
-HOOK: compound-modifier db ( str seq -- hash )
+HOOK: compound db ( str obj -- hash )
HOOK: type-table db ( -- hash )
HOOK: create-type-table db ( -- hash )
-HOOK: compound-type db ( str n -- hash )
HOOK: random-id-quot db ( -- quot )
TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
@@ -100,7 +99,7 @@ ERROR: unknown-modifier ;
: lookup-modifier ( obj -- str )
{
- { [ dup array? ] [ unclip lookup-modifier swap compound-modifier ] }
+ { [ dup array? ] [ unclip lookup-modifier swap compound ] }
[ modifier-table at* [ unknown-modifier ] unless ]
} cond ;
@@ -115,7 +114,7 @@ ERROR: no-sql-type ;
: lookup-create-type ( obj -- str )
dup array? [
- unclip lookup-create-type swap compound-type
+ unclip lookup-create-type swap compound
] [
dup create-type-table at*
[ nip ] [ drop lookup-type* ] if
From f5485c1a3dc729028ab21d2bd25a865051e5aee9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 20 Apr 2008 15:48:09 -0500
Subject: [PATCH 14/20] redo lookup-type
---
extra/db/postgresql/postgresql.factor | 67 ++++++++++++---------------
extra/db/types/types.factor | 47 +++++++++----------
2 files changed, 51 insertions(+), 63 deletions(-)
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index 5f98720de0..04a0a7143f 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -135,7 +135,7 @@ M: postgresql-db bind# ( spec obj -- )
"(" 0% [ ", " 0% ] [
dup column-name>> 0%
" " 0%
- dup type>> t lookup-type 0%
+ dup type>> lookup-create-type 0%
modifiers 0%
] interleave ");" 0%
] postgresql-make ;
@@ -147,7 +147,7 @@ M: postgresql-db bind# ( spec obj -- )
"(" 0%
over [ "," 0% ]
[
- type>> f lookup-type 0%
+ type>> lookup-type 0%
] interleave
")" 0%
" returns bigint as '" 0%
@@ -174,7 +174,7 @@ M: postgresql-db create-sql-statement ( class -- seq )
"drop function add_" 0% 0%
"(" 0%
remove-id
- [ ", " 0% ] [ type>> f lookup-type 0% ] interleave
+ [ ", " 0% ] [ type>> lookup-type 0% ] interleave
");" 0%
] postgresql-make ;
@@ -252,42 +252,33 @@ M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
] if ";" 0%
] postgresql-make ;
-M: postgresql-db type-table ( -- hash )
+M: postgresql-db persistent-table ( -- hashtable )
H{
- { +native-id+ "integer" }
- { +random-id+ "bigint" }
- { TEXT "text" }
- { VARCHAR "varchar" }
- { INTEGER "integer" }
- { DOUBLE "real" }
- { DATE "date" }
- { TIME "time" }
- { DATETIME "timestamp" }
- { TIMESTAMP "timestamp" }
- { BLOB "bytea" }
- { FACTOR-BLOB "bytea" }
- } ;
-
-M: postgresql-db create-type-table ( -- hash )
- H{
- { +native-id+ "serial primary key" }
- { +random-id+ "bigint primary key" }
- } ;
-
-M: postgresql-db modifier-table ( -- hashtable )
- H{
- { +native-id+ "primary key" }
- { +assigned-id+ "primary key" }
- { +random-id+ "primary key" }
- { +foreign-id+ "references" }
- { +autoincrement+ "autoincrement" }
- { +unique+ "unique" }
- { +default+ "default" }
- { +null+ "null" }
- { +not-null+ "not null" }
- { system-random-generator "" }
- { secure-random-generator "" }
- { random-generator "" }
+ { +native-id+ { "integer" "serial primary key" f } }
+ { +assigned-id+ { f f "primary key" } }
+ { +random-id+ { "bigint" "bigint primary key" f } }
+ { TEXT { "text" f f } }
+ { VARCHAR { "varchar" "varchar" f } }
+ { INTEGER { "integer" "integer" f } }
+ { BIG-INTEGER { "bigint" "bigint" f } }
+ { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
+ { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
+ { DOUBLE { "real" "real" f } }
+ { DATE { "date" "date" f } }
+ { TIME { "time" "time" f } }
+ { DATETIME { "timestamp" "timestamp" f } }
+ { TIMESTAMP { "timestamp" "timestamp" f } }
+ { BLOB { "bytea" "bytea" f } }
+ { FACTOR-BLOB { "bytea" "bytea" f } }
+ { +foreign-id+ { f f "references" } }
+ { +autoincrement+ { f f "autoincrement" } }
+ { +unique+ { f f "unique" } }
+ { +default+ { f f "default" } }
+ { +null+ { f f "null" } }
+ { +not-null+ { f f "not null" } }
+ { system-random-generator { f f f } }
+ { secure-random-generator { f f f } }
+ { random-generator { f f f } }
} ;
M: postgresql-db compound ( str obj -- str' )
diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor
index 80e11e7afb..a31713fa35 100755
--- a/extra/db/types/types.factor
+++ b/extra/db/types/types.factor
@@ -7,10 +7,9 @@ mirrors classes.tuple combinators calendar.format symbols
classes.singleton accessors quotations random ;
IN: db.types
-HOOK: modifier-table db ( -- hash )
+HOOK: persistent-table db ( -- hash )
HOOK: compound db ( str obj -- hash )
-HOOK: type-table db ( -- hash )
-HOOK: create-type-table db ( -- hash )
+
HOOK: random-id-quot db ( -- quot )
TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
@@ -40,26 +39,26 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
] find nip [ system-random-generator ] unless* ;
: primary-key? ( spec -- ? )
- sql-spec-primary-key +primary-key+? ;
+ primary-key>> +primary-key+? ;
: native-id? ( spec -- ? )
- sql-spec-primary-key +native-id+? ;
+ primary-key>> +native-id+? ;
: nonnative-id? ( spec -- ? )
- sql-spec-primary-key +nonnative-id+? ;
+ primary-key>> +nonnative-id+? ;
: normalize-spec ( spec -- )
- dup sql-spec-type dup +primary-key+? [
- swap set-sql-spec-primary-key
+ dup type>> dup +primary-key+? [
+ >>primary-key drop
] [
- drop dup sql-spec-modifiers [
+ drop dup modifiers>> [
+primary-key+?
] deep-find
- [ swap set-sql-spec-primary-key ] [ drop ] if*
+ [ >>primary-key drop ] [ drop ] if*
] if ;
: find-primary-key ( specs -- obj )
- [ sql-spec-primary-key ] find nip ;
+ [ primary-key>> ] find nip ;
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
@@ -88,7 +87,7 @@ FACTOR-BLOB NULL ;
[ relation? not ] subset ;
: remove-id ( specs -- obj )
- [ sql-spec-primary-key not ] subset ;
+ [ primary-key>> not ] subset ;
! SQLite Types: http://www.sqlite.org/datatype3.html
! NULL INTEGER REAL TEXT BLOB
@@ -100,29 +99,28 @@ ERROR: unknown-modifier ;
: lookup-modifier ( obj -- str )
{
{ [ dup array? ] [ unclip lookup-modifier swap compound ] }
- [ modifier-table at* [ unknown-modifier ] unless ]
+ [ persistent-table at* [ unknown-modifier ] unless third ]
} cond ;
ERROR: no-sql-type ;
-: lookup-type* ( obj -- str )
+: (lookup-type) ( obj -- str )
+ persistent-table at* [ no-sql-type ] unless ;
+
+: lookup-type ( obj -- str )
dup array? [
- first lookup-type*
+ unclip (lookup-type) first nip
] [
- type-table at* [ no-sql-type ] unless
+ (lookup-type) first
] if ;
: lookup-create-type ( obj -- str )
dup array? [
- unclip lookup-create-type swap compound
+ unclip (lookup-type) second swap compound
] [
- dup create-type-table at*
- [ nip ] [ drop lookup-type* ] if
+ (lookup-type) second
] if ;
-: lookup-type ( obj create? -- str )
- [ lookup-create-type ] [ lookup-type* ] if ;
-
: single-quote ( str -- newstr )
"'" swap "'" 3append ;
@@ -136,8 +134,7 @@ ERROR: no-sql-type ;
" " swap 3append ;
: modifiers ( spec -- str )
- sql-spec-modifiers
- [ lookup-modifier ] map " " join
+ modifiers>> [ lookup-modifier ] map " " join
dup empty? [ " " prepend ] unless ;
HOOK: bind% db ( spec -- )
@@ -157,6 +154,6 @@ HOOK: bind# db ( spec obj -- )
: tuple>params ( specs tuple -- obj )
[
- >r dup sql-spec-type swap sql-spec-slot-name r>
+ >r [ type>> ] [ slot-name>> ] bi r>
get-slot-named swap
] curry { } map>assoc ;
From be8ac1d7b6a5c87d03ce3295ac1cf0ba40d38bef Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 20 Apr 2008 16:57:50 -0500
Subject: [PATCH 15/20] use new lookup for sqlite
---
extra/db/sqlite/sqlite.factor | 60 +++++++++++++----------------
extra/db/tuples/tuples-tests.factor | 29 ++++++--------
2 files changed, 37 insertions(+), 52 deletions(-)
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index fb3fbe92be..1bf3e28bb2 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -126,7 +126,7 @@ M: sqlite-db create-sql-statement ( class -- statement )
"(" 0% [ ", " 0% ] [
dup column-name>> 0%
" " 0%
- dup type>> t lookup-type 0%
+ dup type>> lookup-create-type 0%
modifiers 0%
] interleave ");" 0%
] sqlite-make dup sql>> . ;
@@ -247,42 +247,34 @@ M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
M: sqlite-db random-id-quot ( -- quot )
[ 64 [ 2^ random ] keep 1 - set-bit ] ;
-M: sqlite-db modifier-table ( -- hashtable )
+M: sqlite-db persistent-table ( -- assoc )
H{
- { +native-id+ "primary key" }
- { +assigned-id+ "primary key" }
- { +random-id+ "primary key" }
- { +autoincrement+ "autoincrement" }
- { +unique+ "unique" }
- { +default+ "default" }
- { +null+ "null" }
- { +not-null+ "not null" }
- { system-random-generator "" }
- { secure-random-generator "" }
- { random-generator "" }
+ { +native-id+ { "integer primary key" "integer primary key" f } }
+ { +assigned-id+ { f f "primary key" } }
+ { +random-id+ { "integer primary key" "integer primary key" f } }
+ { INTEGER { "integer" "integer" "primary key" } }
+ { BIG-INTEGER { "bigint" "bigint" } }
+ { SIGNED-BIG-INTEGER { "bigint" "bigint" } }
+ { UNSIGNED-BIG-INTEGER { "bigint" "bigint" } }
+ { TEXT { "text" "text" } }
+ { VARCHAR { "text" "text" } }
+ { DATE { "date" "date" } }
+ { TIME { "time" "time" } }
+ { DATETIME { "datetime" "datetime" } }
+ { TIMESTAMP { "timestamp" "timestamp" } }
+ { DOUBLE { "real" "real" } }
+ { BLOB { "blob" "blob" } }
+ { FACTOR-BLOB { "blob" "blob" } }
+ { +autoincrement+ { f f "autoincrement" } }
+ { +unique+ { f f "unique" } }
+ { +default+ { f f "default" } }
+ { +null+ { f f "null" } }
+ { +not-null+ { f f "not null" } }
+ { system-random-generator { f f f } }
+ { secure-random-generator { f f f } }
+ { random-generator { f f f } }
} ;
-M: sqlite-db type-table ( -- assoc )
- H{
- { +native-id+ "integer primary key" }
- { +random-id+ "integer primary key" }
- { INTEGER "integer" }
- { BIG-INTEGER "bigint" }
- { SIGNED-BIG-INTEGER "bigint" }
- { UNSIGNED-BIG-INTEGER "bigint" }
- { TEXT "text" }
- { VARCHAR "text" }
- { DATE "date" }
- { TIME "time" }
- { DATETIME "datetime" }
- { TIMESTAMP "timestamp" }
- { DOUBLE "real" }
- { BLOB "blob" }
- { FACTOR-BLOB "blob" }
- } ;
-
-M: sqlite-db create-type-table ( symbol -- str ) type-table ;
-
M: sqlite-db compound ( str seq -- str' )
over {
{ "default" [ first number>string join-space ] }
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 0648f9b254..c6870bd703 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges
-prettyprint tools.walker db.sqlite calendar sequences
+prettyprint tools.walker calendar sequences db.sqlite
math.intervals db.postgresql accessors random math.bitfields.lib ;
IN: db.tuples.tests
@@ -106,13 +106,6 @@ SYMBOL: person4
[ ] [ person drop-table ] unit-test ;
-: make-native-person-table ( -- )
- [ person drop-table ] [ drop ] recover
- person create-table
- T{ person f f "billy" 200 3.14 } insert-tuple
- T{ person f f "johnny" 10 3.14 } insert-tuple
- ;
-
: native-person-schema ( -- )
person "PERSON"
{
@@ -192,7 +185,6 @@ TUPLE: annotation n paste-id summary author mode contents ;
: test-repeated-insert
[ ] [ person ensure-table ] unit-test
-
[ ] [ person1 get insert-tuple ] unit-test
[ person1 get insert-tuple ] must-fail ;
@@ -302,11 +294,12 @@ TUPLE: bignum-test id m n o ;
} define-persistent
[ bignum-test drop-table ] ignore-errors
[ ] [ bignum-test ensure-table ] unit-test
- [ ] [ 63 2^ dup dup <bignum-test> insert-tuple ] unit-test
+ [ ] [ 63 2^ 1- dup dup <bignum-test> insert-tuple ] unit-test ;
- [ T{ bignum-test f 1
- -9223372036854775808 9223372036854775808 -9223372036854775808 } ]
- [ T{ bignum-test f 1 } select-tuple ] unit-test ;
+ ! sqlite only
+ ! [ T{ bignum-test f 1
+ ! -9223372036854775808 9223372036854775808 -9223372036854775808 } ]
+ ! [ T{ bignum-test f 1 } select-tuple ] unit-test ;
TUPLE: secret n message ;
C: <secret> secret
@@ -346,17 +339,17 @@ C: <secret> secret
[ native-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-repeated-insert ] test-postgresql
-[ test-bignum ] test-sqlite
+[ test-bignum ] test-postgresql
[ test-serialize ] test-postgresql
! [ test-intervals ] test-postgresql
! [ test-random-id ] test-postgresql
TUPLE: does-not-persist ;
-[
- [ does-not-persist create-sql-statement ]
- [ class \ not-persistent = ] must-fail-with
-] test-sqlite
+! [
+ ! [ does-not-persist create-sql-statement ]
+ ! [ class \ not-persistent = ] must-fail-with
+! ] test-sqlite
[
[ does-not-persist create-sql-statement ]
From 5dc015f0f563fdd3ba657b2de62e36f859539113 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 20 Apr 2008 17:47:43 -0500
Subject: [PATCH 16/20] add queries.db to refactor some code
---
extra/db/postgresql/postgresql.factor | 41 ++++++++-------------------
extra/db/queries/queries.factor | 19 +++++++++++++
extra/db/sqlite/sqlite.factor | 28 +++++-------------
3 files changed, 38 insertions(+), 50 deletions(-)
create mode 100644 extra/db/queries/queries.factor
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index 04a0a7143f..4b76804fc2 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -5,7 +5,7 @@ kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators sequences.lib classes locals words tools.walker
-namespaces.lib accessors random ;
+namespaces.lib accessors random db.queries ;
IN: db.postgresql
TUPLE: postgresql-db < db
@@ -15,9 +15,6 @@ TUPLE: postgresql-statement < statement ;
TUPLE: postgresql-result-set < result-set ;
-: <postgresql-statement> ( statement in out -- postgresql-statement )
- postgresql-statement construct-statement ;
-
M: postgresql-db make-db* ( seq tuple -- db )
>r first4 r>
swap >>db
@@ -99,19 +96,10 @@ M: postgresql-statement prepare-statement ( statement -- )
>>handle drop ;
M: postgresql-db <simple-statement> ( sql in out -- statement )
- <postgresql-statement> ;
+ postgresql-statement construct-statement ;
M: postgresql-db <prepared-statement> ( sql in out -- statement )
- <postgresql-statement> dup prepare-statement ;
-
-M: postgresql-db begin-transaction ( -- )
- "BEGIN" sql-command ;
-
-M: postgresql-db commit-transaction ( -- )
- "COMMIT" sql-command ;
-
-M: postgresql-db rollback-transaction ( -- )
- "ROLLBACK" sql-command ;
+ <simple-statement> dup prepare-statement ;
SYMBOL: postgresql-counter
: bind-name% ( -- )
@@ -124,11 +112,6 @@ M: postgresql-db bind% ( spec -- )
M: postgresql-db bind# ( spec obj -- )
>r bind-name% f swap type>> r> <literal-bind> 1, ;
-: postgresql-make ( class quot -- )
- >r sql-props r>
- [ postgresql-counter off call ] { "" { } { } } nmake
- <postgresql-statement> ; inline
-
: create-table-sql ( class -- statement )
[
"create table " 0% 0%
@@ -138,7 +121,7 @@ M: postgresql-db bind# ( spec obj -- )
dup type>> lookup-create-type 0%
modifiers 0%
] interleave ");" 0%
- ] postgresql-make ;
+ ] query-make ;
: create-function-sql ( class -- statement )
[
@@ -160,7 +143,7 @@ M: postgresql-db bind# ( spec obj -- )
swap [ ", " 0% ] [ drop bind-name% ] interleave
"); " 0%
"select currval(''" 0% 0% "_id_seq'');' language sql;" 0%
- ] postgresql-make ;
+ ] query-make ;
M: postgresql-db create-sql-statement ( class -- seq )
[
@@ -176,12 +159,12 @@ M: postgresql-db create-sql-statement ( class -- seq )
remove-id
[ ", " 0% ] [ type>> lookup-type 0% ] interleave
");" 0%
- ] postgresql-make ;
+ ] query-make ;
: drop-table-sql ( table -- statement )
[
"drop table " 0% 0% ";" 0% drop
- ] postgresql-make ;
+ ] query-make ;
M: postgresql-db drop-sql-statement ( class -- seq )
[
@@ -198,7 +181,7 @@ M: postgresql-db <insert-native-statement> ( class -- statement )
remove-id
[ ", " 0% ] [ bind% ] interleave
");" 0%
- ] postgresql-make ;
+ ] query-make ;
M: postgresql-db <insert-nonnative-statement> ( class -- statement )
[
@@ -210,7 +193,7 @@ M: postgresql-db <insert-nonnative-statement> ( class -- statement )
" values(" 0%
[ ", " 0% ] [ bind% ] interleave
");" 0%
- ] postgresql-make ;
+ ] query-make ;
M: postgresql-db insert-tuple* ( tuple statement -- )
query-modify-tuple ;
@@ -225,7 +208,7 @@ M: postgresql-db <update-tuple-statement> ( class -- statement )
" where " 0%
find-primary-key
dup column-name>> 0% " = " 0% bind%
- ] postgresql-make ;
+ ] query-make ;
M: postgresql-db <delete-tuple-statement> ( class -- statement )
[
@@ -233,7 +216,7 @@ M: postgresql-db <delete-tuple-statement> ( class -- statement )
" where " 0%
find-primary-key
dup column-name>> 0% " = " 0% bind%
- ] postgresql-make ;
+ ] query-make ;
M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
[
@@ -250,7 +233,7 @@ M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
[ " and " 0% ]
[ dup column-name>> 0% " = " 0% bind% ] interleave
] if ";" 0%
- ] postgresql-make ;
+ ] query-make ;
M: postgresql-db persistent-table ( -- hashtable )
H{
diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor
new file mode 100644
index 0000000000..d0b379ab76
--- /dev/null
+++ b/extra/db/queries/queries.factor
@@ -0,0 +1,19 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces sequences namespaces.lib db
+db.tuples db.types ;
+IN: db.queries
+
+: maybe-make-retryable ( statement -- statement )
+ dup in-params>> [ generator-bind? ] contains? [
+ make-retryable
+ ] when ;
+
+: query-make ( class quot -- )
+ >r sql-props r>
+ [ 0 sql-counter rot with-variable ] { "" { } { } } nmake
+ <simple-statement> maybe-make-retryable ;
+
+M: db begin-transaction ( -- ) "BEGIN" sql-command ;
+M: db commit-transaction ( -- ) "COMMIT" sql-command ;
+M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index 1bf3e28bb2..5ceff51325 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -6,7 +6,7 @@ prettyprint sequences strings classes.tuple alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators math.intervals
io namespaces.lib accessors vectors math.ranges random
-math.bitfields.lib ;
+math.bitfields.lib db.queries ;
USE: tools.walker
IN: db.sqlite
@@ -106,20 +106,6 @@ M: sqlite-statement query-results ( query -- result-set )
dup handle>> sqlite-result-set construct-result-set
dup advance-row ;
-M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
-M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ;
-M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
-
-: maybe-make-retryable ( statement -- statement )
- dup in-params>> [ generator-bind? ] contains? [
- make-retryable
- ] when ;
-
-: sqlite-make ( class quot -- )
- >r sql-props r>
- [ 0 sql-counter rot with-variable ] { "" { } { } } nmake
- <simple-statement> maybe-make-retryable ;
-
M: sqlite-db create-sql-statement ( class -- statement )
[
"create table " 0% 0%
@@ -129,10 +115,10 @@ M: sqlite-db create-sql-statement ( class -- statement )
dup type>> lookup-create-type 0%
modifiers 0%
] interleave ");" 0%
- ] sqlite-make dup sql>> . ;
+ ] query-make dup sql>> . ;
M: sqlite-db drop-sql-statement ( class -- statement )
- [ "drop table " 0% 0% ";" 0% drop ] sqlite-make ;
+ [ "drop table " 0% 0% ";" 0% drop ] query-make ;
M: sqlite-db <insert-native-statement> ( tuple -- statement )
[
@@ -156,7 +142,7 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
] if
] interleave
");" 0%
- ] sqlite-make ;
+ ] query-make ;
M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
<insert-native-statement> ;
@@ -222,7 +208,7 @@ M: sqlite-db <update-tuple-statement> ( class -- statement )
dup remove-id
[ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
where-primary-key%
- ] sqlite-make ;
+ ] query-make ;
M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
[
@@ -230,7 +216,7 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
" where " 0%
find-primary-key
dup column-name>> 0% " = " 0% bind%
- ] sqlite-make ;
+ ] query-make ;
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[
@@ -242,7 +228,7 @@ M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
dupd
[ slot-name>> swap get-slot-named ] with subset
dup empty? [ 2drop ] [ where-clause ] if ";" 0%
- ] sqlite-make ;
+ ] query-make ;
M: sqlite-db random-id-quot ( -- quot )
[ 64 [ 2^ random ] keep 1 - set-bit ] ;
From cd62fff6045932f2468f8ea7b5270a06b1ed4303 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 20 Apr 2008 17:50:39 -0500
Subject: [PATCH 17/20] remove old code
---
extra/db/postgresql/postgresql.factor | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index 4b76804fc2..0401913a8d 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -101,10 +101,9 @@ M: postgresql-db <simple-statement> ( sql in out -- statement )
M: postgresql-db <prepared-statement> ( sql in out -- statement )
<simple-statement> dup prepare-statement ;
-SYMBOL: postgresql-counter
: bind-name% ( -- )
CHAR: $ 0,
- postgresql-counter [ inc ] [ get 0# ] bi ;
+ sql-counter [ inc ] [ get 0# ] bi ;
M: postgresql-db bind% ( spec -- )
bind-name% 1, ;
From dfe736a8b98b522797004f510fbb10f6e26525cb Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 20 Apr 2008 17:55:08 -0500
Subject: [PATCH 18/20] eliminate tons of code duplication
---
extra/db/postgresql/postgresql.factor | 20 ------------------
extra/db/queries/queries.factor | 29 +++++++++++++++++++++++++--
extra/db/sqlite/sqlite.factor | 25 -----------------------
3 files changed, 27 insertions(+), 47 deletions(-)
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index 0401913a8d..fc3b08d9b9 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -197,26 +197,6 @@ M: postgresql-db <insert-nonnative-statement> ( class -- statement )
M: postgresql-db insert-tuple* ( tuple statement -- )
query-modify-tuple ;
-M: postgresql-db <update-tuple-statement> ( class -- statement )
- [
- "update " 0% 0%
- " set " 0%
- dup remove-id
- [ ", " 0% ]
- [ dup column-name>> 0% " = " 0% bind% ] interleave
- " where " 0%
- find-primary-key
- dup column-name>> 0% " = " 0% bind%
- ] query-make ;
-
-M: postgresql-db <delete-tuple-statement> ( class -- statement )
- [
- "delete from " 0% 0%
- " where " 0%
- find-primary-key
- dup column-name>> 0% " = " 0% bind%
- ] query-make ;
-
M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
[
"select " 0%
diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor
index d0b379ab76..79c1909c05 100644
--- a/extra/db/queries/queries.factor
+++ b/extra/db/queries/queries.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces sequences namespaces.lib db
-db.tuples db.types ;
+USING: accessors kernel math namespaces sequences random
+math.bitfields.lib namespaces.lib db db.tuples db.types ;
IN: db.queries
: maybe-make-retryable ( statement -- statement )
@@ -17,3 +17,28 @@ IN: db.queries
M: db begin-transaction ( -- ) "BEGIN" sql-command ;
M: db commit-transaction ( -- ) "COMMIT" sql-command ;
M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
+
+: where-primary-key% ( specs -- )
+ " where " 0%
+ find-primary-key dup column-name>> 0% " = " 0% bind% ;
+
+M: db <update-tuple-statement> ( class -- statement )
+ [
+ "update " 0% 0%
+ " set " 0%
+ dup remove-id
+ [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
+ where-primary-key%
+ ] query-make ;
+
+M: db <delete-tuple-statement> ( specs table -- sql )
+ [
+ "delete from " 0% 0%
+ " where " 0%
+ find-primary-key
+ dup column-name>> 0% " = " 0% bind%
+ ] query-make ;
+
+M: db random-id-quot ( -- quot )
+ [ 63 [ 2^ random ] keep 1 - set-bit ] ;
+
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index 5ceff51325..b948fb1696 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -156,10 +156,6 @@ M: sqlite-db bind# ( spec obj -- )
M: sqlite-db bind% ( spec -- )
dup 1, column-name>> ":" prepend 0% ;
-: where-primary-key% ( specs -- )
- " where " 0%
- find-primary-key dup column-name>> 0% " = " 0% bind% ;
-
GENERIC: where ( specs obj -- )
: interval-comparison ( ? str -- str )
@@ -200,24 +196,6 @@ M: string where ( spec obj -- ) object-where ;
2dup slot-name>> swap get-slot-named where
] interleave drop ;
-M: sqlite-db <update-tuple-statement> ( class -- statement )
- [
- "update " 0%
- 0%
- " set " 0%
- dup remove-id
- [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
- where-primary-key%
- ] query-make ;
-
-M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
- [
- "delete from " 0% 0%
- " where " 0%
- find-primary-key
- dup column-name>> 0% " = " 0% bind%
- ] query-make ;
-
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[
"select " 0%
@@ -230,9 +208,6 @@ M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
dup empty? [ 2drop ] [ where-clause ] if ";" 0%
] query-make ;
-M: sqlite-db random-id-quot ( -- quot )
- [ 64 [ 2^ random ] keep 1 - set-bit ] ;
-
M: sqlite-db persistent-table ( -- assoc )
H{
{ +native-id+ { "integer primary key" "integer primary key" f } }
From 4da64986f3503902136e8492842b6297006d635a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 21 Apr 2008 00:13:12 -0500
Subject: [PATCH 19/20] fix postgresql for new alien accessors
---
extra/db/postgresql/lib/lib.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor
index 56bfc29be8..3fc95fcafe 100755
--- a/extra/db/postgresql/lib/lib.factor
+++ b/extra/db/postgresql/lib/lib.factor
@@ -4,8 +4,8 @@ USING: arrays continuations db io kernel math namespaces
quotations sequences db.postgresql.ffi alien alien.c-types
db.types tools.walker ascii splitting math.parser combinators
libc shuffle calendar.format byte-arrays destructors prettyprint
-accessors strings serialize io.encodings.binary
-io.streams.byte-array inspector ;
+accessors strings serialize io.encodings.binary io.encodings.utf8
+alien.strings io.streams.byte-array inspector ;
IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f )
@@ -79,7 +79,7 @@ M: postgresql-result-null summary ( obj -- str )
{ BLOB [ dup [ malloc-byte-array/length ] [ 0 ] if ] }
[
drop number>string* dup [
- malloc-char-string dup free-always
+ utf8 malloc-string dup free-always
] when 0
]
} case 2array
@@ -111,7 +111,7 @@ M: postgresql-result-null summary ( obj -- str )
PQgetisnull 1 = ;
: pq-get-string ( handle row column -- obj )
- 3dup PQgetvalue alien>char-string
+ 3dup PQgetvalue utf8 alien>string
dup empty? [ >r pq-get-is-null f r> ? ] [ 3nip ] if ;
: pq-get-number ( handle row column -- obj )
From 411fb2f97d871b4c40fedcd0915a580f7bfd8499 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 21 Apr 2008 00:45:14 -0500
Subject: [PATCH 20/20] postgresql interval and range and sequence queries
---
extra/db/postgresql/postgresql.factor | 32 +++++++--------
extra/db/queries/queries.factor | 56 ++++++++++++++++++++++++++-
extra/db/sqlite/sqlite.factor | 52 -------------------------
extra/db/tuples/tuples-tests.factor | 2 +-
4 files changed, 69 insertions(+), 73 deletions(-)
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index fc3b08d9b9..057c5f5168 100755
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -39,9 +39,20 @@ M: postgresql-db dispose ( db -- )
M: postgresql-statement bind-statement* ( statement -- )
drop ;
+GENERIC: postgresql-bind-conversion
+
+M: sql-spec postgresql-bind-conversion ( tuple spec -- array )
+ slot-name>> swap get-slot-named ;
+
+M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- array )
+ nip value>> ;
+
+M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- array )
+ nip quot>> call ;
+
M: postgresql-statement bind-tuple ( tuple statement -- )
tuck in-params>>
- [ slot-name>> swap get-slot-named ] with map
+ [ postgresql-bind-conversion ] with map
>>bind-params drop ;
M: postgresql-result-set #rows ( result-set -- n )
@@ -197,29 +208,12 @@ M: postgresql-db <insert-nonnative-statement> ( class -- statement )
M: postgresql-db insert-tuple* ( tuple statement -- )
query-modify-tuple ;
-M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
- [
- "select " 0%
- over [ ", " 0% ]
- [ dup column-name>> 0% 2, ] interleave
-
- " from " 0% 0%
- [ slot-name>> swap get-slot-named ] with subset
- dup empty? [
- drop
- ] [
- " where " 0%
- [ " and " 0% ]
- [ dup column-name>> 0% " = " 0% bind% ] interleave
- ] if ";" 0%
- ] query-make ;
-
M: postgresql-db persistent-table ( -- hashtable )
H{
{ +native-id+ { "integer" "serial primary key" f } }
{ +assigned-id+ { f f "primary key" } }
{ +random-id+ { "bigint" "bigint primary key" f } }
- { TEXT { "text" f f } }
+ { TEXT { "text" "text" f } }
{ VARCHAR { "varchar" "varchar" f } }
{ INTEGER { "integer" "integer" f } }
{ BIG-INTEGER { "bigint" "bigint" f } }
diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor
index 79c1909c05..7053eefba1 100644
--- a/extra/db/queries/queries.factor
+++ b/extra/db/queries/queries.factor
@@ -1,7 +1,9 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math namespaces sequences random
-math.bitfields.lib namespaces.lib db db.tuples db.types ;
+strings
+math.bitfields.lib namespaces.lib db db.tuples db.types
+math.intervals ;
IN: db.queries
: maybe-make-retryable ( statement -- statement )
@@ -42,3 +44,55 @@ M: db <delete-tuple-statement> ( specs table -- sql )
M: db random-id-quot ( -- quot )
[ 63 [ 2^ random ] keep 1 - set-bit ] ;
+GENERIC: where ( specs obj -- )
+
+: interval-comparison ( ? str -- str )
+ "from" = " >" " <" ? swap [ "= " append ] when ;
+
+: where-interval ( spec obj from/to -- )
+ pick column-name>> 0%
+ >r first2 r> interval-comparison 0%
+ bind# ;
+
+: in-parens ( quot -- )
+ "(" 0% call ")" 0% ; inline
+
+M: interval where ( spec obj -- )
+ [
+ [ from>> "from" where-interval " and " 0% ]
+ [ to>> "to" where-interval ] 2bi
+ ] in-parens ;
+
+M: sequence where ( spec obj -- )
+ [
+ [ " or " 0% ] [ dupd where ] interleave drop
+ ] in-parens ;
+
+: object-where ( spec obj -- )
+ over column-name>> 0% " = " 0% bind# ;
+
+M: object where ( spec obj -- ) object-where ;
+
+M: integer where ( spec obj -- ) object-where ;
+
+M: string where ( spec obj -- ) object-where ;
+
+: where-clause ( tuple specs -- )
+ " where " 0% [
+ " and " 0%
+ ] [
+ 2dup slot-name>> swap get-slot-named where
+ ] interleave drop ;
+
+M: db <select-by-slots-statement> ( tuple class -- statement )
+ [
+ "select " 0%
+ over [ ", " 0% ]
+ [ dup column-name>> 0% 2, ] interleave
+
+ " from " 0% 0%
+ dupd
+ [ slot-name>> swap get-slot-named ] with subset
+ dup empty? [ 2drop ] [ where-clause ] if ";" 0%
+ ] query-make ;
+
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index b948fb1696..f4247cf6d8 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -156,58 +156,6 @@ M: sqlite-db bind# ( spec obj -- )
M: sqlite-db bind% ( spec -- )
dup 1, column-name>> ":" prepend 0% ;
-GENERIC: where ( specs obj -- )
-
-: interval-comparison ( ? str -- str )
- "from" = " >" " <" ? swap [ "= " append ] when ;
-
-: where-interval ( spec obj from/to -- )
- pick column-name>> 0%
- >r first2 r> interval-comparison 0%
- bind# ;
-
-: in-parens ( quot -- )
- "(" 0% call ")" 0% ; inline
-
-M: interval where ( spec obj -- )
- [
- [ from>> "from" where-interval " and " 0% ]
- [ to>> "to" where-interval ] 2bi
- ] in-parens ;
-
-M: sequence where ( spec obj -- )
- [
- [ " or " 0% ] [ dupd where ] interleave drop
- ] in-parens ;
-
-: object-where ( spec obj -- )
- over column-name>> 0% " = " 0% bind# ;
-
-M: object where ( spec obj -- ) object-where ;
-
-M: integer where ( spec obj -- ) object-where ;
-
-M: string where ( spec obj -- ) object-where ;
-
-: where-clause ( tuple specs -- )
- " where " 0% [
- " and " 0%
- ] [
- 2dup slot-name>> swap get-slot-named where
- ] interleave drop ;
-
-M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
- [
- "select " 0%
- over [ ", " 0% ]
- [ dup column-name>> 0% 2, ] interleave
-
- " from " 0% 0%
- dupd
- [ slot-name>> swap get-slot-named ] with subset
- dup empty? [ 2drop ] [ where-clause ] if ";" 0%
- ] query-make ;
-
M: sqlite-db persistent-table ( -- assoc )
H{
{ +native-id+ { "integer primary key" "integer primary key" f } }
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index c6870bd703..026370e806 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -341,7 +341,7 @@ C: <secret> secret
[ assigned-person-schema test-repeated-insert ] test-postgresql
[ test-bignum ] test-postgresql
[ test-serialize ] test-postgresql
-! [ test-intervals ] test-postgresql
+[ test-intervals ] test-postgresql
! [ test-random-id ] test-postgresql
TUPLE: does-not-persist ;