basis/db/tuples/tuples.factor

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