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 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 -- ) drop ;
  41
  42 GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding )
  43
  44 M: sql-spec postgresql-bind-conversion ( tuple spec -- object )
  45     slot-name>> swap get-slot-named <low-level-binding> ;
  46
  47 M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- object )
  48     nip value>> <low-level-binding> ;
  49
  50 M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object )
  51     dup generator-singleton>> eval-generator
  52     [ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
  53
  54 M: postgresql-statement bind-tuple ( tuple statement -- )
  55     tuck in-params>>
  56     [ postgresql-bind-conversion ] with map
  57     >>bind-params drop ;
  58
  59 M: postgresql-result-set #rows ( result-set -- n )
  60     handle>> PQntuples ;
  61
  62 M: postgresql-result-set #columns ( result-set -- n )
  63     handle>> PQnfields ;
  64
  65 : result-handle-n ( result-set -- handle n )
  66     [ handle>> ] [ n>> ] bi ;
  67
  68 M: postgresql-result-set row-column ( result-set column -- object )
  69     [ result-handle-n ] dip pq-get-string ;
  70
  71 M: postgresql-result-set row-column-typed ( result-set column -- object )
  72     dup pick out-params>> nth type>>
  73     [ result-handle-n ] 2dip postgresql-column-typed ;
  74
  75 M: postgresql-statement query-results ( query -- result-set )
  76     dup bind-params>> [
  77         over [ bind-statement ] keep
  78         do-postgresql-bound-statement
  79     ] [
  80         dup do-postgresql-statement
  81     ] if*
  82     postgresql-result-set new-result-set
  83     dup init-result-set ;
  84
  85 M: postgresql-result-set advance-row ( result-set -- )
  86     [ 1+ ] change-n drop ;
  87
  88 M: postgresql-result-set more-rows? ( result-set -- ? )
  89     [ n>> ] [ max>> ] bi < ;
  90
  91 M: postgresql-statement dispose ( query -- )
  92     dup handle>> PQclear
  93     f >>handle drop ;
  94
  95 M: postgresql-result-set dispose ( result-set -- )
  96     [ handle>> PQclear ]
  97     [
  98         0 >>n
  99         0 >>max
 100         f >>handle drop
 101     ] bi ;
 102
 103 M: postgresql-statement prepare-statement ( statement -- )
 104     dup
 105     >r db get handle>> f r>
 106     [ sql>> ] [ in-params>> ] bi
 107     length f PQprepare postgresql-error
 108     >>handle drop ;
 109
 110 M: postgresql-db <simple-statement> ( sql in out -- statement )
 111     postgresql-statement new-statement ;
 112
 113 M: postgresql-db <prepared-statement> ( sql in out -- statement )
 114     <simple-statement> dup prepare-statement ;
 115
 116 : bind-name% ( -- )
 117     CHAR: $ 0,
 118     sql-counter [ inc ] [ get 0# ] bi ;
 119
 120 M: postgresql-db bind% ( spec -- )
 121     bind-name% 1, ;
 122
 123 M: postgresql-db bind# ( spec object -- )
 124     >r bind-name% f swap type>> r> <literal-bind> 1, ;
 125
 126 : create-table-sql ( class -- statement )
 127     [
 128         dupd
 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
 136
 137         ", " 0%
 138         find-primary-key
 139         "primary key(" 0%
 140         [ "," 0% ] [ column-name>> 0% ] interleave
 141         "));" 0%
 142     ] query-make ;
 143
 144 : create-function-sql ( class -- statement )
 145     [
 146         >r remove-id r>
 147         "create function add_" 0% dup 0%
 148         "(" 0%
 149         over [ "," 0% ]
 150         [
 151             type>> lookup-type 0%
 152         ] interleave
 153         ")" 0%
 154         " returns bigint as '" 0%
 155
 156         "insert into " 0%
 157         dup 0%
 158         "(" 0%
 159         over [ ", " 0% ] [ column-name>> 0% ] interleave
 160         ") values(" 0%
 161         swap [ ", " 0% ] [ drop bind-name% ] interleave
 162         "); " 0%
 163         "select currval(''" 0% 0% "_id_seq'');' language sql;" 0%
 164     ] query-make ;
 165
 166 M: postgresql-db create-sql-statement ( class -- seq )
 167     [
 168         [ create-table-sql , ] keep
 169         dup db-assigned? [ create-function-sql , ] [ drop ] if
 170     ] { } make ;
 171
 172 : drop-function-sql ( class -- statement )
 173     [
 174         "drop function add_" 0% 0%
 175         "(" 0%
 176         remove-id
 177         [ ", " 0% ] [ type>> lookup-type 0% ] interleave
 178         ");" 0%
 179     ] query-make ;
 180
 181 : drop-table-sql ( table -- statement )
 182     [
 183         "drop table " 0% 0% drop
 184     ] query-make ;
 185
 186 M: postgresql-db drop-sql-statement ( class -- seq )
 187     [
 188         [ drop-table-sql , ] keep
 189         dup db-assigned? [ drop-function-sql , ] [ drop ] if
 190     ] { } make ;
 191
 192 M: postgresql-db <insert-db-assigned-statement> ( class -- statement )
 193     [
 194         "select add_" 0% 0%
 195         "(" 0%
 196         dup find-primary-key first 2,
 197         remove-id
 198         [ ", " 0% ] [ bind% ] interleave
 199         ");" 0%
 200     ] query-make ;
 201
 202 M: postgresql-db <insert-user-assigned-statement> ( class -- statement )
 203     [
 204         "insert into " 0% 0%
 205         "(" 0%
 206         dup [ ", " 0% ] [ column-name>> 0% ] interleave
 207         ")" 0%
 208
 209         " values(" 0%
 210         [ ", " 0% ] [
 211             dup type>> +random-id+ = [
 212                 [
 213                     bind-name%
 214                     slot-name>>
 215                     f
 216                     random-id-generator
 217                 ] [ type>> ] bi <generator-bind> 1,
 218             ] [
 219                 bind%
 220             ] if
 221         ] interleave
 222         ");" 0%
 223     ] query-make ;
 224
 225 M: postgresql-db insert-tuple-set-key ( tuple statement -- )
 226     query-modify-tuple ;
 227
 228 M: postgresql-db persistent-table ( -- hashtable )
 229     H{
 230         { +db-assigned-id+ { "integer" "serial" f } }
 231         { +user-assigned-id+ { f f f } }
 232         { +random-id+ { "bigint" "bigint" f } }
 233
 234         { +foreign-id+ { f f "references" } }
 235
 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 join-space ] }
 270         { "varchar" [ first number>string paren append ] }
 271         { "references" [ >reference-string ] }
 272         [ drop no-compound-found ]
 273     } case ;