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 dispose ( db -- )
  34     handle>> 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         [ 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% "_id_seq'');' language sql;" 0%
 161     ] query-make ;
 162
 163 M: postgresql-db create-sql-statement ( class -- seq )
 164     [
 165         [ create-table-sql , ] keep
 166         dup db-assigned? [ create-function-sql , ] [ drop ] if
 167     ] { } make ;
 168
 169 : drop-function-sql ( class -- statement )
 170     [
 171         "drop function add_" 0% 0%
 172         "(" 0%
 173         remove-id
 174         [ ", " 0% ] [ type>> lookup-type 0% ] interleave
 175         ");" 0%
 176     ] query-make ;
 177
 178 : drop-table-sql ( table -- statement )
 179     [
 180         "drop table " 0% 0% drop
 181     ] query-make ;
 182
 183 M: postgresql-db drop-sql-statement ( class -- seq )
 184     [
 185         [ drop-table-sql , ] keep
 186         dup db-assigned? [ drop-function-sql , ] [ drop ] if
 187     ] { } make ;
 188
 189 M: postgresql-db <insert-db-assigned-statement> ( class -- statement )
 190     [
 191         "select add_" 0% 0%
 192         "(" 0%
 193         dup find-primary-key first 2,
 194         remove-id
 195         [ ", " 0% ] [ bind% ] interleave
 196         ");" 0%
 197     ] query-make ;
 198
 199 M: postgresql-db <insert-user-assigned-statement> ( class -- statement )
 200     [
 201         "insert into " 0% 0%
 202         "(" 0%
 203         dup [ ", " 0% ] [ column-name>> 0% ] interleave
 204         ")" 0%
 205
 206         " values(" 0%
 207         [ ", " 0% ] [
 208             dup type>> +random-id+ = [
 209                 [
 210                     bind-name%
 211                     slot-name>>
 212                     f
 213                     random-id-generator
 214                 ] [ type>> ] bi <generator-bind> 1,
 215             ] [
 216                 bind%
 217             ] if
 218         ] interleave
 219         ");" 0%
 220     ] query-make ;
 221
 222 M: postgresql-db insert-tuple-set-key ( tuple statement -- )
 223     query-modify-tuple ;
 224
 225 M: postgresql-db persistent-table ( -- hashtable )
 226     H{
 227         { +db-assigned-id+ { "integer" "serial" f } }
 228         { +user-assigned-id+ { f f f } }
 229         { +random-id+ { "bigint" "bigint" f } }
 230
 231         { +foreign-id+ { f f "references" } }
 232
 233         { +on-delete+ { f f "on delete" } }
 234         { +restrict+ { f f "restrict" } }
 235         { +cascade+ { f f "cascade" } }
 236         { +set-null+ { f f "set null" } }
 237         { +set-default+ { f f "set default" } }
 238
 239         { TEXT { "text" "text" f } }
 240         { VARCHAR { "varchar" "varchar" f } }
 241         { INTEGER { "integer" "integer" f } }
 242         { BIG-INTEGER { "bigint" "bigint" f } }
 243         { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
 244         { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
 245         { DOUBLE { "real" "real" f } }
 246         { DATE { "date" "date" f } }
 247         { TIME { "time" "time" f } }
 248         { DATETIME { "timestamp" "timestamp" f } }
 249         { TIMESTAMP { "timestamp" "timestamp" f } }
 250         { BLOB { "bytea" "bytea" f } }
 251         { FACTOR-BLOB { "bytea" "bytea" f } }
 252         { URL { "varchar" "varchar" f } }
 253         { +autoincrement+ { f f "autoincrement" } }
 254         { +unique+ { f f "unique" } }
 255         { +default+ { f f "default" } }
 256         { +null+ { f f "null" } }
 257         { +not-null+ { f f "not null" } }
 258         { system-random-generator { f f f } }
 259         { secure-random-generator { f f f } }
 260         { random-generator { f f f } }
 261     } ;
 262
 263 ERROR: no-compound-found string object ;
 264 M: postgresql-db compound ( string object -- string' )
 265     over {
 266         { "default" [ first number>string join-space ] }
 267         { "varchar" [ first number>string paren append ] }
 268         { "references" [ >reference-string ] }
 269         [ drop no-compound-found ]
 270     } case ;