basis/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 hashtables
   4 io.files kernel math math.parser namespaces prettyprint
   5 sequences strings classes.tuple alien.c-types continuations
   6 db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
   7 math.intervals io nmake accessors vectors math.ranges random
   8 math.bitwise db.queries destructors db.tuples.private ;
   9 IN: db.sqlite
  10
  11 TUPLE: sqlite-db < db path ;
  12
  13 M: sqlite-db make-db* ( path db -- db )
  14     swap >>path ;
  15
  16 M: sqlite-db db-open ( db -- db )
  17     dup path>> sqlite-open >>handle ;
  18
  19 M: sqlite-db db-close ( handle -- ) sqlite-close ;
  20 M: sqlite-db dispose ( db -- ) db-dispose ;
  21
  22 TUPLE: sqlite-statement < statement ;
  23
  24 TUPLE: sqlite-result-set < result-set has-more? ;
  25
  26 M: sqlite-db <simple-statement> ( str in out -- obj )
  27     <prepared-statement> ;
  28
  29 M: sqlite-db <prepared-statement> ( str in out -- obj )
  30     sqlite-statement new-statement ;
  31
  32 : sqlite-maybe-prepare ( statement -- statement )
  33     dup handle>> [
  34         db get handle>> over sql>> sqlite-prepare
  35         >>handle
  36     ] unless ;
  37
  38 M: sqlite-statement dispose ( statement -- )
  39     handle>>
  40     [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
  41
  42 M: sqlite-result-set dispose ( result-set -- )
  43     f >>handle drop ;
  44
  45 : reset-bindings ( statement -- )
  46     sqlite-maybe-prepare
  47     handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
  48
  49 M: sqlite-statement low-level-bind ( statement -- )
  50     [ bind-params>> ] [ handle>> ] bi
  51     [ swap [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] curry each ;
  52
  53 M: sqlite-statement bind-statement* ( statement -- )
  54     sqlite-maybe-prepare
  55     dup bound?>> [ dup reset-bindings ] when
  56     low-level-bind ;
  57
  58 GENERIC: sqlite-bind-conversion ( tuple obj -- array )
  59
  60 TUPLE: sqlite-low-level-binding < low-level-binding key type ;
  61 : <sqlite-low-level-binding> ( key value type -- obj )
  62     sqlite-low-level-binding new
  63         swap >>type
  64         swap >>value
  65         swap >>key ;
  66
  67 M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
  68     [ column-name>> ":" prepend ]
  69     [ slot-name>> rot get-slot-named ]
  70     [ type>> ] tri <sqlite-low-level-binding> ;
  71
  72 M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
  73     nip [ key>> ] [ value>> ] [ type>> ] tri
  74     <sqlite-low-level-binding> ;
  75
  76 M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
  77     tuck
  78     [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi
  79     rot set-slot-named
  80     >r [ key>> ] [ type>> ] bi r> swap <sqlite-low-level-binding> ;
  81
  82 M: sqlite-statement bind-tuple ( tuple statement -- )
  83     [
  84         in-params>> [ sqlite-bind-conversion ] with map
  85     ] keep bind-statement ;
  86
  87 : last-insert-id ( -- id )
  88     db get handle>> sqlite3_last_insert_rowid
  89     dup zero? [ "last-id failed" throw ] when ;
  90
  91 M: sqlite-db insert-tuple-set-key ( tuple statement -- )
  92     execute-statement last-insert-id swap set-primary-key ;
  93
  94 M: sqlite-result-set #columns ( result-set -- n )
  95     handle>> sqlite-#columns ;
  96
  97 M: sqlite-result-set row-column ( result-set n -- obj )
  98     [ handle>> ] [ sqlite-column ] bi* ;
  99
 100 M: sqlite-result-set row-column-typed ( result-set n -- obj )
 101     dup pick out-params>> nth type>>
 102     >r >r handle>> r> r> sqlite-column-typed ;
 103
 104 M: sqlite-result-set advance-row ( result-set -- )
 105     dup handle>> sqlite-next >>has-more? drop ;
 106
 107 M: sqlite-result-set more-rows? ( result-set -- ? )
 108     has-more?>> ;
 109
 110 M: sqlite-statement query-results ( query -- result-set )
 111     sqlite-maybe-prepare
 112     dup handle>> sqlite-result-set new-result-set
 113     dup advance-row ;
 114
 115 M: sqlite-db create-sql-statement ( class -- statement )
 116     [
 117         dupd
 118         "create table " 0% 0%
 119         "(" 0% [ ", " 0% ] [
 120             dup column-name>> 0%
 121             " " 0%
 122             dup type>> lookup-create-type 0%
 123             modifiers 0%
 124         ] interleave
 125
 126         ", " 0%
 127         find-primary-key
 128         "primary key(" 0%
 129         [ "," 0% ] [ column-name>> 0% ] interleave
 130         "));" 0%
 131     ] query-make ;
 132
 133 M: sqlite-db drop-sql-statement ( class -- statement )
 134     [ "drop table " 0% 0% ";" 0% drop ] query-make ;
 135
 136 M: sqlite-db <insert-db-assigned-statement> ( tuple -- statement )
 137     [
 138         "insert into " 0% 0%
 139         "(" 0%
 140         remove-db-assigned-id
 141         dup [ ", " 0% ] [ column-name>> 0% ] interleave
 142         ") values(" 0%
 143         [ ", " 0% ] [
 144             dup type>> +random-id+ = [
 145                 [ slot-name>> ]
 146                 [
 147                     column-name>> ":" prepend dup 0%
 148                     random-id-generator
 149                 ] [ type>> ] tri <generator-bind> 1,
 150             ] [
 151                 bind%
 152             ] if
 153         ] interleave
 154         ");" 0%
 155     ] query-make ;
 156
 157 M: sqlite-db <insert-user-assigned-statement> ( tuple -- statement )
 158     <insert-db-assigned-statement> ;
 159
 160 M: sqlite-db bind# ( spec obj -- )
 161     >r
 162     [ column-name>> ":" swap next-sql-counter 3append dup 0% ]
 163     [ type>> ] bi
 164     r> <literal-bind> 1, ;
 165
 166 M: sqlite-db bind% ( spec -- )
 167     dup 1, column-name>> ":" prepend 0% ;
 168
 169 M: sqlite-db persistent-table ( -- assoc )
 170     H{
 171         { +db-assigned-id+ { "integer" "integer" f } }
 172         { +user-assigned-id+ { f f f } }
 173         { +random-id+ { "integer" "integer" f } }
 174         { +foreign-id+ { "integer" "integer" "references" } }
 175
 176         { +on-delete+ { f f "on delete" } }
 177         { +restrict+ { f f "restrict" } }
 178         { +cascade+ { f f "cascade" } }
 179         { +set-null+ { f f "set null" } }
 180         { +set-default+ { f f "set default" } }
 181
 182         { INTEGER { "integer" "integer" f } }
 183         { BIG-INTEGER { "bigint" "bigint" f } }
 184         { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
 185         { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
 186         { TEXT { "text" "text" f } }
 187         { VARCHAR { "text" "text" f } }
 188         { DATE { "date" "date" f } }
 189         { TIME { "time" "time" f } }
 190         { DATETIME { "datetime" "datetime" f } }
 191         { TIMESTAMP { "timestamp" "timestamp" f } }
 192         { DOUBLE { "real" "real" f } }
 193         { BLOB { "blob" "blob" f } }
 194         { FACTOR-BLOB { "blob" "blob" f } }
 195         { URL { "text" "text" f } }
 196         { +autoincrement+ { f f "autoincrement" } }
 197         { +unique+ { f f "unique" } }
 198         { +default+ { f f "default" } }
 199         { +null+ { f f "null" } }
 200         { +not-null+ { f f "not null" } }
 201         { system-random-generator { f f f } }
 202         { secure-random-generator { f f f } }
 203         { random-generator { f f f } }
 204     } ;
 205
 206 M: sqlite-db compound ( string seq -- new-string )
 207     over {
 208         { "default" [ first number>string join-space ] }
 209         { "references" [ >reference-string ] }
 210         [ 2drop ]
 211     } case ;