1 ! Copyright (C) 2007, 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors classes.tuple combinators db
4 db.postgresql.errors db.postgresql.ffi db.postgresql.lib
5 db.private db.queries db.tuples db.tuples.private db.types
6 destructors kernel make math math.parser namespaces nmake random
10 TUPLE: postgresql-db host port pgopts pgtty database username password ;
12 : <postgresql-db> ( -- postgresql-db )
17 TUPLE: postgresql-db-connection < db-connection ;
18 : <postgresql-db-connection> ( handle -- db-connection )
19 postgresql-db-connection new-db-connection
24 TUPLE: postgresql-statement < statement ;
26 TUPLE: postgresql-result-set < result-set ;
28 M: postgresql-db db-open ( db -- db-connection )
37 } cleave connect-postgres <postgresql-db-connection> ;
39 M: postgresql-db-connection db-close ( handle -- ) PQfinish ;
41 M: postgresql-statement bind-statement* ( statement -- ) drop ;
43 GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding )
45 M: sql-spec postgresql-bind-conversion ( tuple spec -- object )
46 slot-name>> swap get-slot-named <low-level-binding> ;
48 M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- object )
49 nip value>> <low-level-binding> ;
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 ;
55 M: postgresql-statement bind-tuple ( tuple statement -- )
58 [ postgresql-bind-conversion ] with map
62 M: postgresql-result-set #rows ( result-set -- n )
65 M: postgresql-result-set #columns ( result-set -- n )
68 : result-handle-n ( result-set -- handle n )
69 [ handle>> ] [ n>> ] bi ;
71 M: postgresql-result-set row-column ( result-set column -- object )
72 [ result-handle-n ] dip pq-get-string ;
74 M: postgresql-result-set row-column-typed ( result-set column -- object )
75 dup pick out-params>> nth type>>
76 [ result-handle-n ] 2dip postgresql-column-typed ;
78 M: postgresql-statement query-results ( query -- result-set )
80 over [ bind-statement ] keep
81 do-postgresql-bound-statement
83 dup do-postgresql-statement
85 postgresql-result-set new-result-set
88 M: postgresql-result-set advance-row ( result-set -- )
89 [ 1 + ] change-n drop ;
91 M: postgresql-result-set more-rows? ( result-set -- ? )
92 [ n>> ] [ max>> ] bi < ;
94 M: postgresql-statement dispose ( query -- )
98 M: postgresql-result-set dispose ( result-set -- )
106 M: postgresql-statement prepare-statement ( statement -- )
108 [ db-connection get handle>> f ] dip
109 [ sql>> ] [ in-params>> ] bi
110 length f PQprepare postgresql-error
113 M: postgresql-db-connection <simple-statement> ( sql in out -- statement )
114 postgresql-statement new-statement ;
116 M: postgresql-db-connection <prepared-statement> ( sql in out -- statement )
117 <simple-statement> dup prepare-statement ;
121 sql-counter [ inc ] [ get 0# ] bi ;
123 M: postgresql-db-connection bind% ( spec -- )
126 M: postgresql-db-connection bind# ( spec object -- )
127 [ bind-name% f swap type>> ] dip
130 : create-table-sql ( class -- statement )
133 "create table " 0% 0%
137 dup type>> lookup-create-type 0%
144 [ "," 0% ] [ column-name>> 0% ] interleave
148 : create-function-sql ( class -- statement )
150 [ dup remove-id ] dip
151 "create function add_" 0% dup 0%
155 type>> lookup-type 0%
158 " returns bigint as '" 0%
163 over [ ", " 0% ] [ column-name>> 0% ] interleave
165 swap [ ", " 0% ] [ drop bind-name% ] interleave
167 "select currval(''" 0% 0% "_" 0%
168 find-primary-key first column-name>> 0%
169 "_seq'');' language sql;" 0%
172 M: postgresql-db-connection create-sql-statement ( class -- seq )
174 [ create-table-sql , ] keep
175 dup db-assigned? [ create-function-sql , ] [ drop ] if
178 : drop-function-sql ( class -- statement )
180 "drop function add_" 0% 0%
183 [ ", " 0% ] [ type>> lookup-type 0% ] interleave
187 : drop-table-sql ( table -- statement )
189 "drop table " 0% 0% drop
192 M: postgresql-db-connection drop-sql-statement ( class -- seq )
194 [ drop-table-sql , ] keep
195 dup db-assigned? [ drop-function-sql , ] [ drop ] if
198 M: postgresql-db-connection <insert-db-assigned-statement> ( class -- statement )
202 dup find-primary-key first 2,
204 [ ", " 0% ] [ bind% ] interleave
208 M: postgresql-db-connection <insert-user-assigned-statement> ( class -- statement )
212 dup [ ", " 0% ] [ column-name>> 0% ] interleave
217 dup type>> +random-id+ = [
223 ] [ type>> ] bi <generator-bind> 1,
231 M: postgresql-db-connection insert-tuple-set-key ( tuple statement -- )
234 M: postgresql-db-connection persistent-table ( -- hashtable )
236 { +db-assigned-id+ { "integer" "serial" f } }
237 { +user-assigned-id+ { f f f } }
238 { +random-id+ { "bigint" "bigint" f } }
240 { +foreign-id+ { f f "references" } }
242 { +on-update+ { f f "on update" } }
243 { +on-delete+ { f f "on delete" } }
244 { +restrict+ { f f "restrict" } }
245 { +cascade+ { f f "cascade" } }
246 { +set-null+ { f f "set null" } }
247 { +set-default+ { f f "set default" } }
249 { TEXT { "text" "text" f } }
250 { VARCHAR { "varchar" "varchar" f } }
251 { INTEGER { "integer" "integer" f } }
252 { BIG-INTEGER { "bigint" "bigint" f } }
253 { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
254 { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
255 { DOUBLE { "real" "real" f } }
256 { DATE { "date" "date" f } }
257 { TIME { "time" "time" f } }
258 { DATETIME { "timestamp" "timestamp" f } }
259 { TIMESTAMP { "timestamp" "timestamp" f } }
260 { BLOB { "bytea" "bytea" f } }
261 { FACTOR-BLOB { "bytea" "bytea" f } }
262 { URL { "varchar" "varchar" f } }
263 { +autoincrement+ { f f "autoincrement" } }
264 { +unique+ { f f "unique" } }
265 { +default+ { f f "default" } }
266 { +null+ { f f "null" } }
267 { +not-null+ { f f "not null" } }
268 { system-random-generator { f f f } }
269 { secure-random-generator { f f f } }
270 { random-generator { f f f } }
273 ERROR: no-compound-found string object ;
274 M: postgresql-db-connection compound ( string object -- string' )
276 { "default" [ first number>string " " glue ] }
277 { "varchar" [ first number>string "(" ")" surround append ] }
278 { "references" [ >reference-string ] }
279 [ drop no-compound-found ]
282 M: postgresql-db-connection parse-db-error
283 "\n" split dup length {
284 { 1 [ first parse-postgresql-sql-error ] }
285 { 2 [ concat parse-postgresql-sql-error ] }
288 [ parse-postgresql-sql-error ] 2dip
289 postgresql-location >>location