diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 00e39be2ba..cd17a32255 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -11,6 +11,26 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +SYMBOL: builds-dir + +: builds ( -- path ) + builds-dir get + home "/builds" append + or ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: prepare-build-machine ( -- ) + builds make-directory + builds cd + { "git" "clone" "git://factorcode.org/git/factor.git" } run-process drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : git-clone ( -- desc ) { "git" "clone" "../factor" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -19,7 +39,7 @@ VAR: stamp : enter-build-dir ( -- ) datestamp >stamp - "/builds" cd + builds cd stamp> make-directory stamp> cd ; @@ -69,14 +89,22 @@ VAR: stamp ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +SYMBOL: build-status + : (build) ( -- ) + builds-check + + build-status off + enter-build-dir "report" [ "Build machine: " write host-name print - "Build directory: " write cwd print + "CPU: " write cpu print + "OS: " write os print + "Build directory: " write cwd print nl git-clone [ "git clone failed" print ] run-or-bail @@ -88,7 +116,7 @@ VAR: stamp make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail - [ my-arch download-image ] [ "Image download error" print throw ] recover + [ retrieve-image ] [ "Image download error" print throw ] recover bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail @@ -98,7 +126,7 @@ VAR: stamp "Boot time: " write "../boot-time" eval-file milli-seconds>time print "Load time: " write "../load-time" eval-file milli-seconds>time print - "Test time: " write "../test-time" eval-file milli-seconds>time print + "Test time: " write "../test-time" eval-file milli-seconds>time print nl "Did not pass load-everything: " print "../load-everything-vocabs" cat "Did not pass test-all: " print "../test-all-vocabs" cat @@ -106,23 +134,32 @@ VAR: stamp "Benchmarks: " print "../benchmarks" [ stdio get contents eval ] with-file-in benchmarks. - ] with-file-out ; + ] with-file-out + + build-status on ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +SYMBOL: builder-from + SYMBOL: builder-recipients : tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ; -: build ( -- ) - [ (build) ] [ drop ] recover +: subject ( -- str ) build-status get [ "report" ] [ "error" ] if tag-subject ; + +: send-builder-email ( -- ) - "ed@factorcode.org" >>from + builder-from get >>from builder-recipients get >>to - "report" tag-subject >>subject + subject >>subject "../report" file>string >>body send ; +: build ( -- ) + [ (build) ] [ drop ] recover + [ send-builder-email ] [ drop "not sending mail" . ] recover ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : git-pull ( -- desc ) @@ -141,8 +178,9 @@ SYMBOL: builder-recipients = not ; : build-loop ( -- ) + builds-check [ - "/builds/factor" cd + builds "/factor" append cd updates-available? [ build ] when diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor index b3b88874b0..f9f432a8f6 100644 --- a/extra/builder/util/util.factor +++ b/extra/builder/util/util.factor @@ -69,9 +69,9 @@ TUPLE: process* arguments stdin stdout stderr timeout ; : milli-seconds>time ( n -- string ) 1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ; -: eval-file ( file -- obj ) contents eval ; +: eval-file ( file -- obj ) file-contents eval ; -: cat ( file -- ) contents print ; +: cat ( file -- ) file-contents print ; : run-or-bail ( desc quot -- ) [ [ try-process ] curry ] @@ -81,3 +81,6 @@ TUPLE: process* arguments stdin stdout stderr timeout ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +USING: bootstrap.image bootstrap.image.download io.streams.null ; + +: retrieve-image ( -- ) [ my-arch download-image ] with-null-stream ; \ No newline at end of file diff --git a/extra/db/db.factor b/extra/db/db.factor index 46b257ce7a..3595558dec 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs classes continuations kernel math -namespaces sequences sequences.lib tuples words ; +namespaces sequences sequences.lib tuples words strings ; IN: db TUPLE: db handle insert-statements update-statements delete-statements select-statements ; @@ -36,13 +36,17 @@ HOOK: db ( str -- statement ) GENERIC: prepare-statement ( statement -- ) GENERIC: bind-statement* ( obj statement -- ) GENERIC: reset-statement ( statement -- ) -GENERIC: execute-statement* ( statement -- result-set ) -HOOK: last-id db ( res -- id ) -: execute-statement ( statement -- ) - execute-statement* dispose ; +GENERIC: insert-statement ( statement -- id ) -: execute-statement-last-id ( statement -- id ) - execute-statement* [ last-id ] with-disposal ; +TUPLE: result-set sql params handle n max ; +GENERIC: query-results ( query -- result-set ) +GENERIC: #rows ( result-set -- n ) +GENERIC: #columns ( result-set -- n ) +GENERIC# row-column 1 ( result-set n -- obj ) +GENERIC: advance-row ( result-set -- ) +GENERIC: more-rows? ( result-set -- ? ) + +: execute-statement ( statement -- ) query-results dispose ; : bind-statement ( obj statement -- ) dup statement-bound? [ dup reset-statement ] when @@ -50,17 +54,9 @@ HOOK: last-id db ( res -- id ) [ set-statement-params ] keep t swap set-statement-bound? ; -TUPLE: result-set sql params handle n max ; - -GENERIC: query-results ( query -- result-set ) -GENERIC: #rows ( result-set -- n ) -GENERIC: #columns ( result-set -- n ) -GENERIC# row-column 1 ( result-set n -- obj ) -GENERIC: advance-row ( result-set -- ? ) - : init-result-set ( result-set -- ) dup #rows over set-result-set-max - -1 swap set-result-set-n ; + 0 swap set-result-set-n ; : ( query handle tuple -- result-set ) >r >r { statement-sql statement-params } get-slots r> @@ -74,10 +70,10 @@ GENERIC: advance-row ( result-set -- ? ) dup #columns [ row-column ] with map ; : query-each ( statement quot -- ) - over advance-row [ - 2drop + over more-rows? [ + [ call ] 2keep over advance-row query-each ] [ - [ call ] 2keep query-each + 2drop ] if ; inline : query-map ( statement quot -- seq ) @@ -98,11 +94,6 @@ GENERIC: advance-row ( result-set -- ? ) : do-bound-command ( obj query -- ) [ bind-statement ] keep execute-statement ; -: sql-query ( sql -- rows ) - [ do-query ] with-disposal ; - -: sql-command ( sql -- ) - [ execute-statement ] with-disposal ; SYMBOL: in-transaction HOOK: begin-transaction db ( -- ) @@ -116,3 +107,13 @@ HOOK: rollback-transaction db ( -- ) begin-transaction [ ] [ rollback-transaction ] cleanup commit-transaction ] with-variable ; + +: sql-query ( sql -- rows ) + [ do-query ] with-disposal ; + +: sql-command ( sql -- ) + dup string? [ + [ execute-statement ] with-disposal + ] [ + [ [ sql-command ] each ] with-transaction + ] if ; diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index d8381ca83a..c48eff964a 100644 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays continuations db io kernel math namespaces -quotations sequences db.postgresql.ffi alien alien.c-types ; +quotations sequences db.postgresql.ffi alien alien.c-types +db.types ; IN: db.postgresql.lib : postgresql-result-error-message ( res -- str/f ) @@ -37,13 +38,9 @@ IN: db.postgresql.lib >r db get db-handle r> [ statement-sql ] keep [ statement-params length f ] keep - statement-params [ second malloc-char-string ] map >c-void*-array + statement-params + [ first number>string* malloc-char-string ] map >c-void*-array f f 0 PQexecParams dup postgresql-result-ok? [ dup postgresql-result-error-message swap PQclear throw ] unless ; - -: pq-oid-value ( res -- n ) - PQoidValue dup InvalidOid = [ - "postgresql returned an InvalidOid" throw - ] when ; diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor index 8c6791c767..36b6fc829b 100644 --- a/extra/db/postgresql/postgresql-tests.factor +++ b/extra/db/postgresql/postgresql-tests.factor @@ -2,7 +2,7 @@ ! Set username and password in the 'connect' word. USING: kernel db.postgresql alien continuations io prettyprint -sequences namespaces tools.test db ; +sequences namespaces tools.test db db.types ; IN: temporary IN: scratchpad @@ -40,13 +40,13 @@ IN: temporary test-db [ "select * from person where name = $1 and country = $2" [ - { "Jane" "New Zealand" } + { { "Jane" TEXT } { "New Zealand" TEXT } } over do-bound-query { { "Jane" "New Zealand" } } = [ "test fails" throw ] unless - { "John" "America" } + { { "John" TEXT } { "America" TEXT } } swap do-bound-query ] with-disposal ] with-db diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index dac4d78b78..f0a008d065 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -3,7 +3,7 @@ USING: arrays assocs alien alien.syntax continuations io kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi -db.tuples db.types ; +db.tuples db.types tools.annotations math.ranges ; IN: db.postgresql TUPLE: postgresql-db host port pgopts pgtty db user pass ; @@ -52,11 +52,11 @@ M: postgresql-result-set #columns ( result-set -- n ) M: postgresql-result-set row-column ( result-set n -- obj ) >r dup result-set-handle swap result-set-n r> PQgetvalue ; -M: postgresql-statement execute-statement* ( statement -- obj ) - query-results ; +M: postgresql-result-set row-column ( result-set n -- obj ) + >r dup result-set-handle swap result-set-n r> PQgetvalue ; -: increment-n ( result-set -- n ) - dup result-set-n 1+ dup rot set-result-set-n ; +M: postgresql-statement insert-statement ( statement -- id ) + query-results [ break 0 row-column ] with-disposal ; M: postgresql-statement query-results ( query -- result-set ) dup statement-params [ @@ -68,8 +68,11 @@ M: postgresql-statement query-results ( query -- result-set ) postgresql-result-set dup init-result-set ; -M: postgresql-result-set advance-row ( result-set -- ? ) - dup increment-n swap result-set-max >= ; +M: postgresql-result-set advance-row ( result-set -- ) + dup result-set-n 1+ swap set-result-set-n ; + +M: postgresql-result-set more-rows? ( result-set -- ? ) + dup result-set-n swap result-set-max < ; M: postgresql-statement dispose ( query -- ) dup statement-handle PQclear @@ -105,36 +108,105 @@ M: postgresql-db commit-transaction ( -- ) M: postgresql-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; +: postgresql-type-hash* ( -- assoc ) + H{ + { SERIAL "serial" } + } ; -M: postgresql-db create-sql ( columns table -- sql ) +: postgresql-type-hash ( -- assoc ) + H{ + { INTEGER "integer" } + { SERIAL "integer" } + { TEXT "text" } + { VARCHAR "varchar" } + { DOUBLE "real" } + } ; + +: enquote ( str -- newstr ) "(" swap ")" 3append ; + +: postgresql-type ( str n/str -- newstr ) + " " swap number>string* enquote 3append ; + +: >sql-type* ( obj -- str ) + dup pair? [ + first2 >r >sql-type* r> postgresql-type + ] [ + dup postgresql-type-hash* at* [ + nip + ] [ + drop >sql-type + ] if + ] if ; + +M: postgresql-db >sql-type ( hash obj -- str ) + dup pair? [ + first2 >r >sql-type r> postgresql-type + ] [ + postgresql-type-hash at* [ + no-sql-type + ] unless + ] if ; + +: insert-function ( columns table -- sql ) [ - "create table " % % - " (" % [ ", " % ] [ - dup second % " " % - dup third >sql-type % " " % - sql-modifiers " " join % - ] interleave ")" % - ] "" make ; + >r remove-id r> + "create function add_" % dup % + "(" % + over [ "," % ] + [ third dup array? [ first ] when >sql-type % ] interleave + ")" % + " returns bigint as '" % -M: postgresql-db drop-sql ( table -- sql ) - [ - "drop table " % % - ] "" make ; - -SYMBOL: postgresql-counter - -M: postgresql-db insert-sql* ( columns table -- sql ) - [ - postgresql-counter off - "insert into " % + 2dup "insert into " % % "(" % dup [ ", " % ] [ second % ] interleave ") " % " values (" % - [ ", " % ] [ - drop "$" % postgresql-counter [ inc ] keep get # - ] interleave + length [1,b] [ ", " % ] [ "$" % # ] interleave + "); " % + + "select currval(''" % % "_id_seq'');' language sql;" % + drop + ] "" make ; + +: drop-function ( columns table -- sql ) + [ + >r remove-id r> + "drop function add_" % % + "(" % + [ "," % ] [ third >sql-type % ] interleave + ")" % + ] "" make ; + +M: postgresql-db create-sql ( columns table -- seq ) + [ + [ + 2dup + "create table " % % + " (" % [ ", " % ] [ + dup second % " " % + dup third >sql-type* % " " % + sql-modifiers " " join % + ] interleave "); " % + ] "" make , + + over native-id? [ insert-function , ] [ 2drop ] if + ] { } make ; + +M: postgresql-db drop-sql ( columns table -- seq ) + [ + [ + dup "drop table " % % ";" % + ] "" make , + over native-id? [ drop-function , ] [ 2drop ] if + ] { } make ; + +M: postgresql-db insert-sql* ( columns table -- sql ) + [ + "select add_" % % + "(" % + length [1,b] [ ", " % ] [ "$" % # ] interleave ")" % ] "" make ; @@ -144,9 +216,10 @@ M: postgresql-db update-sql* ( columns table -- sql ) % " set " % dup remove-id - [ ", " % ] [ second dup % " = :" % % ] interleave + dup length [1,b] swap 2array flip + [ ", " % ] [ first2 second % " = $" % # ] interleave " where " % - [ primary-key? ] find nip second dup % " = :" % % + [ primary-key? ] find nip second dup % " = $" % length 2 + # ] "" make ; M: postgresql-db delete-sql* ( columns table -- sql ) @@ -154,23 +227,19 @@ M: postgresql-db delete-sql* ( columns table -- sql ) "delete from " % % " where " % - first second dup % " = :" % % + first second % " = $1" % ] "" make ; M: postgresql-db select-sql* ( columns table -- sql ) drop ; M: postgresql-db tuple>params ( columns tuple -- obj ) - [ - >r dup first r> get-slot-named swap third - ] curry { } map>assoc ; + [ >r dup third swap first r> get-slot-named swap ] + curry { } map>assoc ; -M: postgresql-db last-id ( res -- id ) - pq-oid-value ; - : postgresql-db-modifiers ( -- hashtable ) H{ - { +native-id+ "primary key" } + { +native-id+ "not null primary key" } { +assigned-id+ "primary key" } { +autoincrement+ "autoincrement" } { +unique+ "unique" } @@ -189,18 +258,3 @@ M: postgresql-db sql-modifiers* ( modifiers -- str ) swap at ] if ] with map [ ] subset ; - -: postgresql-type-hash ( -- assoc ) - H{ - { INTEGER "integer" } - { TEXT "text" } - { VARCHAR "text" } - { DOUBLE "real" } - } ; - -M: postgresql-db >sql-type ( obj -- str ) - dup pair? [ - first >sql-type - ] [ - postgresql-type-hash at* [ T{ no-sql-type } throw ] unless - ] if ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index e97dcf80c9..dfa8a4b2dc 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -74,10 +74,11 @@ IN: db.sqlite.lib dup array? [ first ] when { { INTEGER [ sqlite-bind-int-by-name ] } - { BIG_INTEGER [ sqlite-bind-int-by-name ] } + { BIG_INTEGER [ sqlite-bind-int64-by-name ] } { TEXT [ sqlite-bind-text-by-name ] } { VARCHAR [ sqlite-bind-text-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] } + { SERIAL [ sqlite-bind-int-by-name ] } ! { NULL [ sqlite-bind-null-by-name ] } [ no-sql-type ] } case ; @@ -99,13 +100,13 @@ IN: db.sqlite.lib : sqlite-row ( handle -- seq ) dup sqlite-#columns [ sqlite-column ] with map ; -: step-complete? ( step-result -- bool ) +: sqlite-step-has-more-rows? ( step-result -- bool ) dup SQLITE_ROW = [ - drop f + drop t ] [ dup SQLITE_DONE = - [ drop ] [ sqlite-check-result ] if t + [ drop ] [ sqlite-check-result ] if f ] if ; : sqlite-next ( prepared -- ? ) - sqlite3_step step-complete? ; + sqlite3_step sqlite-step-has-more-rows? ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index f58c669681..298220b3ca 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -25,9 +25,7 @@ M: sqlite-db dispose ( db -- ) dispose-db ; TUPLE: sqlite-statement ; C: sqlite-statement -TUPLE: sqlite-result-set advanced? ; -: ( query -- sqlite-result-set ) - dup statement-handle sqlite-result-set ; +TUPLE: sqlite-result-set has-more? ; M: sqlite-db ( str -- obj ) ; @@ -40,13 +38,7 @@ M: sqlite-db ( str -- obj ) M: sqlite-statement dispose ( statement -- ) statement-handle sqlite-finalize ; -: maybe-advance-row ( result-set -- result-set ) - dup sqlite-result-set-advanced? [ - dup advance-row drop - ] unless ; - M: sqlite-result-set dispose ( result-set -- ) - maybe-advance-row f swap set-result-set-handle ; : sqlite-bind ( triples handle -- ) @@ -58,8 +50,12 @@ M: sqlite-statement bind-statement* ( triples statement -- ) M: sqlite-statement reset-statement ( statement -- ) statement-handle sqlite-reset ; -M: sqlite-statement execute-statement* ( statement -- obj ) - query-results ; +: last-insert-id ( -- id ) + db get db-handle sqlite3_last_insert_rowid + dup zero? [ "last-id failed" throw ] when ; + +M: sqlite-statement insert-statement ( statement -- id ) + execute-statement last-insert-id ; M: sqlite-result-set #columns ( result-set -- n ) result-set-handle sqlite-#columns ; @@ -67,12 +63,16 @@ M: sqlite-result-set #columns ( result-set -- n ) M: sqlite-result-set row-column ( result-set n -- obj ) >r result-set-handle r> sqlite-column ; -M: sqlite-result-set advance-row ( result-set -- handle ? ) +M: sqlite-result-set advance-row ( result-set -- ) [ result-set-handle sqlite-next ] keep - t swap set-sqlite-result-set-advanced? ; + set-sqlite-result-set-has-more? ; + +M: sqlite-result-set more-rows? ( result-set -- ? ) + sqlite-result-set-has-more? ; M: sqlite-statement query-results ( query -- result-set ) - dup statement-handle sqlite-result-set ; + dup statement-handle sqlite-result-set + dup advance-row ; M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ; @@ -93,9 +93,10 @@ M: sqlite-db create-sql ( columns table -- sql ) ] interleave ")" % ] "" make ; -M: sqlite-db drop-sql ( table -- sql ) +M: sqlite-db drop-sql ( columns table -- sql ) [ "drop table " % % + drop ] "" make ; M: sqlite-db insert-sql* ( columns table -- sql ) @@ -144,11 +145,6 @@ M: sqlite-db tuple>params ( columns tuple -- obj ) dupd >r first r> get-slot-named swap third 3array ] curry map ; - -M: sqlite-db last-id ( result-set -- id ) - maybe-advance-row drop - db get db-handle sqlite3_last_insert_rowid - dup zero? [ "last-id failed" throw ] when ; : sqlite-db-modifiers ( -- hashtable ) H{ @@ -175,6 +171,7 @@ M: sqlite-db sql-modifiers* ( modifiers -- str ) : sqlite-type-hash ( -- assoc ) H{ { INTEGER "integer" } + { SERIAL "integer" } { TEXT "text" } { VARCHAR "text" } { DOUBLE "real" } @@ -190,4 +187,3 @@ M: sqlite-db >sql-type ( obj -- str ) ! HOOK: get-column-value ( n result-set type -- ) ! M: sqlite get-column-value { { "TEXT" get-text-column } { ! "INTEGER" get-integer-column } ... } case ; - diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 6945ccc722..72fb6396b5 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: io.files kernel tools.test db db.sqlite db.tuples -db.types continuations namespaces db.postgresql math -tools.time ; +db.types continuations namespaces db.postgresql math ; +! tools.time ; IN: temporary TUPLE: person the-id the-name the-number real ; @@ -30,7 +30,8 @@ SYMBOL: the-person [ ] [ the-person get update-tuple ] unit-test - [ ] [ the-person get delete-tuple ] unit-test ; + [ ] [ the-person get delete-tuple ] unit-test + [ ] [ person drop-table ] unit-test ; : test-sqlite ( -- ) "tuples-test.db" resource-path [ @@ -44,7 +45,7 @@ SYMBOL: the-person person "PERSON" { - { "the-id" "ROWID" INTEGER +native-id+ } + { "the-id" "ID" SERIAL +native-id+ } { "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-number" "AGE" INTEGER { +default+ 0 } } { "real" "REAL" DOUBLE { +default+ 0.3 } } @@ -52,12 +53,12 @@ person "PERSON" "billy" 10 3.14 the-person set -test-sqlite -! test-postgresql +! test-sqlite +test-postgresql person "PERSON" { - { "the-id" "ROWID" INTEGER +assigned-id+ } + { "the-id" "ID" INTEGER +assigned-id+ } { "the-name" "NAME" { VARCHAR 256 } +not-null+ } { "the-number" "AGE" INTEGER { +default+ 0 } } { "real" "REAL" DOUBLE { +default+ 0.3 } } @@ -65,5 +66,5 @@ person "PERSON" 1 "billy" 20 6.28 the-person set -test-sqlite +! test-sqlite ! test-postgresql diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 783001f3f8..74726f12aa 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -38,8 +38,9 @@ TUPLE: no-slot-named ; [ db-table dupd ] swap [ ] 3compose cache nip ; inline -HOOK: create-sql db ( columns table -- sql ) -HOOK: drop-sql db ( table -- sql ) +HOOK: create-sql db ( columns table -- seq ) +HOOK: drop-sql db ( columns table -- seq ) + HOOK: insert-sql* db ( columns table -- sql ) HOOK: update-sql* db ( columns table -- sql ) HOOK: delete-sql* db ( columns table -- sql ) @@ -75,12 +76,12 @@ HOOK: tuple>params db ( columns tuple -- obj ) dup db-columns swap db-table create-sql sql-command ; : drop-table ( class -- ) - db-table drop-sql sql-command ; + dup db-columns swap db-table drop-sql sql-command ; : insert-tuple ( tuple -- ) [ [ maybe-remove-id ] [ insert-sql ] - make-tuple-statement execute-statement-last-id + make-tuple-statement insert-statement ] keep set-primary-key ; : update-tuple ( tuple -- ) diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index b8c82524a8..7cacbcf861 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -11,6 +11,12 @@ SYMBOL: +assigned-id+ : primary-key? ( spec -- ? ) [ { +native-id+ +assigned-id+ } member? ] contains? ; +: contains-id? ( columns id -- ? ) + swap [ member? ] with contains? ; + +: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ; +: native-id? ( columns -- ? ) +native-id+ contains-id? ; + ! Same concept, SQLite has autoincrement, PostgreSQL has serial SYMBOL: +autoincrement+ SYMBOL: +serial+ @@ -22,6 +28,7 @@ SYMBOL: +not-null+ SYMBOL: +has-many+ +SYMBOL: SERIAL SYMBOL: INTEGER SYMBOL: DOUBLE SYMBOL: BOOLEAN