basis/db/postgresql/postgresql.factor

   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
   7 sequences splitting ;
   8 IN: db.postgresql
   9
  10 TUPLE: postgresql-db host port pgopts pgtty database username password ;
  11
  12 : <postgresql-db> ( -- postgresql-db )
  13     postgresql-db new ;
  14
  15 <PRIVATE
  16
  17 TUPLE: postgresql-db-connection < db-connection ;
  18 : <postgresql-db-connection> ( handle -- db-connection )
  19     postgresql-db-connection new-db-connection
  20         swap >>handle ;
  21
  22 PRIVATE>
  23
  24 TUPLE: postgresql-statement < statement ;
  25
  26 TUPLE: postgresql-result-set < result-set ;
  27
  28 M: postgresql-db db-open
  29     {
  30         [ host>> ]
  31         [ port>> ]
  32         [ pgopts>> ]
  33         [ pgtty>> ]
  34         [ database>> ]
  35         [ username>> ]
  36         [ password>> ]
  37     } cleave connect-postgres <postgresql-db-connection> ;
  38
  39 M: postgresql-db-connection db-close PQfinish ;
  40
  41 M: postgresql-statement bind-statement* drop ;
  42
  43 GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding )
  44
  45 M: sql-spec postgresql-bind-conversion
  46     slot-name>> swap get-slot-named <low-level-binding> ;
  47
  48 M: literal-bind postgresql-bind-conversion
  49     nip value>> <low-level-binding> ;
  50
  51 M: generator-bind postgresql-bind-conversion
  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
  56     [ nip ] [
  57         in-params>>
  58         [ postgresql-bind-conversion ] with map
  59     ] 2bi
  60     >>bind-params drop ;
  61
  62 M: postgresql-result-set #rows
  63     handle>> PQntuples ;
  64
  65 M: postgresql-result-set #columns
  66     handle>> PQnfields ;
  67
  68 : result-handle-n ( result-set -- handle n )
  69     [ handle>> ] [ n>> ] bi ;
  70
  71 M: postgresql-result-set row-column
  72     [ result-handle-n ] dip pq-get-string ;
  73
  74 M: postgresql-result-set row-column-typed
  75     dup pick out-params>> nth type>>
  76     [ result-handle-n ] 2dip postgresql-column-typed ;
  77
  78 M: postgresql-statement query-results
  79     dup bind-params>> [
  80         over [ bind-statement ] keep
  81         do-postgresql-bound-statement
  82     ] [
  83         dup do-postgresql-statement
  84     ] if*
  85     postgresql-result-set new-result-set
  86     dup init-result-set ;
  87
  88 M: postgresql-result-set advance-row
  89     [ 1 + ] change-n drop ;
  90
  91 M: postgresql-result-set more-rows?
  92     [ n>> ] [ max>> ] bi < ;
  93
  94 M: postgresql-statement dispose
  95     dup handle>> PQclear
  96     f >>handle drop ;
  97
  98 M: postgresql-result-set dispose
  99     [ handle>> PQclear ]
 100     [
 101         0 >>n
 102         0 >>max
 103         f >>handle drop
 104     ] bi ;
 105
 106 M: postgresql-statement prepare-statement
 107     dup
 108     [ db-connection get handle>> f ] dip
 109     [ sql>> ] [ in-params>> ] bi
 110     length f PQprepare postgresql-error
 111     >>handle drop ;
 112
 113 M: postgresql-db-connection <simple-statement>
 114     postgresql-statement new-statement ;
 115
 116 M: postgresql-db-connection <prepared-statement>
 117     <simple-statement> dup prepare-statement ;
 118
 119 : bind-name% ( -- )
 120     CHAR: $ 0,
 121     sql-counter [ inc ] [ get 0# ] bi ;
 122
 123 M: postgresql-db-connection bind%
 124     bind-name% 1, ;
 125
 126 M: postgresql-db-connection bind#
 127     [ bind-name% f swap type>> ] dip
 128     <literal-bind> 1, ;
 129
 130 : create-table-sql ( class -- statement )
 131     [
 132         dupd
 133         "create table " 0% 0%
 134         "(" 0% [ ", " 0% ] [
 135             dup column-name>> 0%
 136             " " 0%
 137             dup type>> lookup-create-type 0%
 138             modifiers 0%
 139         ] interleave
 140
 141         ", " 0%
 142         find-primary-key
 143         "primary key(" 0%
 144         [ "," 0% ] [ column-name>> 0% ] interleave
 145         "));" 0%
 146     ] query-make ;
 147
 148 : create-function-sql ( class -- statement )
 149     [
 150         [ dup remove-id ] dip
 151         "create function add_" 0% dup 0%
 152         "(" 0%
 153         over [ "," 0% ]
 154         [
 155             type>> lookup-type 0%
 156         ] interleave
 157         ")" 0%
 158         " returns bigint as '" 0%
 159
 160         "insert into " 0%
 161         dup 0%
 162         "(" 0%
 163         over [ ", " 0% ] [ column-name>> 0% ] interleave
 164         ") values(" 0%
 165         swap [ ", " 0% ] [ drop bind-name% ] interleave
 166         "); " 0%
 167         "select currval(''" 0% 0% "_" 0%
 168         find-primary-key first column-name>> 0%
 169         "_seq'');' language sql;" 0%
 170     ] query-make ;
 171
 172 M: postgresql-db-connection create-sql-statement
 173     [
 174         [ create-table-sql , ] keep
 175         dup db-assigned? [ create-function-sql , ] [ drop ] if
 176     ] { } make ;
 177
 178 : drop-function-sql ( class -- statement )
 179     [
 180         "drop function add_" 0% 0%
 181         "(" 0%
 182         remove-id
 183         [ ", " 0% ] [ type>> lookup-type 0% ] interleave
 184         ");" 0%
 185     ] query-make ;
 186
 187 : drop-table-sql ( table -- statement )
 188     [
 189         "drop table " 0% 0% drop
 190     ] query-make ;
 191
 192 M: postgresql-db-connection drop-sql-statement
 193     [
 194         [ drop-table-sql , ] keep
 195         dup db-assigned? [ drop-function-sql , ] [ drop ] if
 196     ] { } make ;
 197
 198 M: postgresql-db-connection <insert-db-assigned-statement>
 199     [
 200         "select add_" 0% 0%
 201         "(" 0%
 202         dup find-primary-key first 2,
 203         remove-id
 204         [ ", " 0% ] [ bind% ] interleave
 205         ");" 0%
 206     ] query-make ;
 207
 208 M: postgresql-db-connection <insert-user-assigned-statement>
 209     [
 210         "insert into " 0% 0%
 211         "(" 0%
 212         dup [ ", " 0% ] [ column-name>> 0% ] interleave
 213         ")" 0%
 214
 215         " values(" 0%
 216         [ ", " 0% ] [
 217             dup type>> +random-id+ = [
 218                 [
 219                     bind-name%
 220                     slot-name>>
 221                     f
 222                     random-id-generator
 223                 ] [ type>> ] bi <generator-bind> 1,
 224             ] [
 225                 bind%
 226             ] if
 227         ] interleave
 228         ");" 0%
 229     ] query-make ;
 230
 231 M: postgresql-db-connection insert-tuple-set-key
 232     query-modify-tuple ;
 233
 234 M: postgresql-db-connection persistent-table
 235     H{
 236         { +db-assigned-id+ { "integer" "serial" f } }
 237         { +user-assigned-id+ { f f f } }
 238         { +random-id+ { "bigint" "bigint" f } }
 239
 240         { +foreign-id+ { f f "references" } }
 241
 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" } }
 248
 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 } }
 271     } ;
 272
 273 ERROR: no-compound-found string object ;
 274 M: postgresql-db-connection compound
 275     over {
 276         { "default" [ first number>string " " glue ] }
 277         { "varchar" [ first number>string "(" ")" surround append ] }
 278         { "references" [ >reference-string ] }
 279         [ drop no-compound-found ]
 280     } case ;
 281
 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 ] }
 286         { 3 [
 287                 first3
 288                 [ parse-postgresql-sql-error ] 2dip
 289                 postgresql-location >>location
 290         ] }
 291     } case ;