extra/db/sqlite/sqlite.factor

   1 ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien arrays assocs classes compiler db
   4 hashtables io.files kernel math math.parser namespaces
   5 prettyprint sequences strings tuples alien.c-types
   6 continuations db.sqlite.lib db.sqlite.ffi db.tuples
   7 words combinators.lib db.types combinators
   8 combinators.cleave io namespaces.lib ;
   9 IN: db.sqlite
  10
  11 TUPLE: sqlite-db path ;
  12
  13 M: sqlite-db make-db* ( path db -- db )
  14     [ set-sqlite-db-path ] keep ;
  15
  16 M: sqlite-db db-open ( db -- )
  17     dup sqlite-db-path sqlite-open <db>
  18     swap set-delegate ;
  19
  20 M: sqlite-db db-close ( handle -- )
  21     sqlite-close ;
  22
  23 M: sqlite-db dispose ( db -- ) dispose-db ;
  24
  25 : with-sqlite ( path quot -- )
  26     sqlite-db swap with-db ; inline
  27
  28 TUPLE: sqlite-statement ;
  29
  30 TUPLE: sqlite-result-set has-more? ;
  31
  32 M: sqlite-db <simple-statement> ( str in out -- obj )
  33     <prepared-statement> ;
  34
  35 M: sqlite-db <prepared-statement> ( str in out -- obj )
  36     {
  37         set-statement-sql
  38         set-statement-in-params
  39         set-statement-out-params
  40     } statement construct
  41     db get db-handle over statement-sql sqlite-prepare
  42     over set-statement-handle
  43     sqlite-statement construct-delegate ;
  44
  45 M: sqlite-statement dispose ( statement -- )
  46     statement-handle sqlite-finalize ;
  47
  48 M: sqlite-result-set dispose ( result-set -- )
  49     f swap set-result-set-handle ;
  50
  51 : sqlite-bind ( triples handle -- )
  52     swap [ first3 sqlite-bind-type ] with each ;
  53
  54 : reset-statement ( statement -- )
  55     statement-handle sqlite-reset ;
  56
  57 M: sqlite-statement bind-statement* ( statement -- )
  58     dup statement-bound? [ dup reset-statement ] when
  59     [ statement-bind-params ] [ statement-handle ] bi
  60     sqlite-bind ;
  61
  62 M: sqlite-statement bind-tuple ( tuple statement -- )
  63     [
  64         statement-in-params
  65         [
  66             [ sql-spec-column-name ":" swap append ]
  67             [ sql-spec-slot-name rot get-slot-named ]
  68             [ sql-spec-type ] tri 3array
  69         ] with map
  70     ] keep
  71     bind-statement ;
  72
  73 : last-insert-id ( -- id )
  74     db get db-handle sqlite3_last_insert_rowid
  75     dup zero? [ "last-id failed" throw ] when ;
  76
  77 M: sqlite-db insert-tuple* ( tuple statement -- )
  78     execute-statement last-insert-id swap set-primary-key ;
  79
  80 M: sqlite-result-set #columns ( result-set -- n )
  81     result-set-handle sqlite-#columns ;
  82
  83 M: sqlite-result-set row-column ( result-set n -- obj )
  84     >r result-set-handle r> sqlite-column ;
  85
  86 M: sqlite-result-set row-column-typed ( result-set n -- obj )
  87     dup pick result-set-out-params nth sql-spec-type
  88     >r >r result-set-handle r> r> sqlite-column-typed ;
  89
  90 M: sqlite-result-set advance-row ( result-set -- )
  91     [ result-set-handle sqlite-next ] keep
  92     set-sqlite-result-set-has-more? ;
  93
  94 M: sqlite-result-set more-rows? ( result-set -- ? )
  95     sqlite-result-set-has-more? ;
  96
  97 M: sqlite-statement query-results ( query -- result-set )
  98     dup statement-handle sqlite-result-set <result-set>
  99     dup advance-row ;
 100
 101 M: sqlite-db begin-transaction ( -- )
 102     "BEGIN" sql-command ;
 103
 104 M: sqlite-db commit-transaction ( -- )
 105     "COMMIT" sql-command ;
 106
 107 M: sqlite-db rollback-transaction ( -- )
 108     "ROLLBACK" sql-command ;
 109
 110 : sqlite-make ( class quot -- )
 111     >r sql-props r>
 112     { "" { } { } } nmake <simple-statement> ;
 113
 114 M: sqlite-db create-sql-statement ( class -- statement )
 115     [
 116         "create table " 0% 0%
 117         "(" 0% [ ", " 0% ] [
 118             dup sql-spec-column-name 0%
 119             " " 0%
 120             dup sql-spec-type t lookup-type 0%
 121             modifiers 0%
 122         ] interleave ");" 0%
 123     ] sqlite-make ;
 124
 125 M: sqlite-db drop-sql-statement ( class -- statement )
 126     [
 127         "drop table " 0% 0% ";" 0% drop
 128     ] sqlite-make ;
 129
 130 M: sqlite-db <insert-native-statement> ( tuple -- statement )
 131     [
 132         "insert into " 0% 0%
 133         "(" 0%
 134         maybe-remove-id
 135         dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
 136         ") values(" 0%
 137         [ ", " 0% ] [ bind% ] interleave
 138         ");" 0%
 139     ] sqlite-make ;
 140
 141 M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
 142     <insert-native-statement> ;
 143
 144 : where-primary-key% ( specs -- )
 145     " where " 0%
 146     find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ;
 147
 148 : where-clause ( specs -- )
 149     " where " 0%
 150     [ " and " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ;
 151
 152 M: sqlite-db <update-tuple-statement> ( class -- statement )
 153     [
 154         "update " 0%
 155         0%
 156         " set " 0%
 157         dup remove-id
 158         [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
 159         where-primary-key%
 160     ] sqlite-make ;
 161
 162 M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
 163     [
 164         "delete from " 0% 0%
 165         " where " 0%
 166         find-primary-key
 167         dup sql-spec-column-name 0% " = " 0% bind%
 168     ] sqlite-make ;
 169
 170 ! : select-interval ( interval name -- ) ;
 171 ! : select-sequence ( seq name -- ) ;
 172
 173 M: sqlite-db bind% ( spec -- )
 174     dup 1, sql-spec-column-name ":" swap append 0% ;
 175
 176 M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
 177     [
 178         "select " 0%
 179         over [ ", " 0% ]
 180         [ dup sql-spec-column-name 0% 2, ] interleave
 181
 182         " from " 0% 0%
 183         [ sql-spec-slot-name swap get-slot-named ] with subset
 184         dup empty? [ drop ] [ where-clause ] if ";" 0%
 185     ] sqlite-make ;
 186
 187 M: sqlite-db modifier-table ( -- hashtable )
 188     H{
 189         { +native-id+ "primary key" }
 190         { +assigned-id+ "primary key" }
 191         { +autoincrement+ "autoincrement" }
 192         { +unique+ "unique" }
 193         { +default+ "default" }
 194         { +null+ "null" }
 195         { +not-null+ "not null" }
 196     } ;
 197
 198 M: sqlite-db compound-modifier ( str obj -- newstr )
 199     compound-type ;
 200
 201 M: sqlite-db compound-type ( str seq -- newstr )
 202     over {
 203         { "default" [ first number>string join-space ] }
 204         [ 2drop ] !  "no sqlite compound data type" 3array throw ]
 205     } case ;
 206
 207 M: sqlite-db type-table ( -- assoc )
 208     H{
 209         { +native-id+ "integer primary key" }
 210         { INTEGER "integer" }
 211         { TEXT "text" }
 212         { VARCHAR "text" }
 213         { DATE "date" }
 214         { TIME "time" }
 215         { DATETIME "datetime" }
 216         { TIMESTAMP "timestamp" }
 217         { DOUBLE "real" }
 218         { BLOB "blob" }
 219         { FACTOR-BLOB "blob" }
 220     } ;
 221
 222 M: sqlite-db create-type-table
 223     type-table ;