basis/db/tuples/tuples.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! Copyright (C) 2018 Alexander Ilin.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: accessors assocs classes classes.tuple
   5 combinators.short-circuit continuations db db.errors db.types
   6 destructors kernel math.parser namespaces sequences sets words ;
   7 IN: db.tuples
   8
   9 HOOK: create-sql-statement db-connection ( class -- object )
  10 HOOK: drop-sql-statement db-connection ( class -- object )
  11
  12 HOOK: <insert-db-assigned-statement> db-connection ( class -- object )
  13 HOOK: <insert-user-assigned-statement> db-connection ( class -- object )
  14 HOOK: <update-tuple-statement> db-connection ( class -- object )
  15 HOOK: <delete-tuples-statement> db-connection ( tuple class -- object )
  16 HOOK: <select-by-slots-statement> db-connection ( tuple class -- statement )
  17 HOOK: <count-statement> db-connection ( query -- statement )
  18 HOOK: query>statement db-connection ( query -- statement )
  19 HOOK: insert-tuple-set-key db-connection ( tuple statement -- )
  20
  21 <PRIVATE
  22
  23 SYMBOL: sql-counter
  24
  25 : next-sql-counter ( -- str )
  26     sql-counter [ inc ] [ get ] bi number>string ;
  27
  28 GENERIC: eval-generator ( singleton -- object )
  29
  30 : resulting-tuple ( exemplar-tuple row out-params -- tuple )
  31     rot class-of new [
  32         '[ slot-name>> _ set-slot-named ] 2each
  33     ] keep ;
  34
  35 : query-tuples-each ( exemplar-tuple statement quot: ( tuple -- ) -- )
  36     [ [ out-params>> ] keep query-results ] dip '[
  37         [ sql-row-typed swap resulting-tuple @ ] 2with query-each
  38     ] with-disposal ; inline
  39
  40 : query-tuples ( exemplar-tuple statement -- seq )
  41     [ ] collector [ query-tuples-each ] dip { } like ;
  42
  43 : query-modify-tuple ( tuple statement -- )
  44     [ query-results [ sql-row-typed ] with-disposal ] keep
  45     out-params>> rot '[ slot-name>> _ set-slot-named ] 2each ;
  46
  47 : with-disposals ( object quotation -- )
  48     over sequence? [
  49         over '[ _ dispose-each ] finally
  50     ] [
  51         with-disposal
  52     ] if ; inline
  53
  54 : insert-db-assigned-statement ( tuple -- )
  55     dup class-of
  56     db-connection get insert-statements>>
  57     [ <insert-db-assigned-statement> ] cache
  58     [ bind-tuple ] 2keep insert-tuple-set-key ;
  59
  60 : insert-user-assigned-statement ( tuple -- )
  61     dup class-of
  62     db-connection get insert-statements>>
  63     [ <insert-user-assigned-statement> ] cache
  64     [ bind-tuple ] keep execute-statement ;
  65
  66 : do-each-tuple ( exemplar-tuple statement quot: ( tuple -- ) -- tuples )
  67     '[ [ bind-tuple ] [ _ query-tuples-each ] 2bi ] with-disposal
  68     ; inline
  69
  70 : do-select ( exemplar-tuple statement -- tuples )
  71     [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
  72
  73 : do-count ( exemplar-tuple statement -- tuples )
  74     [ [ bind-tuple ] [ nip default-query ] 2bi ] with-disposal ;
  75
  76 PRIVATE>
  77
  78 ! High level
  79 ERROR: no-slots-named class seq ;
  80
  81 : check-columns ( columns class -- )
  82     [ nip ] [
  83         [ keys ]
  84         [ all-slots [ name>> ] map ] bi* diff
  85     ] 2bi
  86     [ drop ] [ no-slots-named ] if-empty ;
  87
  88 : define-persistent ( class table columns -- )
  89     pick dupd
  90     check-columns
  91     [ dupd "db-table" set-word-prop dup ] dip
  92     [ relation? ] partition swapd
  93     dupd [ spec>tuple ] with map
  94     "db-columns" set-word-prop
  95     "db-relations" set-word-prop ;
  96
  97 TUPLE: query tuple group order offset limit ;
  98
  99 : <query> ( -- query ) \ query new ;
 100
 101 GENERIC: >query ( object -- query )
 102
 103 M: query >query clone ;
 104
 105 M: tuple >query <query> swap >>tuple ;
 106
 107 ERROR: no-defined-persistent object ;
 108
 109 : ensure-defined-persistent ( object -- object )
 110     dup { [ class? ] [ "db-table" word-prop ] } 1&& [
 111         no-defined-persistent
 112     ] unless ;
 113
 114 : create-table ( class -- )
 115     ensure-defined-persistent
 116     create-sql-statement [ execute-statement ] with-disposals ;
 117
 118 : drop-table ( class -- )
 119     ensure-defined-persistent
 120     drop-sql-statement [ execute-statement ] with-disposals ;
 121
 122 : recreate-table ( class -- )
 123     [ '[ [ _ drop-table ] ignore-table-missing ] ignore-function-missing ]
 124     [ create-table ] bi ;
 125
 126 : ensure-table ( class -- )
 127     '[ [ _ create-table ] ignore-table-exists ] ignore-function-exists ;
 128
 129 : ensure-tables ( classes -- ) [ ensure-table ] each ;
 130
 131 : insert-tuple ( tuple -- )
 132     dup class-of ensure-defined-persistent db-assigned?
 133     [ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
 134
 135 : update-tuple ( tuple -- )
 136     dup class-of ensure-defined-persistent
 137     db-connection get update-statements>> [ <update-tuple-statement> ] cache
 138     [ bind-tuple ] keep execute-statement ;
 139
 140 : delete-tuples ( tuple -- )
 141     dup
 142     dup class-of ensure-defined-persistent
 143     <delete-tuples-statement> [
 144         [ bind-tuple ] keep execute-statement
 145     ] with-disposal ;
 146
 147 : select-tuples ( query/tuple -- tuples )
 148     >query [ tuple>> ] [ query>statement ] bi do-select ;
 149
 150 : select-tuple ( query/tuple -- tuple/f )
 151     >query 1 >>limit [ tuple>> ] [ query>statement ] bi
 152     do-select ?first ;
 153
 154 : count-tuples ( query/tuple -- n )
 155     >query [ tuple>> ] [ <count-statement> ] bi do-count
 156     [ first string>number ] map dup length 1 = [ first ] when ;
 157
 158 : each-tuple ( query/tuple quot: ( tuple -- ) -- )
 159     [ >query [ tuple>> ] [ query>statement ] bi ] dip do-each-tuple
 160     ; inline
 161
 162 : update-tuples ( query/tuple quot: ( tuple -- tuple'/f ) -- )
 163     '[ @ [ update-tuple ] when* ] each-tuple ; inline
 164
 165 : reject-tuples ( query/tuple quot: ( tuple -- ? ) -- )
 166     '[ dup @ [ delete-tuples ] [ drop ] if ] each-tuple ; inline