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