extra/odbc/odbc.factor

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