1 /* Part of SWI-Prolog
2
3 Author: Jan Wielemaker
4 E-mail: J.Wielemaker@vu.nl
5 WWW: http://www.swi-prolog.org
6 Copyright (c) 2002-2018, University of Amsterdam,
7 VU University Amsterdam
8 All rights reserved.
9
10 Redistribution and use in source and binary forms, with or without
11 modification, are permitted provided that the following conditions
12 are met:
13
14 1. Redistributions of source code must retain the above copyright
15 notice, this list of conditions and the following disclaimer.
16
17 2. Redistributions in binary form must reproduce the above copyright
18 notice, this list of conditions and the following disclaimer in
19 the documentation and/or other materials provided with the
20 distribution.
21
22 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
25 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
26 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
27 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
28 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
29 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
30 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
31 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
32 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
33 POSSIBILITY OF SUCH DAMAGE.
34 */
35
36 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
37 This module is based on pl_odbc.{c,pl}, a read-only ODBC interface by
38 Stefano De Giorgi (s.degiorgi@tin.it).
39 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
40
41 #include <config.h>
42
43 #include <SWI-Stream.h>
44 #include <SWI-Prolog.h>
45
46 #define O_DEBUG 1
47
48 static int odbc_debuglevel = 0;
49
50 #ifdef O_DEBUG
51 #define DEBUG(level, g) if ( odbc_debuglevel >= (level) ) g
52 #else
53 #define DEBUG(level, g) ((void)0)
54 #endif
55
56 #include <sql.h>
57 #include <sqlext.h>
58 #include <time.h>
59 #include <limits.h> /* LONG_MAX, etc. */
60
61 #ifndef HAVE_SQLLEN
62 #define SQLLEN DWORD
63 #endif
64 #ifndef HAVE_SQLULEN
65 #define SQLULEN SQLUINTEGER
66 #endif
67
68 #ifndef SQL_COPT_SS_MARS_ENABLED
69 #define SQL_COPT_SS_MARS_ENABLED 1224
70 #endif
71
72 #ifndef SQL_MARS_ENABLED_YES
73 #define SQL_MARS_ENABLED_YES (SQLPOINTER)1
74 #endif
75
76 #ifndef WORDS_BIGENDIAN
77 #define ENC_SQLWCHAR ENC_UNICODE_LE
78 #else
79 #define ENC_SQLWCHAR ENC_UNICODE_BE
80 #endif
81
82 #ifdef __WINDOWS__
83 #define DEFAULT_ENCODING ENC_SQLWCHAR
84 #else
85 #define DEFAULT_ENCODING ENC_UTF8
86 #endif
87
88 #include <stdio.h>
89 #include <stdlib.h>
90 #include <string.h>
91 #include <assert.h>
92
93 #ifndef NULL
94 #define NULL 0
95 #endif
96 #define MAX_NOGETDATA 1024 /* use SQLGetData() on wider columns */
97 #ifndef STRICT
98 #define STRICT
99 #endif
100
101 #define NameBufferLength 256
102 #define CVNERR -1 /* conversion error */
103
104 #if defined(_REENTRANT) || defined(O_PLTM)
105 #include <pthread.h>
106
107 /* FIXME: Actually use these */
108 static pthread_mutex_t mutex = PTHREAD_MUTEX_INITIALIZER;
109 #define LOCK() pthread_mutex_lock(&mutex)
110 #define UNLOCK() pthread_mutex_unlock(&mutex)
111 #if __WINDOWS__
112 static CRITICAL_SECTION context_mutex;
113 #define INIT_CONTEXT_LOCK() InitializeCriticalSection(&context_mutex)
114 #define LOCK_CONTEXTS() EnterCriticalSection(&context_mutex)
115 #define UNLOCK_CONTEXTS() LeaveCriticalSection(&context_mutex)
116 #else
117 static pthread_mutex_t context_mutex = PTHREAD_MUTEX_INITIALIZER;
118 #define INIT_CONTEXT_LOCK()
119 #define LOCK_CONTEXTS() pthread_mutex_lock(&context_mutex)
120 #define UNLOCK_CONTEXTS() pthread_mutex_unlock(&context_mutex)
121 #endif
122 #else /*multi-threaded*/
123 #define LOCK()
124 #define UNLOCK()
125 #define LOCK_CONTEXTS()
126 #define UNLOCK_CONTEXTS()
127 #define INIT_CONTEXT_LOCK()
128 #endif /*multi-threaded*/
129
130 #if !defined(HAVE_TIMEGM) && defined(HAVE_MKTIME) && defined(USE_UTC)
131 #define EMULATE_TIMEGM
132 static time_t timegm(struct tm *tm);
133 #define HAVE_TIMEGM
134 #endif
135
136 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
137 Work around bug in MS SQL Server that reports NumCols of SQLColumns()
138 as 19, while there are only 12. Grrr!
139
140 This bug appears fixed now, so we'll remove the work-around
141 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
142
143 /*#define SQL_SERVER_BUG 1*/
144
145 static atom_t ATOM_row; /* "row" */
146 static atom_t ATOM_informational; /* "informational" */
147 static atom_t ATOM_default; /* "default" */
148 static atom_t ATOM_once; /* "once" */
149 static atom_t ATOM_multiple; /* "multiple" */
150 static atom_t ATOM_commit; /* "commit" */
151 static atom_t ATOM_rollback; /* "rollback" */
152 static atom_t ATOM_atom;
153 static atom_t ATOM_string;
154 static atom_t ATOM_codes;
155 static atom_t ATOM_float;
156 static atom_t ATOM_integer;
157 static atom_t ATOM_time;
158 static atom_t ATOM_date;
159 static atom_t ATOM_timestamp;
160 static atom_t ATOM_all_types;
161 static atom_t ATOM_null; /* default null atom */
162 static atom_t ATOM_; /* "" */
163 static atom_t ATOM_read;
164 static atom_t ATOM_update;
165 static atom_t ATOM_dynamic;
166 static atom_t ATOM_forwards_only;
167 static atom_t ATOM_keyset_driven;
168 static atom_t ATOM_static;
169 static atom_t ATOM_auto;
170 static atom_t ATOM_fetch;
171 static atom_t ATOM_end_of_file;
172 static atom_t ATOM_next;
173 static atom_t ATOM_prior;
174 static atom_t ATOM_first;
175 static atom_t ATOM_last;
176 static atom_t ATOM_absolute;
177 static atom_t ATOM_relative;
178 static atom_t ATOM_bookmark;
179 static atom_t ATOM_strict;
180 static atom_t ATOM_relaxed;
181
182 static functor_t FUNCTOR_timestamp7; /* timestamp/7 */
183 static functor_t FUNCTOR_time3; /* time/7 */
184 static functor_t FUNCTOR_date3; /* date/3 */
185 static functor_t FUNCTOR_odbc3; /* odbc(state, code, message) */
186 static functor_t FUNCTOR_error2; /* error(Formal, Context) */
187 static functor_t FUNCTOR_type_error2; /* type_error(Term, Expected) */
188 static functor_t FUNCTOR_domain_error2; /* domain_error(Term, Expected) */
189 static functor_t FUNCTOR_existence_error2; /* existence_error(Term, Expected) */
190 static functor_t FUNCTOR_representation_error1; /* representation_error(What) */
191 static functor_t FUNCTOR_resource_error1; /* resource_error(Error) */
192 static functor_t FUNCTOR_permission_error3;
193 static functor_t FUNCTOR_odbc_statement1; /* $odbc_statement(Id) */
194 static functor_t FUNCTOR_odbc_connection1;
195 static functor_t FUNCTOR_encoding1;
196 static functor_t FUNCTOR_user1;
197 static functor_t FUNCTOR_password1;
198 static functor_t FUNCTOR_driver_string1;
199 static functor_t FUNCTOR_alias1;
200 static functor_t FUNCTOR_mars1;
201 static functor_t FUNCTOR_connection_pooling1;
202 static functor_t FUNCTOR_connection_pool_mode1;
203 static functor_t FUNCTOR_odbc_version1;
204 static functor_t FUNCTOR_open1;
205 static functor_t FUNCTOR_auto_commit1;
206 static functor_t FUNCTOR_types1;
207 static functor_t FUNCTOR_minus2;
208 static functor_t FUNCTOR_gt2;
209 static functor_t FUNCTOR_context_error3;
210 static functor_t FUNCTOR_data_source2;
211 static functor_t FUNCTOR_null1;
212 static functor_t FUNCTOR_source1;
213 static functor_t FUNCTOR_column3;
214 static functor_t FUNCTOR_access_mode1;
215 static functor_t FUNCTOR_cursor_type1;
216 static functor_t FUNCTOR_silent1;
217 static functor_t FUNCTOR_findall2; /* findall(Term, row(...)) */
218 static functor_t FUNCTOR_affected1;
219 static functor_t FUNCTOR_fetch1;
220 static functor_t FUNCTOR_wide_column_threshold1; /* set max_nogetdata */
221
222 #define SQL_PL_DEFAULT 0 /* don't change! */
223 #define SQL_PL_ATOM 1 /* return as atom */
224 #define SQL_PL_CODES 2 /* return as code-list */
225 #define SQL_PL_STRING 3 /* return as string */
226 #define SQL_PL_INTEGER 4 /* return as integer */
227 #define SQL_PL_FLOAT 5 /* return as float */
228 #define SQL_PL_TIME 6 /* return as time/3 structure */
229 #define SQL_PL_DATE 7 /* return as date/3 structure */
230 #define SQL_PL_TIMESTAMP 8 /* return as timestamp/7 structure */
231
232 #define PARAM_BUFSIZE (SQLLEN)sizeof(double)
233
234 typedef uintptr_t code;
235
236 typedef struct
237 { SWORD cTypeID; /* C type of value */
238 SWORD plTypeID; /* Prolog type of value */
239 SWORD sqlTypeID; /* Sql type of value */
240 SWORD scale; /* Scale */
241 SQLPOINTER ptr_value; /* ptr to value */
242 SQLLEN length_ind; /* length/indicator of value */
243 SQLLEN len_value; /* length of value (as parameter) */
244 term_t put_data; /* data to put there */
245 struct
246 { atom_t table; /* Table name */
247 atom_t column; /* column name */
248 } source; /* origin of the data */
249 char buf[PARAM_BUFSIZE]; /* Small buffer for simple cols */
250 } parameter;
251
252 typedef struct
253 { enum
254 { NULL_VAR, /* represent as variable */
255 NULL_ATOM, /* some atom */
256 NULL_FUNCTOR, /* e.g. null(_) */
257 NULL_RECORD /* an arbitrary term */
258 } nulltype;
259 union
260 { atom_t atom; /* as atom */
261 functor_t functor; /* as functor */
262 record_t record; /* as term */
263 } nullvalue;
264 int references; /* reference count */
265 } nulldef; /* Prolog's representation of NULL */
266
267 typedef struct
268 { int references; /* reference count */
269 unsigned flags; /* misc flags */
270 code codes[1]; /* executable code */
271 } findall;
272
273 typedef struct connection
274 { long magic; /* magic code */
275 atom_t alias; /* alias name of the connection */
276 atom_t dsn; /* DSN name of the connection */
277 HDBC hdbc; /* ODBC handle */
278 nulldef *null; /* Prolog null value */
279 unsigned flags; /* general flags */
280 int max_qualifier_length; /* SQL_MAX_QUALIFIER_NAME_LEN */
281 SQLULEN max_nogetdata; /* handle as long field if larger */
282 IOENC encoding; /* Character encoding to use */
283 int rep_flag; /* REP_* for encoding */
284 struct connection *next; /* next in chain */
285 } connection;
286
287 typedef struct
288 { long magic; /* magic code */
289 connection *connection; /* connection used */
290 HENV henv; /* ODBC environment */
291 HSTMT hstmt; /* ODBC statement handle */
292 RETCODE rc; /* status of last operation */
293 parameter *params; /* Input parameters */
294 parameter *result; /* Outputs (row descriptions) */
295 SQLSMALLINT NumCols; /* # columns */
296 SQLSMALLINT NumParams; /* # parameters */
297 functor_t db_row; /* Functor for row */
298 SQLINTEGER sqllen; /* length of statement (in characters) */
299 union
300 { SQLWCHAR *w; /* as unicode */
301 unsigned char *a; /* as multibyte */
302 } sqltext; /* statement text */
303 int char_width; /* sizeof a character */
304 unsigned flags; /* general flags */
305 nulldef *null; /* Prolog null value */
306 findall *findall; /* compiled code to create result */
307 SQLULEN max_nogetdata; /* handle as long field if larger */
308 struct context *clones; /* chain of clones */
309 } context;
310
311 static struct
312 { long statements_created; /* # created statements */
313 long statements_freed; /* # destroyed statements */
314 } statistics;
315
316
317 #define CON_MAGIC 0x7c42b620 /* magic code */
318 #define CTX_MAGIC 0x7c42b621 /* magic code */
319 #define CTX_FREEMAGIC 0x7c42b622 /* magic code if freed */
320
321 #define CTX_PERSISTENT 0x0001 /* persistent statement handle */
322 #define CTX_BOUND 0x0002 /* result-columns are bound */
323 #define CTX_SQLMALLOCED 0x0004 /* sqltext is malloced */
324 #define CTX_INUSE 0x0008 /* statement is running */
325 #define CTX_OWNNULL 0x0010 /* null-definition is not shared */
326 #define CTX_SOURCE 0x0020 /* include source of results */
327 #define CTX_SILENT 0x0040 /* don't produce messages */
328 #define CTX_PREFETCHED 0x0080 /* we have a prefetched value */
329 #define CTX_COLUMNS 0x0100 /* this is an SQLColumns() statement */
330 #define CTX_TABLES 0x0200 /* this is an SQLTables() statement */
331 #define CTX_GOT_QLEN 0x0400 /* got SQL_MAX_QUALIFIER_NAME_LEN */
332 #define CTX_NOAUTO 0x0800 /* fetch by hand */
333
334 #define CTX_PRIMARYKEY 0x1000 /* this is an SQLPrimaryKeys() statement */
335 #define CTX_FOREIGNKEY 0x2000 /* this is an SQLForeignKeys() statement */
336 #define CTX_EXECUTING 0x4000 /* Context is currently being used in SQLExecute */
337
338 #define FND_SIZE(n) ((size_t)&((findall*)NULL)->codes[n])
339
340 #define true(s, f) ((s)->flags & (f))
341 #define false(s, f) !true(s, f)
342 #define set(s, f) ((s)->flags |= (f))
343 #define clear(s, f) ((s)->flags &= ~(f))
344
345 static HENV henv; /* environment handle (ODBC) */
346
347
348 /* Prototypes */
349 static int pl_put_row(term_t, context *);
350 static int pl_put_column(context *c, int nth, term_t col);
351 static SWORD CvtSqlToCType(context *ctxt, SQLSMALLINT, SQLSMALLINT);
352 static void free_context(context *ctx);
353 static void close_context(context *ctx);
354 static void unmark_and_close_context(context *ctx);
355 static foreign_t odbc_set_connection(connection *cn, term_t option);
356 static int get_pltype(term_t t, SWORD *type);
357 static SWORD get_sqltype_from_atom(atom_t name, SWORD *type);
358
359
360 /*******************************
361 * ERRORS *
362 *******************************/
363
364 static int
odbc_report(HENV henv,HDBC hdbc,HSTMT hstmt,RETCODE rc)365 odbc_report(HENV henv, HDBC hdbc, HSTMT hstmt, RETCODE rc)
366 { SQLCHAR state[16]; /* Normally 5-character ID */
367 SQLINTEGER native; /* was DWORD */
368 SQLCHAR message[SQL_MAX_MESSAGE_LENGTH+1];
369 SWORD msglen;
370 RETCODE rce;
371 term_t msg = PL_new_term_ref();
372
373 switch ( (rce=SQLError(henv, hdbc, hstmt, state, &native, message,
374 sizeof(message), &msglen)) )
375 { case SQL_NO_DATA_FOUND:
376 case SQL_SUCCESS_WITH_INFO:
377 if ( rc != SQL_ERROR )
378 return TRUE;
379 /*FALLTHROUGH*/
380 case SQL_SUCCESS:
381 if ( msglen > SQL_MAX_MESSAGE_LENGTH )
382 msglen = SQL_MAX_MESSAGE_LENGTH; /* TBD: get the rest? */
383 if ( !PL_unify_term(msg,
384 PL_FUNCTOR, FUNCTOR_odbc3,
385 PL_CHARS, state,
386 PL_INTEGER, (long)native,
387 PL_NCHARS, (size_t)msglen, message) )
388 return FALSE;
389 break;
390 case SQL_INVALID_HANDLE:
391 return PL_warning("ODBC INTERNAL ERROR: Invalid handle in error");
392 default:
393 if ( rc != SQL_ERROR )
394 return TRUE;
395 }
396
397 switch(rc)
398 { case SQL_SUCCESS_WITH_INFO:
399 { fid_t fid = PL_open_foreign_frame();
400 predicate_t pred = PL_predicate("print_message", 2, "user");
401 term_t av;
402 int rc;
403
404 rc = ( (av = PL_new_term_refs(2)) &&
405 PL_put_atom(av+0, ATOM_informational) &&
406 PL_put_term(av+1, msg) &&
407 PL_call_predicate(NULL, PL_Q_NORMAL, pred, av)
408 );
409 PL_discard_foreign_frame(fid);
410
411 return rc;
412 }
413 case SQL_ERROR:
414 { term_t ex;
415
416 if ( (ex=PL_new_term_ref()) &&
417 PL_unify_term(ex,
418 PL_FUNCTOR, FUNCTOR_error2,
419 PL_TERM, msg,
420 PL_VARIABLE) )
421 return PL_raise_exception(ex);
422
423 return FALSE;
424 }
425 default:
426 return PL_warning("Statement returned %d\n", rc);
427 }
428 }
429
430 #define TRY(ctxt, stmt, onfail) \
431 { ctxt->rc = (stmt); \
432 if ( !report_status(ctxt) ) \
433 { onfail; \
434 return FALSE; \
435 } \
436 }
437
438
439 static int
report_status(context * ctxt)440 report_status(context *ctxt)
441 { switch(ctxt->rc)
442 { case SQL_SUCCESS:
443 return TRUE;
444 case SQL_SUCCESS_WITH_INFO:
445 if ( true(ctxt, CTX_SILENT) )
446 return TRUE;
447 break;
448 case SQL_NO_DATA_FOUND:
449 return TRUE;
450 case SQL_INVALID_HANDLE:
451 return PL_warning("Invalid handle: %p", ctxt->hstmt);
452 }
453
454 return odbc_report(ctxt->henv, ctxt->connection->hdbc,
455 ctxt->hstmt, ctxt->rc);
456 }
457
458
459 static int
type_error(term_t actual,const char * expected)460 type_error(term_t actual, const char *expected)
461 { term_t ex;
462
463 if ( (ex=PL_new_term_ref()) &&
464 PL_unify_term(ex,
465 PL_FUNCTOR, FUNCTOR_error2,
466 PL_FUNCTOR, FUNCTOR_type_error2,
467 PL_CHARS, expected,
468 PL_TERM, actual,
469 PL_VARIABLE) )
470 return PL_raise_exception(ex);
471
472 return FALSE;
473 }
474
475 static int
domain_error(term_t actual,const char * expected)476 domain_error(term_t actual, const char *expected)
477 { term_t ex;
478
479 if ( (ex=PL_new_term_ref()) &&
480 PL_unify_term(ex,
481 PL_FUNCTOR, FUNCTOR_error2,
482 PL_FUNCTOR, FUNCTOR_domain_error2,
483 PL_CHARS, expected,
484 PL_TERM, actual,
485 PL_VARIABLE) )
486 return PL_raise_exception(ex);
487
488 return FALSE;
489 }
490
491 static int
existence_error(term_t actual,const char * expected)492 existence_error(term_t actual, const char *expected)
493 { term_t ex;
494
495 if ( (ex=PL_new_term_ref()) &&
496 PL_unify_term(ex,
497 PL_FUNCTOR, FUNCTOR_error2,
498 PL_FUNCTOR, FUNCTOR_existence_error2,
499 PL_CHARS, expected,
500 PL_TERM, actual,
501 PL_VARIABLE) )
502 return PL_raise_exception(ex);
503
504 return FALSE;
505 }
506
507 static int
resource_error(const char * error)508 resource_error(const char *error)
509 { term_t ex;
510
511 if ( (ex=PL_new_term_ref()) &&
512 PL_unify_term(ex,
513 PL_FUNCTOR, FUNCTOR_error2,
514 PL_FUNCTOR, FUNCTOR_resource_error1,
515 PL_CHARS, error,
516 PL_VARIABLE) )
517 return PL_raise_exception(ex);
518
519 return FALSE;
520 }
521
522
523 static int
representation_error(term_t t,const char * error)524 representation_error(term_t t, const char *error)
525 { term_t ex;
526
527 if ( (ex=PL_new_term_ref()) &&
528 PL_unify_term(ex,
529 PL_FUNCTOR, FUNCTOR_error2,
530 PL_FUNCTOR, FUNCTOR_representation_error1,
531 PL_CHARS, error,
532 PL_TERM, t) )
533 return PL_raise_exception(ex);
534
535 return FALSE;
536 }
537
538
539 static int
context_error(term_t term,const char * error,const char * what)540 context_error(term_t term, const char *error, const char *what)
541 { term_t ex;
542
543 if ( (ex=PL_new_term_ref()) &&
544 PL_unify_term(ex,
545 PL_FUNCTOR, FUNCTOR_error2,
546 PL_FUNCTOR, FUNCTOR_context_error3,
547 PL_TERM, term,
548 PL_CHARS, error,
549 PL_CHARS, what,
550 PL_VARIABLE) )
551 return PL_raise_exception(ex);
552
553 return FALSE;
554 }
555
556
557 static int
permission_error(const char * op,const char * type,term_t obj)558 permission_error(const char *op, const char *type, term_t obj)
559 { term_t ex;
560
561 if ( (ex=PL_new_term_ref()) &&
562 PL_unify_term(ex,
563 PL_FUNCTOR, FUNCTOR_error2,
564 PL_FUNCTOR, FUNCTOR_permission_error3,
565 PL_CHARS, op,
566 PL_CHARS, type,
567 PL_TERM, obj,
568 PL_VARIABLE) )
569 return PL_raise_exception(ex);
570
571 return FALSE;
572 }
573
574
575 static void *
odbc_malloc(size_t bytes)576 odbc_malloc(size_t bytes)
577 { void *ptr = malloc(bytes);
578
579 if ( !ptr )
580 resource_error("memory");
581
582 return ptr;
583 }
584
585
586 static void *
odbc_realloc(void * inptr,size_t bytes)587 odbc_realloc(void* inptr, size_t bytes)
588 { void *ptr = realloc(inptr, bytes);
589
590 if ( !ptr )
591 { free(inptr);
592 resource_error("memory");
593 }
594
595 return ptr;
596 }
597
598
599 /*******************************
600 * PRIMITIVES *
601 *******************************/
602
603 #define get_name_arg_ex(i, t, n) \
604 PL_get_typed_arg_ex(i, t, PL_get_atom_chars, "atom", n)
605 #define get_text_arg_ex(i, t, n) \
606 PL_get_typed_arg_ex(i, t, get_text, "text", n)
607 #define get_atom_arg_ex(i, t, n) \
608 PL_get_typed_arg_ex(i, t, PL_get_atom, "atom", n)
609 #define get_int_arg_ex(i, t, n) \
610 PL_get_typed_arg_ex(i, t, PL_get_integer, "integer", n)
611 #define get_long_arg_ex(i, t, n) \
612 PL_get_typed_arg_ex(i, t, PL_get_long, "integer", n)
613 #define get_bool_arg_ex(i, t, n) \
614 PL_get_typed_arg_ex(i, t, PL_get_bool, "boolean", n)
615 #define get_float_arg_ex(i, t, n) \
616 PL_get_typed_arg_ex(i, t, PL_get_float, "float", n)
617 #define get_encoding_arg_ex(i, t, n) \
618 PL_get_typed_arg_ex(i, t, get_encoding, "encoding", n)
619 #define get_odbc_version_arg_ex(i, t, n) \
620 PL_get_typed_arg_ex(i, t, get_odbc_version, "odbc_version", n)
621
622 /* Used for passwd and driver string. Should use Unicode/encoding
623 stuff for that.
624 */
625
626 static int
get_text(term_t t,char ** s)627 get_text(term_t t, char **s)
628 { return PL_get_chars(t, s, CVT_ATOM|CVT_STRING|CVT_LIST|REP_MB|BUF_RING);
629 }
630
631 typedef struct enc_name
632 { char *name;
633 IOENC code;
634 atom_t a;
635 } enc_name;
636
637 static enc_name encodings[] =
638 { { "iso_latin_1", ENC_ISO_LATIN_1 },
639 { "locale", ENC_ANSI },
640 { "utf8", ENC_UTF8 },
641 { "unicode", ENC_SQLWCHAR },
642 { NULL }
643 };
644
645
646 static int
get_encoding(term_t t,IOENC * enc)647 get_encoding(term_t t, IOENC *enc)
648 { atom_t a;
649
650 if ( PL_get_atom(t, &a) )
651 { enc_name *en;
652
653 for(en=encodings; en->name; en++)
654 { if ( !en->a )
655 en->a = PL_new_atom(en->name);
656 if ( en->a == a )
657 { *enc = en->code;
658 return TRUE;
659 }
660 }
661 }
662
663 return FALSE;
664 }
665
666
667 static void
put_encoding(term_t t,IOENC enc)668 put_encoding(term_t t, IOENC enc)
669 { enc_name *en;
670
671 for(en=encodings; en->name; en++)
672 { if ( en->code == enc )
673 { if ( !en->a )
674 en->a = PL_new_atom(en->name);
675 PL_put_atom(t, en->a);
676 return;
677 }
678 }
679
680 assert(0);
681 }
682
683
684 static int
enc_to_rep(IOENC enc)685 enc_to_rep(IOENC enc)
686 { switch(enc)
687 { case ENC_ISO_LATIN_1:
688 return REP_ISO_LATIN_1;
689 case ENC_ANSI:
690 return REP_MB;
691 case ENC_UTF8:
692 return REP_UTF8;
693 case ENC_SQLWCHAR:
694 return 0; /* not used for wide characters */
695 default:
696 assert(0);
697 return 0;
698 }
699 }
700
701
702 static int
PL_get_typed_arg_ex(int i,term_t t,int (* func)(),const char * ex,void * ap)703 PL_get_typed_arg_ex(int i, term_t t, int (*func)(), const char *ex, void *ap)
704 { term_t a = PL_new_term_ref();
705
706 if ( !PL_get_arg(i, t, a) )
707 return type_error(t, "compound");
708 if ( !(*func)(a, ap) )
709 return type_error(a, ex);
710
711 return TRUE;
712 }
713
714 #define get_int_arg(i, t, n) \
715 PL_get_typed_arg(i, t, PL_get_integer, n)
716
717 static int
PL_get_typed_arg(int i,term_t t,int (* func)(),void * ap)718 PL_get_typed_arg(int i, term_t t, int (*func)(), void *ap)
719 { term_t a = PL_new_term_ref();
720
721 if ( !PL_get_arg(i, t, a) )
722 return FALSE;
723 return (*func)(a, ap);
724 }
725
726
727 static int
list_length(term_t list)728 list_length(term_t list)
729 { size_t len;
730
731 if ( PL_skip_list(list, 0, &len) == PL_LIST )
732 return (int)len;
733
734 type_error(list, "list");
735 return -1;
736 }
737
738
739 typedef struct odbc_version_name
740 { char *name;
741 intptr_t version;
742 atom_t a;
743 } odbc_version_name;
744
745 static odbc_version_name odbc_versions[] =
746 { { "2.0", SQL_OV_ODBC2 },
747 { "3.0", SQL_OV_ODBC3 },
748 { NULL }
749 };
750
751 static int
get_odbc_version(term_t t,intptr_t * ver)752 get_odbc_version(term_t t, intptr_t *ver)
753 { atom_t a;
754
755 if ( PL_get_atom_ex(t, &a) )
756 { odbc_version_name *v;
757
758 for(v=odbc_versions; v->name; v++)
759 { if ( !v->a )
760 v->a = PL_new_atom(v->name);
761 if ( v->a == a )
762 { *ver = v->version;
763 return TRUE;
764 }
765 }
766 }
767
768 return FALSE;
769 }
770
771
772 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
773 int formatted_string(Context, +Fmt-[Arg...])
774 Much like sformat, but this approach avoids avoids creating
775 intermediate Prolog data. Maybe we should publish pl_format()?
776 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
777
778 static int
formatted_string(context * ctxt,term_t in)779 formatted_string(context *ctxt, term_t in)
780 { term_t av = PL_new_term_refs(3);
781 static predicate_t format;
782 char *out = NULL;
783 size_t len = 0;
784 IOSTREAM *fd = Sopenmem(&out, &len, "w");
785
786 if ( !fd )
787 return FALSE; /* resource error */
788 if ( !format )
789 format = PL_predicate("format", 3, "user");
790
791 fd->encoding = ctxt->connection->encoding;
792 if ( !PL_unify_stream(av+0, fd) ||
793 !PL_get_arg(1, in, av+1) ||
794 !PL_get_arg(2, in, av+2) ||
795 !PL_call_predicate(NULL, PL_Q_PASS_EXCEPTION, format, av) )
796 { Sclose(fd);
797 if ( out )
798 PL_free(out);
799 return FALSE;
800 }
801 Sclose(fd);
802
803 if ( ctxt->connection->encoding == ENC_SQLWCHAR )
804 { ctxt->sqltext.w = (SQLWCHAR*)out;
805 ctxt->sqllen = (SQLINTEGER)(len/sizeof(SQLWCHAR)); /* TBD: Check range */
806 ctxt->char_width = sizeof(SQLWCHAR);
807 } else
808 { ctxt->sqltext.a = (unsigned char*)out;
809 ctxt->sqllen = (SQLINTEGER)len; /* TBD: Check range */
810 ctxt->char_width = sizeof(char);
811 }
812 set(ctxt, CTX_SQLMALLOCED);
813
814 return TRUE;
815 }
816
817
818 /*******************************
819 * NULL VALUES *
820 *******************************/
821
822 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
823 There are many ways one may wish to handle SQL null-values. These
824 functions deal with the three common ways specially and can deal with
825 arbitrary representations.
826 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
827
828 static nulldef *
nulldef_spec(term_t t)829 nulldef_spec(term_t t)
830 { atom_t a;
831 functor_t f;
832 nulldef *nd;
833
834 if ( !(nd=odbc_malloc(sizeof(*nd))) )
835 return NULL;
836
837 memset(nd, 0, sizeof(*nd));
838
839 if ( PL_get_atom(t, &a) )
840 { if ( a == ATOM_null )
841 { free(nd); /* TBD: not very elegant */
842 return NULL; /* default specifier */
843 }
844 nd->nulltype = NULL_ATOM;
845 nd->nullvalue.atom = a;
846 PL_register_atom(a); /* avoid atom-gc */
847 } else if ( PL_is_variable(t) )
848 { nd->nulltype = NULL_VAR;
849 } else if ( PL_get_functor(t, &f) &&
850 PL_functor_arity(f) == 1 )
851 { term_t a1 = PL_new_term_ref();
852
853 _PL_get_arg(1, t, a1);
854 if ( PL_is_variable(a1) )
855 { nd->nulltype = NULL_FUNCTOR;
856 nd->nullvalue.functor = f;
857 } else
858 goto term;
859 } else
860 { term:
861 nd->nulltype = NULL_RECORD;
862 nd->nullvalue.record = PL_record(t);
863 }
864
865 nd->references = 1;
866
867 return nd;
868 }
869
870
871 static nulldef *
clone_nulldef(nulldef * nd)872 clone_nulldef(nulldef *nd)
873 { if ( nd )
874 nd->references++;
875
876 return nd;
877 }
878
879
880 static void
free_nulldef(nulldef * nd)881 free_nulldef(nulldef *nd)
882 { if ( nd && --nd->references == 0 )
883 { switch(nd->nulltype)
884 { case NULL_ATOM:
885 PL_unregister_atom(nd->nullvalue.atom);
886 break;
887 case NULL_RECORD:
888 PL_erase(nd->nullvalue.record);
889 break;
890 default:
891 break;
892 }
893
894 free(nd);
895 }
896 }
897
898
899 WUNUSED static int
put_sql_null(term_t t,nulldef * nd)900 put_sql_null(term_t t, nulldef *nd)
901 { if ( nd )
902 { switch(nd->nulltype)
903 { case NULL_VAR:
904 return TRUE;
905 case NULL_ATOM:
906 return PL_put_atom(t, nd->nullvalue.atom);
907 case NULL_FUNCTOR:
908 return PL_put_functor(t, nd->nullvalue.functor);
909 case NULL_RECORD:
910 return PL_recorded(nd->nullvalue.record, t);
911 default:
912 assert(0);
913 return FALSE;
914 }
915 } else
916 return PL_put_atom(t, ATOM_null);
917 }
918
919
920 static int
is_sql_null(term_t t,nulldef * nd)921 is_sql_null(term_t t, nulldef *nd)
922 { if ( nd )
923 { switch(nd->nulltype)
924 { case NULL_VAR:
925 return PL_is_variable(t);
926 case NULL_ATOM:
927 { atom_t a;
928
929 return PL_get_atom(t, &a) && a == nd->nullvalue.atom;
930 }
931 case NULL_FUNCTOR:
932 return PL_is_functor(t, nd->nullvalue.functor);
933 case NULL_RECORD: /* TBD: Provide PL_unify_record */
934 { term_t rec = PL_new_term_ref();
935 PL_recorded(nd->nullvalue.record, rec);
936 return PL_unify(t, rec);
937 }
938 default: /* should not happen */
939 assert(0);
940 return FALSE;
941 }
942 } else
943 { atom_t a;
944
945 return PL_get_atom(t, &a) && a == ATOM_null;
946 }
947 }
948
949 /*******************************
950 * FINDALL(Term, row(X,...)) *
951 *******************************/
952
953 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
954 This section deals with the implementation of the statement option
955 findall(Template, row(Column,...)), returning a list of instances of
956 Template for each row.
957
958 Ideally, we should unify the row with the second argument and add the
959 first to the list. Unfortunately, we have to make fresh copies of the
960 findall/2 term for this to work, or we must protect the Template using a
961 record. Both approaches are slow and largely discard the purpose of the
962 option, which is to avoid findall/3 and its associated costs in terms of
963 copying and memory fragmentation.
964
965 The current implementation is incomplete. It does not allow arguments of
966 row(...) to be instantiated. Plain instantiation can always be avoided
967 using a proper SELECT statement. Potentionally useful however would be
968 the translation of compound terms, especially to translates
969 date/time/timestamp structures to a format for use by the application.
970
971 The statement is compiled into a findall statement, a set of
972 instructions that builds the target structure from the row returned by
973 the current statement.
974 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
975
976 #define MAXCODES 256
977 #define ROW_ARG 1024 /* way above Prolog types */
978
979 typedef struct
980 { term_t row; /* the row */
981 term_t tmp; /* scratch term */
982 size_t columns; /* arity of row-term */
983 unsigned flags; /* CTX_PERSISTENT */
984 int size; /* # codes */
985 code buf[MAXCODES];
986 } compile_info;
987
988 #define ADDCODE(info, val) (info->buf[info->size++] = (code)(val))
989 #define ADDCODE_1(info, v1, v2) ADDCODE(info, v1), ADDCODE(info, v2)
990
991 static int
nth_row_arg(compile_info * info,term_t var)992 nth_row_arg(compile_info *info, term_t var)
993 { int i;
994
995 for(i=1; i<=info->columns; i++)
996 { _PL_get_arg(i, info->row, info->tmp);
997 if ( PL_compare(info->tmp, var) == 0 )
998 return i;
999 }
1000
1001 return 0;
1002 }
1003
1004
1005 typedef union
1006 { code ascode[sizeof(double)/sizeof(code)];
1007 double asdouble;
1008 } u_double;
1009
1010
1011 static int
compile_arg(compile_info * info,term_t t)1012 compile_arg(compile_info *info, term_t t)
1013 { int tt;
1014
1015 switch((tt=PL_term_type(t)))
1016 { case PL_VARIABLE:
1017 { int nth;
1018
1019 if ( (nth=nth_row_arg(info, t)) )
1020 { ADDCODE_1(info, ROW_ARG, nth);
1021 } else
1022 ADDCODE(info, PL_VARIABLE);
1023 break;
1024 }
1025 case PL_ATOM:
1026 #ifdef PL_NIL
1027 case PL_NIL:
1028 #endif
1029 { atom_t val;
1030
1031 if ( !PL_get_atom(t, &val) )
1032 assert(0);
1033 ADDCODE_1(info, PL_ATOM, val);
1034 if ( true(info, CTX_PERSISTENT) )
1035 PL_register_atom(val);
1036 break;
1037 }
1038 case PL_STRING:
1039 case PL_FLOAT:
1040 if ( true(info, CTX_PERSISTENT) )
1041 { if ( tt == PL_FLOAT )
1042 { u_double v;
1043 unsigned int i;
1044
1045 if ( !PL_get_float(t, &v.asdouble) )
1046 assert(0);
1047 ADDCODE(info, PL_FLOAT);
1048 for(i=0; i<sizeof(double)/sizeof(code); i++)
1049 ADDCODE(info, v.ascode[i]);
1050 } else /* string */
1051 { size_t len;
1052 char *s, *cp = NULL;
1053 wchar_t *w = NULL;
1054 int flags = 0;
1055
1056 if (PL_get_string_chars(t, &s, &len))
1057 { if ( !(cp = odbc_malloc(len+1)) )
1058 return FALSE;
1059 memcpy(cp, s, len+1);
1060 } else if (PL_get_wchars(t, &len, &w, CVT_STRING|CVT_EXCEPTION))
1061 { if ( !(cp = odbc_malloc((len+1)*sizeof(wchar_t))) )
1062 return FALSE;
1063 memcpy(cp, w, (len+1)*sizeof(wchar_t));
1064 flags |= PL_BLOB_WCHAR;
1065 } else {
1066 return FALSE;
1067 }
1068 ADDCODE(info, PL_STRING);
1069 ADDCODE(info, flags);
1070 ADDCODE(info, len);
1071 ADDCODE(info, cp);
1072 }
1073 } else
1074 { term_t cp = PL_copy_term_ref(t);
1075 ADDCODE_1(info, PL_TERM, cp);
1076 }
1077 break;
1078 case PL_INTEGER:
1079 { int64_t v;
1080
1081 if ( !PL_get_int64(t, &v) )
1082 return PL_domain_error("int64", t);
1083 ADDCODE_1(info, PL_INTEGER, v);
1084 break;
1085 }
1086 case PL_TERM:
1087 #ifdef PL_LIST_PAIR
1088 case PL_LIST_PAIR:
1089 #endif
1090 { functor_t f;
1091 int i, arity;
1092 term_t a = PL_new_term_ref();
1093
1094 if ( !PL_get_functor(t, &f) )
1095 assert(0);
1096 arity = PL_functor_arity(f);
1097 ADDCODE_1(info, PL_FUNCTOR, f);
1098 for(i=1; i<=arity; i++)
1099 { _PL_get_arg(i, t, a);
1100 if ( !compile_arg(info, a) )
1101 return FALSE;
1102 }
1103 break;
1104 }
1105 default:
1106 assert(0);
1107 }
1108
1109 return TRUE;
1110 }
1111
1112
1113 static findall *
compile_findall(term_t all,unsigned flags)1114 compile_findall(term_t all, unsigned flags)
1115 { compile_info info;
1116 term_t t = PL_new_term_ref();
1117 atom_t a;
1118 findall *f;
1119 int i;
1120
1121 info.tmp = PL_new_term_ref();
1122 info.row = PL_new_term_ref();
1123 info.size = 0;
1124 info.flags = flags;
1125
1126 if ( !PL_get_arg(2, all, info.row) ||
1127 !PL_get_name_arity(info.row, &a, &info.columns) )
1128 return NULL;
1129
1130 for(i=1; i<=info.columns; i++)
1131 { if ( !PL_get_arg(i, info.row, t) )
1132 return NULL;
1133 if ( !PL_is_variable(t) )
1134 { type_error(t, "unbound");
1135 return NULL;
1136 }
1137 }
1138
1139 if ( !PL_get_arg(1, all, t) )
1140 return NULL;
1141 if ( !compile_arg(&info, t) )
1142 return NULL;
1143
1144 if ( !(f = odbc_malloc(FND_SIZE(info.size))) )
1145 return NULL;
1146 f->references = 1;
1147 f->flags = flags;
1148 memcpy(f->codes, info.buf, sizeof(code)*info.size);
1149
1150 return f;
1151 }
1152
1153
1154 static findall *
clone_findall(findall * in)1155 clone_findall(findall *in)
1156 { if ( in )
1157 in->references++;
1158 return in;
1159 }
1160
1161
1162 static code *
unregister_code(code * PC)1163 unregister_code(code *PC)
1164 { switch((int)*PC++)
1165 { case PL_VARIABLE:
1166 return PC;
1167 case ROW_ARG: /* 1-based column */
1168 case PL_INTEGER:
1169 case PL_TERM:
1170 return PC+1;
1171 case PL_ATOM:
1172 PL_unregister_atom((atom_t)*PC++);
1173 return PC;
1174 case PL_FLOAT:
1175 return PC+sizeof(double)/sizeof(code);
1176 case PL_STRING:
1177 { char *s = (char*)PC[2];
1178 free(s);
1179 return PC+3;
1180 }
1181 case PL_FUNCTOR:
1182 { functor_t f = (functor_t)*PC++;
1183 int i, arity = PL_functor_arity(f);
1184
1185 for(i=0;i<arity;i++)
1186 { if ( !(PC=unregister_code(PC)) )
1187 return NULL;
1188 }
1189
1190 return PC;
1191 }
1192 default:
1193 assert(0);
1194 return NULL;
1195 }
1196 }
1197
1198
1199 static void
free_findall(findall * in)1200 free_findall(findall *in)
1201 { if ( in && --in->references == 0 )
1202 { if ( true(in, CTX_PERSISTENT) )
1203 unregister_code(in->codes);
1204
1205 free(in);
1206 }
1207 }
1208
1209
1210 static code *
build_term(context * ctxt,code * PC,term_t result)1211 build_term(context *ctxt, code *PC, term_t result)
1212 { switch((int)*PC++)
1213 { case PL_VARIABLE:
1214 return PC;
1215 case ROW_ARG: /* 1-based column */
1216 { int column = (int)*PC++;
1217 if ( pl_put_column(ctxt, column-1, result) )
1218 return PC;
1219 return NULL;
1220 }
1221 case PL_ATOM:
1222 { PL_put_atom(result, (atom_t)*PC++);
1223 return PC;
1224 }
1225 case PL_FLOAT:
1226 { u_double v;
1227 unsigned int i;
1228
1229 for(i=0; i<sizeof(double)/sizeof(code); i++)
1230 v.ascode[i] = *PC++;
1231 if ( !PL_put_float(result, v.asdouble) )
1232 return NULL;
1233 return PC;
1234 }
1235 case PL_STRING:
1236 { if (((int)*PC++)&PL_BLOB_WCHAR)
1237 { size_t len = (size_t)*PC++;
1238 wchar_t *w = (wchar_t*)*PC++;
1239 if ( !PL_unify_wchars(result, PL_STRING, len, w) )
1240 return NULL;
1241 } else
1242 { size_t len = (size_t)*PC++;
1243 char *s = (char*)*PC++;
1244 if ( !PL_put_string_nchars(result, len, s) )
1245 return NULL;
1246 }
1247 return PC;
1248 }
1249 case PL_INTEGER:
1250 { if ( !PL_put_int64(result, (int64_t)*PC++) )
1251 return NULL;
1252 return PC;
1253 }
1254 case PL_TERM:
1255 { if ( !PL_put_term(result, (term_t)*PC++) )
1256 return NULL;
1257 return PC;
1258 }
1259 case PL_FUNCTOR:
1260 { functor_t f = (functor_t)*PC++;
1261 int i, arity = PL_functor_arity(f);
1262 term_t av = PL_new_term_refs(arity);
1263
1264 for(i=0;i<arity;i++)
1265 { if ( !(PC=build_term(ctxt, PC, av+i)) )
1266 return NULL;
1267 }
1268
1269 if ( !PL_cons_functor_v(result, f, av) )
1270 return NULL;
1271 PL_reset_term_refs(av);
1272 return PC;
1273 }
1274 default:
1275 assert(0);
1276 return NULL;
1277 }
1278 }
1279
1280
1281 static int
put_findall(context * ctxt,term_t result)1282 put_findall(context *ctxt, term_t result)
1283 { PL_put_variable(result);
1284 if ( build_term(ctxt, ctxt->findall->codes, result) )
1285 return TRUE;
1286
1287 return FALSE;
1288 }
1289
1290
1291
1292 /*******************************
1293 * CONNECTION *
1294 *******************************/
1295
1296 static connection *connections;
1297
1298 static connection *
find_connection(atom_t alias)1299 find_connection(atom_t alias)
1300 { connection *c;
1301
1302 LOCK();
1303 for(c=connections; c; c=c->next)
1304 { if ( c->alias == alias )
1305 { UNLOCK();
1306 return c;
1307 }
1308 }
1309 UNLOCK();
1310
1311 return NULL;
1312 }
1313
1314
1315 static connection *
find_connection_from_dsn(atom_t dsn)1316 find_connection_from_dsn(atom_t dsn)
1317 { connection *c;
1318
1319 LOCK();
1320 for(c=connections; c; c=c->next)
1321 { if ( c->dsn == dsn )
1322 { UNLOCK();
1323 return c;
1324 }
1325 }
1326 UNLOCK();
1327
1328 return NULL;
1329 }
1330
1331
1332 static connection *
alloc_connection(atom_t alias,atom_t dsn)1333 alloc_connection(atom_t alias, atom_t dsn)
1334 { connection *c;
1335
1336 if ( alias && find_connection(alias) )
1337 return NULL; /* already existenting */
1338
1339 if ( !(c = odbc_malloc(sizeof(*c))) )
1340 return NULL;
1341 memset(c, 0, sizeof(*c));
1342 c->alias = alias;
1343 c->magic = CON_MAGIC;
1344 if ( alias )
1345 PL_register_atom(alias);
1346 c->dsn = dsn;
1347 PL_register_atom(dsn);
1348 c->max_nogetdata = MAX_NOGETDATA;
1349
1350 LOCK();
1351 c->next = connections;
1352 connections = c;
1353 UNLOCK();
1354
1355 return c;
1356 }
1357
1358
1359 static void
free_connection(connection * c)1360 free_connection(connection *c)
1361 { LOCK();
1362 if ( c == connections )
1363 connections = c->next;
1364 else
1365 { connection *c2;
1366
1367 for(c2 = connections; c2; c2 = c2->next)
1368 { if ( c2->next == c )
1369 { c2->next = c->next;
1370 break;
1371 }
1372 }
1373 }
1374 UNLOCK();
1375
1376 if ( c->alias )
1377 PL_unregister_atom(c->alias);
1378 if ( c->dsn )
1379 PL_unregister_atom(c->dsn);
1380 free_nulldef(c->null);
1381
1382 free(c);
1383 }
1384
1385
1386 static int
get_connection(term_t tcid,connection ** cn)1387 get_connection(term_t tcid, connection **cn)
1388 { atom_t alias;
1389 connection *c;
1390
1391 if ( PL_is_functor(tcid, FUNCTOR_odbc_connection1) )
1392 { term_t a = PL_new_term_ref();
1393 void *ptr;
1394
1395 _PL_get_arg(1, tcid, a);
1396 if ( !PL_get_pointer(a, &ptr) )
1397 return type_error(tcid, "odbc_connection");
1398 c = ptr;
1399
1400 if ( c->magic != CON_MAGIC )
1401 return existence_error(tcid, "odbc_connection");
1402 } else
1403 { if ( !PL_get_atom(tcid, &alias) )
1404 return type_error(tcid, "odbc_connection");
1405 if ( !(c=find_connection(alias)) )
1406 return existence_error(tcid, "odbc_connection");
1407 }
1408
1409 *cn = c;
1410
1411 return TRUE;
1412 }
1413
1414
1415 static int
unify_connection(term_t t,connection * cn)1416 unify_connection(term_t t, connection *cn)
1417 { if ( cn->alias )
1418 return PL_unify_atom(t, cn->alias);
1419
1420 return PL_unify_term(t, PL_FUNCTOR, FUNCTOR_odbc_connection1,
1421 PL_POINTER, cn);
1422 }
1423
1424
1425 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1426 odbc_connect(+DSN, -Connection, +Options)
1427 Create a new connection. Option is a list of options with the
1428 following standards:
1429
1430 user(User)
1431
1432 password(Password)
1433
1434 alias(Name)
1435 Alias-name for the connection.
1436 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1437
1438 #define MAX_AFTER_OPTIONS 10
1439
1440 static foreign_t
pl_odbc_connect(term_t tdsource,term_t cid,term_t options)1441 pl_odbc_connect(term_t tdsource, term_t cid, term_t options)
1442 { atom_t dsn;
1443 const char *dsource; /* odbc data source */
1444 char *uid = NULL; /* user id */
1445 char *pwd = NULL; /* password */
1446 char *driver_string = NULL; /* driver_string */
1447 atom_t alias = 0; /* alias-name */
1448 IOENC encoding = DEFAULT_ENCODING; /* Connection encoding */
1449 int mars = 0; /* mars-value */
1450 atom_t pool_mode = 0; /* Connection pooling mode */
1451 intptr_t odbc_version = SQL_OV_ODBC3; /* ODBC connectivity version */
1452 atom_t open = 0; /* open next connection */
1453 RETCODE rc; /* result code for ODBC functions */
1454 HDBC hdbc;
1455 connection *cn;
1456 term_t tail = PL_copy_term_ref(options);
1457 term_t head = PL_new_term_ref();
1458 term_t after_open = PL_new_term_refs(MAX_AFTER_OPTIONS);
1459 int i, nafter = 0;
1460 int silent = FALSE;
1461
1462 /* Read parameters from terms. */
1463 if ( !PL_get_atom(tdsource, &dsn) )
1464 return type_error(tdsource, "atom");
1465
1466 while(PL_get_list(tail, head, tail))
1467 { if ( PL_is_functor(head, FUNCTOR_user1) )
1468 { if ( !get_name_arg_ex(1, head, &uid) )
1469 return FALSE;
1470 } else if ( PL_is_functor(head, FUNCTOR_password1) )
1471 { if ( !get_text_arg_ex(1, head, &pwd) )
1472 return FALSE;
1473 } else if ( PL_is_functor(head, FUNCTOR_alias1) )
1474 { if ( !get_atom_arg_ex(1, head, &alias) )
1475 return FALSE;
1476 } else if ( PL_is_functor(head, FUNCTOR_driver_string1) )
1477 { if ( !get_text_arg_ex(1, head, &driver_string) )
1478 return FALSE;
1479 } else if ( PL_is_functor(head, FUNCTOR_mars1) )
1480 { if ( !get_bool_arg_ex(1, head, &mars) )
1481 return FALSE;
1482 } else if ( PL_is_functor(head, FUNCTOR_connection_pool_mode1) )
1483 { if ( !get_atom_arg_ex(1, head, &pool_mode) )
1484 return FALSE;
1485 if ( pool_mode != ATOM_strict && pool_mode != ATOM_relaxed )
1486 return domain_error(head, "pool_mode");
1487 } else if ( PL_is_functor(head, FUNCTOR_odbc_version1) )
1488 { if ( !get_odbc_version_arg_ex(1, head, &odbc_version) )
1489 return FALSE;
1490 } else if ( PL_is_functor(head, FUNCTOR_open1) )
1491 { if ( !get_atom_arg_ex(1, head, &open) )
1492 return FALSE;
1493 if ( !(open == ATOM_once ||
1494 open == ATOM_multiple) )
1495 return domain_error(head, "open_mode");
1496 } else if ( PL_is_functor(head, FUNCTOR_silent1) )
1497 { if ( !get_bool_arg_ex(1, head, &silent) )
1498 return FALSE;
1499 } else if ( PL_is_functor(head, FUNCTOR_encoding1) )
1500 { if ( !get_encoding_arg_ex(1, head, &encoding) )
1501 return FALSE;
1502 } else if ( PL_is_functor(head, FUNCTOR_auto_commit1) ||
1503 PL_is_functor(head, FUNCTOR_null1) ||
1504 PL_is_functor(head, FUNCTOR_access_mode1) ||
1505 PL_is_functor(head, FUNCTOR_cursor_type1) ||
1506 PL_is_functor(head, FUNCTOR_wide_column_threshold1) )
1507 { if ( nafter < MAX_AFTER_OPTIONS )
1508 { if ( !PL_put_term(after_open+nafter++, head) )
1509 return FALSE;
1510 } else
1511 return PL_warning("Too many options"); /* shouldn't happen */
1512 } else
1513 return domain_error(head, "odbc_option");
1514 }
1515 if ( !PL_get_nil(tail) )
1516 return type_error(tail, "list");
1517
1518 if ( !open )
1519 open = alias ? ATOM_once : ATOM_multiple;
1520 if ( open == ATOM_once && (cn = find_connection_from_dsn(dsn)) )
1521 { if ( alias && cn->alias != alias )
1522 { if ( !cn->alias )
1523 { if ( !find_connection(alias) )
1524 { cn->alias = alias;
1525 PL_register_atom(alias);
1526 } else
1527 return PL_warning("Alias already in use");
1528 } else
1529 return PL_warning("Cannot redefined connection alias");
1530 }
1531 return unify_connection(cid, cn);
1532 }
1533
1534 dsource = PL_atom_chars(dsn);
1535
1536 LOCK();
1537 if ( !henv )
1538 { if ( (rc=SQLAllocEnv(&henv)) != SQL_SUCCESS )
1539 { UNLOCK();
1540 return PL_warning("Could not initialise SQL environment");
1541 }
1542 if ( (rc=SQLSetEnvAttr(henv,
1543 SQL_ATTR_ODBC_VERSION,
1544 (SQLPOINTER) odbc_version,
1545 0)) != SQL_SUCCESS )
1546 { UNLOCK();
1547 return odbc_report(henv, NULL, NULL, rc);
1548 }
1549 }
1550 UNLOCK();
1551
1552 if ( (rc=SQLAllocConnect(henv, &hdbc)) != SQL_SUCCESS )
1553 return odbc_report(henv, NULL, NULL, rc);
1554
1555 if ( mars )
1556 { if ( (rc=SQLSetConnectAttr(hdbc,
1557 SQL_COPT_SS_MARS_ENABLED,
1558 SQL_MARS_ENABLED_YES,
1559 SQL_IS_UINTEGER)) != SQL_SUCCESS )
1560 { SQLFreeConnect(hdbc);
1561 return odbc_report(henv, NULL, NULL, rc);
1562 }
1563 }
1564
1565 if ( pool_mode )
1566 { SQLPOINTER pool_arg = (SQLPOINTER)0;
1567 if (pool_mode == ATOM_strict)
1568 pool_arg = (SQLPOINTER)SQL_CP_STRICT_MATCH;
1569 else if (pool_mode == ATOM_relaxed)
1570 pool_arg = (SQLPOINTER)SQL_CP_RELAXED_MATCH;
1571 if ( (rc=SQLSetConnectAttr(hdbc,
1572 SQL_ATTR_CP_MATCH,
1573 pool_arg,
1574 SQL_IS_INTEGER)) != SQL_SUCCESS )
1575 { SQLFreeConnect(hdbc);
1576 return odbc_report(henv, NULL, NULL, rc);
1577 }
1578 }
1579
1580
1581 /* Connect to a data source. */
1582 if ( driver_string != NULL )
1583 { if ( uid != NULL )
1584 { SQLFreeConnect(hdbc);
1585 return context_error(options, "Option incompatible with driver_string",
1586 "user");
1587 } else if ( pwd != NULL )
1588 { SQLFreeConnect(hdbc);
1589 return context_error(options, "Option incompatible with driver_string",
1590 "password");
1591 } else
1592 { SQLCHAR connection_out[1025]; /* completed driver string */
1593 SQLSMALLINT connection_out_len;
1594
1595 rc = SQLDriverConnect(hdbc,
1596 NULL, /* window handle */
1597 (SQLCHAR *)driver_string, SQL_NTS,
1598 connection_out, 1024,
1599 &connection_out_len,
1600 SQL_DRIVER_NOPROMPT);
1601 }
1602 } else
1603 { rc = SQLConnect(hdbc, (SQLCHAR *)dsource, SQL_NTS,
1604 (SQLCHAR *)uid, SQL_NTS,
1605 (SQLCHAR *)pwd, SQL_NTS);
1606 }
1607 if ( rc == SQL_ERROR )
1608 { odbc_report(henv, hdbc, NULL, rc);
1609 SQLFreeConnect(hdbc);
1610 return FALSE;
1611 }
1612 if ( rc != SQL_SUCCESS && !silent && !odbc_report(henv, hdbc, NULL, rc) )
1613 { SQLFreeConnect(hdbc);
1614 return FALSE;
1615 }
1616
1617 if ( !(cn=alloc_connection(alias, dsn)) )
1618 { SQLFreeConnect(hdbc);
1619 return FALSE;
1620 }
1621 if ( silent )
1622 set(cn, CTX_SILENT);
1623
1624 cn->encoding = encoding;
1625 cn->rep_flag = enc_to_rep(encoding);
1626 cn->hdbc = hdbc;
1627
1628 if ( !unify_connection(cid, cn) )
1629 { SQLFreeConnect(hdbc);
1630 free_connection(cn);
1631 return FALSE;
1632 }
1633
1634 DEBUG(3, Sdprintf("Processing %d `after' options\n", nafter));
1635 for(i=0; i<nafter; i++)
1636 { if ( !odbc_set_connection(cn, after_open+i) )
1637 { SQLFreeConnect(hdbc);
1638 free_connection(cn);
1639 return FALSE;
1640 }
1641 }
1642
1643 return TRUE;
1644 }
1645
1646
1647 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1648 odbc_disconnect(+Connection)
1649 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1650
1651 #define TRY_CN(cn, action) \
1652 { RETCODE rc = action; \
1653 if ( rc != SQL_SUCCESS ) \
1654 return odbc_report(henv, cn->hdbc, NULL, rc); \
1655 }
1656
1657
1658 static foreign_t
pl_odbc_disconnect(term_t conn)1659 pl_odbc_disconnect(term_t conn)
1660 { connection *cn;
1661
1662 if ( !get_connection(conn, &cn) )
1663 return FALSE;
1664
1665 TRY_CN(cn, SQLDisconnect(cn->hdbc)); /* Disconnect from the data source */
1666 TRY_CN(cn, SQLFreeConnect(cn->hdbc)); /* Free the connection handle */
1667 free_connection(cn);
1668
1669 return TRUE;
1670 }
1671
1672
1673 static int
add_cid_dsn_pair(term_t list,connection * cn)1674 add_cid_dsn_pair(term_t list, connection *cn)
1675 { term_t cnterm = PL_new_term_ref();
1676 term_t head = PL_new_term_ref();
1677
1678 if ( PL_unify_list(list, head, list) &&
1679 unify_connection(cnterm, cn) &&
1680 PL_unify_term(head, PL_FUNCTOR, FUNCTOR_minus2,
1681 PL_TERM, cnterm,
1682 PL_ATOM, cn->dsn) )
1683 { PL_reset_term_refs(cnterm);
1684 return TRUE;
1685 }
1686
1687 return FALSE;
1688 }
1689
1690
1691 static foreign_t
odbc_current_connections(term_t cid,term_t dsn,term_t pairs)1692 odbc_current_connections(term_t cid, term_t dsn, term_t pairs)
1693 { atom_t dsn_a;
1694 term_t tail = PL_copy_term_ref(pairs);
1695 connection *cn;
1696
1697 if ( !PL_get_atom(dsn, &dsn_a) )
1698 dsn_a = 0;
1699
1700 if ( !PL_is_variable(cid) )
1701 { if ( get_connection(cid, &cn) &&
1702 (!dsn_a || cn->dsn == dsn_a) )
1703 return ( add_cid_dsn_pair(tail, cn) &&
1704 PL_unify_nil(tail)
1705 );
1706
1707 return FALSE;
1708 }
1709
1710 LOCK();
1711 for(cn=connections; cn; cn=cn->next)
1712 { if ( (!dsn_a || cn->dsn == dsn_a) )
1713 { if ( !add_cid_dsn_pair(tail, cn) )
1714 { UNLOCK();
1715 return FALSE;
1716 }
1717 }
1718 }
1719 UNLOCK();
1720
1721 return PL_unify_nil(tail);
1722 }
1723
1724
1725 static foreign_t
odbc_set_connection(connection * cn,term_t option)1726 odbc_set_connection(connection *cn, term_t option)
1727 { RETCODE rc;
1728 UWORD opt;
1729 UDWORD optval;
1730
1731 if ( PL_is_functor(option, FUNCTOR_auto_commit1) )
1732 { int val;
1733
1734 if ( !get_bool_arg_ex(1, option, &val) )
1735 return FALSE;
1736 opt = SQL_AUTOCOMMIT;
1737 optval = (val ? SQL_AUTOCOMMIT_ON : SQL_AUTOCOMMIT_OFF);
1738 } else if ( PL_is_functor(option, FUNCTOR_access_mode1) )
1739 { atom_t val;
1740
1741 if ( !get_atom_arg_ex(1, option, &val) )
1742 return FALSE;
1743 opt = SQL_ACCESS_MODE;
1744
1745 if ( val == ATOM_read )
1746 optval = SQL_MODE_READ_ONLY;
1747 else if ( val == ATOM_update )
1748 optval = SQL_MODE_READ_WRITE;
1749 else
1750 return domain_error(val, "access_mode");
1751 } else if ( PL_is_functor(option, FUNCTOR_cursor_type1) )
1752 { atom_t val;
1753
1754 if ( !get_atom_arg_ex(1, option, &val) )
1755 return FALSE;
1756 opt = SQL_CURSOR_TYPE;
1757
1758 if ( val == ATOM_dynamic )
1759 optval = SQL_CURSOR_DYNAMIC;
1760 else if ( val == ATOM_forwards_only )
1761 optval = SQL_CURSOR_FORWARD_ONLY;
1762 else if ( val == ATOM_keyset_driven )
1763 optval = SQL_CURSOR_KEYSET_DRIVEN;
1764 else if ( val == ATOM_static )
1765 optval = SQL_CURSOR_STATIC;
1766 else
1767 return domain_error(val, "cursor_type");
1768 } else if ( PL_is_functor(option, FUNCTOR_silent1) )
1769 { int val;
1770
1771 if ( !get_bool_arg_ex(1, option, &val) )
1772 return FALSE;
1773
1774 set(cn, CTX_SILENT);
1775
1776 return TRUE;
1777 } else if ( PL_is_functor(option, FUNCTOR_encoding1) )
1778 { IOENC val;
1779
1780 if ( !get_encoding_arg_ex(1, option, &val) )
1781 return FALSE;
1782
1783 cn->encoding = val;
1784 cn->rep_flag = enc_to_rep(val);
1785
1786 return TRUE;
1787 } else if ( PL_is_functor(option, FUNCTOR_null1) )
1788 { term_t a = PL_new_term_ref();
1789
1790 _PL_get_arg(1, option, a);
1791 cn->null = nulldef_spec(a);
1792
1793 return TRUE;
1794 } else if ( PL_is_functor(option, FUNCTOR_wide_column_threshold1) )
1795 { int val;
1796
1797 if ( !get_int_arg_ex(1, option, &val) )
1798 return FALSE;
1799 DEBUG(2, Sdprintf("Using wide_column_threshold = %d\n", val));
1800 cn->max_nogetdata = val;
1801
1802 return TRUE;
1803 } else
1804 return domain_error(option, "odbc_option");
1805
1806 if ( (rc=SQLSetConnectOption(cn->hdbc, opt, optval)) != SQL_SUCCESS )
1807 return odbc_report(henv, cn->hdbc, NULL, rc);
1808
1809 return TRUE;
1810 }
1811
1812
1813 static foreign_t
pl_odbc_set_connection(term_t con,term_t option)1814 pl_odbc_set_connection(term_t con, term_t option)
1815 { connection *cn;
1816
1817 if ( !get_connection(con, &cn) )
1818 return FALSE;
1819
1820 return odbc_set_connection(cn, option);
1821 }
1822
1823
1824 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1825 Options for SQLGetInfo() from http://msdn.microsoft.com/library/default.asp?url=/library/en-us/odbcsql/od_odbc_c_9qp1.asp
1826 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1827
1828 typedef struct
1829 { const char *name;
1830 UWORD id;
1831 enum { text, sword, ioenc } type;
1832 functor_t functor;
1833 } conn_option;
1834
1835 static conn_option conn_option_list[] =
1836 { { "database_name", SQL_DATABASE_NAME, text },
1837 { "dbms_name", SQL_DBMS_NAME, text },
1838 { "dbms_version", SQL_DBMS_VER, text },
1839 { "driver_name", SQL_DRIVER_NAME, text },
1840 { "driver_odbc_version", SQL_DRIVER_ODBC_VER, text },
1841 { "driver_version", SQL_DRIVER_VER, text },
1842 { "active_statements", SQL_ACTIVE_STATEMENTS, sword },
1843 { "encoding", 0, ioenc },
1844 { NULL, 0 }
1845 };
1846
1847 static foreign_t
odbc_get_connection(term_t conn,term_t option,control_t h)1848 odbc_get_connection(term_t conn, term_t option, control_t h)
1849 { connection *cn;
1850 conn_option *opt;
1851 functor_t f;
1852 term_t a, val;
1853
1854 switch(PL_foreign_control(h))
1855 { case PL_FIRST_CALL:
1856 if ( !get_connection(conn, &cn) )
1857 return FALSE;
1858
1859 opt = conn_option_list;
1860
1861 if ( PL_get_functor(option, &f) )
1862 { goto find;
1863 } else if ( PL_is_variable(option) )
1864 { f = 0;
1865 goto find;
1866 } else
1867 return type_error(option, "odbc_option");
1868 case PL_REDO:
1869 if ( !get_connection(conn, &cn) )
1870 return FALSE;
1871
1872 f = 0;
1873 opt = PL_foreign_context_address(h);
1874
1875 goto find;
1876 case PL_PRUNED:
1877 default:
1878 return TRUE;
1879 }
1880
1881 find:
1882 val = PL_new_term_ref();
1883 a = PL_new_term_ref();
1884 _PL_get_arg(1, option, a);
1885
1886 for(; opt->name; opt++)
1887 { if ( !opt->functor )
1888 opt->functor = PL_new_functor(PL_new_atom(opt->name), 1);
1889
1890 if ( !f || opt->functor == f )
1891 { char buf[256];
1892 SWORD len;
1893 RETCODE rc;
1894
1895 if ( opt->type == ioenc )
1896 { put_encoding(val, cn->encoding);
1897 } else
1898 { if ( (rc=SQLGetInfo(cn->hdbc, opt->id,
1899 buf, sizeof(buf), &len)) != SQL_SUCCESS )
1900 { if ( f )
1901 return odbc_report(henv, cn->hdbc, NULL, rc);
1902 else
1903 continue;
1904 }
1905
1906 switch( opt->type )
1907 { case text:
1908 PL_put_atom_nchars(val, len, buf);
1909 break;
1910 case sword:
1911 { SQLSMALLINT *p = (SQLSMALLINT*)buf;
1912 SQLSMALLINT v = *p;
1913
1914 if ( !PL_put_integer(val, v) )
1915 return FALSE;
1916 break;
1917 }
1918 default:
1919 assert(0);
1920 return FALSE;
1921 }
1922 }
1923
1924 if ( f )
1925 return PL_unify(a, val);
1926
1927 if ( !PL_unify_term(option,
1928 PL_FUNCTOR, opt->functor,
1929 PL_TERM, val) )
1930 return FALSE;
1931
1932 if ( opt[1].name )
1933 PL_retry_address(opt+1);
1934 else
1935 return TRUE;
1936 }
1937 }
1938
1939 if ( f )
1940 return domain_error(option, "odbc_option");
1941
1942 return FALSE;
1943 }
1944
1945
1946 static foreign_t
odbc_end_transaction(term_t conn,term_t action)1947 odbc_end_transaction(term_t conn, term_t action)
1948 { connection *cn;
1949 RETCODE rc;
1950 UWORD opt;
1951 atom_t a;
1952
1953
1954 if ( !get_connection(conn, &cn) )
1955 return FALSE;
1956
1957 if ( !PL_get_atom(action, &a) )
1958 return type_error(action, "atom");
1959 if ( a == ATOM_commit )
1960 { opt = SQL_COMMIT;
1961 } else if ( a == ATOM_rollback )
1962 { opt = SQL_ROLLBACK;
1963 } else
1964 return domain_error(action, "transaction");
1965
1966 if ( (rc=SQLTransact(henv, cn->hdbc, opt)) != SQL_SUCCESS )
1967 return odbc_report(henv, cn->hdbc, NULL, rc);
1968
1969 return TRUE;
1970 }
1971
1972
1973 /*******************************
1974 * CONTEXT (STATEMENTS) *
1975 *******************************/
1976
1977 static context** executing_contexts = NULL;
1978 static int executing_context_size = 0;
1979
1980 static context *
new_context(connection * cn)1981 new_context(connection *cn)
1982 { context *ctxt = odbc_malloc(sizeof(context));
1983 RETCODE rc;
1984
1985 if ( !ctxt )
1986 return NULL;
1987 memset(ctxt, 0, sizeof(*ctxt));
1988 ctxt->magic = CTX_MAGIC;
1989 ctxt->henv = henv;
1990 ctxt->connection = cn;
1991 ctxt->null = cn->null;
1992 ctxt->flags = cn->flags;
1993 ctxt->max_nogetdata = cn->max_nogetdata;
1994 if ( (rc=SQLAllocStmt(cn->hdbc, &ctxt->hstmt)) != SQL_SUCCESS )
1995 { odbc_report(henv, cn->hdbc, NULL, rc);
1996 free(ctxt);
1997 return NULL;
1998 }
1999 statistics.statements_created++;
2000
2001 return ctxt;
2002 }
2003
2004
2005 static void
unmark_and_close_context(context * ctxt)2006 unmark_and_close_context(context *ctxt)
2007 { LOCK_CONTEXTS();
2008 clear(ctxt, CTX_EXECUTING);
2009 executing_contexts[PL_thread_self()] = NULL;
2010 UNLOCK_CONTEXTS();
2011 close_context(ctxt);
2012 }
2013
2014 static void
close_context(context * ctxt)2015 close_context(context *ctxt)
2016 { clear(ctxt, CTX_INUSE);
2017
2018 if ( ctxt->flags & CTX_PERSISTENT )
2019 { if ( ctxt->hstmt )
2020 { ctxt->rc = SQLFreeStmt(ctxt->hstmt, SQL_CLOSE);
2021 if ( ctxt->rc == SQL_ERROR )
2022 report_status(ctxt);
2023 }
2024 } else
2025 free_context(ctxt);
2026 }
2027
2028
2029 static void
free_parameters(int n,parameter * params)2030 free_parameters(int n, parameter *params)
2031 { if ( n && params )
2032 { parameter *p = params;
2033 int i;
2034
2035 for (i=0; i<n; i++, p++)
2036 { if ( p->ptr_value &&
2037 p->ptr_value != (SQLPOINTER)p->buf &&
2038 p->len_value != SQL_LEN_DATA_AT_EXEC(0) ) /* Using SQLPutData() */
2039 free(p->ptr_value);
2040 if ( p->source.table )
2041 PL_unregister_atom(p->source.table);
2042 if ( p->source.column )
2043 PL_unregister_atom(p->source.column);
2044 }
2045
2046 free(params);
2047 }
2048 }
2049
2050
2051 static void
free_context(context * ctx)2052 free_context(context *ctx)
2053 { if ( ctx->magic != CTX_MAGIC )
2054 { if ( ctx->magic == CTX_FREEMAGIC )
2055 Sdprintf("ODBC: Trying to free context twice: %p\n", ctx);
2056 else
2057 Sdprintf("ODBC: Trying to free non-context: %p\n", ctx);
2058
2059 return;
2060 }
2061
2062 ctx->magic = CTX_FREEMAGIC;
2063
2064 if ( ctx->hstmt )
2065 { ctx->rc = SQLFreeStmt(ctx->hstmt, SQL_DROP);
2066 if ( ctx->rc == SQL_ERROR )
2067 report_status(ctx);
2068 }
2069
2070 free_parameters(ctx->NumCols, ctx->result);
2071 free_parameters(ctx->NumParams, ctx->params);
2072 if ( true(ctx, CTX_SQLMALLOCED) )
2073 PL_free(ctx->sqltext.a);
2074 if ( true(ctx, CTX_OWNNULL) )
2075 free_nulldef(ctx->null);
2076 if ( ctx->findall )
2077 free_findall(ctx->findall);
2078 free(ctx);
2079
2080 statistics.statements_freed++;
2081 }
2082
2083
2084 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2085 clone_context()
2086
2087 Create a clone of a context, so we can have the same statement running
2088 multiple times. Is there really no better way to handle this? Can't I
2089 have multiple cursors on one statement?
2090 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2091
2092 static context *
clone_context(context * in)2093 clone_context(context *in)
2094 { context *new;
2095 size_t bytes = (in->sqllen+1)*in->char_width;
2096
2097 if ( !(new = new_context(in->connection)) )
2098 return NULL;
2099 /* Copy SQL statement */
2100 if ( !(new->sqltext.a = PL_malloc(bytes)) )
2101 return NULL;
2102 new->sqllen = in->sqllen;
2103 new->char_width = in->char_width;
2104 memcpy(new->sqltext.a, in->sqltext.a, bytes);
2105 set(new, CTX_SQLMALLOCED);
2106
2107 /* Prepare the statement */
2108 if ( new->char_width == 1 )
2109 { TRY(new,
2110 SQLPrepareA(new->hstmt, new->sqltext.a, new->sqllen),
2111 close_context(new));
2112 } else
2113 { TRY(new,
2114 SQLPrepareW(new->hstmt, new->sqltext.w, new->sqllen),
2115 close_context(new));
2116 }
2117
2118 /* Copy parameter declarations */
2119 if ( (new->NumParams = in->NumParams) > 0 )
2120 { int pn;
2121 parameter *p;
2122
2123 if ( !(new->params = odbc_malloc(sizeof(parameter)*new->NumParams)) )
2124 return NULL;
2125 memcpy(new->params, in->params, sizeof(parameter)*new->NumParams);
2126
2127 for(p=new->params, pn=1; pn<=new->NumParams; pn++, p++)
2128 { SQLLEN *vlenptr = NULL;
2129
2130 switch(p->cTypeID)
2131 { case SQL_C_CHAR:
2132 case SQL_C_WCHAR:
2133 case SQL_C_BINARY:
2134 /* if p->length_ind == 0 then we are using SQLPutData
2135 and must not overwrite the index stored in ptr_value with
2136 a buffer of 0 length!
2137 */
2138 if ( p->length_ind != 0 && !(p->ptr_value = odbc_malloc(p->length_ind+1)) )
2139 return NULL;
2140 vlenptr = &p->len_value;
2141 break;
2142 case SQL_C_DATE:
2143 case SQL_C_TYPE_DATE:
2144 case SQL_C_TIME:
2145 case SQL_C_TYPE_TIME:
2146 case SQL_C_TIMESTAMP:
2147 if ( !(p->ptr_value = odbc_malloc(p->len_value)) )
2148 return NULL;
2149 break;
2150 case SQL_C_SLONG:
2151 case SQL_C_SBIGINT:
2152 case SQL_C_DOUBLE:
2153 p->ptr_value = (SQLPOINTER)p->buf;
2154 break;
2155 }
2156
2157 TRY(new, SQLBindParameter(new->hstmt, /* hstmt */
2158 (SWORD)pn, /* ipar */
2159 SQL_PARAM_INPUT, /* fParamType */
2160 p->cTypeID, /* fCType */
2161 p->sqlTypeID, /* fSqlType */
2162 p->length_ind, /* cbColDef */
2163 p->scale, /* ibScale */
2164 p->ptr_value, /* rgbValue */
2165 0, /* cbValueMax */
2166 vlenptr), /* pcbValue */
2167 close_context(new));
2168 }
2169 }
2170
2171 /* Copy result columns */
2172 new->db_row = in->db_row; /* the row/N functor */
2173
2174 if ( in->result )
2175 { new->NumCols = in->NumCols;
2176 if ( !(new->result = odbc_malloc(in->NumCols*sizeof(parameter))) )
2177 return NULL;
2178 memcpy(new->result, in->result, in->NumCols*sizeof(parameter));
2179
2180 if ( true(in, CTX_BOUND) )
2181 { parameter *p = new->result;
2182 int i;
2183
2184 for(i = 1; i <= new->NumCols; i++, p++)
2185 { if ( p->len_value > PARAM_BUFSIZE )
2186 { if ( !(p->ptr_value = odbc_malloc(p->len_value)) )
2187 return NULL;
2188 } else
2189 p->ptr_value = (SQLPOINTER)p->buf;
2190
2191 TRY(new, SQLBindCol(new->hstmt, (SWORD)i,
2192 p->cTypeID,
2193 p->ptr_value,
2194 p->len_value,
2195 &p->length_ind),
2196 close_context(new));
2197 }
2198
2199 set(new, CTX_BOUND);
2200 }
2201 }
2202
2203 new->null = clone_nulldef(in->null);
2204 new->findall = clone_findall(in->findall);
2205
2206 return new;
2207 }
2208
2209
2210 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2211 The string is malloced by Prolog and this probably poses problems when
2212 using on Windows, where each DLL has its own memory pool. SWI-Prolog
2213 5.0.9 introduces PL_malloc(), PL_realloc() and PL_free() for foreign
2214 code to synchronise this problem.
2215 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2216
2217 static int
get_sql_text(context * ctxt,term_t tquery)2218 get_sql_text(context *ctxt, term_t tquery)
2219 { if ( PL_is_functor(tquery, FUNCTOR_minus2) )
2220 { if ( !formatted_string(ctxt, tquery) )
2221 return FALSE;
2222 } else
2223 { size_t qlen;
2224
2225 if ( ctxt->connection->encoding == ENC_SQLWCHAR )
2226 { wchar_t *ws;
2227
2228 #if SIZEOF_SQLWCHAR != SIZEOF_WCHAR_T
2229 if ( PL_get_wchars(tquery, &qlen, &ws, CVT_ATOM|CVT_STRING))
2230 { wchar_t *es = ws+qlen;
2231 SQLWCHAR *o, *q;
2232
2233 q = PL_malloc((qlen+1)*sizeof(SQLWCHAR));
2234 for(o=q; ws<es;)
2235 *o++ = *ws++;
2236 *o = 0;
2237 ctxt->sqltext.w = q;
2238 #else
2239 if ( PL_get_wchars(tquery, &qlen, &ws, CVT_ATOM|CVT_STRING|BUF_MALLOC))
2240 { ctxt->sqltext.w = (SQLWCHAR *)ws;
2241 #endif
2242 set(ctxt, CTX_SQLMALLOCED);
2243 ctxt->sqllen = (SQLINTEGER)qlen;
2244 ctxt->char_width = sizeof(SQLWCHAR);
2245 } else
2246 return type_error(tquery, "atom_or_format");
2247 } else
2248 { char *s;
2249 int rep = ctxt->connection->rep_flag;
2250
2251 if ( PL_get_nchars(tquery, &qlen, &s, CVT_ATOM|CVT_STRING|BUF_MALLOC|rep))
2252 { ctxt->sqltext.a = (unsigned char*)s;
2253 ctxt->sqllen = (SQLINTEGER)qlen;
2254 ctxt->char_width = sizeof(char);
2255 set(ctxt, CTX_SQLMALLOCED);
2256 } else
2257 return type_error(tquery, "atom_or_format");
2258 }
2259 }
2260
2261 return TRUE;
2262 }
2263
2264
2265 static int
2266 max_qualifier_length(connection *cn)
2267 { if ( false(cn, CTX_GOT_QLEN) )
2268 { SQLUSMALLINT len;
2269 SWORD plen;
2270 RETCODE rc;
2271
2272 if ( (rc=SQLGetInfo(cn->hdbc, SQL_MAX_QUALIFIER_NAME_LEN,
2273 &len, sizeof(len), &plen)) == SQL_SUCCESS )
2274 { /*Sdprintf("SQL_MAX_QUALIFIER_NAME_LEN = %d\n", (int)len);*/
2275 cn->max_qualifier_length = (int)len; /* 0: unknown */
2276 } else
2277 { odbc_report(henv, cn->hdbc, NULL, rc);
2278 cn->max_qualifier_length = -1;
2279 }
2280
2281 set(cn, CTX_GOT_QLEN);
2282 }
2283
2284 return cn->max_qualifier_length;
2285 }
2286
2287
2288 static int
2289 prepare_result(context *ctxt)
2290 { SQLSMALLINT i;
2291 SQLCHAR nameBuffer[NameBufferLength];
2292 SQLSMALLINT nameLength, dataType, decimalDigits, nullable;
2293 SQLULEN columnSize; /* was SQLUINTEGER */
2294 parameter *ptr_result;
2295 SQLSMALLINT ncol;
2296
2297 #ifdef SQL_SERVER_BUG
2298 if ( true(ctxt, CTX_COLUMNS) )
2299 ncol = 12;
2300 else
2301 #endif
2302 SQLNumResultCols(ctxt->hstmt, &ncol);
2303 if ( ncol == 0 )
2304 return TRUE; /* no results */
2305
2306 if ( ctxt->result ) /* specified types */
2307 { if ( ncol != ctxt->NumCols )
2308 return PL_warning("# columns mismatch"); /* TBD: exception */
2309 } else
2310 { ctxt->NumCols = ncol;
2311 ctxt->db_row = PL_new_functor(ATOM_row, ctxt->NumCols);
2312 if ( !(ctxt->result = odbc_malloc(sizeof(parameter)*ctxt->NumCols)) )
2313 return FALSE;
2314 memset(ctxt->result, 0, sizeof(parameter)*ctxt->NumCols);
2315 }
2316
2317 ptr_result = ctxt->result;
2318 for(i = 1; i <= ctxt->NumCols; i++, ptr_result++)
2319 { SQLDescribeCol(ctxt->hstmt, i,
2320 nameBuffer, NameBufferLength, &nameLength,
2321 &dataType, &columnSize, &decimalDigits,
2322 &nullable);
2323
2324 if ( true(ctxt, CTX_SOURCE) )
2325 { SQLLEN ival; /* was DWORD */
2326
2327 ptr_result->source.column = PL_new_atom_nchars(nameLength,
2328 (char*)nameBuffer);
2329 if ( (ctxt->rc=SQLColAttributes(ctxt->hstmt, i,
2330 SQL_COLUMN_TABLE_NAME,
2331 nameBuffer,
2332 NameBufferLength, &nameLength,
2333 &ival)) == SQL_SUCCESS )
2334 { ptr_result->source.table = PL_new_atom_nchars(nameLength,
2335 (char*)nameBuffer);
2336 } else
2337 { if ( !report_status(ctxt) ) /* TBD: May close ctxt */
2338 return FALSE;
2339 ptr_result->source.table = ATOM_;
2340 PL_register_atom(ATOM_);
2341 }
2342 }
2343
2344 ptr_result->sqlTypeID = dataType;
2345 ptr_result->cTypeID = CvtSqlToCType(ctxt, dataType, ptr_result->plTypeID);
2346 if (ptr_result->cTypeID == CVNERR)
2347 { free_context(ctxt);
2348 return PL_warning("odbc_query/2: column type not managed");
2349 }
2350
2351 DEBUG(1, Sdprintf("prepare_result(): column %d, "
2352 "sqlTypeID = %d, cTypeID = %d, "
2353 "columnSize = %u\n",
2354 i, ptr_result->sqlTypeID, ptr_result->cTypeID,
2355 columnSize));
2356
2357 if ( true(ctxt, CTX_TABLES) )
2358 { switch (ptr_result->sqlTypeID)
2359 { case SQL_LONGVARCHAR:
2360 case SQL_VARCHAR:
2361 { int qlen = max_qualifier_length(ctxt->connection);
2362
2363 if ( qlen > 0 )
2364 { /*Sdprintf("Using SQL_MAX_QUALIFIER_NAME_LEN = %d\n", qlen);*/
2365 ptr_result->len_value = qlen+1; /* play safe */
2366 goto bind;
2367 } else if ( qlen < 0 ) /* error getting it */
2368 return FALSE;
2369 }
2370 }
2371 }
2372
2373 switch (ptr_result->sqlTypeID)
2374 { case SQL_LONGVARCHAR:
2375 case SQL_LONGVARBINARY:
2376 { if ( columnSize > ctxt->max_nogetdata || columnSize == 0 )
2377 { use_sql_get_data:
2378 DEBUG(2,
2379 Sdprintf("Wide SQL_LONGVAR* column %d: using SQLGetData()\n", i));
2380 ptr_result->ptr_value = NULL; /* handle using SQLGetData() */
2381 continue;
2382 }
2383 ptr_result->len_value = sizeof(char)*(columnSize+1);
2384 goto bind;
2385 }
2386 }
2387
2388 switch (ptr_result->cTypeID)
2389 { case SQL_C_CHAR:
2390 if ( columnSize == 0 )
2391 goto use_sql_get_data;
2392 columnSize += 2; /* decimal dot and '-' sign */
2393 /*FALLTHROUGH*/
2394 case SQL_C_BINARY:
2395 if ( columnSize > ctxt->max_nogetdata || columnSize == 0 )
2396 goto use_sql_get_data;
2397 ptr_result->len_value = sizeof(char)*(columnSize+1)*((ctxt->connection->encoding == ENC_UTF8)?4:1);
2398 break;
2399 case SQL_C_WCHAR:
2400 if ( columnSize > ctxt->max_nogetdata || columnSize == 0 )
2401 goto use_sql_get_data;
2402 ptr_result->len_value = sizeof(wchar_t)*(columnSize+1);
2403 break;
2404 case SQL_C_SLONG:
2405 ptr_result->len_value = sizeof(SQLINTEGER);
2406 break;
2407 case SQL_C_SBIGINT:
2408 ptr_result->len_value = sizeof(SQLBIGINT);
2409 break;
2410 case SQL_C_DOUBLE:
2411 ptr_result->len_value = sizeof(SQLDOUBLE);
2412 break;
2413 case SQL_C_TYPE_DATE:
2414 ptr_result->len_value = sizeof(DATE_STRUCT);
2415 break;
2416 case SQL_C_TYPE_TIME:
2417 ptr_result->len_value = sizeof(TIME_STRUCT);
2418 break;
2419 case SQL_C_TIMESTAMP:
2420 ptr_result->len_value = sizeof(SQL_TIMESTAMP_STRUCT);
2421 break;
2422 default:
2423 Sdprintf("Oops: %s:%d: cTypeID = %d\n",
2424 __FILE__, __LINE__, ptr_result->cTypeID);
2425 assert(0);
2426 return FALSE; /* make compiler happy */
2427 }
2428
2429 bind:
2430 if ( ptr_result->len_value <= PARAM_BUFSIZE )
2431 ptr_result->ptr_value = (SQLPOINTER)ptr_result->buf;
2432 else
2433 { if ( !(ptr_result->ptr_value = odbc_malloc(ptr_result->len_value)) )
2434 return FALSE;
2435 }
2436
2437 TRY(ctxt, SQLBindCol(ctxt->hstmt, i,
2438 ptr_result->cTypeID,
2439 ptr_result->ptr_value,
2440 ptr_result->len_value,
2441 &ptr_result->length_ind),
2442 (void)0);
2443 }
2444
2445 return TRUE;
2446 }
2447
2448
2449 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2450 odbc_row() is the final call from the various query predicates,
2451 returning a result row or, in case of findall, the whole result-set. It
2452 must call close_context() if we are done with the context due to an
2453 error or the last result.
2454 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2455
2456 static foreign_t
2457 odbc_row(context *ctxt, term_t trow)
2458 { term_t local_trow;
2459 fid_t fid;
2460
2461 if ( !true(ctxt, CTX_BOUND) )
2462 { if ( !prepare_result(ctxt) )
2463 { close_context(ctxt);
2464 return FALSE;
2465 }
2466 set(ctxt, CTX_BOUND);
2467 }
2468
2469 if ( !ctxt->result ) /* not a SELECT statement */
2470 { SQLLEN rows = 0; /* was DWORD */
2471 int rval;
2472
2473 if ( ctxt->rc != SQL_NO_DATA_FOUND )
2474 ctxt->rc = SQLRowCount(ctxt->hstmt, &rows);
2475 if ( ctxt->rc == SQL_SUCCESS ||
2476 ctxt->rc == SQL_SUCCESS_WITH_INFO ||
2477 ctxt->rc == SQL_NO_DATA_FOUND )
2478 rval = PL_unify_term(trow,
2479 PL_FUNCTOR, FUNCTOR_affected1,
2480 PL_LONG, (long)rows);
2481 else
2482 rval = TRUE;
2483
2484 close_context(ctxt);
2485
2486 return rval;
2487 }
2488
2489 if ( ctxt->rc == SQL_NO_DATA_FOUND )
2490 return FALSE;
2491
2492 if ( ctxt->findall ) /* findall: return the whole set */
2493 { term_t tail = PL_copy_term_ref(trow);
2494 term_t head = PL_new_term_ref();
2495 term_t tmp = PL_new_term_ref();
2496
2497 for(;;)
2498 { ctxt->rc = SQLFetch(ctxt->hstmt);
2499
2500 switch(ctxt->rc)
2501 { case SQL_NO_DATA_FOUND:
2502 close_context(ctxt);
2503 return PL_unify_nil(tail);
2504 case SQL_SUCCESS:
2505 break;
2506 default:
2507 if ( !report_status(ctxt) )
2508 { close_context(ctxt);
2509 return FALSE;
2510 }
2511 }
2512
2513 if ( !PL_unify_list(tail, head, tail) ||
2514 !put_findall(ctxt, tmp) ||
2515 !PL_unify(head, tmp) )
2516 { close_context(ctxt);
2517 return FALSE;
2518 }
2519 }
2520 }
2521
2522 local_trow = PL_new_term_ref();
2523 fid = PL_open_foreign_frame();
2524
2525 for(;;) /* normal non-deterministic access */
2526 { if ( true(ctxt, CTX_PREFETCHED) )
2527 { clear(ctxt, CTX_PREFETCHED);
2528 } else
2529 { TRY(ctxt, SQLFetch(ctxt->hstmt), close_context(ctxt));
2530 if ( ctxt->rc == SQL_NO_DATA_FOUND )
2531 return FALSE;
2532 }
2533
2534 if ( !pl_put_row(local_trow, ctxt) )
2535 { close_context(ctxt);
2536 return FALSE; /* with pending exception */
2537 }
2538
2539 if ( !PL_unify(trow, local_trow) )
2540 { PL_rewind_foreign_frame(fid);
2541 continue;
2542 }
2543
2544 /* success! */
2545 /* pre-fetch to get determinism */
2546 ctxt->rc = SQLFetch(ctxt->hstmt);
2547 switch(ctxt->rc)
2548 { case SQL_NO_DATA_FOUND: /* no alternative */
2549 close_context(ctxt);
2550 return TRUE;
2551 case SQL_SUCCESS_WITH_INFO:
2552 report_status(ctxt); /* Always returns TRUE */
2553 /*FALLTHROUGH*/
2554 case SQL_SUCCESS:
2555 set(ctxt, CTX_PREFETCHED);
2556 PL_retry_address(ctxt);
2557 default:
2558 if ( !report_status(ctxt) )
2559 { close_context(ctxt);
2560 return FALSE;
2561 }
2562 return TRUE;
2563 }
2564 }
2565 }
2566
2567
2568 static int
2569 set_column_types(context *ctxt, term_t option)
2570 { term_t tail = PL_new_term_ref();
2571 term_t head = PL_new_term_ref();
2572 parameter *p;
2573 int ntypes;
2574
2575 if ( !PL_get_arg(1, option, tail) ||
2576 (ntypes = list_length(tail)) < 0 )
2577 return FALSE; /* not a proper list */
2578
2579 ctxt->NumCols = ntypes;
2580 ctxt->db_row = PL_new_functor(ATOM_row, ctxt->NumCols);
2581 if ( !(ctxt->result = odbc_malloc(sizeof(parameter)*ctxt->NumCols)) )
2582 return FALSE;
2583 memset(ctxt->result, 0, sizeof(parameter)*ctxt->NumCols);
2584
2585 for(p = ctxt->result; PL_get_list(tail, head, tail); p++)
2586 { if ( !get_pltype(head, &p->plTypeID) )
2587 return FALSE;
2588 }
2589 if ( !PL_get_nil(tail) )
2590 return type_error(tail, "list");
2591
2592 return TRUE;
2593 }
2594
2595
2596 static int
2597 set_statement_options(context *ctxt, term_t options)
2598 { if ( !PL_get_nil(options) )
2599 { term_t tail = PL_copy_term_ref(options);
2600 term_t head = PL_new_term_ref();
2601
2602 while(PL_get_list(tail, head, tail))
2603 { if ( PL_is_functor(head, FUNCTOR_types1) )
2604 { if ( !set_column_types(ctxt, head) )
2605 return FALSE;
2606 } else if ( PL_is_functor(head, FUNCTOR_null1) )
2607 { term_t arg = PL_new_term_ref();
2608
2609 _PL_get_arg(1, head, arg);
2610 ctxt->null = nulldef_spec(arg);
2611 set(ctxt, CTX_OWNNULL);
2612 } else if ( PL_is_functor(head, FUNCTOR_source1) )
2613 { int val;
2614
2615 if ( !get_bool_arg_ex(1, head, &val) )
2616 return FALSE;
2617
2618 if ( val )
2619 set(ctxt, CTX_SOURCE);
2620 } else if ( PL_is_functor(head, FUNCTOR_findall2) )
2621 { if ( !(ctxt->findall = compile_findall(head, ctxt->flags)) )
2622 return FALSE;
2623 } else if ( PL_is_functor(head, FUNCTOR_fetch1) )
2624 { atom_t a;
2625
2626 if ( !get_atom_arg_ex(1, head, &a) )
2627 return FALSE;
2628 if ( a == ATOM_auto )
2629 clear(ctxt, CTX_NOAUTO);
2630 else if ( a == ATOM_fetch )
2631 set(ctxt, CTX_NOAUTO);
2632 else
2633 { term_t a = PL_new_term_ref();
2634 _PL_get_arg(1, head, a);
2635 return domain_error(a, "fetch");
2636 }
2637 } else if ( PL_is_functor(head, FUNCTOR_wide_column_threshold1) )
2638 { int val;
2639
2640 if ( !get_int_arg_ex(1, head, &val) )
2641 return FALSE;
2642
2643 ctxt->max_nogetdata = val;
2644 } else
2645 return domain_error(head, "odbc_option");
2646 }
2647 if ( !PL_get_nil(tail) )
2648 return type_error(tail, "list");
2649 }
2650
2651 return TRUE;
2652 }
2653
2654
2655 /* This is not thread-safe: You must hold the lock when entering! */
2656 static int
2657 mark_context_as_executing(int self, context* ctxt)
2658 { if ( self >= executing_context_size )
2659 { int old_size = executing_context_size;
2660 int i;
2661
2662 executing_context_size = 16;
2663 while (self >= executing_context_size)
2664 executing_context_size <<= 1;
2665
2666 if ( executing_contexts == NULL )
2667 { executing_contexts = odbc_malloc(executing_context_size * sizeof(context*));
2668 if ( executing_contexts == NULL )
2669 return FALSE;
2670 } else
2671 { context** tmp = odbc_realloc(executing_contexts,
2672 executing_context_size * sizeof(context*));
2673 if ( tmp == NULL )
2674 return FALSE;
2675 executing_contexts = tmp;
2676 }
2677 for (i = old_size; i < executing_context_size; i++)
2678 executing_contexts[i] = NULL;
2679 }
2680
2681 executing_contexts[self] = ctxt;
2682 set(ctxt, CTX_EXECUTING);
2683
2684 return TRUE;
2685 }
2686
2687 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2688 odbc_query(+Conn, +SQL, -Row)
2689 Execute an SQL query, returning the result-rows 1-by-1 on
2690 backtracking
2691 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2692
2693 static foreign_t
2694 pl_odbc_query(term_t conn, term_t tquery, term_t trow, term_t options,
2695 control_t handle)
2696 { context *ctxt;
2697
2698 switch( PL_foreign_control(handle) )
2699 { case PL_FIRST_CALL:
2700 { connection *cn;
2701 int self = PL_thread_self();
2702 if ( !get_connection(conn, &cn) )
2703 return FALSE;
2704
2705 if ( !(ctxt = new_context(cn)) )
2706 return FALSE;
2707 if ( !get_sql_text(ctxt, tquery) )
2708 { free_context(ctxt);
2709 return FALSE;
2710 }
2711
2712 if ( !set_statement_options(ctxt, options) )
2713 { free_context(ctxt);
2714 return FALSE;
2715 }
2716 set(ctxt, CTX_INUSE);
2717 LOCK_CONTEXTS();
2718 if (!mark_context_as_executing(self, ctxt))
2719 { UNLOCK_CONTEXTS();
2720 return FALSE;
2721 }
2722 UNLOCK_CONTEXTS();
2723 if ( ctxt->char_width == 1 )
2724 { TRY(ctxt,
2725 SQLExecDirectA(ctxt->hstmt, ctxt->sqltext.a, ctxt->sqllen),
2726 unmark_and_close_context(ctxt));
2727 } else
2728 { TRY(ctxt,
2729 SQLExecDirectW(ctxt->hstmt, ctxt->sqltext.w, ctxt->sqllen),
2730 unmark_and_close_context(ctxt));
2731 }
2732 LOCK_CONTEXTS();
2733 clear(ctxt, CTX_EXECUTING);
2734 executing_contexts[self] = NULL;
2735 UNLOCK_CONTEXTS();
2736 return odbc_row(ctxt, trow);
2737 }
2738 case PL_REDO:
2739 return odbc_row(PL_foreign_context_address(handle), trow);
2740
2741 default:
2742 case PL_PRUNED:
2743 free_context(PL_foreign_context_address(handle));
2744 return TRUE;
2745 }
2746 }
2747
2748
2749 /*******************************
2750 * DICTIONARY SUPPORT *
2751 *******************************/
2752
2753 static foreign_t
2754 odbc_tables(term_t conn, term_t row, control_t handle)
2755 { switch( PL_foreign_control(handle) )
2756 { case PL_FIRST_CALL:
2757 { connection *cn;
2758 context *ctxt;
2759
2760 if ( !get_connection(conn, &cn) )
2761 return FALSE;
2762
2763 if ( !(ctxt = new_context(cn)) )
2764 return FALSE;
2765 ctxt->null = NULL; /* use default $null$ */
2766 set(ctxt, CTX_TABLES);
2767 TRY(ctxt,
2768 SQLTables(ctxt->hstmt, NULL,0,NULL,0,NULL,0,NULL,0),
2769 close_context(ctxt));
2770
2771 return odbc_row(ctxt, row);
2772 }
2773 case PL_REDO:
2774 return odbc_row(PL_foreign_context_address(handle), row);
2775
2776 case PL_PRUNED:
2777 free_context(PL_foreign_context_address(handle));
2778 return TRUE;
2779
2780 default:
2781 assert(0);
2782 return FALSE;
2783 }
2784 }
2785
2786
2787 static foreign_t
2788 pl_odbc_column(term_t conn, term_t db, term_t row, control_t handle)
2789 { switch( PL_foreign_control(handle) )
2790 { case PL_FIRST_CALL:
2791 { connection *cn;
2792 context *ctxt;
2793 size_t len;
2794 char *s;
2795
2796 if ( !get_connection(conn, &cn) )
2797 return FALSE;
2798 /* TBD: Unicode version */
2799 if ( !PL_get_nchars(db, &len, &s, CVT_ATOM|CVT_STRING|cn->rep_flag) )
2800 return type_error(db, "atom");
2801
2802 if ( !(ctxt = new_context(cn)) )
2803 return FALSE;
2804 ctxt->null = NULL; /* use default $null$ */
2805 set(ctxt, CTX_COLUMNS);
2806 TRY(ctxt,
2807 SQLColumns(ctxt->hstmt, NULL, 0, NULL, 0,
2808 (SQLCHAR*)s, (SWORD)len, NULL, 0),
2809 close_context(ctxt));
2810
2811 return odbc_row(ctxt, row);
2812 }
2813 case PL_REDO:
2814 return odbc_row(PL_foreign_context_address(handle), row);
2815
2816 case PL_PRUNED:
2817 free_context(PL_foreign_context_address(handle));
2818 return TRUE;
2819
2820 default:
2821 assert(0);
2822 return FALSE;
2823 }
2824 }
2825
2826
2827 static foreign_t
2828 odbc_primary_key(term_t conn, term_t table, term_t row, control_t handle)
2829 { switch( PL_foreign_control(handle) )
2830 { case PL_FIRST_CALL:
2831 { connection *cn;
2832 context *ctxt;
2833 size_t len;
2834 char *s;
2835
2836 if ( !get_connection(conn, &cn) )
2837 return FALSE;
2838 /* TBD: Unicode version */
2839 if ( !PL_get_nchars(table, &len, &s, CVT_ATOM|CVT_STRING|cn->rep_flag) )
2840 return type_error(table, "atom");
2841
2842 if ( !(ctxt = new_context(cn)) )
2843 return FALSE;
2844 ctxt->null = NULL; /* use default $null$ */
2845 set(ctxt, CTX_PRIMARYKEY);
2846 TRY(ctxt,
2847 SQLPrimaryKeys(ctxt->hstmt, NULL, 0, NULL, 0,
2848 (SQLCHAR*)s, (SWORD)len),
2849 close_context(ctxt));
2850
2851 return odbc_row(ctxt, row);
2852 }
2853 case PL_REDO:
2854 return odbc_row(PL_foreign_context_address(handle), row);
2855
2856 case PL_PRUNED:
2857 free_context(PL_foreign_context_address(handle));
2858 return TRUE;
2859
2860 default:
2861 assert(0);
2862 return FALSE;
2863 }
2864 }
2865
2866 static foreign_t
2867 odbc_foreign_key(term_t conn, term_t pktable, term_t fktable, term_t row, control_t handle)
2868 { switch( PL_foreign_control(handle) )
2869 { case PL_FIRST_CALL:
2870 { connection *cn;
2871 context *ctxt;
2872 size_t lpkt = 0;
2873 char *spkt = 0;
2874 size_t lpkf = 0;
2875 char *spkf = 0;
2876
2877 if ( !get_connection(conn, &cn) )
2878 return FALSE;
2879
2880 int nt = 0;
2881 if ( PL_get_nchars(pktable, &lpkt, &spkt, CVT_ATOM|CVT_STRING|cn->rep_flag) )
2882 ++nt;
2883 if ( PL_get_nchars(fktable, &lpkf, &spkf, CVT_ATOM|CVT_STRING|cn->rep_flag) )
2884 ++nt;
2885 if (!nt)
2886 return resource_error("set at least PkTable or FkTable");
2887
2888 if ( !(ctxt = new_context(cn)) )
2889 return FALSE;
2890 ctxt->null = NULL; /* use default $null$ */
2891 set(ctxt, CTX_FOREIGNKEY);
2892 TRY(ctxt,
2893 SQLForeignKeys(ctxt->hstmt, NULL, 0, NULL, 0,
2894 (SQLCHAR*)spkt, (SWORD)lpkt, NULL, 0, NULL, 0, (SQLCHAR*)spkf, (SWORD)lpkf),
2895 close_context(ctxt));
2896
2897 return odbc_row(ctxt, row);
2898 }
2899 case PL_REDO:
2900 return odbc_row(PL_foreign_context_address(handle), row);
2901
2902 case PL_PRUNED:
2903 free_context(PL_foreign_context_address(handle));
2904 return TRUE;
2905
2906 default:
2907 assert(0);
2908 return FALSE;
2909 }
2910 }
2911
2912
2913 static foreign_t
2914 odbc_types(term_t conn, term_t sqltype, term_t row, control_t handle)
2915 { switch( PL_foreign_control(handle) )
2916 { case PL_FIRST_CALL:
2917 { connection *cn;
2918 context *ctxt;
2919 atom_t tname;
2920 SWORD type;
2921 int v;
2922
2923 if ( PL_get_integer(sqltype, &v) )
2924 { type = v;
2925 } else
2926 { if ( !PL_get_atom(sqltype, &tname) )
2927 return type_error(sqltype, "sql_type");
2928 if ( tname == ATOM_all_types )
2929 type = SQL_ALL_TYPES;
2930 else if ( !get_sqltype_from_atom(tname, &type) )
2931 return domain_error(sqltype, "sql_type");
2932 }
2933
2934 if ( !get_connection(conn, &cn) )
2935 return FALSE;
2936 if ( !(ctxt = new_context(cn)) )
2937 return FALSE;
2938 ctxt->null = NULL; /* use default $null$ */
2939 TRY(ctxt,
2940 SQLGetTypeInfo(ctxt->hstmt, type),
2941 close_context(ctxt));
2942
2943 return odbc_row(ctxt, row);
2944 }
2945 case PL_REDO:
2946 return odbc_row(PL_foreign_context_address(handle), row);
2947
2948 case PL_PRUNED:
2949 free_context(PL_foreign_context_address(handle));
2950 return TRUE;
2951
2952 default:
2953 assert(0);
2954 return FALSE;
2955 }
2956 }
2957
2958
2959 static foreign_t
2960 odbc_data_sources(term_t list)
2961 { UCHAR dsn[SQL_MAX_DSN_LENGTH];
2962 UCHAR description[1024];
2963 SWORD dsnlen, dlen;
2964 UWORD dir = SQL_FETCH_FIRST;
2965 RETCODE rc;
2966 term_t tail = PL_copy_term_ref(list);
2967 term_t head = PL_new_term_ref();
2968
2969 LOCK();
2970 if ( !henv )
2971 { SQLAllocEnv(&henv); /* Allocate an environment handle */
2972 SQLSetEnvAttr(henv,
2973 SQL_ATTR_ODBC_VERSION,
2974 (SQLPOINTER) SQL_OV_ODBC3,
2975 0);
2976 }
2977 UNLOCK();
2978
2979 for(;; dir=SQL_FETCH_NEXT)
2980 { rc = SQLDataSources(henv,
2981 dir,
2982 dsn, sizeof(dsn)-1, &dsnlen,
2983 description, sizeof(description)-1, &dlen);
2984 switch(rc)
2985 { case SQL_SUCCESS:
2986 { if ( PL_unify_list(tail, head, tail) &&
2987 PL_unify_term(head, PL_FUNCTOR, FUNCTOR_data_source2,
2988 PL_NCHARS, (size_t)dsnlen, dsn,
2989 PL_NCHARS, (size_t)dlen, description) )
2990 continue;
2991
2992 return FALSE;
2993 }
2994 case SQL_NO_DATA_FOUND:
2995 return PL_unify_nil(tail);
2996 default:
2997 odbc_report(henv, NULL, NULL, rc);
2998 return FALSE;
2999 }
3000 }
3001 }
3002
3003
3004 /*******************************
3005 * COMPILE STATEMENTS *
3006 *******************************/
3007
3008 static int
3009 unifyStmt(term_t id, context *ctxt)
3010 { return PL_unify_term(id, PL_FUNCTOR, FUNCTOR_odbc_statement1,
3011 PL_POINTER, ctxt);
3012 }
3013
3014
3015 static int
3016 getStmt(term_t id, context **ctxt)
3017 { if ( PL_is_functor(id, FUNCTOR_odbc_statement1) )
3018 { term_t a = PL_new_term_ref();
3019 void *ptr;
3020
3021 _PL_get_arg(1, id, a);
3022 if ( PL_get_pointer(a, &ptr) )
3023 { *ctxt = ptr;
3024
3025 if ( (*ctxt)->magic != CTX_MAGIC )
3026 return existence_error(id, "odbc_statement_handle");
3027
3028 return TRUE;
3029 }
3030 }
3031
3032 return type_error(id, "odbc_statement_handle");
3033 }
3034
3035
3036 typedef struct
3037 { SWORD type; /* SQL_* */
3038 const char *text; /* same as text */
3039 atom_t name; /* Prolog name */
3040 } sqltypedef;
3041
3042 static sqltypedef sqltypes[] =
3043 { { SQL_BIGINT, "bigint" },
3044 { SQL_BINARY, "binary" },
3045 { SQL_BIT, "bit" },
3046 { SQL_CHAR, "char" },
3047 { SQL_DATE, "date" },
3048 { SQL_DECIMAL, "decimal" },
3049 { SQL_DOUBLE, "double" },
3050 { SQL_FLOAT, "float" },
3051 { SQL_INTEGER, "integer" },
3052 { SQL_LONGVARBINARY, "longvarbinary" },
3053 { SQL_LONGVARCHAR, "longvarchar" },
3054 { SQL_NUMERIC, "numeric" },
3055 { SQL_REAL, "real" },
3056 { SQL_SMALLINT, "smallint" },
3057 { SQL_TIME, "time" },
3058 { SQL_TIMESTAMP, "timestamp" },
3059 { SQL_TINYINT, "tinyint" },
3060 { SQL_VARBINARY, "varbinary" },
3061 { SQL_VARCHAR, "varchar" },
3062 { SQL_WCHAR, "nchar" },
3063 { SQL_WLONGVARCHAR, "longnvarchar" },
3064 { SQL_WVARCHAR, "nvarchar" },
3065 { 0, NULL }
3066 };
3067
3068
3069 static SWORD
3070 get_sqltype_from_atom(atom_t name, SWORD *type)
3071 { sqltypedef *def;
3072
3073 for(def=sqltypes; def->text; def++)
3074 { if ( !def->name )
3075 def->name = PL_new_atom(def->text);
3076 if ( def->name == name )
3077 { *type = def->type;
3078 return TRUE;
3079 }
3080 }
3081
3082 return FALSE;
3083 }
3084
3085 static sqltypedef pltypes[] =
3086 { { SQL_PL_DEFAULT, "default" },
3087 { SQL_PL_ATOM, "atom" },
3088 { SQL_PL_STRING, "string" },
3089 { SQL_PL_CODES, "codes" },
3090 { SQL_PL_INTEGER, "integer" },
3091 { SQL_PL_FLOAT, "float" },
3092 { SQL_PL_TIME, "time" },
3093 { SQL_PL_DATE, "date" },
3094 { SQL_PL_TIMESTAMP, "timestamp" },
3095 { 0, NULL }
3096 };
3097
3098
3099 static int
3100 get_pltype(term_t t, SWORD *type)
3101 { atom_t name;
3102
3103 if ( PL_get_atom(t, &name) )
3104 { sqltypedef *def;
3105
3106 for(def=pltypes; def->text; def++)
3107 { if ( !def->name )
3108 def->name = PL_new_atom(def->text);
3109
3110 if ( def->name == name )
3111 { *type = def->type;
3112 return TRUE;
3113 }
3114 }
3115
3116 return domain_error(t, "sql_prolog_type");
3117 }
3118
3119 return type_error(t, "atom");
3120 }
3121
3122
3123 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3124 Declare parameters for prepared statements.
3125
3126 odbc_prepare(DSN, 'select * from product where price < ?',
3127 [ integer
3128 ],
3129 Qid,
3130 Options).
3131 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3132
3133 static int
3134 declare_parameters(context *ctxt, term_t parms)
3135 { int nparams;
3136 term_t tail = PL_copy_term_ref(parms);
3137 term_t head = PL_new_term_ref();
3138 parameter *params;
3139 SWORD npar;
3140 int pn;
3141 int character_size = ((ctxt->connection->encoding == ENC_UTF8)?4:1)*sizeof(char);
3142
3143 TRY(ctxt,
3144 SQLNumParams(ctxt->hstmt, &npar),
3145 (void)0);
3146 if ( (nparams=list_length(parms)) < 0 )
3147 return FALSE;
3148 if ( npar != nparams )
3149 return domain_error(parms, "length"); /* TBD: What error to raise?? */
3150
3151 ctxt->NumParams = nparams;
3152 if ( nparams == 0 )
3153 return TRUE; /* no parameters */
3154
3155 if ( !(ctxt->params = odbc_malloc(sizeof(parameter)*nparams)) )
3156 return FALSE;
3157 memset(ctxt->params, 0, sizeof(parameter)*nparams);
3158 params = ctxt->params;
3159
3160 for(params = ctxt->params, pn = 1;
3161 PL_get_list(tail, head, tail);
3162 params++, pn++)
3163 { atom_t name;
3164 size_t arity;
3165 SWORD sqlType, fNullable;
3166 SQLULEN cbColDef = 0;
3167 SWORD plType = SQL_PL_DEFAULT;
3168 SQLLEN *vlenptr = NULL; /* pointer to length */
3169
3170 if ( PL_is_functor(head, FUNCTOR_gt2) )
3171 { term_t a = PL_new_term_ref();
3172
3173 _PL_get_arg(1, head, a);
3174 if ( !get_pltype(a, &plType) )
3175 return FALSE;
3176
3177 _PL_get_arg(2, head, head);
3178 }
3179
3180 if ( !PL_get_name_arity(head, &name, &arity) )
3181 return type_error(head, "parameter_type");
3182
3183 if ( name != ATOM_default )
3184 { int val;
3185
3186 if ( !get_sqltype_from_atom(name, &sqlType) )
3187 return domain_error(head, "parameter_type");
3188
3189 /* char(N) --> cbColDef */
3190 if ( get_int_arg(1, head, &val) ) /* TBD: incomplete */
3191 cbColDef = val;
3192 if ( get_int_arg(2, head, &val) ) /* decimal(cbColDef, scale) */
3193 params->scale = val;
3194 } else
3195 { TRY(ctxt, SQLDescribeParam(ctxt->hstmt, /* hstmt */
3196 (SWORD)pn, /* ipar */
3197 &sqlType,
3198 &cbColDef, /* This is in characters - not bytes */
3199 ¶ms->scale,
3200 &fNullable),
3201 (void)0);
3202 }
3203
3204 params->sqlTypeID = sqlType;
3205 params->plTypeID = plType;
3206 params->cTypeID = CvtSqlToCType(ctxt, params->sqlTypeID, plType);
3207 params->ptr_value = (SQLPOINTER)params->buf;
3208
3209 switch(params->cTypeID)
3210 { case SQL_C_WCHAR:
3211 character_size = sizeof(SQLWCHAR);
3212 /* FALLTHROUGH */
3213 case SQL_C_CHAR:
3214 case SQL_C_BINARY:
3215 if ( cbColDef > 0 )
3216 { if ( params->sqlTypeID == SQL_DECIMAL ||
3217 params->sqlTypeID == SQL_NUMERIC )
3218 { cbColDef += 2*character_size; /* decimal dot and '-' sign */
3219 }
3220 if ( (cbColDef+1) * character_size > PARAM_BUFSIZE )
3221 { if ( !(params->ptr_value = odbc_malloc((cbColDef+1)*character_size)) )
3222 return FALSE;
3223 }
3224 params->length_ind = cbColDef * character_size;
3225 } else /* unknown, use SQLPutData() */
3226 { params->ptr_value = (SQLPOINTER)(intptr_t)pn;
3227 params->len_value = SQL_LEN_DATA_AT_EXEC(0);
3228 DEBUG(2, Sdprintf("Using SQLPutData() for column %d\n", pn));
3229 }
3230 vlenptr = ¶ms->len_value;
3231 break;
3232 case SQL_C_SLONG:
3233 params->len_value = sizeof(SQLINTEGER);
3234 vlenptr = ¶ms->len_value;
3235 break;
3236 case SQL_C_SBIGINT:
3237 params->len_value = sizeof(SQLBIGINT);
3238 vlenptr = ¶ms->len_value;
3239 break;
3240 case SQL_C_DOUBLE:
3241 params->len_value = sizeof(SQLDOUBLE);
3242 vlenptr = ¶ms->len_value;
3243 break;
3244 case SQL_C_DATE:
3245 case SQL_C_TYPE_DATE:
3246 if ( !(params->ptr_value = odbc_malloc(sizeof(DATE_STRUCT))) )
3247 return FALSE;
3248 params->len_value = sizeof(DATE_STRUCT);
3249 vlenptr = ¶ms->len_value;
3250 break;
3251 case SQL_C_TIME:
3252 case SQL_C_TYPE_TIME:
3253 if ( !(params->ptr_value = odbc_malloc(sizeof(TIME_STRUCT))) )
3254 return FALSE;
3255 params->len_value = sizeof(TIME_STRUCT);
3256 vlenptr = ¶ms->len_value;
3257 break;
3258 case SQL_C_TIMESTAMP:
3259 if ( !(params->ptr_value = odbc_malloc(sizeof(SQL_TIMESTAMP_STRUCT))) )
3260 return FALSE;
3261 params->len_value = sizeof(SQL_TIMESTAMP_STRUCT);
3262 vlenptr = ¶ms->len_value;
3263 break;
3264 default:
3265 Sdprintf("declare_parameters(): cTypeID %d not supported\n",
3266 params->cTypeID);
3267 }
3268
3269
3270 TRY(ctxt, SQLBindParameter(ctxt->hstmt, /* hstmt */
3271 (SWORD)pn, /* ipar */
3272 SQL_PARAM_INPUT, /* fParamType */
3273 params->cTypeID, /* fCType */
3274 params->sqlTypeID, /* fSqlType */
3275 params->length_ind, /* cbColDef */
3276 params->scale, /* ibScale */
3277 params->ptr_value, /* rgbValue */
3278 0, /* cbValueMax */
3279 vlenptr), /* pcbValue */
3280 (void)0);
3281 }
3282
3283 return TRUE;
3284 }
3285
3286
3287 static foreign_t
3288 odbc_prepare(term_t conn, term_t sql, term_t parms, term_t qid, term_t options)
3289 { connection *cn;
3290 context *ctxt;
3291
3292 if ( !get_connection(conn, &cn) )
3293 return FALSE;
3294
3295 if ( !(ctxt = new_context(cn)) )
3296 return FALSE;
3297 if ( !get_sql_text(ctxt, sql) )
3298 { free_context(ctxt);
3299 return FALSE;
3300 }
3301
3302 if ( ctxt->char_width == 1 )
3303 { TRY(ctxt,
3304 SQLPrepareA(ctxt->hstmt, ctxt->sqltext.a, ctxt->sqllen),
3305 close_context(ctxt));
3306 } else
3307 { TRY(ctxt,
3308 SQLPrepareW(ctxt->hstmt, ctxt->sqltext.w, ctxt->sqllen),
3309 close_context(ctxt));
3310 }
3311
3312 if ( !declare_parameters(ctxt, parms) )
3313 { free_context(ctxt);
3314 return FALSE;
3315 }
3316
3317 ctxt->flags |= CTX_PERSISTENT;
3318
3319 if ( !set_statement_options(ctxt, options) )
3320 { free_context(ctxt);
3321 return FALSE;
3322 }
3323
3324 return unifyStmt(qid, ctxt);
3325 }
3326
3327
3328 static foreign_t
3329 odbc_clone_statement(term_t qid, term_t cloneqid)
3330 { context *ctxt, *clone;
3331
3332 if ( !getStmt(qid, &ctxt) )
3333 return FALSE;
3334 if ( !(clone = clone_context(ctxt)) )
3335 return FALSE;
3336
3337 clone->flags |= CTX_PERSISTENT;
3338
3339 return unifyStmt(cloneqid, clone);
3340 }
3341
3342
3343 static foreign_t
3344 odbc_free_statement(term_t qid)
3345 { context *ctxt;
3346
3347 if ( !getStmt(qid, &ctxt) )
3348 return FALSE;
3349
3350 if ( true(ctxt, CTX_INUSE) )
3351 clear(ctxt, CTX_PERSISTENT); /* oops, delay! */
3352 else
3353 free_context(ctxt);
3354
3355 return TRUE;
3356 }
3357
3358
3359 static int
3360 get_date(term_t head, DATE_STRUCT* date)
3361 { if ( PL_is_functor(head, FUNCTOR_date3) )
3362 { int v;
3363
3364 if ( !get_int_arg(1, head, &v) ) return FALSE;
3365 date->year = v;
3366 if ( !get_int_arg(2, head, &v) ) return FALSE;
3367 date->month = v;
3368 if ( !get_int_arg(3, head, &v) ) return FALSE;
3369 date->day = v;
3370
3371 return TRUE;
3372 }
3373
3374 return FALSE;
3375 }
3376
3377
3378 static int
3379 get_time(term_t head, TIME_STRUCT* time)
3380 { if ( PL_is_functor(head, FUNCTOR_time3) )
3381 { int v;
3382
3383 if ( !get_int_arg(1, head, &v) ) return FALSE;
3384 time->hour = v;
3385 if ( !get_int_arg(2, head, &v) ) return FALSE;
3386 time->minute = v;
3387 if ( !get_int_arg(3, head, &v) ) return FALSE;
3388 time->second = v;
3389
3390 return TRUE;
3391 }
3392
3393 return FALSE;
3394 }
3395
3396
3397 static int
3398 get_timestamp(term_t t, SQL_TIMESTAMP_STRUCT* stamp)
3399 {
3400 #if defined(HAVE_LOCALTIME) || defined(HAVE_GMTIME)
3401 double tf;
3402 #endif
3403
3404 if ( PL_is_functor(t, FUNCTOR_timestamp7) )
3405 { int v;
3406
3407 if ( !get_int_arg(1, t, &v) ) return FALSE;
3408 stamp->year = v;
3409 if ( !get_int_arg(2, t, &v) ) return FALSE;
3410 stamp->month = v;
3411 if ( !get_int_arg(3, t, &v) ) return FALSE;
3412 stamp->day = v;
3413 if ( !get_int_arg(4, t, &v) ) return FALSE;
3414 stamp->hour = v;
3415 if ( !get_int_arg(5, t, &v) ) return FALSE;
3416 stamp->minute = v;
3417 if ( !get_int_arg(6, t, &v) ) return FALSE;
3418 stamp->second = v;
3419 if ( !get_int_arg(7, t, &v) ) return FALSE;
3420 stamp->fraction = v;
3421
3422 return TRUE;
3423 #if defined(HAVE_LOCALTIME) || defined(HAVE_GMTIME)
3424 } else if ( PL_get_float(t, &tf) && tf <= LONG_MAX && tf >= LONG_MIN )
3425 { time_t t = (time_t)tf;
3426 long ns = (long)((tf - (double)t) * 1000000000.0);
3427 #if defined(HAVE_GMTIME) && defined USE_UTC
3428 struct tm *tm = gmtime(&t);
3429 #else
3430 struct tm *tm = localtime(&t);
3431 #endif
3432
3433 stamp->year = tm->tm_year + 1900;
3434 stamp->month = tm->tm_mon + 1;
3435 stamp->day = tm->tm_mday;
3436 stamp->hour = tm->tm_hour;
3437 stamp->minute = tm->tm_min;
3438 stamp->second = tm->tm_sec;
3439 stamp->fraction = ns;
3440
3441 return TRUE;
3442 #endif
3443 } else
3444 return FALSE;
3445 }
3446
3447
3448 static int
3449 try_null(context *ctxt, parameter *prm, term_t val, const char *expected)
3450 { if ( is_sql_null(val, ctxt->null) )
3451 { prm->len_value = SQL_NULL_DATA;
3452
3453 return TRUE;
3454 } else
3455 return type_error(val, expected);
3456 }
3457
3458 static unsigned int
3459 plTypeID_convert_flags(int plTypeID, const char** expected)
3460 { unsigned int flags;
3461
3462 switch(plTypeID)
3463 { case SQL_PL_DEFAULT:
3464 flags = CVT_ATOM|CVT_STRING;
3465 *expected = "text";
3466 break;
3467 case SQL_PL_ATOM:
3468 flags = CVT_ATOM;
3469 *expected = "atom";
3470 break;
3471 case SQL_PL_STRING:
3472 flags = CVT_STRING;
3473 *expected = "string";
3474 break;
3475 case SQL_PL_CODES:
3476 flags = CVT_LIST;
3477 *expected = "code_list";
3478 break;
3479 default:
3480 flags = 0; /* keep compiler happy */
3481 assert(0);
3482 }
3483 return flags;
3484 }
3485
3486
3487 static int
3488 get_datetime(term_t t, size_t *len, char *s)
3489 { SQL_TIMESTAMP_STRUCT stamp;
3490
3491 if ( get_timestamp(t, &stamp) )
3492 { size_t l;
3493 char *e;
3494
3495 snprintf(s, *len, "%04d-%02d-%02d %02d:%02d:%02d.%09d",
3496 (int)stamp.year, (int)stamp.month, (int)stamp.day,
3497 (int)stamp.hour, (int)stamp.minute, (int)stamp.second,
3498 (int)stamp.fraction);
3499 l = strlen(s); /* return from snprintf() is not */
3500 e = &s[l];
3501 while(e[-1] == '0')
3502 e--;
3503 *e = '\0';
3504
3505 *len = e-s;
3506 return TRUE; /* very portable (e.g., Windows) */
3507 }
3508
3509 return FALSE;
3510 }
3511
3512
3513 static int
3514 bind_parameters(context *ctxt, term_t parms)
3515 { term_t tail = PL_copy_term_ref(parms);
3516 term_t head = PL_new_term_ref();
3517 parameter *prm;
3518
3519 for(prm = ctxt->params; PL_get_list(tail, head, tail); prm++)
3520 { if ( prm->len_value == SQL_LEN_DATA_AT_EXEC(0) )
3521 { DEBUG(2, Sdprintf("bind_parameters(): Delaying column %d\n",
3522 prm-ctxt->params+1));
3523 prm->put_data = PL_copy_term_ref(head);
3524 continue;
3525 }
3526
3527 switch(prm->cTypeID)
3528 { case SQL_C_SLONG:
3529 { int32_t val;
3530
3531 if ( PL_get_integer(head, &val) )
3532 { SQLINTEGER sqlval = val;
3533 memcpy(prm->ptr_value, &sqlval, sizeof(SQLINTEGER));
3534 prm->len_value = sizeof(SQLINTEGER);
3535 } else if ( !try_null(ctxt, prm, head, "32 bit integer") )
3536 return FALSE;
3537 break;
3538 }
3539 case SQL_C_SBIGINT:
3540 { int64_t val;
3541
3542 if ( PL_get_int64(head, &val) )
3543 { SQLBIGINT sqlval = val;
3544 memcpy(prm->ptr_value, &sqlval, sizeof(SQLBIGINT));
3545 prm->len_value = sizeof(SQLBIGINT);
3546 } else if ( !try_null(ctxt, prm, head, "64 bit integer") )
3547 return FALSE;
3548 break;
3549 }
3550 case SQL_C_DOUBLE:
3551 if ( PL_get_float(head, (double *)prm->ptr_value) )
3552 prm->len_value = sizeof(double);
3553 else if ( !try_null(ctxt, prm, head, "float") )
3554 return FALSE;
3555 break;
3556 case SQL_C_CHAR:
3557 case SQL_C_WCHAR:
3558 case SQL_C_BINARY:
3559 { SQLLEN len;
3560 size_t l;
3561 char *s;
3562 const char *expected = "text";
3563 unsigned int flags = plTypeID_convert_flags(prm->plTypeID, &expected);
3564
3565 /* check for NULL */
3566 if ( is_sql_null(head, ctxt->null) )
3567 { prm->len_value = SQL_NULL_DATA;
3568 break;
3569 }
3570 if ( prm->cTypeID == SQL_C_WCHAR )
3571 { wchar_t *ws;
3572 size_t ls;
3573
3574 if ( !PL_get_wchars(head, &ls, &ws, flags) )
3575 return type_error(head, expected);
3576 len = ls*sizeof(SQLWCHAR);
3577 if ( len > prm->length_ind )
3578 { DEBUG(1, Sdprintf("Column-width (SQL_C_WCHAR) = %d\n",
3579 prm->length_ind));
3580 return representation_error(head, "column_width");
3581 }
3582 prm->len_value = len;
3583 #if SIZEOF_SQLWCHAR == SIZEOF_WCHAR_T
3584 memcpy(prm->ptr_value, ws, (ls+1)*sizeof(SQLWCHAR));
3585 #else
3586 { wchar_t *es = ws+ls;
3587 SQLWCHAR *o;
3588
3589 for(o=(SQLWCHAR*)prm->ptr_value; ws<es;)
3590 *o++ = *ws++;
3591 *o = 0;
3592 }
3593 #endif
3594 } else
3595 { char datetime_str[128];
3596 int rep = (prm->cTypeID == SQL_C_CHAR ? ctxt->connection->rep_flag
3597 : REP_ISO_LATIN_1);
3598
3599 l = sizeof(datetime_str);
3600 s = datetime_str;
3601 if ( !PL_get_nchars(head, &l, &s, flags|rep) &&
3602 !get_datetime(head, &l, s) )
3603 return type_error(head, expected);
3604 len = l;
3605 if ( len > prm->length_ind )
3606 { DEBUG(1, Sdprintf("Column-width (SQL_C_CHAR) = %d\n",
3607 prm->length_ind));
3608 return representation_error(head, "column_width");
3609 }
3610 memcpy(prm->ptr_value, s, len+1);
3611 prm->len_value = len;
3612 }
3613
3614 break;
3615 }
3616 case SQL_C_TYPE_DATE:
3617 { if ( get_date(head, (DATE_STRUCT*)prm->ptr_value) )
3618 prm->len_value = sizeof(DATE_STRUCT);
3619 else if ( !try_null(ctxt, prm, head, "date") )
3620 return FALSE;
3621 break;
3622 }
3623 case SQL_C_TYPE_TIME:
3624 { if ( get_time(head, (TIME_STRUCT*)prm->ptr_value) )
3625 prm->len_value = sizeof(TIME_STRUCT);
3626 else if ( !try_null(ctxt, prm, head, "time") )
3627 return FALSE;
3628 break;
3629 }
3630 case SQL_C_TIMESTAMP:
3631 { if ( get_timestamp(head, (SQL_TIMESTAMP_STRUCT*)prm->ptr_value) )
3632 prm->len_value = sizeof(SQL_TIMESTAMP_STRUCT);
3633 else if ( !try_null(ctxt, prm, head, "timestamp") )
3634 return FALSE;
3635 break;
3636 }
3637 default:
3638 return PL_warning("Unknown parameter type: %d", prm->cTypeID);
3639 }
3640 }
3641 if ( !PL_get_nil(tail) )
3642 return type_error(tail, "list");
3643
3644 return TRUE;
3645 }
3646
3647 static foreign_t
3648 odbc_execute(term_t qid, term_t args, term_t row, control_t handle)
3649 { switch( PL_foreign_control(handle) )
3650 { case PL_FIRST_CALL:
3651 { context *ctxt;
3652 int self = PL_thread_self();
3653 if ( !getStmt(qid, &ctxt) )
3654 return FALSE;
3655 if ( true(ctxt, CTX_INUSE) )
3656 { context *clone;
3657
3658 if ( true(ctxt, CTX_NOAUTO) || !(clone = clone_context(ctxt)) )
3659 return context_error(qid, "in_use", "statement");
3660 else
3661 ctxt = clone;
3662 }
3663
3664 if ( !bind_parameters(ctxt, args) )
3665 return FALSE;
3666
3667 set(ctxt, CTX_INUSE);
3668 clear(ctxt, CTX_PREFETCHED);
3669 LOCK_CONTEXTS();
3670 if (!mark_context_as_executing(self, ctxt))
3671 { UNLOCK_CONTEXTS();
3672 return FALSE;
3673 }
3674 UNLOCK_CONTEXTS();
3675 ctxt->rc = SQLExecute(ctxt->hstmt);
3676 LOCK_CONTEXTS();
3677 clear(ctxt, CTX_EXECUTING);
3678 executing_contexts[self] = NULL;
3679 UNLOCK_CONTEXTS();
3680 while( ctxt->rc == SQL_NEED_DATA )
3681 { PTR token;
3682
3683 if ( (ctxt->rc = SQLParamData(ctxt->hstmt, &token)) == SQL_NEED_DATA )
3684 { parameter *p = &ctxt->params[(intptr_t)token - 1];
3685 size_t len;
3686 char *s;
3687
3688 if ( is_sql_null(p->put_data, ctxt->null) )
3689 { s = NULL;
3690 len = SQL_NULL_DATA;
3691 SQLPutData(ctxt->hstmt, s, len);
3692 } else
3693 { const char *expected = "text";
3694 unsigned int flags = plTypeID_convert_flags(p->plTypeID, &expected);
3695
3696 if ( p->cTypeID == SQL_C_WCHAR )
3697 { wchar_t *ws;
3698
3699 if ( !PL_get_wchars(p->put_data, &len, &ws, flags) )
3700 { SQLCancel(ctxt->hstmt);
3701 return type_error(p->put_data, expected);
3702 }
3703 #if SIZEOF_SQLWCHAR == SIZEOF_WCHAR_T
3704 SQLPutData(ctxt->hstmt, ws, len*sizeof(SQLWCHAR));
3705 #else
3706 { SQLWCHAR fast[256];
3707 SQLWCHAR *tmp;
3708 wchar_t *es = ws+len;
3709 SQLWCHAR *o;
3710
3711 if ( len+1 <= sizeof(fast)/sizeof(SQLWCHAR) )
3712 { tmp = fast;
3713 } else
3714 { if ( !(tmp = odbc_malloc((len+1)*sizeof(SQLWCHAR))) )
3715 { SQLCancel(ctxt->hstmt);
3716 return FALSE;
3717 }
3718 }
3719
3720 for(o=tmp; ws<es;)
3721 *o++ = *ws++;
3722 *o = 0;
3723 SQLPutData(ctxt->hstmt, tmp, len*sizeof(SQLWCHAR));
3724
3725 if ( tmp != fast )
3726 free(tmp);
3727 }
3728 #endif
3729 } else
3730 { int rep = (p->cTypeID == SQL_C_BINARY ? REP_ISO_LATIN_1
3731 : ctxt->connection->rep_flag);
3732
3733 if ( !PL_get_nchars(p->put_data, &len, &s, flags|rep) )
3734 { SQLCancel(ctxt->hstmt);
3735 return type_error(p->put_data, expected);
3736 }
3737 SQLPutData(ctxt->hstmt, s, len);
3738 }
3739 }
3740 }
3741 }
3742 if ( !report_status(ctxt) )
3743 { close_context(ctxt);
3744 return FALSE;
3745 }
3746
3747 if ( true(ctxt, CTX_NOAUTO) )
3748 return TRUE;
3749
3750 return odbc_row(ctxt, row);
3751 }
3752
3753 case PL_REDO:
3754 return odbc_row(PL_foreign_context_address(handle), row);
3755
3756 case PL_PRUNED:
3757 close_context(PL_foreign_context_address(handle));
3758 return TRUE;
3759
3760 default:
3761 assert(0);
3762 return FALSE;
3763 }
3764 }
3765
3766
3767 static int
3768 get_scroll_param(term_t param, int *orientation, long *offset)
3769 { atom_t name;
3770 size_t arity;
3771
3772 if ( PL_get_name_arity(param, &name, &arity) )
3773 { if ( name == ATOM_next && arity == 0 )
3774 { *orientation = SQL_FETCH_NEXT;
3775 *offset = 0;
3776 return TRUE;
3777 } else if ( name == ATOM_prior && arity == 0 )
3778 { *orientation = SQL_FETCH_PRIOR;
3779 *offset = 0;
3780 return TRUE;
3781 } else if ( name == ATOM_first && arity == 0 )
3782 { *orientation = SQL_FETCH_FIRST;
3783 *offset = 0;
3784 return TRUE;
3785 } else if ( name == ATOM_last && arity == 0 )
3786 { *orientation = SQL_FETCH_LAST;
3787 *offset = 0;
3788 return TRUE;
3789 } else if ( name == ATOM_absolute && arity == 1 )
3790 { *orientation = SQL_FETCH_ABSOLUTE;
3791 return get_long_arg_ex(1, param, offset);
3792 } else if ( name == ATOM_relative && arity == 1 )
3793 { *orientation = SQL_FETCH_RELATIVE;
3794 return get_long_arg_ex(1, param, offset);
3795 } else if ( name == ATOM_bookmark && arity == 1 )
3796 { *orientation = SQL_FETCH_BOOKMARK;
3797 return get_long_arg_ex(1, param, offset);
3798 } else
3799 return domain_error(param, "fetch_option");
3800 }
3801
3802 return type_error(param, "fetch_option");
3803 }
3804
3805
3806 static foreign_t
3807 odbc_next_result_set(term_t qid, control_t handle)
3808 { context *ctxt;
3809 int rc;
3810 if ( !getStmt(qid, &ctxt) )
3811 return FALSE;
3812 if ( false(ctxt, CTX_NOAUTO) || false(ctxt, CTX_INUSE) || false(ctxt, CTX_BOUND) )
3813 return permission_error("next_result_set", "statement", qid);
3814 rc = SQLMoreResults(ctxt->hstmt);
3815 /* We now need to free the buffers used to retrieve the previous result set and
3816 re-prepare them for the new result set
3817 */
3818 SQLFreeStmt(ctxt->hstmt, SQL_UNBIND);
3819 free_parameters(ctxt->NumCols, ctxt->result);
3820 ctxt->result = NULL;
3821 clear(ctxt, CTX_BOUND);
3822
3823 switch (rc)
3824 { case SQL_NO_DATA_FOUND:
3825 PL_fail;
3826 case SQL_SUCCESS_WITH_INFO:
3827 report_status(ctxt);
3828 /*FALLTHROUGH*/
3829 case SQL_SUCCESS:
3830 PL_succeed;
3831 default:
3832 if ( !report_status(ctxt) )
3833 { close_context(ctxt);
3834 return FALSE;
3835 }
3836 return TRUE;
3837 }
3838 }
3839
3840 static foreign_t
3841 odbc_fetch(term_t qid, term_t row, term_t options)
3842 { context *ctxt;
3843 term_t local_trow = PL_new_term_ref();
3844 int orientation;
3845 long offset;
3846
3847 if ( !getStmt(qid, &ctxt) )
3848 return FALSE;
3849 if ( false(ctxt, CTX_NOAUTO) || false(ctxt, CTX_INUSE) )
3850 return permission_error("fetch", "statement", qid);
3851
3852 if ( !true(ctxt, CTX_BOUND) )
3853 { if ( !prepare_result(ctxt) )
3854 return FALSE;
3855 set(ctxt, CTX_BOUND);
3856 }
3857
3858 if ( !ctxt->result ) /* not a SELECT statement */
3859 { SQLLEN rows = 0; /* was DWORD */
3860
3861 if ( ctxt->rc != SQL_NO_DATA_FOUND )
3862 ctxt->rc = SQLRowCount(ctxt->hstmt, &rows);
3863 if ( ctxt->rc == SQL_SUCCESS ||
3864 ctxt->rc == SQL_SUCCESS_WITH_INFO ||
3865 ctxt->rc == SQL_NO_DATA_FOUND )
3866 return PL_unify_term(row,
3867 PL_FUNCTOR, FUNCTOR_affected1,
3868 PL_LONG, (long)rows);
3869 return report_status(ctxt);
3870 }
3871
3872 if ( PL_get_nil(options) )
3873 { orientation = SQL_FETCH_NEXT;
3874 } else if ( PL_is_list(options) )
3875 { term_t tail = PL_copy_term_ref(options);
3876 term_t head = PL_new_term_ref();
3877
3878 while(PL_get_list(tail, head, tail))
3879 { if ( !get_scroll_param(head, &orientation, &offset) )
3880 return FALSE;
3881 }
3882 if ( !PL_get_nil(tail) )
3883 return type_error(tail, "list");
3884 } else if ( !get_scroll_param(options, &orientation, &offset) )
3885 return FALSE;
3886
3887 if ( orientation == SQL_FETCH_NEXT )
3888 ctxt->rc = SQLFetch(ctxt->hstmt);
3889 else
3890 ctxt->rc = SQLFetchScroll(ctxt->hstmt,
3891 (SQLSMALLINT)orientation,
3892 (SQLINTEGER)offset);
3893
3894 switch(ctxt->rc)
3895 { case SQL_NO_DATA_FOUND: /* no alternative */
3896 return PL_unify_atom(row, ATOM_end_of_file);
3897 case SQL_SUCCESS_WITH_INFO:
3898 report_status(ctxt);
3899 /*FALLTHROUGH*/
3900 case SQL_SUCCESS:
3901 if ( !pl_put_row(local_trow, ctxt) )
3902 { close_context(ctxt);
3903 return FALSE; /* with pending exception */
3904 }
3905
3906 return PL_unify(local_trow, row);
3907 default:
3908 if ( !report_status(ctxt) )
3909 { close_context(ctxt);
3910 return FALSE;
3911 }
3912
3913 return TRUE;
3914 }
3915 }
3916
3917
3918 static foreign_t
3919 odbc_close_statement(term_t qid)
3920 { context *ctxt;
3921
3922 if ( !getStmt(qid, &ctxt) )
3923 return FALSE;
3924
3925 close_context(ctxt);
3926
3927 return TRUE;
3928 }
3929
3930 static foreign_t
3931 odbc_cancel_thread(term_t Tid)
3932 { int tid;
3933
3934 if ( !PL_get_thread_id_ex(Tid, &tid) )
3935 return FALSE;
3936
3937 LOCK_CONTEXTS();
3938 if (tid < executing_context_size &&
3939 executing_contexts[tid] != NULL &&
3940 true(executing_contexts[tid], CTX_EXECUTING))
3941 SQLCancel(executing_contexts[tid]->hstmt);
3942 UNLOCK_CONTEXTS();
3943
3944 return TRUE;
3945 }
3946
3947
3948 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3949 $odbc_statistics/1
3950
3951 NOTE: enumeration of available statistics is done in Prolog
3952 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
3953
3954 static functor_t FUNCTOR_statements2; /* statements(created,freed) */
3955
3956 static int
3957 unify_int_arg(int pos, term_t t, long val)
3958 { term_t a = PL_new_term_ref();
3959
3960 if ( PL_get_arg(pos, t, a) )
3961 return PL_unify_integer(a, val);
3962
3963 return FALSE;
3964 }
3965
3966
3967 static foreign_t
3968 odbc_statistics(term_t what)
3969 { if ( !PL_is_compound(what) )
3970 return type_error(what, "compound");
3971
3972 if ( PL_is_functor(what, FUNCTOR_statements2) )
3973 { if ( unify_int_arg(1, what, statistics.statements_created) &&
3974 unify_int_arg(2, what, statistics.statements_freed) )
3975 return TRUE;
3976 } else
3977 return domain_error(what, "odbc_statistics");
3978
3979 return FALSE;
3980 }
3981
3982
3983 static foreign_t
3984 odbc_debug(term_t level)
3985 { if ( !PL_get_integer(level, &odbc_debuglevel) )
3986 return type_error(level, "integer");
3987
3988 return TRUE;
3989 }
3990
3991 static foreign_t
3992 pl_odbc_set_option(term_t option)
3993 {
3994 if ( PL_is_functor(option, FUNCTOR_connection_pooling1) )
3995 { int is_pooled = 0;
3996 if ( !get_bool_arg_ex(1, option, &is_pooled) )
3997 return FALSE;
3998 if (is_pooled) /* Note that it is not possible to turn pooling off once it is turned on */
3999 { if ( SQLSetEnvAttr(NULL,
4000 SQL_ATTR_CONNECTION_POOLING,
4001 (SQLPOINTER)SQL_CP_ONE_PER_HENV,
4002 SQL_IS_INTEGER) != SQL_SUCCESS)
4003 { return PL_warning("Could not configure connection pooling");
4004 }
4005 }
4006 }
4007 return TRUE;
4008 }
4009
4010
4011 #define MKFUNCTOR(name, arity) PL_new_functor(PL_new_atom(name), arity)
4012 #define NDET(name, arity, func) PL_register_foreign(name, arity, func, \
4013 PL_FA_NONDETERMINISTIC)
4014 #define DET(name, arity, func) PL_register_foreign(name, arity, func, 0)
4015
4016 install_t
4017 install_odbc4pl()
4018 { INIT_CONTEXT_LOCK();
4019 ATOM_row = PL_new_atom("row");
4020 ATOM_informational = PL_new_atom("informational");
4021 ATOM_default = PL_new_atom("default");
4022 ATOM_once = PL_new_atom("once");
4023 ATOM_multiple = PL_new_atom("multiple");
4024 ATOM_commit = PL_new_atom("commit");
4025 ATOM_rollback = PL_new_atom("rollback");
4026 ATOM_atom = PL_new_atom("atom");
4027 ATOM_string = PL_new_atom("string");
4028 ATOM_codes = PL_new_atom("codes");
4029 ATOM_integer = PL_new_atom("integer");
4030 ATOM_float = PL_new_atom("float");
4031 ATOM_time = PL_new_atom("time");
4032 ATOM_date = PL_new_atom("date");
4033 ATOM_timestamp = PL_new_atom("timestamp");
4034 ATOM_all_types = PL_new_atom("all_types");
4035 ATOM_null = PL_new_atom("$null$");
4036 ATOM_ = PL_new_atom("");
4037 ATOM_read = PL_new_atom("read");
4038 ATOM_update = PL_new_atom("update");
4039 ATOM_dynamic = PL_new_atom("dynamic");
4040 ATOM_forwards_only = PL_new_atom("forwards_only");
4041 ATOM_keyset_driven = PL_new_atom("keyset_driven");
4042 ATOM_static = PL_new_atom("static");
4043 ATOM_auto = PL_new_atom("auto");
4044 ATOM_fetch = PL_new_atom("fetch");
4045 ATOM_end_of_file = PL_new_atom("end_of_file");
4046 ATOM_next = PL_new_atom("next");
4047 ATOM_prior = PL_new_atom("prior");
4048 ATOM_first = PL_new_atom("first");
4049 ATOM_last = PL_new_atom("last");
4050 ATOM_absolute = PL_new_atom("absolute");
4051 ATOM_relative = PL_new_atom("relative");
4052 ATOM_bookmark = PL_new_atom("bookmark");
4053 ATOM_strict = PL_new_atom("strict");
4054 ATOM_relaxed = PL_new_atom("relaxed");
4055
4056 FUNCTOR_timestamp7 = MKFUNCTOR("timestamp", 7);
4057 FUNCTOR_time3 = MKFUNCTOR("time", 3);
4058 FUNCTOR_date3 = MKFUNCTOR("date", 3);
4059 FUNCTOR_odbc3 = MKFUNCTOR("odbc", 3);
4060 FUNCTOR_error2 = MKFUNCTOR("error", 2);
4061 FUNCTOR_type_error2 = MKFUNCTOR("type_error", 2);
4062 FUNCTOR_domain_error2 = MKFUNCTOR("domain_error", 2);
4063 FUNCTOR_existence_error2 = MKFUNCTOR("existence_error", 2);
4064 FUNCTOR_resource_error1 = MKFUNCTOR("resource_error", 1);
4065 FUNCTOR_permission_error3 = MKFUNCTOR("permission_error", 3);
4066 FUNCTOR_representation_error1 = MKFUNCTOR("representation_error", 1);
4067 FUNCTOR_odbc_statement1 = MKFUNCTOR("$odbc_statement", 1);
4068 FUNCTOR_odbc_connection1 = MKFUNCTOR("$odbc_connection", 1);
4069 FUNCTOR_encoding1 = MKFUNCTOR("encoding", 1);
4070 FUNCTOR_user1 = MKFUNCTOR("user", 1);
4071 FUNCTOR_password1 = MKFUNCTOR("password", 1);
4072 FUNCTOR_driver_string1 = MKFUNCTOR("driver_string", 1);
4073 FUNCTOR_alias1 = MKFUNCTOR("alias", 1);
4074 FUNCTOR_mars1 = MKFUNCTOR("mars", 1);
4075 FUNCTOR_connection_pooling1 = MKFUNCTOR("connection_pooling", 1);
4076 FUNCTOR_connection_pool_mode1 = MKFUNCTOR("connection_pool_mode", 1);
4077 FUNCTOR_odbc_version1 = MKFUNCTOR("odbc_version", 1);
4078 FUNCTOR_open1 = MKFUNCTOR("open", 1);
4079 FUNCTOR_auto_commit1 = MKFUNCTOR("auto_commit", 1);
4080 FUNCTOR_types1 = MKFUNCTOR("types", 1);
4081 FUNCTOR_minus2 = MKFUNCTOR("-", 2);
4082 FUNCTOR_gt2 = MKFUNCTOR(">", 2);
4083 FUNCTOR_context_error3 = MKFUNCTOR("context_error", 3);
4084 FUNCTOR_statements2 = MKFUNCTOR("statements", 2);
4085 FUNCTOR_data_source2 = MKFUNCTOR("data_source", 2);
4086 FUNCTOR_null1 = MKFUNCTOR("null", 1);
4087 FUNCTOR_source1 = MKFUNCTOR("source", 1);
4088 FUNCTOR_column3 = MKFUNCTOR("column", 3);
4089 FUNCTOR_access_mode1 = MKFUNCTOR("access_mode", 1);
4090 FUNCTOR_cursor_type1 = MKFUNCTOR("cursor_type", 1);
4091 FUNCTOR_silent1 = MKFUNCTOR("silent", 1);
4092 FUNCTOR_findall2 = MKFUNCTOR("findall", 2);
4093 FUNCTOR_affected1 = MKFUNCTOR("affected", 1);
4094 FUNCTOR_fetch1 = MKFUNCTOR("fetch", 1);
4095 FUNCTOR_wide_column_threshold1= MKFUNCTOR("wide_column_threshold", 1);
4096
4097 DET("odbc_set_option", 1, pl_odbc_set_option);
4098 DET("odbc_connect", 3, pl_odbc_connect);
4099 DET("odbc_disconnect", 1, pl_odbc_disconnect);
4100 DET("odbc_current_connections", 3, odbc_current_connections);
4101 DET("odbc_set_connection", 2, pl_odbc_set_connection);
4102 NDET("odbc_get_connection", 2, odbc_get_connection);
4103 DET("odbc_end_transaction", 2, odbc_end_transaction);
4104
4105 DET("odbc_prepare", 5, odbc_prepare);
4106 DET("odbc_clone_statement", 2, odbc_clone_statement);
4107 DET("odbc_free_statement", 1, odbc_free_statement);
4108 NDET("odbc_execute", 3, odbc_execute);
4109 DET("odbc_fetch", 3, odbc_fetch);
4110 DET("odbc_next_result_set", 1, odbc_next_result_set);
4111 DET("odbc_close_statement", 1, odbc_close_statement);
4112 DET("odbc_cancel_thread", 1, odbc_cancel_thread);
4113
4114 NDET("odbc_query", 4, pl_odbc_query);
4115 NDET("odbc_tables", 2, odbc_tables);
4116 NDET("odbc_column", 3, pl_odbc_column);
4117 NDET("odbc_types", 3, odbc_types);
4118 DET("odbc_data_sources", 1, odbc_data_sources);
4119
4120 DET("$odbc_statistics", 1, odbc_statistics);
4121 DET("odbc_debug", 1, odbc_debug);
4122
4123 NDET("odbc_primary_key", 3, odbc_primary_key);
4124 NDET("odbc_foreign_key", 4, odbc_foreign_key);
4125 }
4126
4127
4128 install_t
4129 uninstall_odbc() /* TBD: make sure the library is */
4130 { LOCK();
4131 if ( henv ) /* not in use! */
4132 { SQLFreeEnv(henv);
4133 henv = NULL;
4134 }
4135 UNLOCK();
4136 }
4137
4138
4139 /*******************************
4140 * TYPES *
4141 *******************************/
4142
4143 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4144 MS SQL Server seems to store the dictionary in UNICODE, returning the
4145 types SQL_WCHAR, etc.
4146 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4147
4148 static SWORD
4149 CvtSqlToCType(context *ctxt, SQLSMALLINT fSqlType, SQLSMALLINT plTypeID)
4150 { switch(plTypeID)
4151 { case SQL_PL_DEFAULT:
4152 switch (fSqlType)
4153 { case SQL_CHAR:
4154 case SQL_VARCHAR:
4155 case SQL_LONGVARCHAR:
4156 return SQL_C_CHAR;
4157 #ifdef SQL_WCHAR
4158 case SQL_WCHAR: /* see note above */
4159 case SQL_WVARCHAR:
4160 case SQL_WLONGVARCHAR:
4161 return ctxt->connection->encoding == ENC_SQLWCHAR ? SQL_C_WCHAR
4162 : SQL_C_CHAR;
4163 #endif
4164
4165 case SQL_BINARY:
4166 case SQL_VARBINARY:
4167 case SQL_LONGVARBINARY:
4168 return SQL_C_BINARY;
4169
4170 case SQL_DECIMAL:
4171 case SQL_NUMERIC:
4172 return SQL_C_CHAR;
4173
4174 case SQL_REAL:
4175 case SQL_FLOAT:
4176 case SQL_DOUBLE:
4177 return SQL_C_DOUBLE;
4178
4179 case SQL_BIT:
4180 case SQL_TINYINT:
4181 case SQL_SMALLINT:
4182 case SQL_INTEGER:
4183 return SQL_C_SLONG;
4184
4185 case SQL_BIGINT: /* 64-bit integers */
4186 return SQL_C_SBIGINT;
4187
4188 case SQL_DATE:
4189 case SQL_TYPE_DATE:
4190 return SQL_C_TYPE_DATE;
4191 case SQL_TIME:
4192 case SQL_TYPE_TIME:
4193 return SQL_C_TYPE_TIME;
4194 case SQL_TIMESTAMP:
4195 case SQL_TYPE_TIMESTAMP:
4196 return SQL_C_TIMESTAMP;
4197 default:
4198 if ( !true(ctxt, CTX_SILENT) )
4199 Sdprintf("Mapped unknown fSqlType %d to atom\n", fSqlType);
4200 return SQL_C_CHAR;
4201 }
4202 case SQL_PL_ATOM:
4203 case SQL_PL_STRING:
4204 case SQL_PL_CODES:
4205 switch (fSqlType)
4206 { case SQL_BINARY:
4207 case SQL_VARBINARY:
4208 case SQL_LONGVARBINARY:
4209 return SQL_C_BINARY;
4210 case SQL_WCHAR:
4211 case SQL_WVARCHAR:
4212 case SQL_WLONGVARCHAR:
4213 return ctxt->connection->encoding == ENC_SQLWCHAR ? SQL_C_WCHAR
4214 : SQL_C_CHAR;
4215 default:
4216 return SQL_C_CHAR;
4217 }
4218 case SQL_PL_INTEGER:
4219 switch(fSqlType)
4220 { case SQL_TIMESTAMP:
4221 return SQL_C_TIMESTAMP;
4222 case SQL_BIGINT: /* 64-bit integers */
4223 return SQL_C_SBIGINT;
4224 default:
4225 return SQL_C_SLONG;
4226 }
4227 case SQL_PL_FLOAT:
4228 switch(fSqlType)
4229 { case SQL_TIMESTAMP:
4230 return SQL_C_TIMESTAMP;
4231 default:
4232 return SQL_C_DOUBLE;
4233 }
4234 case SQL_PL_DATE:
4235 return SQL_C_TYPE_DATE;
4236 case SQL_PL_TIME:
4237 return SQL_C_TYPE_TIME;
4238 case SQL_PL_TIMESTAMP:
4239 return SQL_C_TIMESTAMP;
4240 default:
4241 assert(0);
4242 return CVNERR;
4243 }
4244 }
4245
4246
4247 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4248 pl_put_column(context *c, int nth, term_t col)
4249
4250 Put the nth (0-based) result column of the statement in the Prolog
4251 variable col. If the source(true) option is in effect, bind col to
4252 column(Table, Column, Value)
4253
4254 If ptr_value is NULL, prepare_result() has not used SQLBindCol() due
4255 to a potentionally too large field such as for SQL_LONGVARCHAR
4256 columns.
4257
4258 There is a lot of odd code around the SQL_SERVER_BUG below. It turns out
4259 Microsoft SQL Server sometimes gives the wrong length indication as well
4260 as the wrong number of pad bytes for the first part of the data.
4261 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4262
4263 static int
4264 plTypeID_to_pltype(int plTypeID)
4265 { switch( plTypeID )
4266 { case SQL_PL_DEFAULT:
4267 case SQL_PL_ATOM:
4268 return PL_ATOM;
4269 case SQL_PL_STRING:
4270 return PL_STRING;
4271 case SQL_PL_CODES:
4272 return PL_CODE_LIST;
4273 default:
4274 assert(0);
4275 return FALSE;
4276 }
4277 }
4278
4279
4280 WUNUSED static int
4281 put_chars(term_t val, int plTypeID, int rep, size_t len, const char *chars)
4282 { int pltype = plTypeID_to_pltype(plTypeID);
4283
4284 return PL_unify_chars(val, pltype|rep, len, chars);
4285 }
4286
4287
4288 WUNUSED static int
4289 put_wchars(term_t val, int plTypeID, size_t len, const SQLWCHAR *chars)
4290 { int pltype = plTypeID_to_pltype(plTypeID);
4291
4292 #if SIZEOF_SQLWCHAR == SIZEOF_WCHAR_T
4293 return PL_unify_wchars(val, pltype, len, chars);
4294 #else
4295 wchar_t fast[256];
4296 wchar_t *tmp, *o;
4297 const SQLWCHAR *es = &chars[len];
4298 int rc;
4299
4300 if ( len+1 <= sizeof(fast)/sizeof(fast[0]) )
4301 { tmp = fast;
4302 } else
4303 { if ( !(tmp = odbc_malloc((len+1)*sizeof(wchar_t))) )
4304 return FALSE;
4305 }
4306
4307 for(o=tmp; chars<es;)
4308 *o++ = *chars++;
4309 *o = 0;
4310 rc = PL_unify_wchars(val, pltype, len, tmp);
4311
4312 if ( tmp != fast )
4313 free(tmp);
4314
4315 return rc;
4316 #endif
4317 }
4318
4319
4320 static int
4321 pl_put_column(context *c, int nth, term_t col)
4322 { parameter *p = &c->result[nth];
4323 term_t cell;
4324 term_t val;
4325
4326 if ( true(c, CTX_SOURCE) )
4327 { cell = PL_new_term_refs(3);
4328
4329 PL_put_atom(cell+0, p->source.table);
4330 PL_put_atom(cell+1, p->source.column);
4331 val = cell+2;
4332 } else
4333 { val = col;
4334 cell = 0; /* make compiler happy */
4335 }
4336
4337 if ( !p->ptr_value ) /* use SQLGetData() */
4338 { char buf[256];
4339 char *data = buf;
4340 SQLLEN len;
4341
4342 DEBUG(2, Sdprintf("Fetching value for column %d using SQLGetData()\n",
4343 nth+1));
4344
4345 c->rc = SQLGetData(c->hstmt, (UWORD)(nth+1), p->cTypeID,
4346 buf, sizeof(buf), &len);
4347
4348 if ( c->rc == SQL_SUCCESS || c->rc == SQL_SUCCESS_WITH_INFO )
4349 { DEBUG(2, Sdprintf("Got %ld bytes\n", len));
4350 if ( len == SQL_NULL_DATA )
4351 { if ( !put_sql_null(val, c->null) )
4352 return FALSE;
4353 goto ok;
4354 } else if ( len == SQL_NO_TOTAL )
4355 { int pad = p->cTypeID == SQL_C_CHAR ? 1 : 0;
4356 int readsofar = sizeof(buf) - pad;
4357 SQLLEN bufsize = 2048; /* must be > sizeof(buf) */
4358
4359 if ( !(data = odbc_malloc(bufsize)) )
4360 return FALSE;
4361 memcpy(data, buf, sizeof(buf));
4362
4363 do /* Read blocks */
4364 { c->rc = SQLGetData(c->hstmt, (UWORD)(nth+1), p->cTypeID,
4365 &data[readsofar], bufsize-readsofar, &len);
4366 if ( c->rc == SQL_ERROR )
4367 { DEBUG(1, Sdprintf("SQLGetData() returned %d\n", c->rc));
4368 return report_status(c);
4369 } else if ( len == SQL_NO_DATA ) /* Previous block was final one */
4370 { len += readsofar;
4371 goto got_all_data;
4372 } else if ( len == SQL_NO_TOTAL ) /* More blocks are yet to come */
4373 { int chunk = bufsize-readsofar-pad;
4374 readsofar += chunk;
4375 bufsize *= 2;
4376 if ( !(data = odbc_realloc(data, bufsize)) )
4377 return FALSE;
4378 } else if ( len <= bufsize-readsofar ) /* This block is the last one */
4379 { len += readsofar;
4380 goto got_all_data;
4381 } else /* Is this possible? */
4382 { readsofar+= len; /* It is analgous to the case */
4383 bufsize *= 2; /* below where SQL_NO_TOTAL is */
4384 if ( !(data = odbc_realloc(data, bufsize)) ) /* not returned */
4385 return FALSE;
4386 }
4387 } while(c->rc != SQL_SUCCESS && c->rc != SQL_NO_DATA);
4388 len = readsofar;
4389 } else if ( len >= (SDWORD)sizeof(buf) )
4390 { int pad;
4391 size_t todo;
4392 SQLLEN len2;
4393 char *ep;
4394 int part = 2;
4395
4396 switch(p->cTypeID)
4397 { case SQL_C_CHAR:
4398 pad = sizeof(SQLCHAR);
4399 break;
4400 case SQL_C_WCHAR:
4401 pad = sizeof(SQLWCHAR);
4402 break;
4403 default:
4404 pad = 0;
4405 }
4406 todo = len-sizeof(buf)+2*pad;
4407 if ( !(data = odbc_malloc(len+pad)) )
4408 return FALSE;
4409 memcpy(data, buf, sizeof(buf)); /* you don't get the data twice! */
4410 ep = data+sizeof(buf)-pad;
4411 #ifdef SQL_SERVER_BUG /* compensate for wrong pad info */
4412 while(ep>data && ep[-1] == 0)
4413 { ep--;
4414 todo++;
4415 }
4416 #endif
4417 while(todo > 0)
4418 { c->rc = SQLGetData(c->hstmt, (UWORD)(nth+1), p->cTypeID,
4419 ep, todo, &len2);
4420 DEBUG(2, Sdprintf("Requested %d bytes for part %d; \
4421 pad=%d; got %ld\n",
4422 todo, part, pad, len2));
4423 todo -= len2;
4424 ep += len2;
4425 part++;
4426
4427 switch( c->rc )
4428 { case SQL_SUCCESS:
4429 len = ep-data;
4430 goto got_all_data;
4431 case SQL_SUCCESS_WITH_INFO:
4432 break;
4433 default:
4434 { Sdprintf("ERROR: %d\n", c->rc);
4435 free(data);
4436 return report_status(c);
4437 }
4438 }
4439 }
4440 }
4441 } else
4442 { DEBUG(1, Sdprintf("SQLGetData() returned %d\n", c->rc));
4443 return report_status(c);
4444 }
4445
4446 got_all_data:
4447 if ( p->cTypeID == SQL_C_WCHAR )
4448 { if ( !put_wchars(val, p->plTypeID, len/sizeof(SQLWCHAR), (SQLWCHAR*)data) )
4449 { if ( data != buf )
4450 free(data);
4451 return FALSE;
4452 }
4453 } else
4454 { int rep = (p->cTypeID == SQL_C_BINARY ? REP_ISO_LATIN_1
4455 : c->connection->rep_flag);
4456
4457 if ( !put_chars(val, p->plTypeID, rep, len, data) )
4458 { if ( data != buf )
4459 free(data);
4460 return FALSE;
4461 }
4462 }
4463 if ( data != buf )
4464 free(data);
4465 goto ok;
4466 }
4467
4468 if ( p->length_ind == SQL_NULL_DATA )
4469 { if ( !put_sql_null(val, c->null) )
4470 return FALSE;
4471 } else
4472 { int rc;
4473
4474 switch( p->cTypeID )
4475 { case SQL_C_CHAR:
4476 rc = put_chars(val, p->plTypeID, c->connection->rep_flag,
4477 p->length_ind, (char*)p->ptr_value);
4478 break;
4479 case SQL_C_WCHAR:
4480 rc = put_wchars(val, p->plTypeID,
4481 p->length_ind/sizeof(SQLWCHAR), (SQLWCHAR*)p->ptr_value);
4482 break;
4483 case SQL_C_BINARY:
4484 rc = put_chars(val, p->plTypeID, REP_ISO_LATIN_1,
4485 p->length_ind, (char*)p->ptr_value);
4486 break;
4487 case SQL_C_SLONG:
4488 rc = PL_put_integer(val,*(SQLINTEGER *)p->ptr_value);
4489 break;
4490 case SQL_C_SBIGINT:
4491 rc = PL_put_int64(val, *(SQLBIGINT *)p->ptr_value);
4492 break;
4493 case SQL_C_DOUBLE:
4494 rc = PL_put_float(val,*(SQLDOUBLE *)p->ptr_value);
4495 break;
4496 case SQL_C_TYPE_DATE:
4497 { DATE_STRUCT* ds = (DATE_STRUCT*)p->ptr_value;
4498 term_t av;
4499
4500 rc = ( (av=PL_new_term_refs(3)) &&
4501 PL_put_integer(av+0, ds->year) &&
4502 PL_put_integer(av+1, ds->month) &&
4503 PL_put_integer(av+2, ds->day) &&
4504 PL_cons_functor_v(val, FUNCTOR_date3, av)
4505 );
4506 break;
4507 }
4508 case SQL_C_TYPE_TIME:
4509 { TIME_STRUCT* ts = (TIME_STRUCT*)p->ptr_value;
4510 term_t av;
4511
4512 rc = ( (av=PL_new_term_refs(3)) &&
4513 PL_put_integer(av+0, ts->hour) &&
4514 PL_put_integer(av+1, ts->minute) &&
4515 PL_put_integer(av+2, ts->second) &&
4516 PL_cons_functor_v(val, FUNCTOR_time3, av)
4517 );
4518 break;
4519 }
4520 case SQL_C_TIMESTAMP:
4521 { SQL_TIMESTAMP_STRUCT* ts = (SQL_TIMESTAMP_STRUCT*)p->ptr_value;
4522
4523 switch( p->plTypeID )
4524 { case SQL_PL_DEFAULT:
4525 case SQL_PL_TIMESTAMP:
4526 { term_t av;
4527
4528 rc = ( (av=PL_new_term_refs(7)) &&
4529 PL_put_integer(av+0, ts->year) &&
4530 PL_put_integer(av+1, ts->month) &&
4531 PL_put_integer(av+2, ts->day) &&
4532 PL_put_integer(av+3, ts->hour) &&
4533 PL_put_integer(av+4, ts->minute) &&
4534 PL_put_integer(av+5, ts->second) &&
4535 PL_put_integer(av+6, ts->fraction) &&
4536 PL_cons_functor_v(val, FUNCTOR_timestamp7, av)
4537 );
4538 break;
4539 }
4540 case SQL_PL_INTEGER:
4541 case SQL_PL_FLOAT:
4542 #ifdef HAVE_TIMEGM
4543 { struct tm tm;
4544 time_t t;
4545
4546 #ifndef USE_UTC
4547 t = time(NULL);
4548 tm = *localtime(&t);
4549 #else
4550 memset(&tm, 0, sizeof(tm));
4551 #endif
4552 tm.tm_year = ts->year - 1900;
4553 tm.tm_mon = ts->month-1;
4554 tm.tm_mday = ts->day;
4555 tm.tm_hour = ts->hour;
4556 tm.tm_min = ts->minute;
4557 tm.tm_sec = ts->second;
4558
4559 #ifdef USE_UTC
4560 t = timegm(&tm);
4561 #else
4562 t = mktime(&tm);
4563 #endif
4564
4565 if ( p->plTypeID == SQL_PL_INTEGER )
4566 rc = PL_put_int64(val, t);
4567 else
4568 rc = PL_put_float(val, (double)t); /* TBD: fraction */
4569 }
4570 #else
4571 return PL_warning("System doesn't support mktime()/timegm()");
4572 #endif
4573 break;
4574 default:
4575 rc = 0; /* keep compiler happy */
4576 assert(0);
4577 }
4578 break;
4579 }
4580 default:
4581 return PL_warning("ODBC: Unknown cTypeID: %d",
4582 p->cTypeID);
4583 }
4584 if ( !rc )
4585 return FALSE;
4586 }
4587
4588 ok:
4589 if ( true(c, CTX_SOURCE) )
4590 return PL_cons_functor_v(col, FUNCTOR_column3, cell);
4591
4592 return TRUE;
4593 }
4594
4595
4596
4597
4598 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4599 Store a row
4600 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4601
4602 static int
4603 pl_put_row(term_t row, context *c)
4604 { term_t columns = PL_new_term_refs(c->NumCols);
4605 SQLSMALLINT i;
4606
4607 for (i=0; i<c->NumCols; i++)
4608 { if ( !pl_put_column(c, i, columns+i) )
4609 return FALSE; /* with exception */
4610 }
4611
4612 return PL_cons_functor_v(row, c->db_row, columns);
4613 }
4614
4615
4616 #ifdef EMULATE_TIMEGM
4617
4618 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4619 timegm() is provided by glibc and the inverse of gmtime(). The glibc
4620 library suggests using mktime with TZ=UTC as alternative.
4621 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
4622
4623 static time_t
4624 timegm(struct tm *tm)
4625 { char *otz = getenv("TZ");
4626 time_t t;
4627 char oenv[20];
4628
4629 if ( otz && strlen(otz) < 10 ) /* avoid buffer overflow */
4630 { putenv("TZ=UTC");
4631 t = mktime(tm);
4632 strcpy(oenv, "TZ=");
4633 strcat(oenv, otz);
4634 putenv(oenv);
4635 } else if ( otz )
4636 { Sdprintf("Too long value for TZ: %s", otz);
4637 t = mktime(tm);
4638 } else /* not set, what to do? */
4639 { t = mktime(tm);
4640 }
4641
4642 return t;
4643 }
4644
4645
4646 #endif
4647