unmaintained/odbc/odbc.factor

   1 ! Copyright (C) 2007 Chris Double.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel alien alien.strings alien.syntax
   4 combinators alien.c-types strings sequences namespaces make
   5 words math threads io.encodings.ascii ;
   6 IN: odbc
   7
   8 << "odbc" "odbc32.dll" stdcall add-library >>
   9
  10 LIBRARY: odbc
  11
  12 TYPEDEF: void* usb_dev_handle*
  13 TYPEDEF: short SQLRETURN
  14 TYPEDEF: short SQLSMALLINT
  15 TYPEDEF: short* SQLSMALLINT*
  16 TYPEDEF: ushort SQLUSMALLINT
  17 TYPEDEF: uint* SQLUINTEGER*
  18 TYPEDEF: int SQLINTEGER
  19 TYPEDEF: char SQLCHAR
  20 TYPEDEF: char* SQLCHAR*
  21 TYPEDEF: void* SQLHANDLE
  22 C-TYPE: SQLHANDLE
  23 TYPEDEF: void* SQLHENV
  24 TYPEDEF: void* SQLHDBC
  25 TYPEDEF: void* SQLHSTMT
  26 TYPEDEF: void* SQLHWND
  27 TYPEDEF: void* SQLPOINTER
  28
  29 : SQL-HANDLE-ENV  ( -- number ) 1 ; inline
  30 : SQL-HANDLE-DBC  ( -- number ) 2 ; inline
  31 : SQL-HANDLE-STMT ( -- number ) 3 ; inline
  32 : SQL-HANDLE-DESC ( -- number ) 4 ; inline
  33
  34 : SQL-NULL-HANDLE ( -- alien ) f ; inline
  35
  36 : SQL-ATTR-ODBC-VERSION ( -- number ) 200 ; inline
  37
  38 : SQL-OV-ODBC2 ( -- number ) 2 <alien> ; inline
  39 : SQL-OV-ODBC3 ( -- number ) 3 <alien> ; inline
  40
  41 : SQL-SUCCESS ( -- number ) 0 ; inline
  42 : SQL-SUCCESS-WITH-INFO ( -- number ) 1 ; inline
  43 : SQL-NO-DATA-FOUND ( -- number ) 100 ; inline
  44
  45 : SQL-DRIVER-NOPROMPT ( -- number ) 0 ; inline
  46 : SQL-DRIVER-PROMPT ( -- number ) 2 ; inline
  47
  48 : SQL-C-DEFAULT ( -- number ) 99 ; inline
  49
  50 SYMBOL: SQL-CHAR
  51 SYMBOL: SQL-VARCHAR
  52 SYMBOL: SQL-LONGVARCHAR
  53 SYMBOL: SQL-WCHAR
  54 SYMBOL: SQL-WCHARVAR
  55 SYMBOL: SQL-WLONGCHARVAR
  56 SYMBOL: SQL-DECIMAL
  57 SYMBOL: SQL-SMALLINT
  58 SYMBOL: SQL-NUMERIC
  59 SYMBOL: SQL-INTEGER
  60 SYMBOL: SQL-REAL
  61 SYMBOL: SQL-FLOAT
  62 SYMBOL: SQL-DOUBLE
  63 SYMBOL: SQL-BIT
  64 SYMBOL: SQL-TINYINT
  65 SYMBOL: SQL-BIGINT
  66 SYMBOL: SQL-BINARY
  67 SYMBOL: SQL-VARBINARY
  68 SYMBOL: SQL-LONGVARBINARY
  69 SYMBOL: SQL-TYPE-DATE
  70 SYMBOL: SQL-TYPE-TIME
  71 SYMBOL: SQL-TYPE-TIMESTAMP
  72 SYMBOL: SQL-TYPE-UTCDATETIME
  73 SYMBOL: SQL-TYPE-UTCTIME
  74 SYMBOL: SQL-INTERVAL-MONTH
  75 SYMBOL: SQL-INTERVAL-YEAR
  76 SYMBOL: SQL-INTERVAL-YEAR-TO-MONTH
  77 SYMBOL: SQL-INTERVAL-DAY
  78 SYMBOL: SQL-INTERVAL-HOUR
  79 SYMBOL: SQL-INTERVAL-MINUTE
  80 SYMBOL: SQL-INTERVAL-SECOND
  81 SYMBOL: SQL-INTERVAL-DAY-TO-HOUR
  82 SYMBOL: SQL-INTERVAL-DAY-TO-MINUTE
  83 SYMBOL: SQL-INTERVAL-DAY-TO-SECOND
  84 SYMBOL: SQL-INTERVAL-HOUR-TO-MINUTE
  85 SYMBOL: SQL-INTERVAL-HOUR-TO-SECOND
  86 SYMBOL: SQL-INTERVAL-MINUTE-TO-SECOND
  87 SYMBOL: SQL-GUID
  88 SYMBOL: SQL-TYPE-UNKNOWN
  89
  90 : convert-sql-type ( number -- symbol )
  91   {
  92     { 1 [ SQL-CHAR ] }
  93     { 12  [ SQL-VARCHAR ] }
  94     { -1  [ SQL-LONGVARCHAR ] }
  95     { -8  [ SQL-WCHAR ] }
  96     { -9  [ SQL-WCHARVAR ] }
  97     { -10 [ SQL-WLONGCHARVAR ] }
  98     { 3 [ SQL-DECIMAL ] }
  99     { 5 [ SQL-SMALLINT ] }
 100     { 2 [ SQL-NUMERIC ] }
 101     { 4 [ SQL-INTEGER ] }
 102     { 7 [ SQL-REAL ] }
 103     { 6 [ SQL-FLOAT ] }
 104     { 8 [ SQL-DOUBLE ] }
 105     { -7 [ SQL-BIT ] }
 106     { -6 [ SQL-TINYINT ] }
 107     { -5 [ SQL-BIGINT ] }
 108     { -2 [ SQL-BINARY ] }
 109     { -3 [ SQL-VARBINARY ] }
 110     { -4 [ SQL-LONGVARBINARY ] }
 111     { 91 [ SQL-TYPE-DATE ] }
 112     { 92 [ SQL-TYPE-TIME ] }
 113     { 93 [ SQL-TYPE-TIMESTAMP ] }
 114     [ drop SQL-TYPE-UNKNOWN ]
 115   } case ;
 116
 117 : succeeded? ( n -- bool )
 118   ! Did the call succeed (SQL-SUCCESS or SQL-SUCCESS-WITH-INFO)
 119   {
 120     { SQL-SUCCESS [ t ] }
 121     { SQL-SUCCESS-WITH-INFO [ t ] }
 122     [ drop f ]
 123   } case ;
 124
 125 FUNCTION: SQLRETURN SQLAllocHandle ( SQLSMALLINT handleType, SQLHANDLE inputHandle, SQLHANDLE* outputHandlePtr ) ;
 126 FUNCTION: SQLRETURN SQLSetEnvAttr ( SQLHENV environmentHandle, SQLINTEGER attribute, SQLPOINTER valuePtr, SQLINTEGER stringLength ) ;
 127 FUNCTION: SQLRETURN SQLDriverConnect ( SQLHDBC connectionHandle, SQLHWND windowHandle, SQLCHAR* inConnectionString, SQLSMALLINT stringLength, SQLCHAR* outConnectionString, SQLSMALLINT bufferLength, SQLSMALLINT* stringLength2Ptr, SQLUSMALLINT driverCompletion ) ;
 128 FUNCTION: SQLRETURN SQLDisconnect ( SQLHDBC connectionHandle ) ;
 129 FUNCTION: SQLRETURN SQLPrepare ( SQLHSTMT statementHandle, SQLCHAR* statementText, SQLINTEGER length ) ;
 130 FUNCTION: SQLRETURN SQLExecute ( SQLHSTMT statementHandle ) ;
 131 FUNCTION: SQLRETURN SQLFreeHandle ( SQLSMALLINT handleType, SQLHANDLE handle ) ;
 132 FUNCTION: SQLRETURN SQLFetch ( SQLHSTMT statementHandle ) ;
 133 FUNCTION: SQLRETURN SQLNumResultCols ( SQLHSTMT statementHandle, SQLSMALLINT* columnCountPtr ) ;
 134 FUNCTION: SQLRETURN SQLDescribeCol ( SQLHSTMT statementHandle, SQLSMALLINT columnNumber, SQLCHAR* columnName, SQLSMALLINT bufferLength, SQLSMALLINT* nameLengthPtr, SQLSMALLINT* dataTypePtr, SQLUINTEGER* columnSizePtr, SQLSMALLINT* decimalDigitsPtr, SQLSMALLINT* nullablePtr ) ;
 135 FUNCTION: SQLRETURN SQLGetData ( SQLHSTMT statementHandle, SQLUSMALLINT columnNumber, SQLSMALLINT targetType, SQLPOINTER targetValuePtr, SQLINTEGER bufferLength, SQLINTEGER* strlen_or_indPtr ) ;
 136
 137 : alloc-handle ( type parent -- handle )
 138   f <void*> [ SQLAllocHandle ] keep swap succeeded? [
 139     *void*
 140   ] [
 141     drop f
 142   ] if ;
 143
 144 : alloc-env-handle ( -- handle )
 145   SQL-HANDLE-ENV SQL-NULL-HANDLE alloc-handle ;
 146
 147 : alloc-dbc-handle ( env -- handle )
 148   SQL-HANDLE-DBC swap alloc-handle ;
 149
 150 : alloc-stmt-handle ( dbc -- handle )
 151   SQL-HANDLE-STMT swap alloc-handle ;
 152
 153 : temp-string ( length -- byte-array length )
 154   [ CHAR: \space  <string> ascii string>alien ] keep ;
 155
 156 : odbc-init ( -- env )
 157   alloc-env-handle
 158   [
 159     SQL-ATTR-ODBC-VERSION SQL-OV-ODBC3 0 SQLSetEnvAttr
 160     succeeded? [ "odbc-init failed" throw ] unless
 161   ] keep ;
 162
 163 : odbc-connect ( env dsn -- dbc )
 164    >r alloc-dbc-handle dup r>
 165    f swap dup length 1024 temp-string 0 <short> SQL-DRIVER-NOPROMPT
 166    SQLDriverConnect succeeded? [ "odbc-connect failed" throw ] unless ;
 167
 168 : odbc-disconnect ( dbc -- )
 169   SQLDisconnect succeeded? [ "odbc-disconnect failed" throw ] unless ;
 170
 171 : odbc-prepare ( dbc string -- statement )
 172   >r alloc-stmt-handle dup r> dup length SQLPrepare succeeded? [ "odbc-prepare failed" throw ] unless ;
 173
 174 : odbc-free-statement ( statement -- )
 175   SQL-HANDLE-STMT swap SQLFreeHandle succeeded? [ "odbc-free-statement failed" throw ] unless ;
 176
 177 : odbc-execute ( statement --  )
 178   SQLExecute succeeded? [ "odbc-execute failed" throw ] unless ;
 179
 180 : odbc-next-row ( statement -- bool )
 181   SQLFetch succeeded? ;
 182
 183 : odbc-number-of-columns ( statement -- number )
 184   0 <short> [ SQLNumResultCols succeeded? ] keep swap [
 185     *short
 186   ] [
 187     drop f
 188   ] if ;
 189
 190 TUPLE: column nullable digits size type name number ;
 191
 192 C: <column> column
 193
 194 : odbc-describe-column ( statement n -- column )
 195   dup >r
 196   1024 CHAR: \space <string> ascii string>alien dup >r
 197   1024
 198   0 <short>
 199   0 <short> dup >r
 200   0 <uint> dup >r
 201   0 <short> dup >r
 202   0 <short> dup >r
 203   SQLDescribeCol succeeded? [
 204     r> *short
 205     r> *short
 206     r> *uint
 207     r> *short convert-sql-type
 208     r> ascii alien>string
 209     r> <column>
 210   ] [
 211     r> drop r> drop r> drop r> drop r> drop r> drop
 212     "odbc-describe-column failed" throw
 213   ] if ;
 214
 215 : dereference-type-pointer ( byte-array column -- object )
 216   type>> {
 217     { SQL-CHAR [ ascii alien>string ] }
 218     { SQL-VARCHAR [ ascii alien>string ] }
 219     { SQL-LONGVARCHAR [ ascii alien>string ] }
 220     { SQL-WCHAR [ ascii alien>string ] }
 221     { SQL-WCHARVAR [ ascii alien>string ] }
 222     { SQL-WLONGCHARVAR [ ascii alien>string ] }
 223     { SQL-SMALLINT [ *short ] }
 224     { SQL-INTEGER [ *long ] }
 225     { SQL-REAL [ *float ] }
 226     { SQL-FLOAT [ *double ] }
 227     { SQL-DOUBLE [ *double ] }
 228     { SQL-TINYINT [ *char  ] }
 229     { SQL-BIGINT [ *longlong ] }
 230     [ nip [ "Unknown SQL Type: " % name>> % ] "" make ]
 231   } case ;
 232
 233 TUPLE: field value column ;
 234
 235 C: <field> field
 236
 237 : odbc-get-field ( statement column -- field )
 238   dup column? [ dupd odbc-describe-column ] unless dup >r number>>
 239   SQL-C-DEFAULT
 240   8192 CHAR: \space <string> ascii string>alien dup >r
 241   8192
 242   f SQLGetData succeeded? [
 243     r> r> [ dereference-type-pointer ] keep <field>
 244   ] [
 245     r> drop r> [
 246       "SQLGetData Failed for Column: " %
 247       dup name>> %
 248       " of type: " % dup type>> name>> %
 249     ] "" make swap <field>
 250   ] if ;
 251
 252 : odbc-get-row-fields ( statement -- seq )
 253   [
 254     dup odbc-number-of-columns [
 255       1+ odbc-get-field value>> ,
 256     ] with each
 257   ] { } make ;
 258
 259 : (odbc-get-all-rows) ( statement -- )
 260   dup odbc-next-row [ dup odbc-get-row-fields , yield (odbc-get-all-rows) ] [ drop ] if ;
 261
 262 : odbc-get-all-rows ( statement -- seq )
 263   [ (odbc-get-all-rows) ] { } make ;
 264
 265 : odbc-query ( string dsn -- result )
 266   odbc-init swap odbc-connect [
 267     swap odbc-prepare
 268     dup odbc-execute
 269     dup odbc-get-all-rows
 270     swap odbc-free-statement
 271   ] keep odbc-disconnect ;