extra/odbc/odbc.factor

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