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
7 FROM: alien.c-types => float short ;
10 << "odbc" "odbc32.dll" stdcall add-library >>
14 TYPEDEF: short SQLRETURN
15 TYPEDEF: short SQLSMALLINT
16 TYPEDEF: ushort SQLUSMALLINT
17 TYPEDEF: uint SQLUINTEGER
18 TYPEDEF: int SQLINTEGER
20 TYPEDEF: void* SQLHANDLE
21 TYPEDEF: void* SQLHENV
22 TYPEDEF: void* SQLHDBC
23 TYPEDEF: void* SQLHSTMT
24 TYPEDEF: void* SQLHWND
25 TYPEDEF: void* SQLPOINTER
27 CONSTANT: SQL-HANDLE-ENV 1
28 CONSTANT: SQL-HANDLE-DBC 2
29 CONSTANT: SQL-HANDLE-STMT 3
30 CONSTANT: SQL-HANDLE-DESC 4
32 CONSTANT: SQL-NULL-HANDLE f
34 CONSTANT: SQL-ATTR-ODBC-VERSION 200
36 : SQL-OV-ODBC2 ( -- number ) 2 <alien> ; inline
37 : SQL-OV-ODBC3 ( -- number ) 3 <alien> ; inline
40 CONSTANT: SQL_SUCCESS 0
41 CONSTANT: SQL_SUCCESS_WITH_INFO 1
42 CONSTANT: SQL_INVALID_HANDLE -2
43 CONSTANT: SQL_NO_DATA 100
45 CONSTANT: SQL_NO_DATA_FOUND 100
47 CONSTANT: SQL-DRIVER-NOPROMPT 0
48 CONSTANT: SQL-DRIVER-PROMPT 2
50 CONSTANT: SQL-C-DEFAULT 99
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
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
71 : convert-sql-type ( number -- symbol )
74 { 12 [ SQL-VARCHAR ] }
75 { -1 [ SQL-LONGVARCHAR ] }
77 { -9 [ SQL-WCHARVAR ] }
78 { -10 [ SQL-WLONGCHARVAR ] }
80 { 5 [ SQL-SMALLINT ] }
87 { -6 [ SQL-TINYINT ] }
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 ]
98 : succeeded? ( n -- bool )
99 ! Did the call succeed (SQL-SUCCESS or SQL-SUCCESS-WITH-INFO)
101 { SQL_SUCCESS [ t ] }
102 { SQL_SUCCESS_WITH_INFO [ t ] }
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,
120 SQLSMALLINT RecNumber,
122 SQLINTEGER* NativeErrorPtr,
123 SQLCHAR* MessageText,
124 SQLSMALLINT BufferLength,
125 SQLSMALLINT* TextLengthPtr )
127 : alloc-handle ( type parent -- handle )
128 f void* <ref> [ SQLAllocHandle ] keep swap succeeded? [
134 : alloc-env-handle ( -- handle )
135 SQL-HANDLE-ENV SQL-NULL-HANDLE alloc-handle ;
137 : alloc-dbc-handle ( env -- handle )
138 SQL-HANDLE-DBC swap alloc-handle ;
140 : alloc-stmt-handle ( dbc -- handle )
141 SQL-HANDLE-STMT swap alloc-handle ;
145 : alien-space-str ( len -- alien )
146 CHAR: space <string> ascii string>alien ;
150 : temp-string ( length -- byte-array length )
151 [ alien-space-str ] keep ;
153 : odbc-init ( -- env )
156 SQL-ATTR-ODBC-VERSION SQL-OV-ODBC3 0 SQLSetEnvAttr
157 succeeded? [ "odbc-init failed" throw ] unless
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 ;
167 : odbc-disconnect ( dbc -- )
168 SQLDisconnect succeeded? [ "odbc-disconnect failed" throw ] unless ;
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 ;
175 : odbc-free-statement ( statement -- )
176 SQL-HANDLE-STMT swap SQLFreeHandle
177 succeeded? [ "odbc-free-statement failed" throw ] unless ;
179 : odbc-execute ( statement -- )
180 SQLExecute succeeded? [ "odbc-execute failed" throw ] unless ;
182 : odbc-next-row ( statement -- bool )
183 SQLFetch succeeded? ;
185 : odbc-number-of-columns ( statement -- number )
186 0 short <ref> [ SQLNumResultCols succeeded? ] keep swap [
192 TUPLE: column nullable digits size type name number ;
196 :: odbc-describe-column ( statement columnNumber -- column )
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>
214 "odbc-describe-column failed" throw
217 : dereference-type-pointer ( byte-array column -- object )
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 ]
235 TUPLE: field value column ;
239 :: odbc-get-field ( statement column! -- field )
241 statement column odbc-describe-column column!
244 bufferLen alien-space-str :> targetValuePtr
245 statement column number>> SQL-C-DEFAULT
246 targetValuePtr bufferLen f SQLGetData
248 targetValuePtr column [ dereference-type-pointer ] keep <field>
251 "SQLGetData Failed for Column: " %
253 " of type: " % dup type>> name>> %
254 ] "" make swap <field>
257 : odbc-get-row-fields ( statement -- seq )
259 dup odbc-number-of-columns <iota> [
260 1 + odbc-get-field value>> ,
264 : (odbc-get-all-rows) ( statement -- )
266 dup odbc-get-row-fields , yield (odbc-get-all-rows)
271 : odbc-get-all-rows ( statement -- seq )
272 [ (odbc-get-all-rows) ] { } make ;
274 : odbc-query ( string dsn -- result )
275 odbc-init swap odbc-connect [
279 dup odbc-get-all-rows
280 swap odbc-free-statement
282 ] [ odbc-disconnect ] finally ;