diff --git a/extra/db/db.factor b/extra/db/db.factor index baf4e9db5a..82193ed467 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 @@ -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 -- ) @@ -36,17 +36,25 @@ 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 ; TUPLE: simple-statement < statement ; TUPLE: prepared-statement < statement ; -TUPLE: nonthrowable-statement < statement ; -TUPLE: throwable-statement < statement ; + +SINGLETON: throwable +SINGLETON: nonthrowable + +: 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 ; TUPLE: result-set sql in-params out-params handle n max ; @@ -55,12 +63,14 @@ TUPLE: result-set sql in-params out-params handle n max ; new swap >>out-params swap >>in-params - swap >>sql ; + swap >>sql + throwable >>type ; HOOK: db ( str in out -- statement ) HOOK: 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 ) @@ -70,20 +80,19 @@ 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 -- ) +M: throwable execute-statement* ( statement type -- ) + drop query-results dispose ; + +M: nonthrowable execute-statement* ( statement type -- ) + drop [ query-results dispose ] [ 2drop ] recover ; + +: execute-statement ( statement -- ) dup sequence? [ [ execute-statement ] each ] [ - query-results dispose - ] if ; - -M: nonthrowable-statement execute-statement ( statement -- ) - dup sequence? [ - [ execute-statement ] each - ] [ - [ query-results dispose ] [ 2drop ] recover + dup type>> execute-statement* ] if ; : bind-statement ( obj statement -- ) diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index bfe7dab3ce..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 ; +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 ) @@ -23,12 +23,18 @@ 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 ; -: 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? ; @@ -37,8 +43,8 @@ IN: db.postgresql.lib 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? [ - dup postgresql-result-error-message swap PQclear throw + db get handle>> swap sql>> PQexec dup postgresql-result-ok? [ + [ postgresql-result-error-message ] [ PQclear ] bi throw ] unless ; : type>oid ( symbol -- n ) @@ -58,28 +64,22 @@ IN: db.postgresql.lib } 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 + utf8 malloc-string dup free-always ] when 0 ] } case 2array @@ -90,22 +90,20 @@ IN: db.postgresql.lib ] 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 ; @@ -113,8 +111,8 @@ IN: db.postgresql.lib PQgetisnull 1 = ; : pq-get-string ( handle row column -- obj ) - 3dup PQgetvalue alien>char-string - dup "" = [ >r pq-get-is-null f r> ? ] [ 3nip ] if ; + 3dup PQgetvalue utf8 alien>string + 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 ; @@ -167,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 322143e7a2..057c5f5168 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -5,19 +5,16 @@ 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 db.queries ; 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 ; -: ( statement in out -- postgresql-statement ) - postgresql-statement construct-statement ; - M: postgresql-db make-db* ( seq tuple -- db ) >r first4 r> swap >>db @@ -42,11 +39,21 @@ 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 -- ) - [ - statement-in-params - [ sql-spec-slot-name swap get-slot-named ] with map - ] keep set-statement-bind-params ; + tuck in-params>> + [ postgresql-bind-conversion ] with map + >>bind-params drop ; M: postgresql-result-set #rows ( result-set -- n ) handle>> PQntuples ; @@ -54,15 +61,18 @@ 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 dup result-set-handle swap result-set-n 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 result-set-out-params nth sql-spec-type - >r >r [ result-set-handle ] [ result-set-n ] bi r> r> postgresql-column-typed ; + dup pick out-params>> nth type>> + >r >r result-handle-n 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 ] [ @@ -72,67 +82,56 @@ 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 result-set-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> - dup statement-sql swap statement-in-params - length f PQprepare postgresql-error - ] keep set-statement-handle ; + dup + >r db get handle>> f r> + [ sql>> ] [ in-params>> ] bi + length f PQprepare postgresql-error + >>handle drop ; M: postgresql-db ( sql in out -- statement ) - ; + postgresql-statement construct-statement ; M: postgresql-db ( sql in out -- statement ) - dup prepare-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 ; - -SYMBOL: postgresql-counter : bind-name% ( -- ) CHAR: $ 0, - postgresql-counter [ inc ] keep get 0# ; + sql-counter [ inc ] [ get 0# ] bi ; M: postgresql-db bind% ( spec -- ) - 1, bind-name% ; + bind-name% 1, ; -: postgresql-make ( class quot -- ) - >r sql-props r> - [ postgresql-counter off call ] { "" { } { } } nmake - ; inline +M: postgresql-db bind# ( spec obj -- ) + >r bind-name% f swap type>> r> 1, ; : 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>> lookup-create-type 0% modifiers 0% ] interleave ");" 0% - ] postgresql-make ; + ] query-make ; : create-function-sql ( class -- statement ) [ @@ -141,7 +140,7 @@ M: postgresql-db bind% ( spec -- ) "(" 0% over [ "," 0% ] [ - sql-spec-type f lookup-type 0% + type>> lookup-type 0% ] interleave ")" 0% " returns bigint as '" 0% @@ -149,12 +148,12 @@ M: postgresql-db bind% ( spec -- ) "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% "select currval(''" 0% 0% "_id_seq'');' language sql;" 0% - ] postgresql-make ; + ] query-make ; M: postgresql-db create-sql-statement ( class -- seq ) [ @@ -168,14 +167,14 @@ 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>> 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 ) [ @@ -192,107 +191,60 @@ M: postgresql-db ( class -- statement ) remove-id [ ", " 0% ] [ bind% ] interleave ");" 0% - ] postgresql-make ; + ] query-make ; M: postgresql-db ( class -- statement ) [ "insert into " 0% 0% "(" 0% - dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + dup [ ", " 0% ] [ column-name>> 0% ] interleave ")" 0% " values(" 0% [ ", " 0% ] [ bind% ] interleave ");" 0% - ] postgresql-make ; + ] query-make ; M: postgresql-db insert-tuple* ( tuple statement -- ) query-modify-tuple ; -M: postgresql-db ( class -- statement ) - [ - "update " 0% 0% - " set " 0% - dup remove-id - [ ", " 0% ] - [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave - " where " 0% - find-primary-key - dup sql-spec-column-name 0% " = " 0% bind% - ] postgresql-make ; - -M: postgresql-db ( class -- statement ) - [ - "delete from " 0% 0% - " where " 0% - find-primary-key - dup sql-spec-column-name 0% " = " 0% bind% - ] postgresql-make ; - -M: postgresql-db ( tuple class -- statement ) - [ - ! tuple columns table - "select " 0% - over [ ", " 0% ] - [ dup sql-spec-column-name 0% 2, ] interleave - - " from " 0% 0% - [ sql-spec-slot-name swap get-slot-named ] with subset - dup empty? [ - drop - ] [ - " where " 0% - [ " and " 0% ] - [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave - ] if ";" 0% - ] postgresql-make ; - -M: postgresql-db type-table ( -- hash ) +M: postgresql-db persistent-table ( -- hashtable ) H{ - { +native-id+ "integer" } - { TEXT "text" } - { VARCHAR "varchar" } - { INTEGER "integer" } - { DOUBLE "real" } - { DATE "date" } - { TIME "time" } - { DATETIME "timestamp" } - { TIMESTAMP "timestamp" } - { BLOB "bytea" } - { FACTOR-BLOB "bytea" } + { +native-id+ { "integer" "serial primary key" f } } + { +assigned-id+ { f f "primary key" } } + { +random-id+ { "bigint" "bigint primary key" f } } + { TEXT { "text" "text" 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 create-type-table ( -- hash ) - H{ - { +native-id+ "serial primary key" } - } ; - -: postgresql-compound ( str n -- newstr ) +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 [ 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 ; - -M: postgresql-db compound-modifier ( str seq -- newstr ) - postgresql-compound ; - -M: postgresql-db modifier-table ( -- hashtable ) - H{ - { +native-id+ "primary key" } - { +assigned-id+ "primary key" } - { +foreign-id+ "references" } - { +autoincrement+ "autoincrement" } - { +unique+ "unique" } - { +default+ "default" } - { +null+ "null" } - { +not-null+ "not null" } - } ; - -M: postgresql-db compound-type ( str n -- newstr ) - postgresql-compound ; diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor new file mode 100644 index 0000000000..7053eefba1 --- /dev/null +++ b/extra/db/queries/queries.factor @@ -0,0 +1,98 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel math namespaces sequences random +strings +math.bitfields.lib namespaces.lib db db.tuples db.types +math.intervals ; +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 + maybe-make-retryable ; + +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 ( 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 ( 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 ] ; + +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 ( 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/sql/sql-tests.factor b/extra/db/sql/sql-tests.factor index 488026fcc7..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" } @@ -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..4561424a9d 100755 --- a/extra/db/sql/sql.factor +++ b/extra/db/sql/sql.factor @@ -27,27 +27,27 @@ 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 [ "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 ; -TUPLE: no-sql-match ; +ERROR: no-sql-match ; : sql% ( obj -- ) { { [ dup string? ] [ " " 0% 0% ] } @@ -55,15 +55,18 @@ TUPLE: no-sql-match ; { [ dup number? ] [ number>string sql% ] } { [ dup symbol? ] [ unparse sql% ] } { [ dup word? ] [ unparse sql% ] } - [ T{ no-sql-match } throw ] + { [ dup quotation? ] [ call ] } + [ no-sql-match ] } 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/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index c724025874..4b5a019fca 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" { @@ -108,24 +108,31 @@ 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 ) ; -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 ) ; +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 ) ; 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 e66accd7e9..b6078fc983 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*" [ sqlite3_open sqlite-check-result ] keep *void* ; @@ -32,7 +33,7 @@ IN: db.sqlite.lib : sqlite-prepare ( db sql -- handle ) dup length "void*" "void*" - [ sqlite3_prepare sqlite-check-result ] 2keep + [ sqlite3_prepare_v2 sqlite-check-result ] 2keep drop *void* ; : sqlite-bind-parameter-index ( handle name -- index ) @@ -51,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 ; @@ -68,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 ; @@ -85,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 ] } @@ -98,12 +107,15 @@ 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 ; : 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 ; @@ -120,10 +132,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 11c0150cd2..f4247cf6d8 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -4,8 +4,10 @@ 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 -io namespaces.lib accessors ; +words combinators.lib db.types combinators math.intervals +io namespaces.lib accessors vectors math.ranges random +math.bitfields.lib db.queries ; +USE: tools.walker IN: db.sqlite TUPLE: sqlite-db < db path ; @@ -19,7 +21,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? ; @@ -42,28 +44,39 @@ 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 ) + +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: 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>> - [ - [ 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 @@ -93,27 +106,19 @@ 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 ; - -: sqlite-make ( class quot -- ) - >r sql-props r> - { "" { } { } } nmake ; inline - M: sqlite-db create-sql-statement ( class -- statement ) [ "create table " 0% 0% "(" 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 ; + ] 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 ( tuple -- statement ) [ @@ -122,91 +127,66 @@ M: sqlite-db ( tuple -- statement ) maybe-remove-id dup [ ", " 0% ] [ column-name>> 0% ] interleave ") values(" 0% - [ ", " 0% ] [ bind% ] interleave + [ ", " 0% ] [ + dup type>> +random-id+ = [ + dup modifiers>> find-random-generator + [ + [ + column-name>> ":" prepend + dup 0% random-id-quot + ] with-random + ] curry + [ type>> ] bi 1, + ] [ + bind% + ] if + ] interleave ");" 0% - ] sqlite-make ; + ] query-make ; M: sqlite-db ( tuple -- statement ) ; -: 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 ; - -M: sqlite-db ( class -- statement ) - [ - "update " 0% - 0% - " set " 0% - dup remove-id - [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave - where-primary-key% - ] sqlite-make ; - -M: sqlite-db ( specs table -- sql ) - [ - "delete from " 0% 0% - " where " 0% - find-primary-key - dup column-name>> 0% " = " 0% bind% - ] sqlite-make ; - -! : select-interval ( interval name -- ) ; -! : select-sequence ( seq name -- ) ; +M: sqlite-db bind# ( spec obj -- ) + >r + [ column-name>> ":" swap next-sql-counter 3append dup 0% ] + [ type>> ] bi + r> 1, ; M: sqlite-db bind% ( spec -- ) dup 1, column-name>> ":" prepend 0% ; -M: sqlite-db ( 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-clause ] if ";" 0% - ] sqlite-make ; - -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" } - ! { +nonnative-id+ "primary key" } - { +autoincrement+ "autoincrement" } - { +unique+ "unique" } - { +default+ "default" } - { +null+ "null" } - { +not-null+ "not null" } + { +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 compound-modifier ( str obj -- str' ) compound-type ; - -M: sqlite-db compound-type ( str seq -- str' ) +M: sqlite-db compound ( 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 ) - H{ - { +native-id+ "integer primary key" } - { +random-id+ "integer primary key" } - { INTEGER "integer" } - { 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 ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 951ded32ea..026370e806 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 -db.types continuations namespaces math -prettyprint tools.walker db.sqlite calendar -math.intervals db.postgresql ; +USING: io.files kernel tools.test db db.tuples classes +db.types continuations namespaces math math.ranges +prettyprint tools.walker calendar sequences db.sqlite +math.intervals db.postgresql accessors random math.bitfields.lib ; IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real @@ -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 ; @@ -212,12 +204,9 @@ 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-ranges ( -- ) +: test-intervals ( -- ) exam "EXAM" { { "id" "ID" +native-id+ } @@ -233,12 +222,84 @@ 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 + + [ + { + 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 ; + +TUPLE: bignum-test id m n o ; +: ( 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^ 1- dup dup insert-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 @@ -246,24 +307,54 @@ C: 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" insert-tuple ] unit-test - [ ] [ T{ secret } select-tuples ] unit-test - ; + [ ] [ f "kilroy was here2" insert-tuple ] unit-test + [ ] [ f "kilroy was here3" insert-tuple ] 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 + [ t ] [ + T{ secret } select-tuples + first message>> "kilroy was here" head? + ] unit-test + + [ t ] [ + T{ secret } select-tuples length 3 = + ] unit-test ; + +[ 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 + +[ 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-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-postgresql ! \ insert-tuple must-infer ! \ update-tuple must-infer diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 311f18daa9..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 @@ -13,15 +13,25 @@ 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 -- ) [ 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 ) @@ -39,6 +49,40 @@ HOOK: 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 [ [ @@ -58,7 +102,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? [ @@ -85,17 +129,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 [ ] 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 98bc451a6f..a31713fa35 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -4,16 +4,21 @@ 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 ) -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: persistent-table db ( -- hash ) +HOOK: compound db ( str obj -- hash ) -TUPLE: sql-spec class slot-name column-name type modifiers primary-key ; +HOOK: random-id-quot db ( -- quot ) + +TUPLE: sql-spec class slot-name column-name type primary-key modifiers ; + +TUPLE: literal-bind key type value ; +C: literal-bind + +TUPLE: generator-bind key quot type ; +C: generator-bind SINGLETON: +native-id+ SINGLETON: +assigned-id+ @@ -24,50 +29,54 @@ 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+? ; + 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 ; -SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR -DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ; +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 ; @@ -78,40 +87,40 @@ TUPLE: no-sql-modifier ; [ 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 ! PostgreSQL Types: ! http://developer.postgresql.org/pgdocs/postgres/datatype.html -: lookup-modifier ( obj -- str ) - dup array? [ - unclip lookup-modifier swap compound-modifier - ] [ - modifier-table at* - [ "unknown modifier" throw ] unless - ] if ; +ERROR: unknown-modifier ; -: lookup-type* ( obj -- str ) +: lookup-modifier ( obj -- str ) + { + { [ dup array? ] [ unclip lookup-modifier swap compound ] } + [ persistent-table at* [ unknown-modifier ] unless third ] + } cond ; + +ERROR: no-sql-type ; + +: (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-type + 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 ; @@ -125,11 +134,11 @@ TUPLE: no-sql-modifier ; " " 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 -- ) +HOOK: bind# db ( spec obj -- ) : offset-of-slot ( str obj -- n ) class "slots" word-prop slot-named slot-spec-offset ; @@ -145,6 +154,6 @@ HOOK: bind% db ( spec -- ) : 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 ; diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 8e3d394754..62cd0adce1 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -201,9 +201,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