From fdbcf006d3ef57cf9256bbfe5415e8898f128dbc Mon Sep 17 00:00:00 2001 From: erg Date: Mon, 18 Dec 2006 04:29:33 +0000 Subject: [PATCH] more work on libs/sql --- libs/sql/execute.factor | 47 ++++++++- libs/sql/simple.factor | 53 ++++++----- libs/sql/sql.factor | 1 + libs/sql/sqlite/execute.factor | 33 ++++++- libs/sql/sqlite/simple.factor | 58 ++++++++++-- libs/sql/sqlite/sqlite.factor | 37 +++++++- libs/sql/tupledb.factor | 8 +- libs/sql/utils.factor | 168 ++++++++++++++++++++------------- 8 files changed, 291 insertions(+), 114 deletions(-) diff --git a/libs/sql/execute.factor b/libs/sql/execute.factor index 00ad16304d..38bf53fd4f 100644 --- a/libs/sql/execute.factor +++ b/libs/sql/execute.factor @@ -1,10 +1,47 @@ -USING: kernel namespaces ; +USING: errors generic kernel namespaces sql:utils ; IN: sql -GENERIC: execute-sql* ( string db -- ) -GENERIC: query-sql* ( string db -- seq ) +G: execute-sql* ( db string -- ) 1 standard-combination ; +G: query-sql* ( db string -- seq ) 1 standard-combination ; -: execute-sql ( string -- ) db get execute-sql* ; -: query-sql ( string -- ) db get query-sql* ; +: execute-sql ( string -- ) >r db get r> execute-sql* ; +: query-sql ( string -- ) >r db get r> query-sql* ; +G: create-table* ( db tuple -- ) 1 standard-combination ; +G: drop-table* ( db tuple -- ) 1 standard-combination ; +G: insert-tuple* ( db tuple -- ) 1 standard-combination ; +G: delete-tuple* ( db tuple -- ) 1 standard-combination ; +G: update-tuple* ( db tuple -- ) 1 standard-combination ; +G: select-tuple* ( db tuple -- ) 1 standard-combination ; + +TUPLE: persistent-error message ; + +: create-table ( tuple -- ) >r db get r> create-table* ; +: drop-table ( tuple -- ) >r db get r> drop-table* ; +: insert-tuple ( tuple -- ) + dup bottom-delegate persistent? + [ + "tuple is persistent, call update not insert" + throw + ] when + >r db get r> insert-tuple* ; + +: delete-tuple ( tuple -- ) + dup bottom-delegate persistent? + [ + "tuple is not persistent, cannot delete" + throw + ] unless + >r db get r> delete-tuple* ; + +: update-tuple ( tuple -- ) + dup bottom-delegate persistent? + [ + "tuple is not persistent, call insert not update" + throw + ] unless + >r db get r> update-tuple* ; + +: select-tuple ( tuple -- ) + >r db get r> select-tuple* ; diff --git a/libs/sql/simple.factor b/libs/sql/simple.factor index 10a083f745..64f912a26b 100644 --- a/libs/sql/simple.factor +++ b/libs/sql/simple.factor @@ -1,52 +1,53 @@ -USING: generic kernel namespaces prettyprint sequences sql:utils ; +USING: errors generic kernel namespaces prettyprint +sequences sql:utils ; IN: sql -GENERIC: create-sql* ( tuple db -- string ) -GENERIC: drop-sql* ( tuple db -- string ) -GENERIC: insert-sql* ( tuple db -- string ) -GENERIC: delete-sql* ( tuple db -- string ) -GENERIC: update-sql* ( tuple db -- string ) -GENERIC: select-sql* ( tuple db -- string ) +G: create-sql* ( db tuple -- string ) 1 standard-combination ; +G: drop-sql* ( db tuple -- string ) 1 standard-combination ; +G: insert-sql* ( db tuple -- string ) 1 standard-combination ; +G: delete-sql* ( db tuple -- string ) 1 standard-combination ; +G: update-sql* ( db tuple -- string ) 1 standard-combination ; +G: select-sql* ( db tuple -- string ) 1 standard-combination ; -: create-sql ( tuple -- string ) db get create-sql* ; -: drop-sql ( tuple -- string ) db get drop-sql* ; -: insert-sql ( tuple -- string ) db get insert-sql* ; -: delete-sql ( tuple -- string ) db get delete-sql* ; -: update-sql ( tuple -- string ) db get update-sql* ; -: select-sql ( tuple -- string ) db get select-sql* ; +: create-sql ( tuple -- string ) >r db get r> create-sql* ; +: drop-sql ( tuple -- string ) >r db get r> drop-sql* ; +: insert-sql ( tuple -- string ) >r db get r> insert-sql* ; +: delete-sql ( tuple -- string ) >r db get r> delete-sql* ; +: update-sql ( tuple -- string ) >r db get r> update-sql* ; +: select-sql ( tuple -- string ) >r db get r> select-sql* ; -M: connection create-sql* ( tuple db -- string ) - drop [ +M: connection create-sql* ( db tuple -- string ) + nip [ "create table " % dup class unparse % "(" % tuple>mapping% ");" % ] "" make ; -M: connection drop-sql* ( tuple db -- string ) - drop [ "drop table " % tuple>sql-name % ";" % ] "" make ; +M: connection drop-sql* ( db tuple -- string ) + nip [ "drop table " % tuple>sql-name % ";" % ] "" make ; -M: connection insert-sql* ( tuple db -- string ) - drop [ +M: connection insert-sql* ( db tuple -- string ) + nip [ "insert into " % dup tuple>sql-name % - " (" % tuple>insert-parts dup first ", " join % + ! " (" % fulltuple>insert-all-parts dup first ", " join % ") values(" % second [ escape-sql enquote ] map ", " join % ");" % ] "" make ; -M: connection delete-sql* ( tuple db -- string ) - drop [ +M: connection delete-sql* ( db tuples -- string ) + nip [ ! "delete from table " % unparse % ";" % ] "" make ; -M: connection update-sql* ( tuples db -- string ) - drop [ +M: connection update-sql* ( db tuples -- string ) + nip [ ] "" make ; -M: connection select-sql* ( tuples db -- string ) - drop [ +M: connection select-sql* ( db tuples -- string ) + nip [ ] "" make ; diff --git a/libs/sql/sql.factor b/libs/sql/sql.factor index 677993983a..e47c54e12a 100644 --- a/libs/sql/sql.factor +++ b/libs/sql/sql.factor @@ -3,6 +3,7 @@ IN: sql SYMBOL: db TUPLE: connection handle ; +TUPLE: persistent id ; ! TESTING "handle" db set-global diff --git a/libs/sql/sqlite/execute.factor b/libs/sql/sqlite/execute.factor index f75342a1c5..3b0276928b 100644 --- a/libs/sql/sqlite/execute.factor +++ b/libs/sql/sqlite/execute.factor @@ -1,7 +1,34 @@ -USING: kernel namespaces sql ; +USING: kernel math namespaces sql sql:utils ; IN: sqlite -M: sqlite execute-sql* ( string db -- ) - connection-handle swap +M: sqlite execute-sql* ( db string -- ) + >r connection-handle r> sqlite-prepare dup [ drop ] sqlite-each sqlite-finalize ; +M: sqlite create-table* ( db tuple -- ) + create-sql execute-sql* ; + +M: sqlite drop-table* ( db tuple -- ) + drop-sql execute-sql* ; + +M: sqlite insert-tuple* ( db tuple -- ) + 2dup insert-sql* >r >r connection-handle r> over r> + sqlite-prepare over bind-for-insert + [ drop ] sqlite-each sqlite-finalize + >r sqlite-last-insert-rowid number>string r> make-persistent ; + +M: sqlite delete-tuple* ( db tuple -- ) + 2dup delete-sql* >r >r connection-handle r> r> + swapd sqlite-prepare over bind-for-delete + [ drop ] sqlite-each sqlite-finalize remove-bottom-delegate ; + +M: sqlite update-tuple* ( db tuple -- ) + 2dup update-sql* >r >r connection-handle r> r> + swapd sqlite-prepare swap bind-for-update + [ drop ] sqlite-each sqlite-finalize drop ; + +M: sqlite select-tuple* ( db tuple -- ) + 2dup select-sql* >r >r connection-handle r> r> + swapd sqlite-prepare over bind-for-select + [ break [ break pick restore-tuple , ] sqlite-each ] { } make + [ sqlite-finalize ] keep ; diff --git a/libs/sql/sqlite/simple.factor b/libs/sql/sqlite/simple.factor index 9c45c17608..6970c91f10 100644 --- a/libs/sql/sqlite/simple.factor +++ b/libs/sql/sqlite/simple.factor @@ -1,4 +1,4 @@ -USING: generic kernel namespaces prettyprint sql sql:utils ; +USING: generic kernel namespaces prettyprint sequences sql sql:utils ; IN: sqlite TUPLE: sqlite ; @@ -6,19 +6,59 @@ C: sqlite ( path -- db ) >r sqlite-open r> [ set-delegate ] keep ; -! M: sqlite insert-sql* ( tuple db -- string ) +M: sqlite create-sql* ( db tuple -- string ) + nip [ + "create table " % dup tuple>sql-name % + " (" % full-tuple>alist "id" alist-remove-key + [ first sanitize ] map ", " join % + ");" % + ] "" make ; + +M: sqlite insert-sql* ( db tuple -- string ) #! Insert and fill in the ID column - ! ; + nip [ + "insert into " % + dup tuple>sql-name % + " (" % tuple>insert-alist + [ [ first ] map ", " join % ] keep + ") values(" % + [ first field>sqlite-bind-name ] map ", " join % + ");" % + ] "" make ; -M: sqlite delete-sql* ( tuple db -- string ) +M: sqlite delete-sql* ( db tuple -- string ) #! Delete based on the ID column - ; + nip [ + "delete from " % tuple>sql-name % + " where ROWID=:rowid;" % + ] "" make ; -M: sqlite update-sql* ( tuple db -- string ) +M: sqlite update-sql* ( db tuple -- string ) #! Update based on the ID column - ; + nip [ + "update " % dup tuple>sql-name% + " set " % full-tuple>alist "id" alist-remove-key + [ + [ + first [ sanitize % ] keep + " = " % field>sqlite-bind-name % + ] "" make + ] map ", " join % + " where ROWID = :rowid;" % + ] "" make ; -M: sqlite select-sql* ( tuple db -- string ) - ; +M: sqlite select-sql* ( db tuple -- string ) + nip [ + "select ROWID,* from " % dup tuple>sql-name % + " where " % tuple>select-alist + [ + [ + first dup % + " = " % + field>sqlite-bind-name % + ] "" make + ] map " and " join % + ";" % + ] "" make ; diff --git a/libs/sql/sqlite/sqlite.factor b/libs/sql/sqlite/sqlite.factor index a5b603a949..cf5d68ae02 100644 --- a/libs/sql/sqlite/sqlite.factor +++ b/libs/sql/sqlite/sqlite.factor @@ -9,7 +9,8 @@ ! executing SQL calls and obtaining results. ! IN: sqlite -USING: alien compiler errors libsqlite kernel namespaces sequences sql strings ; +USING: alien compiler errors generic libsqlite kernel math namespaces +prettyprint sequences sql strings sql:utils ; TUPLE: sqlite-error n message ; @@ -52,7 +53,7 @@ TUPLE: sqlite-error n message ; : sqlite-bind-parameter-index ( statement name -- index ) sqlite3_bind_parameter_index ; -: sqlite-bind-text-by-name ( statement name text -- ) + : sqlite-bind-text-by-name ( statement name text -- ) >r dupd sqlite-bind-parameter-index r> sqlite-bind-text ; : sqlite-finalize ( statement -- ) @@ -124,3 +125,35 @@ DEFER: (sqlite-map) [ db get sqlite-close ] cleanup ] with-scope ; +: bind-for-sql ( statement alist -- ) + [ + first2 >r field>sqlite-bind-name r> + obj>string/f sqlite-bind-text-by-name + ] each-with ; + +: bind-for-insert ( statement tuple -- ) + tuple>insert-alist dupd dupd bind-for-sql ; + +: bind-for-update ( statement tuple -- ) + tuple>update-alist dupd dupd dupd bind-for-sql ; + +: bind-for-delete ( statement tuple -- ) + tuple>delete-alist dupd dupd bind-for-sql ; + +: bind-for-select ( statement tuple -- ) + tuple>select-alist dupd dupd bind-for-sql ; + +: restore-tuple ( statement tuple -- tuple ) + break + clone dup dup full-tuple>fields + [ + 2drop + ! over 1+ >r + ! db-field-slot >r + ! pick swap column-text + ! over r> set-slot r> + ] each-with + ! drop make-persistent swap 0 column-text swap + ! [ set-persistent-key ] keep + ; + diff --git a/libs/sql/tupledb.factor b/libs/sql/tupledb.factor index 67276e1764..b9d45a5fa5 100644 --- a/libs/sql/tupledb.factor +++ b/libs/sql/tupledb.factor @@ -1,14 +1,14 @@ USING: kernel math sql:utils ; IN: sql -: save ( tuple -- ) +: save-tuple ( tuple -- ) dup "id" tuple-slot [ - ! update + update-tuple ] [ - ! insert + insert-tuple ] if ; -: restore ( tuple -- ) +: restore-tuple ( tuple -- ) ; diff --git a/libs/sql/utils.factor b/libs/sql/utils.factor index dd7efcf92b..11736d172e 100644 --- a/libs/sql/utils.factor +++ b/libs/sql/utils.factor @@ -1,11 +1,47 @@ -USING: arrays errors generic hashtables kernel math namespaces -prettyprint sequences sql strings tools words ; +USING: arrays errors generic hashtables kernel kernel-internals +math namespaces parser prettyprint sequences sql +strings tools words ; IN: sql:utils -! : 2seq>hash 2array flip alist>hash ; +: sanitize ( string -- string ) + "_p" "-?" pick subst ; -: 2seq>hash ( seq seq -- hash ) - H{ } clone -rot [ pick set-hash ] 2each ; +: obj>string/f ( obj -- string/f ) + dup [ dup string? [ unparse ] unless ] when ; + +: bottom-delegate ( tuple -- tuple/f ) + dup delegate [ nip bottom-delegate ] when* ; + +: set-bottom-delegate ( delegate tuple -- ) + bottom-delegate set-delegate ; + +: make-persistent ( id tuple -- ) + >r r> set-bottom-delegate ; + +: remove-bottom-delegate ( tuple -- ) + dup delegate [ + delegate [ + delegate remove-bottom-delegate + ] [ + f swap set-delegate + ] if + ] [ + drop + ] if* ; + +: make-empty-tuple ( string -- tuple ) + parse call dup tuple-size ; + +: field>sqlite-bind-name ( string -- string ) + >r ":" r> append sanitize ; + +: tuple-slot ( string tuple -- ? obj ) + "slot-names" over class word-props hash + pick [ = ] curry find over -1 = [ + 2drop delegate dup [ tuple-slot ] [ 2drop f -1 ] if + ] [ + drop rot drop 2 + swap tuple>array nth >r t r> + ] if ; : tuple-fields ( tuple -- seq ) class "slot-names" word-prop ; @@ -13,29 +49,61 @@ IN: sql:utils : tuple>parts ( tuple -- values names ) [ tuple-slots ] keep tuple-fields ; -: tuple>hash ( tuple -- hash ) - tuple>parts 2seq>hash ; +: tuple>alist ( tuple -- alist ) + tuple>parts [ swap 2array ] 2map ; -: tuple>all-slots - delegates V{ } clone - [ tuple-slots dupd nappend ] reduce - prune >array ; - -: tuple>all-fields +: full-tuple>fields ( tuple -- seq ) delegates V{ } clone [ tuple-fields dupd nappend ] reduce prune >array ; + +: full-tuple>slots ( tuple -- seq ) + dup full-tuple>fields [ swap tuple-slot nip ] map-with ; + +: full-tuple>parts ( tuple -- values names ) + [ full-tuple>slots ] keep full-tuple>fields ; + +: full-tuple>alist ( tuple -- alist ) + full-tuple>parts [ swap 2array ] 2map ; + +: alist-remove-key ( alist key -- seq ) + [ >r first r> = not ] curry subset ; + +: alist-remove-value ( alist value -- seq ) + [ >r second r> = not ] curry subset ; + +: alist-key-each ( alist quot -- ) + [ first ] swap append each ; + +: tuple>insert-alist ( tuple -- alist ) + full-tuple>alist + "id" alist-remove-key + f alist-remove-value ; + +: tuple>update-alist ( tuple -- alist ) + full-tuple>alist "id" over assoc + >r "rowid" r> 2array 1array append + "id" alist-remove-key ; + +: tuple>delete-alist ( tuple -- alist ) + >r "rowid" r> "id" swap tuple-slot nip 2array 1array ; + +: tuple>select-alist ( tuple -- alist ) + full-tuple>alist + f alist-remove-value ; + +! : 2seq>hash 2array flip alist>hash ; + +: 2seq>hash ( seq seq -- hash ) + H{ } clone -rot [ pick set-hash ] 2each ; + + +: tuple>hash ( tuple -- hash ) tuple>parts 2seq>hash ; : full-tuple>hash ( tuple -- hash ) delegates H{ } clone [ tuple>hash hash-union ] reduce ; -: tuple>all-parts ( tuple -- values names ) - [ - [ full-tuple>hash ] keep tuple>all-fields - [ swap hash ] map-with - ] keep tuple>all-fields ; - : maybe-unparse ( obj -- ) dup string? [ unparse ] unless ; @@ -49,20 +117,23 @@ IN: sql:utils ] { } make ] keep like ; -GENERIC: escape-sql* ( string type db -- string ) +GENERIC: escape-sql* ( string db -- string ) -M: connection escape-sql* ( string type db -- string ) - drop { "''" } "'" rot replace ; +M: connection escape-sql* ( string db -- string ) + drop dup string? [ + { "''" } "'" rot replace + ] when ; -: escape-sql ( string type -- string ) db get escape-sql* ; - -: sanitize-name ( string -- string ) - "_p" "-?" pick subst ; +: escape-sql ( string -- string ) db get escape-sql* ; : tuple>sql-name ( tuple -- string ) - class unparse sanitize-name ; + class unparse sanitize ; -: enquote% "'" % % "'" % ; +: tuple>sql-name% ( tuple -- string ) + tuple>sql-name % ; + + +: enquote% "'" % dup string? [ unparse ] unless % "'" % ; : enquote ( string -- 'string' ) [ enquote% ] "" make ; @@ -78,7 +149,7 @@ M: connection escape-sql* ( string type db -- string ) >r >r split-last r> each r> each ; inline : each-last ( seq quot quot -- ) - >r dup clone r> append swap (each-last) ; + >r dup clone r> append swap (each-last) ; inline : (2each-last) ( seq seq quot quot -- ) >r >r [ split-last ] 2apply swapd r> 2each r> 2each ; inline @@ -86,7 +157,7 @@ M: connection escape-sql* ( string type db -- string ) : 2each-last ( seq seq quot quot -- ) #! apply first quotation on all but last elt of seq #! apply second quotation on last element - >r dup clone r> append swap (2each-last) ; + >r dup clone r> append swap (2each-last) ; inline ! { integer string } ! mapping: { integer { varchar(256) "not null" } } @@ -104,48 +175,15 @@ H{ } clone mappings set-global : tuple>mapping% ( obj -- seq ) [ get-mapping ] keep tuple-fields - [ sanitize-name % " " % % ] [ ", " % ] 2each-last ; + [ sanitize % " " % % ] [ ", " % ] 2each-last ; : tuple>mapping ( tuple -- string ) [ tuple>mapping% ] "" make ; -: tuple>insert-parts ( tuple -- string ) - [ - tuple>parts - [ - dup "id" = [ - 2drop - ] [ - over [ swap 2array , ] [ 2drop ] if - ] if - ] 2each - ] { } make flip ; - -: tuple>assignments% ( tuple -- string ) - [ tuple-slots [ maybe-unparse escape-sql ] map ] keep - tuple-fields - [ sanitize-name % " = " % enquote% ] [ ", " % ] 2each-last ; - -: tuple>assignments% ( tuple -- string ) - tuple>parts dup [ "id" = ] find drop - dup -1 = [ "tuple must have an id slot" throw ] when - swap >r tuck >r remove-nth r> r> remove-nth - >r [ maybe-unparse escape-sql ] map r> - [ % " = " % enquote% ] [ ", " % ] 2each-last ; - -: tuple>assignments ( tuple -- string ) - [ tuple>assignments% ] "" make ; - -: tuple-slot ( string slot -- ? obj ) - "slot-names" over class word-props hash - rot [ = ] curry find over -1 = [ - swap - ] [ - drop 2 + swap tuple>array nth >r t r> - ] if ; : explode-tuple ( tuple -- ) dup tuple-slots swap class "slot-names" word-prop [ set ] 2each ; +