extra/sqlite/tuple-db/tuple-db.factor

   1 ! Copyright (C) 2005 Chris Double.
   2 !
   3 ! A tuple that is persistent has its delegate set as 'persistent'.
   4 ! 'persistent' holds the numeric rowid for that tuple in its table.
   5 IN: sqlite.tuple-db
   6 USING: io kernel sequences namespaces slots classes slots.private
   7 assocs math words generic sqlite math.parser ;
   8
   9 ! Each slot in a tuple that is storable in the database has
  10 ! an instance of a db-field object the gives the name of the
  11 ! database table and slot number in the tuple object of that field.
  12 TUPLE: db-field name bind-name slot type ;
  13
  14 C: <db-field> db-field
  15
  16 ! The mapping tuple holds information on how the slots of
  17 ! a tuple are mapped to the fields of a sqlite database.
  18 TUPLE: mapping tuple table fields one-to-one one-to-many   ;
  19
  20 C: <mapping> mapping
  21
  22 : sanitize ( string -- string )
  23     #! Convert a string so it can be used as a table or field name.
  24     clone
  25     H{ { CHAR: - CHAR: _ } { CHAR: ? CHAR: p } }
  26     over substitute ;
  27
  28 : tuple-fields ( class -- seq )
  29   #! Given a tuple class return a list of the fields
  30   #! within that tuple. Ignores the delegate field.
  31   "slots" word-prop 1 tail [
  32     [ slot-spec-name sanitize dup ":" swap append ] keep
  33     slot-spec-offset
  34     "text"
  35     <db-field>
  36   ] map ;
  37
  38 : default-mapping ( class -- mapping )
  39   #! Given a tuple class, create a default mappings object. It assumes
  40   #! there are no one-to-one or one-to-many relationships.
  41   dup [ word-name sanitize ] keep tuple-fields f f <mapping> ;
  42
  43 ! The mappings variable holds a hashtable mapping the tuple symbol
  44 ! to the mapping object, describing how that tuple is stored
  45 ! in the database.
  46 SYMBOL: mappings
  47
  48 : init-mappings ( -- )
  49   H{ } mappings set-global ;
  50
  51 : get-mappings ( -- hashtable )
  52   mappings get-global ;
  53
  54 : set-mapping ( mapping -- )
  55   #! Store a database mapping so that the persistence system
  56   #! knows how to store instances of the relevant tuple in the database.
  57   dup mapping-tuple get-mappings set-at ;
  58
  59 : get-mapping ( class -- mapping )
  60   #! Return the database mapping for the given tuple class.
  61   get-mappings at ;
  62
  63 ! The 'persistent' tuple will be set to the delegate of any tuple
  64 ! instance stored in the database. It contains the database key
  65 ! of the row in the database table for the instance or 'f' if it has
  66 ! not yet been stored in the database. It also contains the 'mapping'
  67 ! object used to translate the fields of the tuple to the database fields.
  68 TUPLE: persistent mapping key ;
  69 : <persistent> ( tuple -- persistent )
  70   persistent construct-empty
  71   >r class get-mapping r>
  72   [ set-persistent-mapping ] keep ;
  73
  74 : make-persistent ( tuple -- tuple )
  75   #! Convert the tuple into something that can be stored
  76   #! into a database by setting its delegate to 'persistent'.
  77   [ <persistent> ] keep
  78   [ set-delegate ] keep ;
  79
  80
  81 : comma-fields ( mapping quot -- string )
  82   #! Given a mapping, call quot on each field in
  83   #! the mapping. The contents of quot should call ',' or '%'
  84   #! to generate output. The output of each quot call
  85   #! seperated by commas is returned as a string. 'quot' should be
  86   #! stack effect ( field -- ).
  87   >r mapping-fields r> [ "" make ] curry map "," join ; inline
  88
  89 GENERIC: create-sql ( mapping -- string )
  90 M: mapping create-sql ( mapping -- string )
  91   #! Return the SQL used to create a table for storing this type of tuple.
  92   [
  93     "create table " % dup mapping-table %
  94     " (" %
  95     [ dup db-field-name % " " % db-field-type % ] comma-fields %
  96     ");" %
  97   ] "" make ;
  98
  99 GENERIC: drop-sql ( mapping -- string )
 100 M: mapping drop-sql ( mapping -- string )
 101   #! Return the SQL used to drop the table for storing this type of tuple.
 102   [
 103     "drop table " % mapping-table % ";" %
 104   ] "" make ;
 105
 106 GENERIC: insert-sql ( mapping -- string )
 107 M: mapping insert-sql ( mapping -- string )
 108   #! Return the SQL used to insert a tuple into a table
 109   [
 110     "insert into " % dup mapping-table %
 111     " values(" %
 112     [ db-field-bind-name % ] comma-fields %
 113     ");" %
 114   ] "" make ;
 115
 116 GENERIC: delete-sql ( mapping -- string )
 117 M: mapping delete-sql ( mapping -- string )
 118   #! Return the SQL used to delete a tuple from a table
 119   [
 120     "delete from " % mapping-table %
 121     " where ROWID=:rowid;" %
 122   ] "" make ;
 123
 124 GENERIC: update-sql ( mapping -- string )
 125 M: mapping update-sql ( mapping -- string )
 126   #! Return the SQL used to update the tuple
 127   [
 128     "update " % dup mapping-table %
 129     " set " %
 130     [ dup db-field-name % "=" % db-field-bind-name % ] comma-fields %
 131     " where ROWID=:rowid;" %
 132   ] "" make ;
 133
 134 GENERIC: select-sql ( tuple mapping -- select )
 135 M: mapping select-sql ( tuple mapping -- select )
 136   #! Return the SQL used to select a series of tuples from the database. It
 137   #! will select based on only the filled in fields of the tuple (ie. all non-f).
 138   [
 139     "select ROWID,* from " % dup mapping-table %
 140     mapping-fields [ ! tuple field
 141       swap over db-field-slot slot ! field value
 142       [
 143         [ dup db-field-name % "=" % db-field-bind-name % ] "" make
 144       ] [
 145         drop f
 146       ] if
 147     ] curry* map [ ] subset dup length 0 > [
 148       " where " %
 149       " and " join %
 150     ] [
 151       drop
 152     ] if
 153     ";" %
 154   ] "" make ;
 155
 156 : execute-update-sql ( db string -- )
 157   #! Execute the SQL, which should contain a database update
 158   #! statement (update, insert, create, etc). Ignore the result.
 159   sqlite-prepare dup [ drop ] sqlite-each sqlite-finalize ;
 160
 161 : create-tuple-table ( db class -- )
 162   #! Create the table for the tuple class.
 163   get-mapping create-sql execute-update-sql ;
 164
 165 : drop-tuple-table ( db class -- )
 166   #! Create the table for the tuple class.
 167   get-mapping drop-sql execute-update-sql ;
 168
 169 : bind-for-insert ( statement tuple -- )
 170   #! Bind the fields in the tuple to the fields in the
 171   #! prepared insert statement.
 172   dup class get-mapping mapping-fields [ ! statement tuple field
 173     [ db-field-slot slot ] keep ! statement value field
 174     db-field-bind-name swap ! statement name value
 175     >r dupd r> sqlite-bind-text-by-name
 176   ] curry* each drop ;
 177
 178 : bind-for-select ( statement tuple -- )
 179   #! Bind the fields in the tuple to the fields in the
 180   #! prepared select statement.
 181   dup class get-mapping mapping-fields [ ! statement tuple field
 182     [ db-field-slot slot ] keep ! statement value field
 183     over [
 184       db-field-bind-name swap ! statement name value
 185       >r dupd r> sqlite-bind-text-by-name
 186     ] [
 187       2drop
 188     ] if
 189   ] curry* each drop ;
 190
 191 : bind-for-update ( statement tuple -- )
 192   #! Bind the fields in the tuple to the fields in the
 193   #! prepared update statement.
 194   2dup bind-for-insert
 195   >r ":rowid" r> persistent-key sqlite-bind-text-by-name ;
 196
 197 : bind-for-delete ( statement tuple -- )
 198   #! Bind the fields in the tuple to the fields in the
 199   #! prepared delete statement.
 200   >r ":rowid" r> persistent-key sqlite-bind-text-by-name ;
 201
 202 : (insert-tuple) ( db tuple -- )
 203   #! Insert this tuple instance into the database. Note that
 204   #! it inserts only this instance, and not any one-to-one or
 205   #! one-to-many fields.
 206   dup class get-mapping insert-sql ! db tuple sql
 207   swapd sqlite-prepare swap ! statement tuple
 208   dupd bind-for-insert ! statement
 209   dup [ drop ] sqlite-each
 210   sqlite-finalize ;
 211
 212 : insert-tuple ( db tuple -- )
 213   #! Insert this tuple instance into the database and
 214   #! update the rowid of the insert in the tuple.
 215   [ (insert-tuple) ] 2keep
 216   >r sqlite-last-insert-rowid number>string r> make-persistent set-persistent-key ;
 217
 218 : update-tuple ( db tuple -- )
 219   #! Update this tuple instance in the database. The tuple should have
 220   #! a delegate of 'persistent' with the key field set.
 221   dup class get-mapping update-sql ! db tuple sql
 222   swapd sqlite-prepare swap ! statement tuple
 223   dupd bind-for-update ! statement
 224   dup [ drop ] sqlite-each
 225   sqlite-finalize ;
 226
 227 : save-tuple ( db tuple -- )
 228   #! Insert or Update the tuple instance depending on whether it
 229   #! has a persistent delegate.
 230   dup delegate [ update-tuple ] [ insert-tuple ] if ;
 231
 232 : delete-tuple ( db tuple -- )
 233   #! Delete this tuple instance from the database. The tuple should have
 234   #! a delegate of 'persistent' with the key field set.
 235   dup class get-mapping delete-sql ! db tuple sql
 236   swapd sqlite-prepare swap ! statement tuple
 237   dupd bind-for-delete ! statement
 238   dup [ drop ] sqlite-each
 239   sqlite-finalize ;
 240
 241 : restore-tuple ( statement tuple -- tuple )
 242   #! Using 'tuple' as a template, clone it and
 243   #! return the clone with fields set to the values from the
 244   #! database.
 245   clone dup class get-mapping mapping-fields 1 swap
 246   [ ! statement tuple index field )
 247     over 1+ >r ! statement tuple index field r: index+1
 248     db-field-slot >r ! statement tuple index r: index+1 slot
 249     pick swap column-text ! statement tuple value r: index+1 slot
 250     over r> set-slot r> ! statement tuple index+1
 251   ] each ! statement tuple index
 252   drop make-persistent swap 0 column-text swap [ set-persistent-key ] keep ;
 253
 254 : find-tuples ( db tuple -- seq )
 255   #! Return a sequence of all tuples in the database that
 256   #! match the tuple provided as a template. All fields in the
 257   #! tuple must match the entries in the database, except for
 258   #! those set to 'f'.
 259   dup class get-mapping dupd select-sql ! db tuple sql
 260   swapd sqlite-prepare swap ! statement tuple
 261   2dup bind-for-select ! statement tuple
 262   [
 263     over [ ! tuple statement
 264       over restore-tuple ,
 265     ] sqlite-each
 266   ] { } make nip ! statement tuple accum
 267   swap sqlite-finalize ;
 268
 269
 270 get-mappings [ init-mappings ] unless