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