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 ;
   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 [ retries>> ] [
  75         [
  76             nip
  77             [ query-results dispose t ]
  78             [ ]
  79             [ regenerate-params bind-statement* f ] cleanup
  80         ] curry
  81     ] bi attempt-all drop ;
  82
  83 : resulting-tuple ( class row out-params -- tuple )
  84     rot class new [
  85         [
  86             >r slot-name>> r> set-slot-named
  87         ] curry 2each
  88     ] keep ;
  89
  90 : query-tuples ( exemplar-tuple statement -- seq )
  91     [ out-params>> ] keep query-results [
  92         [ sql-row-typed swap resulting-tuple ] with with query-map
  93     ] with-disposal ;
  94
  95 : query-modify-tuple ( tuple statement -- )
  96     [ query-results [ sql-row-typed ] with-disposal ] keep
  97     out-params>> rot [
  98         >r slot-name>> r> set-slot-named
  99     ] curry 2each ;
 100
 101 : sql-props ( class -- columns table )
 102     [ db-columns ] [ db-table ] bi ;
 103
 104 : with-disposals ( seq quot -- )
 105     over sequence? [
 106         [ with-disposal ] curry each
 107     ] [
 108         with-disposal
 109     ] if ; inline
 110
 111 : create-table ( class -- )
 112     create-sql-statement [ execute-statement ] with-disposals ;
 113
 114 : drop-table ( class -- )
 115     drop-sql-statement [ execute-statement ] with-disposals ;
 116
 117 : recreate-table ( class -- )
 118     [
 119         [ drop-sql-statement [ execute-statement ] with-disposals
 120         ] curry ignore-errors
 121     ] [ create-table ] bi ;
 122
 123 : ensure-table ( class -- )
 124     [ create-table ] curry ignore-errors ;
 125
 126 : ensure-tables ( classes -- )
 127     [ ensure-table ] each ;
 128
 129 : insert-db-assigned-statement ( tuple -- )
 130     dup class
 131     db get insert-statements>> [ <insert-db-assigned-statement> ] cache
 132     [ bind-tuple ] 2keep insert-tuple* ;
 133
 134 : insert-user-assigned-statement ( tuple -- )
 135     dup class
 136     db get insert-statements>> [ <insert-user-assigned-statement> ] cache
 137     [ bind-tuple ] keep execute-statement ;
 138
 139 : insert-tuple ( tuple -- )
 140     dup class db-columns find-primary-key db-assigned-id-spec?
 141     [ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
 142
 143 : update-tuple ( tuple -- )
 144     dup class
 145     db get update-statements>> [ <update-tuple-statement> ] cache
 146     [ bind-tuple ] keep execute-statement ;
 147
 148 : delete-tuples ( tuple -- )
 149     dup dup class <delete-tuples-statement> [
 150         [ bind-tuple ] keep execute-statement
 151     ] with-disposal ;
 152
 153 : do-select ( exemplar-tuple statement -- tuples )
 154     [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
 155
 156 : query ( tuple query -- tuples )
 157     >r dup dup class r> <query> do-select ;
 158
 159 : select-tuples ( tuple -- tuples )
 160     dup dup class <select-by-slots-statement> do-select ;
 161
 162 : select-tuple ( tuple -- tuple/f )
 163     dup dup class \ query new 1 >>limit <query> do-select
 164     [ f ] [ first ] if-empty ;
 165
 166 : do-count ( exemplar-tuple statement -- tuples )
 167     [
 168         [ bind-tuple ] [ nip default-query ] 2bi
 169     ] with-disposal ;
 170
 171 : count-tuples ( tuple groups -- n )
 172     >r dup dup class r> <count-statement> do-count
 173     dup length 1 =
 174     [ first first string>number ] [ [ first string>number ] map ] if ;