-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel alien alien.syntax combinators alien.c-types\r
- strings sequences namespaces words math threads ;\r
-IN: odbc\r
-\r
-"odbc" "odbc32.dll" "stdcall" add-library\r
-\r
-LIBRARY: odbc\r
-\r
-TYPEDEF: void* usb_dev_handle*\r
-TYPEDEF: short SQLRETURN\r
-TYPEDEF: short SQLSMALLINT\r
-TYPEDEF: short* SQLSMALLINT*\r
-TYPEDEF: ushort SQLUSMALLINT\r
-TYPEDEF: uint* SQLUINTEGER*\r
-TYPEDEF: int SQLINTEGER\r
-TYPEDEF: char SQLCHAR\r
-TYPEDEF: char* SQLCHAR*\r
-TYPEDEF: void* SQLHANDLE\r
-TYPEDEF: void* SQLHANDLE*\r
-TYPEDEF: void* SQLHENV\r
-TYPEDEF: void* SQLHDBC\r
-TYPEDEF: void* SQLHSTMT\r
-TYPEDEF: void* SQLHWND\r
-TYPEDEF: void* SQLPOINTER\r
-\r
-: SQL-HANDLE-ENV ( -- number ) 1 ; inline\r
-: SQL-HANDLE-DBC ( -- number ) 2 ; inline\r
-: SQL-HANDLE-STMT ( -- number ) 3 ; inline\r
-: SQL-HANDLE-DESC ( -- number ) 4 ; inline\r
-\r
-: SQL-NULL-HANDLE ( -- alien ) f ; inline\r
-\r
-: SQL-ATTR-ODBC-VERSION ( -- number ) 200 ; inline\r
-\r
-: SQL-OV-ODBC2 ( -- number ) 2 <alien> ; inline\r
-: SQL-OV-ODBC3 ( -- number ) 3 <alien> ; inline\r
-\r
-: SQL-SUCCESS ( -- number ) 0 ; inline\r
-: SQL-SUCCESS-WITH-INFO ( -- number ) 1 ; inline\r
-: SQL-NO-DATA-FOUND ( -- number ) 100 ; inline\r
-\r
-: SQL-DRIVER-NOPROMPT ( -- number ) 0 ; inline\r
-: SQL-DRIVER-PROMPT ( -- number ) 2 ; inline\r
-\r
-: SQL-C-DEFAULT ( -- number ) 99 ; inline\r
-\r
-SYMBOL: SQL-CHAR\r
-SYMBOL: SQL-VARCHAR\r
-SYMBOL: SQL-LONGVARCHAR\r
-SYMBOL: SQL-WCHAR\r
-SYMBOL: SQL-WCHARVAR\r
-SYMBOL: SQL-WLONGCHARVAR\r
-SYMBOL: SQL-DECIMAL\r
-SYMBOL: SQL-SMALLINT\r
-SYMBOL: SQL-NUMERIC\r
-SYMBOL: SQL-INTEGER\r
-SYMBOL: SQL-REAL\r
-SYMBOL: SQL-FLOAT\r
-SYMBOL: SQL-DOUBLE\r
-SYMBOL: SQL-BIT\r
-SYMBOL: SQL-TINYINT\r
-SYMBOL: SQL-BIGINT\r
-SYMBOL: SQL-BINARY\r
-SYMBOL: SQL-VARBINARY\r
-SYMBOL: SQL-LONGVARBINARY\r
-SYMBOL: SQL-TYPE-DATE\r
-SYMBOL: SQL-TYPE-TIME\r
-SYMBOL: SQL-TYPE-TIMESTAMP\r
-SYMBOL: SQL-TYPE-UTCDATETIME\r
-SYMBOL: SQL-TYPE-UTCTIME\r
-SYMBOL: SQL-INTERVAL-MONTH\r
-SYMBOL: SQL-INTERVAL-YEAR\r
-SYMBOL: SQL-INTERVAL-YEAR-TO-MONTH\r
-SYMBOL: SQL-INTERVAL-DAY\r
-SYMBOL: SQL-INTERVAL-HOUR\r
-SYMBOL: SQL-INTERVAL-MINUTE\r
-SYMBOL: SQL-INTERVAL-SECOND\r
-SYMBOL: SQL-INTERVAL-DAY-TO-HOUR\r
-SYMBOL: SQL-INTERVAL-DAY-TO-MINUTE\r
-SYMBOL: SQL-INTERVAL-DAY-TO-SECOND\r
-SYMBOL: SQL-INTERVAL-HOUR-TO-MINUTE\r
-SYMBOL: SQL-INTERVAL-HOUR-TO-SECOND\r
-SYMBOL: SQL-INTERVAL-MINUTE-TO-SECOND\r
-SYMBOL: SQL-GUID\r
-SYMBOL: SQL-TYPE-UNKNOWN\r
-\r
-: convert-sql-type ( number -- symbol )\r
- {\r
- { 1 [ SQL-CHAR ] }\r
- { 12 [ SQL-VARCHAR ] }\r
- { -1 [ SQL-LONGVARCHAR ] }\r
- { -8 [ SQL-WCHAR ] }\r
- { -9 [ SQL-WCHARVAR ] }\r
- { -10 [ SQL-WLONGCHARVAR ] }\r
- { 3 [ SQL-DECIMAL ] }\r
- { 5 [ SQL-SMALLINT ] }\r
- { 2 [ SQL-NUMERIC ] }\r
- { 4 [ SQL-INTEGER ] }\r
- { 7 [ SQL-REAL ] }\r
- { 6 [ SQL-FLOAT ] }\r
- { 8 [ SQL-DOUBLE ] }\r
- { -7 [ SQL-BIT ] }\r
- { -6 [ SQL-TINYINT ] }\r
- { -5 [ SQL-BIGINT ] }\r
- { -2 [ SQL-BINARY ] }\r
- { -3 [ SQL-VARBINARY ] } \r
- { -4 [ SQL-LONGVARBINARY ] }\r
- { 91 [ SQL-TYPE-DATE ] }\r
- { 92 [ SQL-TYPE-TIME ] }\r
- { 93 [ SQL-TYPE-TIMESTAMP ] }\r
- [ drop SQL-TYPE-UNKNOWN ]\r
- } case ;\r
-\r
-: succeeded? ( n -- bool )\r
- #! Did the call succeed (SQL-SUCCESS or SQL-SUCCESS-WITH-INFO)\r
- {\r
- { \ SQL-SUCCESS [ t ] }\r
- { \ SQL-SUCCESS-WITH-INFO [ t ] }\r
- [ drop f ]\r
- } case ; \r
-\r
-FUNCTION: SQLRETURN SQLAllocHandle ( SQLSMALLINT handleType, SQLHANDLE inputHandle, SQLHANDLE* outputHandlePtr ) ;\r
-FUNCTION: SQLRETURN SQLSetEnvAttr ( SQLHENV environmentHandle, SQLINTEGER attribute, SQLPOINTER valuePtr, SQLINTEGER stringLength ) ;\r
-FUNCTION: SQLRETURN SQLDriverConnect ( SQLHDBC connectionHandle, SQLHWND windowHandle, SQLCHAR* inConnectionString, SQLSMALLINT stringLength, SQLCHAR* outConnectionString, SQLSMALLINT bufferLength, SQLSMALLINT* stringLength2Ptr, SQLUSMALLINT driverCompletion ) ; \r
-FUNCTION: SQLRETURN SQLDisconnect ( SQLHDBC connectionHandle ) ;\r
-FUNCTION: SQLRETURN SQLPrepare ( SQLHSTMT statementHandle, SQLCHAR* statementText, SQLINTEGER length ) ;\r
-FUNCTION: SQLRETURN SQLExecute ( SQLHSTMT statementHandle ) ;\r
-FUNCTION: SQLRETURN SQLFreeHandle ( SQLSMALLINT handleType, SQLHANDLE handle ) ;\r
-FUNCTION: SQLRETURN SQLFetch ( SQLHSTMT statementHandle ) ;\r
-FUNCTION: SQLRETURN SQLNumResultCols ( SQLHSTMT statementHandle, SQLSMALLINT* columnCountPtr ) ;\r
-FUNCTION: SQLRETURN SQLDescribeCol ( SQLHSTMT statementHandle, SQLSMALLINT columnNumber, SQLCHAR* columnName, SQLSMALLINT bufferLength, SQLSMALLINT* nameLengthPtr, SQLSMALLINT* dataTypePtr, SQLUINTEGER* columnSizePtr, SQLSMALLINT* decimalDigitsPtr, SQLSMALLINT* nullablePtr ) ;\r
-FUNCTION: SQLRETURN SQLGetData ( SQLHSTMT statementHandle, SQLUSMALLINT columnNumber, SQLSMALLINT targetType, SQLPOINTER targetValuePtr, SQLINTEGER bufferLength, SQLINTEGER* strlen_or_indPtr ) ;\r
-\r
-: alloc-handle ( type parent -- handle )\r
- f <void*> [ SQLAllocHandle ] keep swap succeeded? [\r
- *void*\r
- ] [\r
- drop f\r
- ] if ;\r
-\r
-: alloc-env-handle ( -- handle )\r
- SQL-HANDLE-ENV SQL-NULL-HANDLE alloc-handle ;\r
-\r
-: alloc-dbc-handle ( env -- handle )\r
- SQL-HANDLE-DBC swap alloc-handle ;\r
-\r
-: alloc-stmt-handle ( dbc -- handle )\r
- SQL-HANDLE-STMT swap alloc-handle ;\r
-\r
-: temp-string ( length -- byte-array length )\r
- [ CHAR: \space <string> string>char-alien ] keep ;\r
-\r
-: odbc-init ( -- env )\r
- alloc-env-handle\r
- [ \r
- SQL-ATTR-ODBC-VERSION SQL-OV-ODBC3 0 SQLSetEnvAttr \r
- succeeded? [ "odbc-init failed" throw ] unless\r
- ] keep ;\r
-\r
-: odbc-connect ( env dsn -- dbc )\r
- >r alloc-dbc-handle dup r> \r
- f swap dup length 1024 temp-string 0 <short> SQL-DRIVER-NOPROMPT \r
- SQLDriverConnect succeeded? [ "odbc-connect failed" throw ] unless ;\r
-\r
-: odbc-disconnect ( dbc -- )\r
- SQLDisconnect succeeded? [ "odbc-disconnect failed" throw ] unless ; \r
-\r
-: odbc-prepare ( dbc string -- statement )\r
- >r alloc-stmt-handle dup r> dup length SQLPrepare succeeded? [ "odbc-prepare failed" throw ] unless ;\r
-\r
-: odbc-free-statement ( statement -- )\r
- SQL-HANDLE-STMT swap SQLFreeHandle succeeded? [ "odbc-free-statement failed" throw ] unless ;\r
-\r
-: odbc-execute ( statement -- )\r
- SQLExecute succeeded? [ "odbc-execute failed" throw ] unless ;\r
-\r
-: odbc-next-row ( statement -- bool )\r
- SQLFetch succeeded? ;\r
-\r
-: odbc-number-of-columns ( statement -- number )\r
- 0 <short> [ SQLNumResultCols succeeded? ] keep swap [\r
- *short\r
- ] [\r
- drop f\r
- ] if ;\r
-\r
-TUPLE: column nullable digits size type name number ;\r
-\r
-C: <column> column\r
-\r
-: odbc-describe-column ( statement n -- column )\r
- dup >r\r
- 1024 CHAR: \space <string> string>char-alien dup >r\r
- 1024 \r
- 0 <short>\r
- 0 <short> dup >r\r
- 0 <uint> dup >r\r
- 0 <short> dup >r\r
- 0 <short> dup >r\r
- SQLDescribeCol succeeded? [\r
- r> *short \r
- r> *short \r
- r> *uint \r
- r> *short convert-sql-type \r
- r> alien>char-string \r
- r> <column> \r
- ] [\r
- r> drop r> drop r> drop r> drop r> drop r> drop\r
- "odbc-describe-column failed" throw\r
- ] if ;\r
-\r
-: dereference-type-pointer ( byte-array column -- object )\r
- column-type {\r
- { SQL-CHAR [ alien>char-string ] }\r
- { SQL-VARCHAR [ alien>char-string ] }\r
- { SQL-LONGVARCHAR [ alien>char-string ] }\r
- { SQL-WCHAR [ alien>char-string ] }\r
- { SQL-WCHARVAR [ alien>char-string ] }\r
- { SQL-WLONGCHARVAR [ alien>char-string ] }\r
- { SQL-SMALLINT [ *short ] }\r
- { SQL-INTEGER [ *long ] }\r
- { SQL-REAL [ *float ] }\r
- { SQL-FLOAT [ *double ] }\r
- { SQL-DOUBLE [ *double ] }\r
- { SQL-TINYINT [ *char ] }\r
- { SQL-BIGINT [ *longlong ] }\r
- [ nip [ "Unknown SQL Type: " % word-name % ] "" make ] \r
- } case ;\r
-\r
-TUPLE: field value column ;\r
-\r
-C: <field> field\r
-\r
-: odbc-get-field ( statement column -- field )\r
- dup column? [ dupd odbc-describe-column ] unless dup >r column-number\r
- SQL-C-DEFAULT\r
- 8192 CHAR: \space <string> string>char-alien dup >r\r
- 8192 \r
- f SQLGetData succeeded? [\r
- r> r> [ dereference-type-pointer ] keep <field>\r
- ] [\r
- r> drop r> [ \r
- "SQLGetData Failed for Column: " % \r
- dup column-name % \r
- " of type: " % dup column-type word-name %\r
- ] "" make swap <field>\r
- ] if ;\r
-\r
-: odbc-get-row-fields ( statement -- seq )\r
- [\r
- dup odbc-number-of-columns [\r
- 1+ odbc-get-field field-value ,\r
- ] with each \r
- ] { } make ;\r
-\r
-: (odbc-get-all-rows) ( statement -- )\r
- dup odbc-next-row [ dup odbc-get-row-fields , yield (odbc-get-all-rows) ] [ drop ] if ; \r
- \r
-: odbc-get-all-rows ( statement -- seq )\r
- [ (odbc-get-all-rows) ] { } make ;\r
- \r
-: odbc-query ( string dsn -- result )\r
- odbc-init swap odbc-connect [\r
- swap odbc-prepare\r
- dup odbc-execute\r
- dup odbc-get-all-rows\r
- swap odbc-free-statement\r
- ] keep odbc-disconnect ;\r
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel alien alien.syntax combinators alien.c-types
+ strings sequences namespaces words math threads ;
+IN: odbc
+
+"odbc" "odbc32.dll" "stdcall" add-library
+
+LIBRARY: odbc
+
+TYPEDEF: void* usb_dev_handle*
+TYPEDEF: short SQLRETURN
+TYPEDEF: short SQLSMALLINT
+TYPEDEF: short* SQLSMALLINT*
+TYPEDEF: ushort SQLUSMALLINT
+TYPEDEF: uint* SQLUINTEGER*
+TYPEDEF: int SQLINTEGER
+TYPEDEF: char SQLCHAR
+TYPEDEF: char* SQLCHAR*
+TYPEDEF: void* SQLHANDLE
+TYPEDEF: void* SQLHANDLE*
+TYPEDEF: void* SQLHENV
+TYPEDEF: void* SQLHDBC
+TYPEDEF: void* SQLHSTMT
+TYPEDEF: void* SQLHWND
+TYPEDEF: void* SQLPOINTER
+
+: SQL-HANDLE-ENV ( -- number ) 1 ; inline
+: SQL-HANDLE-DBC ( -- number ) 2 ; inline
+: SQL-HANDLE-STMT ( -- number ) 3 ; inline
+: SQL-HANDLE-DESC ( -- number ) 4 ; inline
+
+: SQL-NULL-HANDLE ( -- alien ) f ; inline
+
+: SQL-ATTR-ODBC-VERSION ( -- number ) 200 ; inline
+
+: SQL-OV-ODBC2 ( -- number ) 2 <alien> ; inline
+: SQL-OV-ODBC3 ( -- number ) 3 <alien> ; inline
+
+: SQL-SUCCESS ( -- number ) 0 ; inline
+: SQL-SUCCESS-WITH-INFO ( -- number ) 1 ; inline
+: SQL-NO-DATA-FOUND ( -- number ) 100 ; inline
+
+: SQL-DRIVER-NOPROMPT ( -- number ) 0 ; inline
+: SQL-DRIVER-PROMPT ( -- number ) 2 ; inline
+
+: SQL-C-DEFAULT ( -- number ) 99 ; inline
+
+SYMBOL: SQL-CHAR
+SYMBOL: SQL-VARCHAR
+SYMBOL: SQL-LONGVARCHAR
+SYMBOL: SQL-WCHAR
+SYMBOL: SQL-WCHARVAR
+SYMBOL: SQL-WLONGCHARVAR
+SYMBOL: SQL-DECIMAL
+SYMBOL: SQL-SMALLINT
+SYMBOL: SQL-NUMERIC
+SYMBOL: SQL-INTEGER
+SYMBOL: SQL-REAL
+SYMBOL: SQL-FLOAT
+SYMBOL: SQL-DOUBLE
+SYMBOL: SQL-BIT
+SYMBOL: SQL-TINYINT
+SYMBOL: SQL-BIGINT
+SYMBOL: SQL-BINARY
+SYMBOL: SQL-VARBINARY
+SYMBOL: SQL-LONGVARBINARY
+SYMBOL: SQL-TYPE-DATE
+SYMBOL: SQL-TYPE-TIME
+SYMBOL: SQL-TYPE-TIMESTAMP
+SYMBOL: SQL-TYPE-UTCDATETIME
+SYMBOL: SQL-TYPE-UTCTIME
+SYMBOL: SQL-INTERVAL-MONTH
+SYMBOL: SQL-INTERVAL-YEAR
+SYMBOL: SQL-INTERVAL-YEAR-TO-MONTH
+SYMBOL: SQL-INTERVAL-DAY
+SYMBOL: SQL-INTERVAL-HOUR
+SYMBOL: SQL-INTERVAL-MINUTE
+SYMBOL: SQL-INTERVAL-SECOND
+SYMBOL: SQL-INTERVAL-DAY-TO-HOUR
+SYMBOL: SQL-INTERVAL-DAY-TO-MINUTE
+SYMBOL: SQL-INTERVAL-DAY-TO-SECOND
+SYMBOL: SQL-INTERVAL-HOUR-TO-MINUTE
+SYMBOL: SQL-INTERVAL-HOUR-TO-SECOND
+SYMBOL: SQL-INTERVAL-MINUTE-TO-SECOND
+SYMBOL: SQL-GUID
+SYMBOL: SQL-TYPE-UNKNOWN
+
+: convert-sql-type ( number -- symbol )
+ {
+ { 1 [ SQL-CHAR ] }
+ { 12 [ SQL-VARCHAR ] }
+ { -1 [ SQL-LONGVARCHAR ] }
+ { -8 [ SQL-WCHAR ] }
+ { -9 [ SQL-WCHARVAR ] }
+ { -10 [ SQL-WLONGCHARVAR ] }
+ { 3 [ SQL-DECIMAL ] }
+ { 5 [ SQL-SMALLINT ] }
+ { 2 [ SQL-NUMERIC ] }
+ { 4 [ SQL-INTEGER ] }
+ { 7 [ SQL-REAL ] }
+ { 6 [ SQL-FLOAT ] }
+ { 8 [ SQL-DOUBLE ] }
+ { -7 [ SQL-BIT ] }
+ { -6 [ SQL-TINYINT ] }
+ { -5 [ SQL-BIGINT ] }
+ { -2 [ SQL-BINARY ] }
+ { -3 [ SQL-VARBINARY ] }
+ { -4 [ SQL-LONGVARBINARY ] }
+ { 91 [ SQL-TYPE-DATE ] }
+ { 92 [ SQL-TYPE-TIME ] }
+ { 93 [ SQL-TYPE-TIMESTAMP ] }
+ [ drop SQL-TYPE-UNKNOWN ]
+ } case ;
+
+: succeeded? ( n -- bool )
+ #! Did the call succeed (SQL-SUCCESS or SQL-SUCCESS-WITH-INFO)
+ {
+ { SQL-SUCCESS [ t ] }
+ { SQL-SUCCESS-WITH-INFO [ t ] }
+ [ drop f ]
+ } case ;
+
+FUNCTION: SQLRETURN SQLAllocHandle ( SQLSMALLINT handleType, SQLHANDLE inputHandle, SQLHANDLE* outputHandlePtr ) ;
+FUNCTION: SQLRETURN SQLSetEnvAttr ( SQLHENV environmentHandle, SQLINTEGER attribute, SQLPOINTER valuePtr, SQLINTEGER stringLength ) ;
+FUNCTION: SQLRETURN SQLDriverConnect ( SQLHDBC connectionHandle, SQLHWND windowHandle, SQLCHAR* inConnectionString, SQLSMALLINT stringLength, SQLCHAR* outConnectionString, SQLSMALLINT bufferLength, SQLSMALLINT* stringLength2Ptr, SQLUSMALLINT driverCompletion ) ;
+FUNCTION: SQLRETURN SQLDisconnect ( SQLHDBC connectionHandle ) ;
+FUNCTION: SQLRETURN SQLPrepare ( SQLHSTMT statementHandle, SQLCHAR* statementText, SQLINTEGER length ) ;
+FUNCTION: SQLRETURN SQLExecute ( SQLHSTMT statementHandle ) ;
+FUNCTION: SQLRETURN SQLFreeHandle ( SQLSMALLINT handleType, SQLHANDLE handle ) ;
+FUNCTION: SQLRETURN SQLFetch ( SQLHSTMT statementHandle ) ;
+FUNCTION: SQLRETURN SQLNumResultCols ( SQLHSTMT statementHandle, SQLSMALLINT* columnCountPtr ) ;
+FUNCTION: SQLRETURN SQLDescribeCol ( SQLHSTMT statementHandle, SQLSMALLINT columnNumber, SQLCHAR* columnName, SQLSMALLINT bufferLength, SQLSMALLINT* nameLengthPtr, SQLSMALLINT* dataTypePtr, SQLUINTEGER* columnSizePtr, SQLSMALLINT* decimalDigitsPtr, SQLSMALLINT* nullablePtr ) ;
+FUNCTION: SQLRETURN SQLGetData ( SQLHSTMT statementHandle, SQLUSMALLINT columnNumber, SQLSMALLINT targetType, SQLPOINTER targetValuePtr, SQLINTEGER bufferLength, SQLINTEGER* strlen_or_indPtr ) ;
+
+: alloc-handle ( type parent -- handle )
+ f <void*> [ SQLAllocHandle ] keep swap succeeded? [
+ *void*
+ ] [
+ drop f
+ ] if ;
+
+: alloc-env-handle ( -- handle )
+ SQL-HANDLE-ENV SQL-NULL-HANDLE alloc-handle ;
+
+: alloc-dbc-handle ( env -- handle )
+ SQL-HANDLE-DBC swap alloc-handle ;
+
+: alloc-stmt-handle ( dbc -- handle )
+ SQL-HANDLE-STMT swap alloc-handle ;
+
+: temp-string ( length -- byte-array length )
+ [ CHAR: \space <string> string>char-alien ] keep ;
+
+: odbc-init ( -- env )
+ alloc-env-handle
+ [
+ SQL-ATTR-ODBC-VERSION SQL-OV-ODBC3 0 SQLSetEnvAttr
+ succeeded? [ "odbc-init failed" throw ] unless
+ ] keep ;
+
+: odbc-connect ( env dsn -- dbc )
+ >r alloc-dbc-handle dup r>
+ f swap dup length 1024 temp-string 0 <short> SQL-DRIVER-NOPROMPT
+ SQLDriverConnect succeeded? [ "odbc-connect failed" throw ] unless ;
+
+: odbc-disconnect ( dbc -- )
+ SQLDisconnect succeeded? [ "odbc-disconnect failed" throw ] unless ;
+
+: odbc-prepare ( dbc string -- statement )
+ >r alloc-stmt-handle dup r> dup length SQLPrepare succeeded? [ "odbc-prepare failed" throw ] unless ;
+
+: odbc-free-statement ( statement -- )
+ SQL-HANDLE-STMT swap SQLFreeHandle succeeded? [ "odbc-free-statement failed" throw ] unless ;
+
+: odbc-execute ( statement -- )
+ SQLExecute succeeded? [ "odbc-execute failed" throw ] unless ;
+
+: odbc-next-row ( statement -- bool )
+ SQLFetch succeeded? ;
+
+: odbc-number-of-columns ( statement -- number )
+ 0 <short> [ SQLNumResultCols succeeded? ] keep swap [
+ *short
+ ] [
+ drop f
+ ] if ;
+
+TUPLE: column nullable digits size type name number ;
+
+C: <column> column
+
+: odbc-describe-column ( statement n -- column )
+ dup >r
+ 1024 CHAR: \space <string> string>char-alien dup >r
+ 1024
+ 0 <short>
+ 0 <short> dup >r
+ 0 <uint> dup >r
+ 0 <short> dup >r
+ 0 <short> dup >r
+ SQLDescribeCol succeeded? [
+ r> *short
+ r> *short
+ r> *uint
+ r> *short convert-sql-type
+ r> alien>char-string
+ r> <column>
+ ] [
+ r> drop r> drop r> drop r> drop r> drop r> drop
+ "odbc-describe-column failed" throw
+ ] if ;
+
+: dereference-type-pointer ( byte-array column -- object )
+ column-type {
+ { SQL-CHAR [ alien>char-string ] }
+ { SQL-VARCHAR [ alien>char-string ] }
+ { SQL-LONGVARCHAR [ alien>char-string ] }
+ { SQL-WCHAR [ alien>char-string ] }
+ { SQL-WCHARVAR [ alien>char-string ] }
+ { SQL-WLONGCHARVAR [ alien>char-string ] }
+ { SQL-SMALLINT [ *short ] }
+ { SQL-INTEGER [ *long ] }
+ { SQL-REAL [ *float ] }
+ { SQL-FLOAT [ *double ] }
+ { SQL-DOUBLE [ *double ] }
+ { SQL-TINYINT [ *char ] }
+ { SQL-BIGINT [ *longlong ] }
+ [ nip [ "Unknown SQL Type: " % word-name % ] "" make ]
+ } case ;
+
+TUPLE: field value column ;
+
+C: <field> field
+
+: odbc-get-field ( statement column -- field )
+ dup column? [ dupd odbc-describe-column ] unless dup >r column-number
+ SQL-C-DEFAULT
+ 8192 CHAR: \space <string> string>char-alien dup >r
+ 8192
+ f SQLGetData succeeded? [
+ r> r> [ dereference-type-pointer ] keep <field>
+ ] [
+ r> drop r> [
+ "SQLGetData Failed for Column: " %
+ dup column-name %
+ " of type: " % dup column-type word-name %
+ ] "" make swap <field>
+ ] if ;
+
+: odbc-get-row-fields ( statement -- seq )
+ [
+ dup odbc-number-of-columns [
+ 1+ odbc-get-field field-value ,
+ ] with each
+ ] { } make ;
+
+: (odbc-get-all-rows) ( statement -- )
+ dup odbc-next-row [ dup odbc-get-row-fields , yield (odbc-get-all-rows) ] [ drop ] if ;
+
+: odbc-get-all-rows ( statement -- seq )
+ [ (odbc-get-all-rows) ] { } make ;
+
+: odbc-query ( string dsn -- result )
+ odbc-init swap odbc-connect [
+ swap odbc-prepare
+ dup odbc-execute
+ dup odbc-get-all-rows
+ swap odbc-free-statement
+ ] keep odbc-disconnect ;
projects / factor.git / commitdiff