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