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 db.types continuations
   6 destructors mirrors sequences.lib combinators.lib ;
   7 IN: db.tuples
   8
   9 : define-persistent ( class table columns -- )
  10     >r dupd "db-table" set-word-prop dup r>
  11     [ relation? ] partition swapd
  12     dupd [ spec>tuple ] with map
  13     "db-columns" set-word-prop
  14     "db-relations" set-word-prop ;
  15
  16 ERROR: not-persistent class ;
  17
  18 : db-table ( class -- obj )
  19     dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
  20
  21 : db-columns ( class -- obj )
  22     superclasses [ "db-columns" word-prop ] map concat ;
  23
  24 : db-relations ( class -- obj )
  25     "db-relations" word-prop ;
  26
  27 : set-primary-key ( key tuple -- )
  28     [
  29         class db-columns find-primary-key slot-name>>
  30     ] keep set-slot-named ;
  31
  32 SYMBOL: sql-counter
  33 : next-sql-counter ( -- str )
  34     sql-counter [ inc ] [ get ] bi number>string ;
  35
  36 ! returns a sequence of prepared-statements
  37 HOOK: create-sql-statement db ( class -- obj )
  38 HOOK: drop-sql-statement db ( class -- obj )
  39
  40 HOOK: <insert-db-assigned-statement> db ( class -- obj )
  41 HOOK: <insert-user-assigned-statement> db ( class -- obj )
  42 HOOK: <update-tuple-statement> db ( class -- obj )
  43 HOOK: <delete-tuples-statement> db ( tuple class -- obj )
  44 HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
  45 TUPLE: query group order offset limit ;
  46 HOOK: <query> db ( tuple class query -- statement' )
  47 HOOK: <count-statement> db ( tuple class groups -- n )
  48
  49 HOOK: insert-tuple* db ( tuple statement -- )
  50
  51 GENERIC: eval-generator ( singleton -- obj )
  52 SINGLETON: retryable
  53
  54 : make-retryable ( obj -- obj' )
  55     dup sequence? [
  56         [ make-retryable ] map
  57     ] [
  58         retryable >>type
  59         10 >>retries
  60     ] if ;
  61
  62 : regenerate-params ( statement -- statement )
  63     dup
  64     [ bind-params>> ] [ in-params>> ] bi
  65     [
  66         dup generator-bind? [
  67             generator-singleton>> eval-generator >>value
  68         ] [
  69             drop
  70         ] if
  71     ] 2map >>bind-params ;
  72
  73 M: retryable execute-statement* ( statement type -- )
  74     drop [
  75         [
  76             [ query-results dispose t ]
  77             [ ]
  78             [ regenerate-params bind-statement* f ] cleanup
  79         ] curry
  80     ] [ retries>> ] bi retry drop ;
  81
  82 : resulting-tuple ( class row out-params -- tuple )
  83     rot class new [
  84         [
  85             >r slot-name>> r> set-slot-named
  86         ] curry 2each
  87     ] keep ;
  88
  89 : query-tuples ( exemplar-tuple statement -- seq )
  90     [ out-params>> ] keep query-results [
  91         [ sql-row-typed swap resulting-tuple ] with with query-map
  92     ] with-disposal ;
  93
  94 : query-modify-tuple ( tuple statement -- )
  95     [ query-results [ sql-row-typed ] with-disposal ] keep
  96     out-params>> rot [
  97         >r slot-name>> r> set-slot-named
  98     ] curry 2each ;
  99
 100 : sql-props ( class -- columns table )
 101     [ db-columns ] [ db-table ] bi ;
 102
 103 : with-disposals ( seq quot -- )
 104     over sequence? [
 105         [ with-disposal ] curry each
 106     ] [
 107         with-disposal
 108     ] if ; inline
 109
 110 : create-table ( class -- )
 111     create-sql-statement [ execute-statement ] with-disposals ;
 112
 113 : drop-table ( class -- )
 114     drop-sql-statement [ execute-statement ] with-disposals ;
 115
 116 : recreate-table ( class -- )
 117     [
 118         [ drop-sql-statement [ execute-statement ] with-disposals
 119         ] curry ignore-errors
 120     ] [ create-table ] bi ;
 121
 122 : ensure-table ( class -- )
 123     [ create-table ] curry ignore-errors ;
 124
 125 : ensure-tables ( classes -- )
 126     [ ensure-table ] each ;
 127
 128 : insert-db-assigned-statement ( tuple -- )
 129     dup class
 130     db get insert-statements>> [ <insert-db-assigned-statement> ] cache
 131     [ bind-tuple ] 2keep insert-tuple* ;
 132
 133 : insert-user-assigned-statement ( tuple -- )
 134     dup class
 135     db get insert-statements>> [ <insert-user-assigned-statement> ] cache
 136     [ bind-tuple ] keep execute-statement ;
 137
 138 : insert-tuple ( tuple -- )
 139     dup class db-columns find-primary-key db-assigned-id-spec?
 140     [ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
 141
 142 : update-tuple ( tuple -- )
 143     dup class
 144     db get update-statements>> [ <update-tuple-statement> ] cache
 145     [ bind-tuple ] keep execute-statement ;
 146
 147 : delete-tuples ( tuple -- )
 148     dup dup class <delete-tuples-statement> [
 149         [ bind-tuple ] keep execute-statement
 150     ] with-disposal ;
 151
 152 : do-select ( exemplar-tuple statement -- tuples )
 153     [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
 154
 155 : query ( tuple query -- tuples )
 156     >r dup dup class r> <query> do-select ;
 157
 158 : select-tuples ( tuple -- tuples )
 159     dup dup class <select-by-slots-statement> do-select ;
 160
 161 : select-tuple ( tuple -- tuple/f )
 162     dup dup class \ query new 1 >>limit <query> do-select ?first ;
 163
 164 : do-count ( exemplar-tuple statement -- tuples )
 165     [
 166         [ bind-tuple ] [ nip default-query ] 2bi
 167     ] with-disposal ;
 168
 169 : count-tuples ( tuple groups -- n )
 170     >r dup dup class r> <count-statement> do-count
 171     dup length 1 =
 172     [ first first string>number ] [ [ first string>number ] map ] if ;