basis/db/postgresql/postgresql.factor

   1 ! Copyright (C) 2007, 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs alien alien.syntax continuations io
   4 kernel math math.parser namespaces make prettyprint quotations
   5 sequences debugger db db.postgresql.lib db.postgresql.ffi
   6 db.tuples db.types tools.annotations math.ranges
   7 combinators classes locals words tools.walker
   8 nmake accessors random db.queries destructors ;
   9 USE: tools.walker
  10 IN: db.postgresql
  11
  12 TUPLE: postgresql-db < db
  13     host port pgopts pgtty db user pass ;
  14
  15 TUPLE: postgresql-statement < statement ;
  16
  17 TUPLE: postgresql-result-set < result-set ;
  18
  19 M: postgresql-db make-db* ( seq db -- db )
  20     >r first4 r>
  21         swap >>db
  22         swap >>pass
  23         swap >>user
  24         swap >>host ;
  25
  26 M: postgresql-db db-open ( db -- db )
  27     dup {
  28         [ host>> ]
  29         [ port>> ]
  30         [ pgopts>> ]
  31         [ pgtty>> ]
  32         [ db>> ]
  33         [ user>> ]
  34         [ pass>> ]
  35     } cleave connect-postgres >>handle ;
  36
  37 M: postgresql-db dispose ( db -- )
  38     handle>> PQfinish ;
  39
  40 M: postgresql-statement bind-statement* ( statement -- )
  41     drop ;
  42
  43 GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding )
  44
  45 M: sql-spec postgresql-bind-conversion ( tuple spec -- object )
  46     slot-name>> swap get-slot-named <low-level-binding> ;
  47
  48 M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- object )
  49     nip value>> <low-level-binding> ;
  50
  51 M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object )
  52     dup generator-singleton>> eval-generator
  53     [ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
  54
  55 M: postgresql-statement bind-tuple ( tuple statement -- )
  56     tuck in-params>>
  57     [ postgresql-bind-conversion ] with map
  58     >>bind-params drop ;
  59
  60 M: postgresql-result-set #rows ( result-set -- n )
  61     handle>> PQntuples ;
  62
  63 M: postgresql-result-set #columns ( result-set -- n )
  64     handle>> PQnfields ;
  65
  66 : result-handle-n ( result-set -- handle n )
  67     [ handle>> ] [ n>> ] bi ;
  68
  69 M: postgresql-result-set row-column ( result-set column -- object )
  70     >r result-handle-n r> pq-get-string ;
  71
  72 M: postgresql-result-set row-column-typed ( result-set column -- object )
  73     dup pick out-params>> nth type>>
  74     >r >r result-handle-n r> r> postgresql-column-typed ;
  75
  76 M: postgresql-statement query-results ( query -- result-set )
  77     dup bind-params>> [
  78         over [ bind-statement ] keep
  79         do-postgresql-bound-statement
  80     ] [
  81         dup do-postgresql-statement
  82     ] if*
  83     postgresql-result-set new-result-set
  84     dup init-result-set ;
  85
  86 M: postgresql-result-set advance-row ( result-set -- )
  87     [ 1+ ] change-n drop ;
  88
  89 M: postgresql-result-set more-rows? ( result-set -- ? )
  90     [ n>> ] [ max>> ] bi < ;
  91
  92 M: postgresql-statement dispose ( query -- )
  93     dup handle>> PQclear
  94     f >>handle drop ;
  95
  96 M: postgresql-result-set dispose ( result-set -- )
  97     [ handle>> PQclear ]
  98     [
  99         0 >>n
 100         0 >>max
 101         f >>handle drop
 102     ] bi ;
 103
 104 M: postgresql-statement prepare-statement ( statement -- )
 105     dup
 106     >r db get handle>> f r>
 107     [ sql>> ] [ in-params>> ] bi
 108     length f PQprepare postgresql-error
 109     >>handle drop ;
 110
 111 M: postgresql-db <simple-statement> ( sql in out -- statement )
 112     postgresql-statement new-statement ;
 113
 114 M: postgresql-db <prepared-statement> ( sql in out -- statement )
 115     <simple-statement> dup prepare-statement ;
 116
 117 : bind-name% ( -- )
 118     CHAR: $ 0,
 119     sql-counter [ inc ] [ get 0# ] bi ;
 120
 121 M: postgresql-db bind% ( spec -- )
 122     bind-name% 1, ;
 123
 124 M: postgresql-db bind# ( spec object -- )
 125     >r bind-name% f swap type>> r> <literal-bind> 1, ;
 126
 127 : create-table-sql ( class -- statement )
 128     [
 129         "create table " 0% 0%
 130         "(" 0% [ ", " 0% ] [
 131             dup column-name>> 0%
 132             " " 0%
 133             dup type>> lookup-create-type 0%
 134             modifiers 0%
 135         ] interleave ");" 0%
 136     ] query-make ;
 137
 138 : create-function-sql ( class -- statement )
 139     [
 140         >r remove-id r>
 141         "create function add_" 0% dup 0%
 142         "(" 0%
 143         over [ "," 0% ]
 144         [
 145             type>> lookup-type 0%
 146         ] interleave
 147         ")" 0%
 148         " returns bigint as '" 0%
 149
 150         "insert into " 0%
 151         dup 0%
 152         "(" 0%
 153         over [ ", " 0% ] [ column-name>> 0% ] interleave
 154         ") values(" 0%
 155         swap [ ", " 0% ] [ drop bind-name% ] interleave
 156         "); " 0%
 157         "select currval(''" 0% 0% "_id_seq'');' language sql;" 0%
 158     ] query-make ;
 159
 160 M: postgresql-db create-sql-statement ( class -- seq )
 161     [
 162         [ create-table-sql , ] keep
 163         dup db-columns find-primary-key db-assigned-id-spec?
 164         [ create-function-sql , ] [ drop ] if
 165     ] { } make ;
 166
 167 : drop-function-sql ( class -- statement )
 168     [
 169         "drop function add_" 0% 0%
 170         "(" 0%
 171         remove-id
 172         [ ", " 0% ] [ type>> lookup-type 0% ] interleave
 173         ");" 0%
 174     ] query-make ;
 175
 176 : drop-table-sql ( table -- statement )
 177     [
 178         "drop table " 0% 0% drop
 179     ] query-make ;
 180
 181 M: postgresql-db drop-sql-statement ( class -- seq )
 182     [
 183         [ drop-table-sql , ] keep
 184         dup db-columns find-primary-key db-assigned-id-spec?
 185         [ drop-function-sql , ] [ drop ] if
 186     ] { } make ;
 187
 188 M: postgresql-db <insert-db-assigned-statement> ( class -- statement )
 189     [
 190         "select add_" 0% 0%
 191         "(" 0%
 192         dup find-primary-key 2,
 193         remove-id
 194         [ ", " 0% ] [ bind% ] interleave
 195         ");" 0%
 196     ] query-make ;
 197
 198 M: postgresql-db <insert-user-assigned-statement> ( class -- statement )
 199     [
 200         "insert into " 0% 0%
 201         "(" 0%
 202         dup [ ", " 0% ] [ column-name>> 0% ] interleave
 203         ")" 0%
 204
 205         " values(" 0%
 206         [ ", " 0% ] [
 207             dup type>> +random-id+ = [
 208                 [
 209                     bind-name%
 210                     slot-name>>
 211                     f
 212                     random-id-generator
 213                 ] [ type>> ] bi <generator-bind> 1,
 214             ] [
 215                 bind%
 216             ] if
 217         ] interleave
 218         ");" 0%
 219     ] query-make ;
 220
 221 M: postgresql-db insert-tuple* ( tuple statement -- )
 222     query-modify-tuple ;
 223
 224 M: postgresql-db persistent-table ( -- hashtable )
 225     H{
 226         { +db-assigned-id+ { "integer" "serial primary key" f } }
 227         { +user-assigned-id+ { f f "primary key" } }
 228         { +random-id+ { "bigint" "bigint primary key" f } }
 229         { TEXT { "text" "text" f } }
 230         { VARCHAR { "varchar" "varchar" f } }
 231         { INTEGER { "integer" "integer" f } }
 232         { BIG-INTEGER { "bigint" "bigint" f } }
 233         { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
 234         { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
 235         { DOUBLE { "real" "real" f } }
 236         { DATE { "date" "date" f } }
 237         { TIME { "time" "time" f } }
 238         { DATETIME { "timestamp" "timestamp" f } }
 239         { TIMESTAMP { "timestamp" "timestamp" f } }
 240         { BLOB { "bytea" "bytea" f } }
 241         { FACTOR-BLOB { "bytea" "bytea" f } }
 242         { URL { "varchar" "varchar" f } }
 243         { +foreign-id+ { f f "references" } }
 244         { +autoincrement+ { f f "autoincrement" } }
 245         { +unique+ { f f "unique" } }
 246         { +default+ { f f "default" } }
 247         { +null+ { f f "null" } }
 248         { +not-null+ { f f "not null" } }
 249         { system-random-generator { f f f } }
 250         { secure-random-generator { f f f } }
 251         { random-generator { f f f } }
 252     } ;
 253
 254 ERROR: no-compound-found string object ;
 255 M: postgresql-db compound ( string object -- string' )
 256     over {
 257         { "default" [ first number>string join-space ] }
 258         { "varchar" [ first number>string paren append ] }
 259         { "references" [
 260                 first2 >r [ unparse join-space ] keep db-columns r>
 261                 swap [ slot-name>> = ] with find nip
 262                 column-name>> paren append
 263             ] }
 264         [ drop no-compound-found ]
 265     } case ;