! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2018 Alexander Ilin.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs classes db kernel namespaces
-classes.tuple words sequences slots math accessors
-math.parser io prettyprint db.types continuations
-destructors mirrors sets db.types ;
+USING: accessors assocs classes classes.tuple
+combinators.short-circuit continuations db db.errors db.types
+destructors kernel math.parser namespaces sequences sets words ;
IN: db.tuples
-<PRIVATE
-! returns a sequence of prepared-statements
-HOOK: create-sql-statement db ( class -- object )
-HOOK: drop-sql-statement db ( class -- object )
+HOOK: create-sql-statement db-connection ( class -- object )
+HOOK: drop-sql-statement db-connection ( class -- object )
-HOOK: <insert-db-assigned-statement> db ( class -- object )
-HOOK: <insert-user-assigned-statement> db ( class -- object )
-HOOK: <update-tuple-statement> db ( class -- object )
-HOOK: <delete-tuples-statement> db ( tuple class -- object )
-HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
-HOOK: <count-statement> db ( query -- statement )
-HOOK: query>statement db ( query -- statement )
+HOOK: <insert-db-assigned-statement> db-connection ( class -- object )
+HOOK: <insert-user-assigned-statement> db-connection ( class -- object )
+HOOK: <update-tuple-statement> db-connection ( class -- object )
+HOOK: <delete-tuples-statement> db-connection ( tuple class -- object )
+HOOK: <select-by-slots-statement> db-connection ( tuple class -- statement )
+HOOK: <count-statement> db-connection ( query -- statement )
+HOOK: query>statement db-connection ( query -- statement )
+HOOK: insert-tuple-set-key db-connection ( tuple statement -- )
-HOOK: insert-tuple-set-key db ( tuple statement -- )
+<PRIVATE
SYMBOL: sql-counter
+
: next-sql-counter ( -- str )
sql-counter [ inc ] [ get ] bi number>string ;
GENERIC: eval-generator ( singleton -- object )
: resulting-tuple ( exemplar-tuple row out-params -- tuple )
- rot class new [
- [ [ slot-name>> ] dip set-slot-named ] curry 2each
+ rot class-of new [
+ '[ slot-name>> _ set-slot-named ] 2each
] keep ;
+: query-tuples-each ( exemplar-tuple statement quot: ( tuple -- ) -- )
+ [ [ out-params>> ] keep query-results ] dip '[
+ [ sql-row-typed swap resulting-tuple @ ] 2with query-each
+ ] with-disposal ; inline
+
: query-tuples ( exemplar-tuple statement -- seq )
- [ out-params>> ] keep query-results [
- [ sql-row-typed swap resulting-tuple ] with with query-map
- ] with-disposal ;
-
+ [ ] collector [ query-tuples-each ] dip { } like ;
+
: query-modify-tuple ( tuple statement -- )
[ query-results [ sql-row-typed ] with-disposal ] keep
- out-params>> rot [
- [ slot-name>> ] dip set-slot-named
- ] curry 2each ;
+ out-params>> rot '[ slot-name>> _ set-slot-named ] 2each ;
: with-disposals ( object quotation -- )
over sequence? [
- [ with-disposal ] curry each
+ over '[ _ dispose-each ] finally
] [
with-disposal
] if ; inline
: insert-db-assigned-statement ( tuple -- )
- dup class
- db get insert-statements>> [ <insert-db-assigned-statement> ] cache
+ dup class-of
+ db-connection get insert-statements>>
+ [ <insert-db-assigned-statement> ] cache
[ bind-tuple ] 2keep insert-tuple-set-key ;
: insert-user-assigned-statement ( tuple -- )
- dup class
- db get insert-statements>> [ <insert-user-assigned-statement> ] cache
+ dup class-of
+ db-connection get insert-statements>>
+ [ <insert-user-assigned-statement> ] cache
[ bind-tuple ] keep execute-statement ;
+: do-each-tuple ( exemplar-tuple statement quot: ( tuple -- ) -- tuples )
+ '[ [ bind-tuple ] [ _ query-tuples-each ] 2bi ] with-disposal
+ ; inline
+
: do-select ( exemplar-tuple statement -- tuples )
[ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
: do-count ( exemplar-tuple statement -- tuples )
[ [ bind-tuple ] [ nip default-query ] 2bi ] with-disposal ;
-PRIVATE>
+PRIVATE>
! High level
ERROR: no-slots-named class seq ;
-: check-columns ( class columns -- )
- tuck
- [ [ first ] map ]
- [ all-slots [ name>> ] map ] bi* diff
+
+: check-columns ( columns class -- )
+ [ nip ] [
+ [ keys ]
+ [ all-slots [ name>> ] map ] bi* diff
+ ] 2bi
[ drop ] [ no-slots-named ] if-empty ;
: define-persistent ( class table columns -- )
M: tuple >query <query> swap >>tuple ;
+ERROR: no-defined-persistent object ;
+
+: ensure-defined-persistent ( object -- object )
+ dup { [ class? ] [ "db-table" word-prop ] } 1&& [
+ no-defined-persistent
+ ] unless ;
+
: create-table ( class -- )
+ ensure-defined-persistent
create-sql-statement [ execute-statement ] with-disposals ;
: drop-table ( class -- )
+ ensure-defined-persistent
drop-sql-statement [ execute-statement ] with-disposals ;
: recreate-table ( class -- )
- [
- [ drop-sql-statement [ execute-statement ] with-disposals
- ] curry ignore-errors
- ] [ create-table ] bi ;
+ [ '[ [ _ drop-table ] ignore-table-missing ] ignore-function-missing ]
+ [ create-table ] bi ;
-: ensure-table ( class -- ) [ create-table ] curry ignore-errors ;
+: ensure-table ( class -- )
+ '[ [ _ create-table ] ignore-table-exists ] ignore-function-exists ;
: ensure-tables ( classes -- ) [ ensure-table ] each ;
: insert-tuple ( tuple -- )
- dup class db-columns find-primary-key db-assigned-id-spec?
+ dup class-of ensure-defined-persistent db-assigned?
[ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
: update-tuple ( tuple -- )
- dup class
- db get update-statements>> [ <update-tuple-statement> ] cache
+ dup class-of ensure-defined-persistent
+ db-connection get update-statements>> [ <update-tuple-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: delete-tuples ( tuple -- )
- dup dup class <delete-tuples-statement> [
+ dup
+ dup class-of ensure-defined-persistent
+ <delete-tuples-statement> [
[ bind-tuple ] keep execute-statement
] with-disposal ;
>query [ tuple>> ] [ query>statement ] bi do-select ;
: select-tuple ( query/tuple -- tuple/f )
- >query 1 >>limit [ tuple>> ] [ query>statement ] bi do-select
- [ f ] [ first ] if-empty ;
+ >query 1 >>limit [ tuple>> ] [ query>statement ] bi
+ do-select ?first ;
: count-tuples ( query/tuple -- n )
>query [ tuple>> ] [ <count-statement> ] bi do-count
- dup length 1 =
- [ first first string>number ] [ [ first string>number ] map ] if ;
+ [ first string>number ] map dup length 1 = [ first ] when ;
+
+: each-tuple ( query/tuple quot: ( tuple -- ) -- )
+ [ >query [ tuple>> ] [ query>statement ] bi ] dip do-each-tuple
+ ; inline
+
+: update-tuples ( query/tuple quot: ( tuple -- tuple'/f ) -- )
+ '[ @ [ update-tuple ] when* ] each-tuple ; inline
+
+: reject-tuples ( query/tuple quot: ( tuple -- ? ) -- )
+ '[ dup @ [ delete-tuples ] [ drop ] if ] each-tuple ; inline
projects / factor.git / blobdiff