1 /*-------------------------------------------------------------------------.
2 *
3 * pgtclCmds.c
4 * C functions which implement pg_* tcl commands
5 *
6 * Portions Copyright (c) 2004-2013, L Bayuk
7 * Portions Copyright (c) 1996-2004, PostgreSQL Global Development Group
8 * Portions Copyright (c) 1994, Regents of the University of California
9 *
10 *
11 * IDENTIFICATION
12 * $Id: pgtclCmds.c 372 2014-09-12 19:37:05Z lbayuk $
13 *
14 *-------------------------------------------------------------------------
15 */
16
17 #include <ctype.h>
18 #include <string.h>
19
20 #include "pgtclCmds.h"
21 #include "pgtclId.h"
22 #include "libpq/libpq-fs.h" /* large-object interface */
23
24 /*
25 * Local function forward declarations
26 */
27 static int execute_put_values(Tcl_Interp *interp, char *array_varname,
28 PGresult *result, int tupno);
29
30 static Tcl_Obj *result_get_obj(PGresult *result, int tupno, int colno);
31
32 static Tcl_Obj *get_row_list_obj(Tcl_Interp *interp, PGresult *result,
33 int tupno);
34
35
36 /**********************************
37 * pg_conndefaults
38
39 syntax:
40 pg_conndefaults
41
42 the return result is a list describing the possible options and their
43 current default values for a call to pg_connect with the new -conninfo
44 syntax. Each entry in the list is a sublist of the format:
45
46 {optname label dispchar dispsize value}
47
48 **********************************/
49
50 int
Pg_conndefaults(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])51 Pg_conndefaults(ClientData cData, Tcl_Interp *interp, int objc,
52 Tcl_Obj *CONST objv[])
53 {
54 PQconninfoOption *options = PQconndefaults();
55 PQconninfoOption *option;
56
57 if (objc != 1)
58 {
59 Tcl_WrongNumArgs(interp, 1, objv, "");
60 return TCL_ERROR;
61 }
62
63 if (options)
64 {
65 Tcl_Obj *resultList = Tcl_GetObjResult(interp);
66
67 Tcl_SetListObj(resultList, 0, NULL);
68
69 for (option = options; option->keyword != NULL; option++)
70 {
71 char *val = option->val ? option->val : "";
72
73 /* start a sublist */
74 Tcl_Obj *subList = Tcl_NewListObj(0, NULL);
75
76 if (Tcl_ListObjAppendElement(interp, subList,
77 Tcl_NewStringObj(option->keyword, -1)) == TCL_ERROR)
78 return TCL_ERROR;
79
80 if (Tcl_ListObjAppendElement(interp, subList,
81 Tcl_NewStringObj(option->label, -1)) == TCL_ERROR)
82 return TCL_ERROR;
83
84 if (Tcl_ListObjAppendElement(interp, subList,
85 Tcl_NewStringObj(option->dispchar, -1)) == TCL_ERROR)
86 return TCL_ERROR;
87
88 if (Tcl_ListObjAppendElement(interp, subList,
89 Tcl_NewIntObj(option->dispsize)) == TCL_ERROR)
90 return TCL_ERROR;
91
92 if (Tcl_ListObjAppendElement(interp, subList,
93 Tcl_NewStringObj(val, -1)) == TCL_ERROR)
94 return TCL_ERROR;
95
96 if (Tcl_ListObjAppendElement(interp, resultList,
97 subList) == TCL_ERROR)
98 return TCL_ERROR;
99 }
100 PQconninfoFree(options);
101 }
102 return TCL_OK;
103 }
104
105
106 /**********************************
107 * pg_connect
108 Make a connection to a backend.
109
110 Syntax:
111
112 pg_connect -conninfo connInfoString
113 Where connInfoString looks like: "host=Hostname dbname=Databasename..."
114 Or, connInfoString can be a postgresql:// or postgres:// URI. This is
115 handled transparently by the libpq function PQconnectDB().
116 pg_connect -connlist connInfoList
117 Where connInfoList is a Tcl list of option name/value pairs.
118 pg_connect dbName [-host hostName] [-port portNumber] [-tty pqtty]
119 This is an old, obsolete form.
120
121 The result is a database connection handle, or a Tcl error with error
122 message on failure.
123
124 **********************************/
125
126 int
Pg_connect(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])127 Pg_connect(ClientData cData, Tcl_Interp *interp, int objc,
128 Tcl_Obj *CONST objv[])
129 {
130 PGconn *conn;
131 const char *firstArg;
132 static char *usage = "-conninfo conninfoString | "
133 "-connlist conninfoList | "
134 "dbName ?options?";
135
136 if (objc == 1)
137 {
138 Tcl_WrongNumArgs(interp, 1, objv, usage);
139 return TCL_ERROR;
140 }
141
142 firstArg = Tcl_GetString(objv[1]);
143 if (strcmp(firstArg, "-conninfo") == 0)
144 {
145 /*
146 * Establish a connection using PQconnectdb()
147 */
148 char *conninfoString;
149
150 if (objc != 3)
151 {
152 Tcl_WrongNumArgs(interp, 2, objv, "conninfoString");
153 return TCL_ERROR;
154 }
155 conninfoString = Tcl_GetString(objv[2]);
156 conn = PQconnectdb(conninfoString);
157 }
158 else if (strcmp(firstArg, "-connlist") == 0)
159 {
160 /*
161 * Establish a connection using PQconnectdbParams()
162 */
163 Tcl_Obj *connList;
164 const char **connKeywords;
165 const char **nextKeyword;
166 const char **connValues;
167 const char **nextValue;
168 int nKeywords;
169 int listLen;
170 int i;
171 int listIndex;
172 Tcl_Obj *connListElement;
173
174 if (objc != 3)
175 {
176 Tcl_WrongNumArgs(interp, 2, objv, "conninfoList");
177 return TCL_ERROR;
178 }
179 connList = objv[2];
180 if (Tcl_ListObjLength(interp, connList, &listLen) == TCL_ERROR)
181 {
182 return TCL_ERROR;
183 }
184 if (listLen % 2)
185 {
186 Tcl_AppendResult(interp, "conninfoList must have"
187 " an even number of elements", 0);
188 return TCL_ERROR;
189 }
190
191 /*
192 * Copy the keyword/value pairwise list to 2 separate arrays for
193 * PQconnectdbParams()
194 */
195 nKeywords = listLen / 2;
196 connKeywords = (const char **)Tcl_Alloc((nKeywords + 1) * sizeof(char *));
197 connValues = (const char **)Tcl_Alloc((nKeywords + 1) * sizeof(char *));
198 listIndex = 0;
199 nextKeyword = connKeywords;
200 nextValue = connValues;
201 for (i = 0; i < nKeywords; i++)
202 {
203 Tcl_ListObjIndex(interp, connList, listIndex++, &connListElement);
204 *nextKeyword++ = Tcl_GetString(connListElement);
205 Tcl_ListObjIndex(interp, connList, listIndex++, &connListElement);
206 *nextValue++ = Tcl_GetString(connListElement);
207 }
208 *nextKeyword = *nextValue = NULL;
209 conn = PQconnectdbParams(connKeywords, connValues, 0);
210 Tcl_Free((char *)connKeywords);
211 Tcl_Free((char *)connValues);
212 }
213 else if (*firstArg == '-')
214 {
215 /*
216 * Catch usage error, rather than assuming -xxx is a database name
217 */
218 Tcl_WrongNumArgs(interp, 1, objv, usage);
219 return TCL_ERROR;
220 }
221 else
222 {
223 /*
224 * Establish a connection using the obsolete PQsetdb() interface.
225 * "firstarg" is the database name.
226 */
227 int i;
228 char *nextArg;
229 int optIndex;
230 const char *pghost = NULL;
231 const char *pgtty = NULL;
232 const char *pgport = NULL;
233 const char *pgoptions = NULL;
234 static CONST84 char *options[] = {
235 "-host", "-port", "-tty", "-options", (char *)NULL
236 };
237 enum options
238 {
239 OPT_HOST, OPT_PORT, OPT_TTY, OPT_OPTIONS
240 };
241
242
243 if (objc > 2) /* More options follow the datbase name*/
244 {
245 /* parse for pg environment settings */
246 i = 2;
247 while (i + 1 < objc)
248 {
249 nextArg = Tcl_GetString(objv[i + 1]);
250
251 /* process command options */
252 if (Tcl_GetIndexFromObj(interp, objv[i], options,
253 "switch", TCL_EXACT, &optIndex) != TCL_OK)
254 return TCL_ERROR;
255
256 switch ((enum options) optIndex)
257 {
258 case OPT_HOST:
259 {
260 pghost = nextArg;
261 i += 2;
262 break;
263 }
264
265 case OPT_PORT:
266 {
267 pgport = nextArg;
268 i += 2;
269 break;
270 }
271
272 case OPT_TTY:
273 {
274 pgtty = nextArg;
275 i += 2;
276 break;
277 }
278
279 case OPT_OPTIONS:
280 {
281 pgoptions = nextArg;
282 i += 2;
283 }
284 }
285 }
286
287 if ((i % 2 != 0) || i != objc)
288 {
289 Tcl_WrongNumArgs(interp, 1, objv, "databaseName ?-host hostName? ?-port portNumber? ?-tty pgtty? ?-options pgoptions?");
290 return TCL_ERROR;
291 }
292 }
293 conn = PQsetdb(pghost, pgport, pgoptions, pgtty, firstArg);
294 }
295
296 if (PQstatus(conn) != CONNECTION_OK)
297 {
298 Tcl_AppendResult(interp, "Connection to database failed\n",
299 PQerrorMessage(conn), 0);
300 PQfinish(conn);
301 return TCL_ERROR;
302 }
303
304 PgSetConnectionId(interp, conn);
305 /* Set libpq's client encoding to UNICODE (UTF8), since that is what
306 Tcl >= 8.1 uses for internal character storage. This replaces
307 the PGCLIENTENCODING environment variable setting in pgtcl.c,
308 which did not work with Windows DLLs.
309 */
310 if (PQsetClientEncoding(conn, "UTF8") != 0)
311 {
312 Tcl_AppendResult(interp, "Unable to set client encoding\n",
313 PQerrorMessage(conn), 0);
314 PQfinish(conn);
315 return TCL_ERROR;
316 }
317
318 return TCL_OK;
319 }
320
321
322 /**********************************
323 * pg_disconnect
324 close a backend connection
325
326 syntax:
327 pg_disconnect connection
328
329 The argument passed in must be a connection pointer.
330
331 **********************************/
332
333 int
Pg_disconnect(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])334 Pg_disconnect(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
335 {
336 PGconn *conn;
337 Tcl_Channel conn_chan;
338 char *connString;
339
340 if (objc != 2)
341 {
342 Tcl_WrongNumArgs(interp, 1, objv, "connection");
343 return TCL_ERROR;
344 }
345
346 connString = Tcl_GetString(objv[1]);
347 conn_chan = Tcl_GetChannel(interp, connString, 0);
348 if (conn_chan == NULL)
349 {
350 Tcl_ResetResult(interp);
351 Tcl_AppendResult(interp, connString, " is not a valid connection", 0);
352 return TCL_ERROR;
353 }
354
355 /* Check that it is a PG connection and not something else */
356 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
357 if (conn == (PGconn *) NULL)
358 return TCL_ERROR;
359
360 return Tcl_UnregisterChannel(interp, conn_chan);
361 }
362
363 /**********************************
364 * pg_encrypt_password
365 Encrypt (hash) a password/username, like PostgreSQL does.
366
367 syntax:
368 pg_encrypt_password password username
369
370 Returns the resulting hash as a string.
371
372 **********************************/
373
374 #ifdef HAVE_PQENCRYPTPASSWORD /* PostgreSQL >= 8.2.0 */
375 int
Pg_encrypt_password(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])376 Pg_encrypt_password(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
377 {
378 CONST char *password;
379 CONST char *username;
380 char *encrypted;
381
382 if (objc != 3)
383 {
384 Tcl_WrongNumArgs(interp, 1, objv, "password username");
385 return TCL_ERROR;
386 }
387
388 password = Tcl_GetString(objv[1]);
389 username = Tcl_GetString(objv[2]);
390
391 encrypted = PQencryptPassword(password, username);
392 if (!encrypted)
393 {
394 Tcl_ResetResult(interp);
395 Tcl_AppendResult(interp, "PQencryptPassword failed", 0);
396 return TCL_ERROR;
397 }
398
399 Tcl_SetObjResult(interp, Tcl_NewStringObj(encrypted, -1));
400 return TCL_OK;
401 }
402 #endif
403
404
405 /**********************************
406 * get_result_format - Helper for pg_exec_prepared and pg_exec_params
407
408 Parse resultListObj and make resultFormat argument.
409 The Tcl command syntax supports per-column result formats, but libpq
410 does not (yet), so make sure the caller isn't asking for something
411 that libpq can't handle. Take the first value, and make sure the
412 remaining ones match.
413 On success, store the result format in *resultFormat and return TCL_OK.
414 On error, store a message in the interp and return TCL_ERROR.
415
416 **********************************/
417 static int
get_result_format(Tcl_Interp * interp,Tcl_Obj * resultListObj,int * resultFormat)418 get_result_format(Tcl_Interp *interp, Tcl_Obj *resultListObj, int *resultFormat)
419 {
420 int listLen;
421 Tcl_Obj **objp;
422 int i;
423
424 if (Tcl_ListObjGetElements(interp, resultListObj, &listLen, &objp) != TCL_OK)
425 {
426 Tcl_SetResult(interp, "Invalid resultFormatList parameter", TCL_STATIC);
427 return TCL_ERROR;
428 }
429 if (listLen > 0)
430 {
431 *resultFormat = (*Tcl_GetString(objp[0]) == 'B');
432 for (i = 1; i < listLen; i++)
433 if (*resultFormat != (*Tcl_GetString(objp[i]) == 'B'))
434 {
435 Tcl_SetResult(interp, "Mixed resultFormat values are not supported",
436 TCL_STATIC);
437 return TCL_ERROR;
438 }
439 }
440 else *resultFormat = 0; /* Empty list => All TEXT */
441
442 return TCL_OK;;
443 }
444
445 /**********************************
446 * get_param_formats - Helper for pg_exec_prepared and pg_exec_params
447
448 Parse argFormat list and make paramFormats argument.
449 The parameter must either be empty (all TEXT), a single word T*|B*
450 (all that format), or nParams values, one per query parameter.
451 The libpq call will accept a null pointer for this argument, meaning
452 all text, so we can avoid the allocation in that most common case.
453 Set the allParamsText flag in that case.
454
455 On success, set or clear the allParamsText flag, store a NULL
456 pointer or a pointer to nParams ints in paramFormatsResult,
457 and return TCL_OK. (Caller must free paramFormatsResult.)
458 On error, store a message in the interp and return TCL_ERROR.
459
460 **********************************/
461 static int
get_param_formats(Tcl_Interp * interp,Tcl_Obj * argFormatListObj,int nParams,int * allParamsText,int ** paramFormatsResult)462 get_param_formats(Tcl_Interp *interp, Tcl_Obj *argFormatListObj,
463 int nParams, int *allParamsText, int **paramFormatsResult)
464 {
465 int listLen;
466 Tcl_Obj **objp;
467 int *paramFormats;
468 int i;
469
470 if (Tcl_ListObjGetElements(interp, argFormatListObj, &listLen, &objp) != TCL_OK)
471 {
472 Tcl_SetResult(interp, "Invalid argFormatList parameter", TCL_STATIC);
473 return TCL_ERROR;
474 }
475
476 paramFormats = NULL;
477 *allParamsText = 1;
478 if (listLen == 1)
479 {
480 if (*Tcl_GetString(objp[0]) == 'B')
481 {
482 paramFormats = (int *)Tcl_Alloc(nParams * sizeof(int));
483 for (i = 0; i < nParams; i++)
484 paramFormats[i] = 1;
485 *allParamsText = 0;
486 }
487 }
488 else if (listLen > 1)
489 {
490 if (listLen != nParams)
491 {
492 Tcl_SetResult(interp, "Mismatched argFormatList and parameter count",
493 TCL_STATIC);
494 return TCL_ERROR;
495 }
496 paramFormats = (int *)Tcl_Alloc(nParams * sizeof(int));
497 for (i = 0; i < nParams; i++)
498 if ((paramFormats[i] = (*Tcl_GetString(objp[i]) == 'B')))
499 *allParamsText = 0;
500 }
501
502 *paramFormatsResult = paramFormats;
503 return TCL_OK;
504 }
505
506 /**********************************
507 * get_param_values - Helper for pg_exec, pg_exec_prepared, and pg_exec_params
508
509 For each query parameter, we need its address in an array paramValues.
510 For each binary-format query parameter, we need its length in an
511 array paramLengths. (Length is ignored for text-format parameters.)
512 If there are no binary parameters, paramLengths will be NULL.
513 (If this is known in advance, and the allParamText flag is 1, then the
514 the paramLengths_result argument can be supplied as NULL. This is used
515 by the extended form of pg_exec.)
516 If there are no query parameters, both arrays are NULL.
517 CHECK: Currently uses ByteArray for binary, String for text, but it
518 is unclear if this is correct.
519
520 Stores the results in *paramLengths_result and *paramValues_result,
521 which the caller must free if not NULL.
522 No errors, void return.
523
524 **********************************/
525 static void
get_param_values(Tcl_Interp * interp,Tcl_Obj * CONST * objv,int nParams,int allParamsText,int * paramFormats,const char * const ** paramValues_result,int ** paramLengths_result)526 get_param_values(Tcl_Interp *interp, Tcl_Obj *CONST *objv,
527 int nParams, int allParamsText, int *paramFormats,
528 const char *const **paramValues_result, int **paramLengths_result)
529 {
530 int i;
531 int *paramLengths;
532 const char **paramValues;
533
534 paramLengths = NULL;
535 paramValues = NULL;
536 if (nParams > 0)
537 {
538 paramValues = (const char **)Tcl_Alloc(nParams * sizeof(char *));
539 if (!allParamsText)
540 paramLengths = (int *)Tcl_Alloc(nParams * sizeof(int));
541
542 for (i = 0; i < nParams; i++)
543 {
544 if (paramFormats && paramFormats[i]) /* Binary Format */
545 paramValues[i] = (char *)Tcl_GetByteArrayFromObj(*objv,
546 ¶mLengths[i]);
547 else /* Text Format */
548 paramValues[i] = Tcl_GetString(*objv);
549 objv++;
550 }
551 }
552 *paramValues_result = paramValues;
553 if (paramLengths_result)
554 *paramLengths_result = paramLengths;
555 }
556
557 /**********************************
558 * get_param_types - Helper for pg_exec_params
559
560 Build an array of type OIDs from the supplied list. The list must
561 either be empty or contain nParams items.
562
563 Stores the result in *paramTypes, which the caller must free
564 if not NULL. This will be either NULL or a pointer to nParams Oids.
565 Returns TCL_OK if OK.
566 On error, store a message in the interp and return TCL_ERROR.
567
568 **********************************/
569 static int
get_param_types(Tcl_Interp * interp,Tcl_Obj * argTypeListObj,int nParams,Oid ** paramTypesResult)570 get_param_types(Tcl_Interp *interp, Tcl_Obj *argTypeListObj,
571 int nParams, Oid **paramTypesResult)
572 {
573 int listLen;
574 Tcl_Obj **objp;
575 Oid *paramTypes;
576 int i;
577
578 if (Tcl_ListObjGetElements(interp, argTypeListObj, &listLen, &objp) != TCL_OK)
579 {
580 Tcl_SetResult(interp, "Invalid argTypeList parameter", TCL_STATIC);
581 return TCL_ERROR;
582 }
583
584 paramTypes = NULL;
585 if (listLen > 0)
586 {
587 if (listLen != nParams)
588 {
589 Tcl_SetResult(interp, "Mismatched argTypeList and parameter count",
590 TCL_STATIC);
591 return TCL_ERROR;
592 }
593 paramTypes = (Oid *)Tcl_Alloc(nParams * sizeof(int));
594 for (i = 0; i < nParams; i++)
595 {
596 /*
597 * Note: paramTypes[i] is Oid which is unsigned int, and
598 * Tcl_GetIntFromObj() expects a pointer to a signed int.
599 * There is no direct support for unsigned in Tcl, but tests
600 * and code examination show it will work for values that
601 * will fit in unsigned but not signed. Anyway, it's the best
602 * we can do.
603 */
604 if (Tcl_GetIntFromObj(interp, objp[i], (int *)¶mTypes[i]) != TCL_OK)
605 {
606 Tcl_Free((char *)paramTypes);
607 return TCL_ERROR;
608 }
609 }
610 }
611 *paramTypesResult = paramTypes;
612 return TCL_OK;
613 }
614
615 /**********************************
616 * PgQueryOK - Check that it is OK to send a query.
617 This checks that the connection ID is valid, no COPY is in progress,
618 and (if asyncOK is 0) no asynchronous query callback is active.
619
620 Returns 1 if OK, else 0. On error, stores an error message in the
621 interp (if applicable).
622
623 *********************************/
624 static int
PgQueryOK(Tcl_Interp * interp,PGconn * conn,Pg_ConnectionId * connid,int asyncOK)625 PgQueryOK(Tcl_Interp *interp, PGconn *conn, Pg_ConnectionId *connid, int asyncOK)
626 {
627 if (conn == NULL) return 0;
628 if (connid->res_copyStatus != RES_COPY_NONE)
629 {
630 Tcl_SetResult(interp, "Operation not allowed while COPY is in progress",
631 TCL_STATIC);
632 return 0;
633 }
634 if (!asyncOK && connid->callbackPtr)
635 {
636 Tcl_SetResult(interp, "Operation not allowed while waiting for callback",
637 TCL_STATIC);
638 return 0;
639 }
640 return 1;
641 }
642
643 /**********************************
644 * pg_exec
645 send a query string to the backend connection
646
647 syntax:
648 pg_exec connection query ?param...?
649
650 Optional args are used as parameters to PQexecParams(). This is a simplified
651 version of Pg_exec_params using text-only, untyped parameters.
652 With no optional args, use regular PQexec().
653
654 the return result is either an error message or a handle for a query
655 result. Handles start with the prefix "pgp"
656 **********************************/
657
658 int
Pg_exec(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])659 Pg_exec(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
660 {
661 Pg_ConnectionId *connid;
662 PGconn *conn;
663 PGresult *result;
664 char *connString;
665 char *execString;
666 const char *const *paramValues;
667 int nParams;
668
669 nParams = objc - 3;
670 if (nParams < 0)
671 {
672 Tcl_WrongNumArgs(interp, 1, objv, "connection queryString ?param...?");
673 return TCL_ERROR;
674 }
675
676 connString = Tcl_GetString(objv[1]);
677
678 conn = PgGetConnectionId(interp, connString, &connid);
679 if (!PgQueryOK(interp, conn, connid, 0))
680 return TCL_ERROR;
681
682 execString = Tcl_GetString(objv[2]);
683
684 if (nParams > 0)
685 {
686 get_param_values(interp, &objv[3], nParams, /* allParamsText = */ 1,
687 /* paramFormats = */ NULL, ¶mValues,
688 /* paramLengths_result = */ NULL);
689
690 result = PQexecParams(conn, execString, nParams, NULL,
691 paramValues, NULL, NULL, /* resultFormat= */ 0);
692
693 if (paramValues)
694 Tcl_Free((char *)paramValues);
695
696 } else {
697 result = PQexec(conn, execString);
698 }
699
700
701 /* Transfer any notify events from libpq to Tcl event queue. */
702 PgNotifyTransferEvents(connid);
703
704 if (result)
705 {
706 int rId = PgSetResultId(interp, connString, result);
707 ExecStatusType rStat;
708
709 if (rId == -1)
710 {
711 /*
712 * Query response was OK, but unable to allocate result slot.
713 * This is bad news, since the caller will think the query failed,
714 * but the query may have worked and modified the database.
715 * But there isn't much choice at this point.
716 */
717 PQclear(result);
718 return TCL_ERROR;
719 }
720 rStat = PQresultStatus(result);
721
722 if (rStat == PGRES_COPY_IN || rStat == PGRES_COPY_OUT)
723 {
724 connid->res_copyStatus = RES_COPY_INPROGRESS;
725 connid->res_copy = rId;
726 connid->copyBuf = NULL;
727 }
728 return TCL_OK;
729 }
730 else
731 {
732 /* error occurred during the query */
733 Tcl_SetObjResult(interp, Tcl_NewStringObj(PQerrorMessage(conn), -1));
734 return TCL_ERROR;
735 }
736 }
737
738
739
740 /**********************************
741 * pg_exec_prepared
742 Execute a pre-prepared query with supplied parameters
743
744 Syntax:
745 pg_exec_prepared connection statementName resultFormatList \
746 argFormatList ?param...?
747
748 argFormatList is empty (= same as T), a single word T|B|TEXT|BINARY, or
749 a list of those words, describing each argument as text or binary. If a
750 single word, it applies to all arguments. (Actually, anything starting
751 with B means Binary, and anything else means Text. There is no error
752 checking.)
753
754 resultFormatList is similar to argFormatList except that it applies to the
755 columns of the results. Currently, all result parameters must be text, or
756 all must be binary (this is a libpq limitation, not a PostgreSQL
757 limitation). So you might as well specify a single word BINARY or leave it
758 empty.
759
760 The return result is either an error message or a handle for a query
761 result.
762 **********************************/
763
764 int
Pg_exec_prepared(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])765 Pg_exec_prepared(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
766 {
767 Pg_ConnectionId *connid;
768 PGconn *conn;
769 char *connString;
770 PGresult *result;
771 char *statementName;
772 int nParams;
773 int allParamsText;
774 int resultFormat;
775 int *paramFormats;
776 int *paramLengths;
777 const char *const *paramValues;
778 int returnValue;
779
780 nParams = objc - 5;
781 if (nParams < 0)
782 {
783 Tcl_WrongNumArgs(interp, 1, objv, "connection statementName "
784 "resultFormat argFormatList ?param...?");
785 return TCL_ERROR;
786 }
787
788 connString = Tcl_GetString(objv[1]);
789
790 conn = PgGetConnectionId(interp, connString, &connid);
791 if (!PgQueryOK(interp, conn, connid, 0))
792 return TCL_ERROR;
793
794 statementName = Tcl_GetString(objv[2]);
795
796 /* Parse resultFormatList and make resultFormat argument. */
797 if (get_result_format(interp, objv[3], &resultFormat) != TCL_OK)
798 return TCL_ERROR;
799
800 /* Parse argFormat list and make paramFormats argument and all-text flag */
801 if (get_param_formats(interp, objv[4], nParams, &allParamsText,
802 ¶mFormats) != TCL_OK)
803 return TCL_ERROR;
804
805 /* Copy query parameters, and lengths if binary format */
806 get_param_values(interp, &objv[5], nParams, allParamsText, paramFormats,
807 ¶mValues, ¶mLengths);
808
809 /* Now execute the prepared query */
810 result = PQexecPrepared(conn, statementName, nParams, paramValues,
811 paramLengths, paramFormats, resultFormat);
812
813 /* Transfer any notify events from libpq to Tcl event queue. */
814 PgNotifyTransferEvents(connid);
815
816 /*
817 * Note: You can't use this command to start a COPY, so there is no
818 * need to check for PGRES_COPY_* status like pg_exec does.
819 */
820 if (!result)
821 {
822 /* error occurred during the query */
823 Tcl_SetObjResult(interp, Tcl_NewStringObj(PQerrorMessage(conn), -1));
824 returnValue = TCL_ERROR;
825 }
826 else if (PgSetResultId(interp, connString, result) == -1)
827 {
828 /* Query response was OK, but unable to allocate result slot. */
829 PQclear(result);
830 returnValue = TCL_ERROR;
831 }
832 else
833 returnValue = TCL_OK;
834
835 if (paramFormats)
836 Tcl_Free((char *)paramFormats);
837 if (paramLengths)
838 Tcl_Free((char *)paramLengths);
839 if (paramValues)
840 Tcl_Free((char *)paramValues);
841
842 return returnValue;
843 }
844
845 /**********************************
846 * pg_exec_params
847 Parse, bind parameters, and execute a query
848
849 Syntax:
850 pg_exec_params connection query resultFormatList argFormatList
851 argTypeList param...
852
853 query is an SQL statement with parameter placeholders specified as
854 $1, $2, etc.
855
856 argFormatList is empty (= same as T), a single word T|B|TEXT|BINARY, or
857 a list of those words, describing each argument as text or binary. If a
858 single word, it applies to all arguments. (Actually, anything starting
859 with B means Binary, and anything else means Text. There is no error
860 checking.)
861
862 resultFormatList is similar to argFormatList except that it applies to the
863 columns of the results. Currently, all result parameters must be text, or
864 all must be binary (this is a libpq limitation, not a PostgreSQL
865 limitation). So you might as well specify a single word BINARY or leave it
866 empty.
867
868 argTypeList is a list of PostgreSQL type OIDs for the query parameter
869 arguments. Type OIDs must be supplied for each binary-format argument.
870 If there are any binary format arguments, the argTypeList must contain
871 an entry for each argument, although the actual value will be ignored
872 for text-mode arguments.
873
874 Note: If you are using all text arguments, it is easier to use pg_exec
875 with the optional parameter arguments.
876
877 The return result is either an error message or a handle for a query
878 result.
879 **********************************/
880
881 int
Pg_exec_params(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])882 Pg_exec_params(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
883 {
884 Pg_ConnectionId *connid;
885 PGconn *conn;
886 char *connString;
887 PGresult *result;
888 char *queryString;
889 int nParams;
890 int allParamsText;
891 int resultFormat;
892 int *paramFormats;
893 int *paramLengths;
894 const char *const *paramValues;
895 Oid *paramTypes;
896 int returnValue;
897
898 nParams = objc - 6;
899 if (nParams < 0)
900 {
901 Tcl_WrongNumArgs(interp, 1, objv, "connection queryString "
902 "resultFormat argFormatList argTypeList ?param...?");
903 return TCL_ERROR;
904 }
905
906 connString = Tcl_GetString(objv[1]);
907
908 conn = PgGetConnectionId(interp, connString, &connid);
909 if (!PgQueryOK(interp, conn, connid, 0))
910 return TCL_ERROR;
911
912 queryString = Tcl_GetString(objv[2]);
913
914 /* Parse resultFormatList and make resultFormat argument. */
915 if (get_result_format(interp, objv[3], &resultFormat) != TCL_OK)
916 return TCL_ERROR;
917
918 /* Parse argFormat list and make paramFormats argument and all-text flag */
919 if (get_param_formats(interp, objv[4], nParams, &allParamsText,
920 ¶mFormats) != TCL_OK)
921 return TCL_ERROR;
922
923 /* Get the parameter type OID list into an array */
924 if (get_param_types(interp, objv[5], nParams, ¶mTypes) != TCL_OK) {
925 if (paramFormats)
926 Tcl_Free((char *)paramFormats);
927 return TCL_ERROR;
928 }
929
930 /* Copy query parameters, and lengths if binary format */
931 get_param_values(interp, &objv[6], nParams, allParamsText, paramFormats,
932 ¶mValues, ¶mLengths);
933
934 /* Now execute the parameterized query */
935 result = PQexecParams(conn, queryString, nParams, paramTypes,
936 paramValues, paramLengths, paramFormats, resultFormat);
937
938 /* Transfer any notify events from libpq to Tcl event queue. */
939 PgNotifyTransferEvents(connid);
940
941 /*
942 * Note: You can't use this command to start a COPY, so there is no
943 * need to check for PGRES_COPY_* status like pg_exec does.
944 */
945 if (!result)
946 {
947 /* error occurred during the query */
948 Tcl_SetObjResult(interp, Tcl_NewStringObj(PQerrorMessage(conn), -1));
949 returnValue = TCL_ERROR;
950 }
951 else if (PgSetResultId(interp, connString, result) == -1)
952 {
953 /* Query response was OK, but unable to allocate result slot. */
954 PQclear(result);
955 returnValue = TCL_ERROR;
956 }
957 else
958 returnValue = TCL_OK;
959
960 if (paramFormats)
961 Tcl_Free((char *)paramFormats);
962 if (paramLengths)
963 Tcl_Free((char *)paramLengths);
964 if (paramValues)
965 Tcl_Free((char *)paramValues);
966 if (paramTypes)
967 Tcl_Free((char *)paramTypes);
968
969 return returnValue;
970 }
971
972 /**********************************
973 * pg_result_errorfield_code
974 Translate error fieldName to fieldCode for pg_result -error?Field?
975 Valid fieldNames are strings matching the constant name without PG_DIAG_,
976 such as "SEVERITY", or the single letter code which is the value of the
977 constant, like 'S'. See postgres_ext.h for the list.
978
979 Both field names and field codes (the PG_DIAG_* names) used to be folded to
980 upper case for comparison, making them case-insensitive. But starting with
981 PostgreSQL-9.2 and 9.3, new codes used single lower case letters. So it was
982 necessary to break compatibility with previous releases. Now the field names
983 (and the aliases, without the prefix e.g. MESSAGE_ or SOURCE_) are still case
984 insensitive, but single-character codes are now case sensitive.
985
986 Returns a valid PG_DIAG_* constant, or 0 if there is no match.
987 **********************************/
988 static int
pg_result_errorfield_code(char * fieldName)989 pg_result_errorfield_code(char *fieldName)
990 {
991 static struct errorfield_names_t {
992 char *fieldName;
993 int fieldCode;
994 } errorfield_names[] = {
995 { "SEVERITY", PG_DIAG_SEVERITY },
996 { "SQLSTATE", PG_DIAG_SQLSTATE },
997 { "MESSAGE_PRIMARY", PG_DIAG_MESSAGE_PRIMARY },
998 { "MESSAGE_DETAIL", PG_DIAG_MESSAGE_DETAIL },
999 { "MESSAGE_HINT", PG_DIAG_MESSAGE_HINT },
1000 { "STATEMENT_POSITION", PG_DIAG_STATEMENT_POSITION },
1001 { "CONTEXT", PG_DIAG_CONTEXT },
1002 { "SOURCE_FILE", PG_DIAG_SOURCE_FILE },
1003 { "SOURCE_LINE", PG_DIAG_SOURCE_LINE },
1004 { "SOURCE_FUNCTION", PG_DIAG_SOURCE_FUNCTION },
1005 { "PRIMARY", PG_DIAG_MESSAGE_PRIMARY },
1006 { "DETAIL", PG_DIAG_MESSAGE_DETAIL },
1007 { "HINT", PG_DIAG_MESSAGE_HINT },
1008 { "POSITION", PG_DIAG_STATEMENT_POSITION },
1009 { "FILE", PG_DIAG_SOURCE_FILE },
1010 { "LINE", PG_DIAG_SOURCE_LINE },
1011 { "FUNCTION", PG_DIAG_SOURCE_FUNCTION },
1012 #ifdef PG_DIAG_SCHEMA_NAME /* These 5 codes were added in PostgreSQL-9.3.0 */
1013 { "SCHEMA_NAME", PG_DIAG_SCHEMA_NAME },
1014 { "TABLE_NAME", PG_DIAG_TABLE_NAME },
1015 { "COLUMN_NAME", PG_DIAG_COLUMN_NAME },
1016 { "DATATYPE_NAME", PG_DIAG_DATATYPE_NAME },
1017 { "CONSTRAINT_NAME", PG_DIAG_CONSTRAINT_NAME },
1018 #endif
1019 { 0, '\0'}};
1020
1021 struct errorfield_names_t *ep = errorfield_names;
1022 char field1;
1023
1024 if (!fieldName || !fieldName[0])
1025 return 0;
1026 if (fieldName[1])
1027 {
1028 /* Check for exact word match if length>1, case insensitively */
1029 while (ep->fieldName &&
1030 !Tcl_StringCaseMatch(fieldName, ep->fieldName, 1))
1031 ep++;
1032 } else {
1033 /* Check for single-character code match.
1034 Note these are being checked against the PG_DIAG_* values,
1035 which are defined in postgres_ext.h as single characters.
1036 */
1037 field1 = fieldName[0];
1038 while (ep->fieldCode && ep->fieldCode != field1) ep++;
1039 }
1040 return ep->fieldCode;
1041 }
1042
1043
1044 /**********************************
1045 * pg_result
1046 get information about the results of a query
1047
1048 syntax:
1049
1050 pg_result result ?option?
1051
1052 the options are:
1053
1054 -status the status of the result
1055
1056 -error ?code?
1057 -errorField ?code?
1058 If the status does not indicate an error, returns an empty string.
1059 Else, if no code is provided, returns the current error message.
1060 Else, the code names an error message subfield or abbreviation,
1061 and the value of that error field is returned if valid and available.
1062 Else, an empty string is returned.
1063
1064 -conn the connection that produced the result
1065
1066 -oid if command was an INSERT, the OID of the inserted tuple
1067
1068 -numTuples the number of tuples in the query
1069
1070 -cmdTuples Same as -numTuples, but for DELETE and UPDATE
1071
1072 -cmdStatus returns the command status tag, e.g. "INSERT ... ..."
1073
1074 -numAttrs returns the number of attributes returned by the query
1075
1076 -assign arrayName
1077 assign the results to an array, using subscripts of the form
1078 (tupno,attributeName)
1079
1080 -assignbyidx arrayName ?appendstr?
1081 assign the results to an array using the first field's value
1082 as a key.
1083 All but the first field of each tuple are stored, using
1084 subscripts of the form (field0value,attributeNameappendstr)
1085
1086 -getTuple tupleNumber
1087 returns the values of the tuple in a list
1088
1089 -getNull tupleNumber
1090 returns a list indicating if each value in the tuple is NULL
1091
1092 -tupleArray tupleNumber arrayName
1093 stores the values of the tuple in array arrayName, indexed
1094 by the attributes returned
1095
1096 -attributes
1097 returns a list of the name/type pairs of the tuple attributes
1098
1099 -lAttributes
1100 returns a list of the {name type len} entries of the tuple
1101 attributes
1102
1103 -lxAttributes
1104 returns an extended list of the tuple attributes in the form:
1105 {name type size size_modifier format table_oid table_column}
1106
1107 -list
1108 returns one list of all of the data
1109
1110 -llist
1111 returns a list of lists, where each embedded list represents
1112 a tuple in the result
1113
1114 -numParams
1115 returns the number of paramters in a prepared statement.
1116 This may be used only after pg_describe_prepared.
1117
1118 -paramTypes
1119 returns a list of Type OIDs for the parameters in a prepared statement.
1120 This may be used only after pg_describe_prepared.
1121
1122 -clear clear the result buffer. Do not reuse after this
1123
1124 -dict Return a Tcl8.5 dictionary containing the query results, with
1125 integer row numbers as outer keys, and field names as inner keys.
1126
1127 **********************************/
1128 int
Pg_result(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])1129 Pg_result(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
1130 {
1131 PGresult *result;
1132 int i;
1133 int tupno;
1134 char *queryResultString;
1135 int optIndex;
1136
1137 static CONST84 char *options[] = {
1138 "-status", "-error", "-errorField", "-conn", "-oid",
1139 "-numTuples", "-cmdTuples", "-numAttrs", "-assign", "-assignbyidx",
1140 "-getTuple", "-tupleArray", "-attributes", "-lAttributes",
1141 "-lxAttributes", "-clear", "-list", "-llist", "-getNull",
1142 "-cmdStatus", "-dict",
1143 #ifdef HAVE_PQDESCRIBEPREPARED /* PostgreSQL >= 8.2.0 */
1144 "-numParams", "-paramTypes",
1145 #endif
1146 (char *)NULL
1147 };
1148
1149 enum options
1150 {
1151 OPT_STATUS, OPT_ERROR, OPT_ERRORFIELD, OPT_CONN, OPT_OID,
1152 OPT_NUMTUPLES, OPT_CMDTUPLES, OPT_NUMATTRS, OPT_ASSIGN, OPT_ASSIGNBYIDX,
1153 OPT_GETTUPLE, OPT_TUPLEARRAY, OPT_ATTRIBUTES, OPT_LATTRIBUTES,
1154 OPT_LXATTRIBUTES, OPT_CLEAR, OPT_LIST, OPT_LLIST, OPT_GETNULL,
1155 OPT_CMDSTATUS, OPT_DICT,
1156 #ifdef HAVE_PQDESCRIBEPREPARED /* PostgreSQL >= 8.2.0 */
1157 OPT_NUMPARAMS, OPT_PARAMTYPES
1158 #endif
1159 };
1160
1161 /*
1162 * Check for resultHandle and switch. Subfunctions will further check
1163 * their argument counts. Note: Common Tcl practice is that with too
1164 * few args, the command reports "wrong # args: should be..." and just
1165 * summarizes the usage. With an invalid arg, the command lists all
1166 * valid args: "bad option "...": must be A, B, ...".
1167 * pg_result now does this; please don't change it back.
1168 */
1169 if (objc < 3)
1170 {
1171 Tcl_WrongNumArgs(interp, 1, objv, "resultHandle switch ?arg ...?");
1172 return TCL_ERROR;
1173 }
1174
1175 /* figure out the query result handle and look it up */
1176 queryResultString = Tcl_GetString(objv[1]);
1177 result = PgGetResultId(interp, queryResultString);
1178 if (result == (PGresult *)NULL)
1179 {
1180 Tcl_AppendResult(interp, "\n", queryResultString,
1181 " is not a valid query result", (char *)NULL);
1182 return TCL_ERROR;
1183 }
1184
1185 /* process command options */
1186 if (Tcl_GetIndexFromObj(interp, objv[2], options, "switch", TCL_EXACT,
1187 &optIndex) != TCL_OK)
1188 return TCL_ERROR;
1189
1190 switch ((enum options) optIndex)
1191 {
1192 case OPT_STATUS:
1193 {
1194 char *resultStatus;
1195
1196 if (objc != 3)
1197 {
1198 Tcl_WrongNumArgs(interp, 3, objv, NULL);
1199 return TCL_ERROR;
1200 }
1201
1202 resultStatus = PQresStatus(PQresultStatus(result));
1203 Tcl_SetObjResult(interp, Tcl_NewStringObj(resultStatus, -1));
1204 return TCL_OK;
1205 }
1206
1207 case OPT_ERROR:
1208 /* Fall through - these subcommands are now identical */
1209
1210 case OPT_ERRORFIELD:
1211 {
1212 char *fieldName;
1213 int fieldCode;
1214 char *errorField;
1215
1216 if (objc == 3)
1217 {
1218 Tcl_SetObjResult(interp,
1219 Tcl_NewStringObj(PQresultErrorMessage(result), -1));
1220 return TCL_OK;
1221 }
1222
1223 if (objc != 4)
1224 {
1225 Tcl_WrongNumArgs(interp, 3, objv, "?fieldName?");
1226 return TCL_ERROR;
1227 }
1228
1229 fieldName = Tcl_GetString(objv[3]);
1230 if ((fieldCode = pg_result_errorfield_code(fieldName)) != 0
1231 && (errorField = PQresultErrorField(result, fieldCode))
1232 != NULL)
1233 Tcl_SetObjResult(interp, Tcl_NewStringObj(errorField, -1));
1234 return TCL_OK;
1235 }
1236
1237 case OPT_CONN:
1238 {
1239 if (objc != 3)
1240 {
1241 Tcl_WrongNumArgs(interp, 3, objv, NULL);
1242 return TCL_ERROR;
1243 }
1244
1245 return PgGetConnByResultId(interp, queryResultString);
1246 }
1247
1248 case OPT_OID:
1249 {
1250 if (objc != 3)
1251 {
1252 Tcl_WrongNumArgs(interp, 3, objv, NULL);
1253 return TCL_ERROR;
1254 }
1255
1256 Tcl_SetLongObj(Tcl_GetObjResult(interp), PQoidValue(result));
1257 return TCL_OK;
1258 }
1259
1260 case OPT_CLEAR:
1261 {
1262 if (objc != 3)
1263 {
1264 Tcl_WrongNumArgs(interp, 3, objv, NULL);
1265 return TCL_ERROR;
1266 }
1267
1268 PgDelResultId(interp, queryResultString);
1269 PQclear(result);
1270 return TCL_OK;
1271 }
1272
1273 case OPT_NUMTUPLES:
1274 {
1275 if (objc != 3)
1276 {
1277 Tcl_WrongNumArgs(interp, 3, objv, NULL);
1278 return TCL_ERROR;
1279 }
1280
1281 Tcl_SetIntObj(Tcl_GetObjResult(interp), PQntuples(result));
1282 return TCL_OK;
1283 }
1284
1285 case OPT_CMDTUPLES:
1286 {
1287 if (objc != 3)
1288 {
1289 Tcl_WrongNumArgs(interp, 3, objv, NULL);
1290 return TCL_ERROR;
1291 }
1292
1293 Tcl_SetStringObj(Tcl_GetObjResult(interp), PQcmdTuples(result), -1);
1294 return TCL_OK;
1295 }
1296
1297 case OPT_CMDSTATUS:
1298 {
1299 if (objc != 3)
1300 {
1301 Tcl_WrongNumArgs(interp, 3, objv, NULL);
1302 return TCL_ERROR;
1303 }
1304
1305 Tcl_SetStringObj(Tcl_GetObjResult(interp), PQcmdStatus(result), -1);
1306 return TCL_OK;
1307 }
1308
1309
1310 case OPT_NUMATTRS:
1311 {
1312 if (objc != 3)
1313 {
1314 Tcl_WrongNumArgs(interp, 3, objv, NULL);
1315 return TCL_ERROR;
1316 }
1317
1318 Tcl_SetIntObj(Tcl_GetObjResult(interp), PQnfields(result));
1319 return TCL_OK;
1320 }
1321
1322 case OPT_ASSIGN:
1323 {
1324 Tcl_Obj *fieldNameObj;
1325 Tcl_Obj *arrVarObj;
1326 Tcl_Obj *valueObj;
1327 int ncols = PQnfields(result);
1328 int nrows = PQntuples(result);
1329
1330 if (objc != 4)
1331 {
1332 Tcl_WrongNumArgs(interp, 3, objv, "arrayName");
1333 return TCL_ERROR;
1334 }
1335
1336 arrVarObj = objv[3];
1337
1338 /*
1339 * this assignment assigns the table of result tuples into
1340 * a giant array with the name given in the argument. The
1341 * indices of the array are of the form (tupno,attrName).
1342 */
1343 for (tupno = 0; tupno < nrows; tupno++)
1344 {
1345 for (i = 0; i < ncols; i++)
1346 {
1347 /*
1348 * Moving this into the loop and increasing the reference count
1349 * became necessary at Tcl-8.5 because Tcl_ObjSetVar2
1350 * now apparently saves a reference to the array index object.
1351 */
1352 fieldNameObj = Tcl_NewObj();
1353 Tcl_IncrRefCount(fieldNameObj);
1354
1355 /*
1356 * construct the array element name consisting
1357 * of the tuple number, a comma, and the field
1358 * name.
1359 * this is a little kludgey -- we set the obj
1360 * to an int but the append following will force a
1361 * string conversion.
1362 */
1363 Tcl_SetIntObj(fieldNameObj, tupno);
1364 Tcl_AppendToObj(fieldNameObj, ",", 1);
1365 Tcl_AppendToObj(fieldNameObj, PQfname(result, i), -1);
1366
1367 valueObj = result_get_obj(result, tupno, i);
1368 Tcl_IncrRefCount(valueObj);
1369 if (Tcl_ObjSetVar2(interp, arrVarObj, fieldNameObj, valueObj,
1370 TCL_LEAVE_ERR_MSG) == NULL) {
1371 Tcl_DecrRefCount(fieldNameObj);
1372 Tcl_DecrRefCount(valueObj);
1373 return TCL_ERROR;
1374 }
1375 Tcl_DecrRefCount(fieldNameObj);
1376 Tcl_DecrRefCount(valueObj);
1377 }
1378 }
1379 return TCL_OK;
1380 }
1381
1382 case OPT_ASSIGNBYIDX:
1383 {
1384 Tcl_Obj *fieldNameObj;
1385 Tcl_Obj *arrVarObj;
1386 Tcl_Obj *valueObj;
1387 Tcl_Obj *appendstrObj;
1388 Tcl_Obj *field0;
1389 int ncols = PQnfields(result);
1390 int nrows = PQntuples(result);
1391
1392 if ((objc != 4) && (objc != 5))
1393 {
1394 Tcl_WrongNumArgs(interp, 3, objv, "arrayName ?append_string?");
1395 return TCL_ERROR;
1396 }
1397
1398 arrVarObj = objv[3];
1399
1400 if (objc == 5)
1401 appendstrObj = objv[4];
1402 else
1403 appendstrObj = NULL;
1404
1405 /*
1406 * this assignment assigns the table of result tuples into
1407 * a giant array with the name given in the argument. The
1408 * indices of the array are of the form
1409 * (field0Value,attrNameappendstr). Here, we still assume
1410 * PQfname won't exceed 200 characters, but we dare not
1411 * make the same assumption about the data in field 0 nor
1412 * the append string.
1413 */
1414 for (tupno = 0; tupno < nrows; tupno++)
1415 {
1416 field0 = result_get_obj(result, tupno, 0);
1417 Tcl_IncrRefCount(field0);
1418
1419 for (i = 1; i < ncols; i++)
1420 {
1421 fieldNameObj = Tcl_NewObj();
1422 Tcl_IncrRefCount(fieldNameObj);
1423 Tcl_SetObjLength(fieldNameObj, 0);
1424 Tcl_AppendObjToObj(fieldNameObj, field0);
1425 Tcl_AppendToObj(fieldNameObj, ",", 1);
1426 Tcl_AppendToObj(fieldNameObj, PQfname(result, i), -1);
1427
1428 if (appendstrObj != NULL)
1429 Tcl_AppendObjToObj(fieldNameObj, appendstrObj);
1430
1431 valueObj = result_get_obj(result, tupno, i);
1432 Tcl_IncrRefCount(valueObj);
1433 if (Tcl_ObjSetVar2(interp, arrVarObj, fieldNameObj, valueObj,
1434 TCL_LEAVE_ERR_MSG) == NULL)
1435 {
1436 Tcl_DecrRefCount(fieldNameObj);
1437 Tcl_DecrRefCount(field0);
1438 Tcl_DecrRefCount(valueObj);
1439 return TCL_ERROR;
1440 }
1441 Tcl_DecrRefCount(fieldNameObj);
1442 Tcl_DecrRefCount(valueObj);
1443 }
1444 Tcl_DecrRefCount(field0);
1445 }
1446 return TCL_OK;
1447 }
1448
1449 case OPT_GETTUPLE:
1450 {
1451 Tcl_Obj *resultObj;
1452
1453 if (objc != 4)
1454 {
1455 Tcl_WrongNumArgs(interp, 3, objv, "tuple_number");
1456 return TCL_ERROR;
1457 }
1458
1459 if (Tcl_GetIntFromObj(interp, objv[3], &tupno) == TCL_ERROR)
1460 return TCL_ERROR;
1461
1462 if (tupno < 0 || tupno >= PQntuples(result))
1463 {
1464 Tcl_AppendResult(interp, "argument to getTuple cannot exceed number of tuples - 1", 0);
1465 return TCL_ERROR;
1466 }
1467
1468 /* set the result object to be the list of values */
1469 resultObj = get_row_list_obj(interp, result, tupno);
1470 if (!resultObj)
1471 return TCL_ERROR;
1472 Tcl_IncrRefCount(resultObj);
1473
1474 /* Make this object the interpreter result */
1475 Tcl_SetObjResult(interp, resultObj);
1476 Tcl_DecrRefCount(resultObj);
1477
1478 return TCL_OK;
1479 }
1480
1481 case OPT_TUPLEARRAY:
1482 {
1483 char *arrayName;
1484 int ncols = PQnfields(result);
1485
1486 if (objc != 5)
1487 {
1488 Tcl_WrongNumArgs(interp, 3, objv, "tuple_number array_name");
1489 return TCL_ERROR;
1490 }
1491
1492 if (Tcl_GetIntFromObj(interp, objv[3], &tupno) == TCL_ERROR)
1493 return TCL_ERROR;
1494
1495 if (tupno < 0 || tupno >= PQntuples(result))
1496 {
1497 Tcl_AppendResult(interp, "argument to tupleArray cannot exceed number of tuples - 1", 0);
1498 return TCL_ERROR;
1499 }
1500
1501 arrayName = Tcl_GetString(objv[4]);
1502
1503 for (i = 0; i < ncols; i++)
1504 {
1505 if (Tcl_SetVar2Ex(interp, arrayName, PQfname(result, i),
1506 result_get_obj(result, tupno, i),
1507 TCL_LEAVE_ERR_MSG) == NULL)
1508 return TCL_ERROR;
1509 }
1510 return TCL_OK;
1511 }
1512
1513 case OPT_ATTRIBUTES:
1514 {
1515 Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
1516 int ncols = PQnfields(result);
1517
1518 if (objc != 3)
1519 {
1520 Tcl_WrongNumArgs(interp, 3, objv, NULL);
1521 return TCL_ERROR;
1522 }
1523
1524 Tcl_SetListObj(resultObj, 0, NULL);
1525
1526 for (i = 0; i < ncols; i++)
1527 {
1528 Tcl_ListObjAppendElement(interp, resultObj,
1529 Tcl_NewStringObj(PQfname(result, i), -1));
1530 }
1531 return TCL_OK;
1532 }
1533
1534 case OPT_LATTRIBUTES:
1535 {
1536 Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
1537 int ncols = PQnfields(result);
1538
1539 if (objc != 3)
1540 {
1541 Tcl_WrongNumArgs(interp, 3, objv, NULL);
1542 return TCL_ERROR;
1543 }
1544
1545 Tcl_SetListObj(resultObj, 0, NULL);
1546
1547 /* For each column: {name type size} */
1548 for (i = 0; i < ncols; i++)
1549 {
1550 Tcl_Obj *subList = Tcl_NewListObj(0, NULL);
1551
1552 Tcl_IncrRefCount(subList);
1553 if (Tcl_ListObjAppendElement(interp, subList,
1554 Tcl_NewStringObj(PQfname(result, i), -1)
1555 ) == TCL_ERROR
1556
1557 || Tcl_ListObjAppendElement(interp, subList,
1558 Tcl_NewLongObj((long)PQftype(result, i))
1559 ) == TCL_ERROR
1560
1561 || Tcl_ListObjAppendElement(interp, subList,
1562 Tcl_NewIntObj(PQfsize(result, i))
1563 ) == TCL_ERROR
1564
1565 || Tcl_ListObjAppendElement(interp, resultObj, subList)
1566 == TCL_ERROR)
1567 {
1568 Tcl_DecrRefCount(subList);
1569 return TCL_ERROR;
1570 }
1571 Tcl_DecrRefCount(subList);
1572 }
1573 return TCL_OK;
1574 }
1575
1576 case OPT_LXATTRIBUTES:
1577 {
1578 Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
1579 int ncols = PQnfields(result);
1580
1581 if (objc != 3)
1582 {
1583 Tcl_WrongNumArgs(interp, 3, objv, NULL);
1584 return TCL_ERROR;
1585 }
1586
1587 Tcl_SetListObj(resultObj, 0, NULL);
1588
1589 /* For each column: {name type size sizemod format tblOid tblCol} */
1590 for (i = 0; i < ncols; i++)
1591 {
1592 Tcl_Obj *subList = Tcl_NewListObj(0, NULL);
1593
1594 Tcl_IncrRefCount(subList);
1595 if (Tcl_ListObjAppendElement(interp, subList,
1596 Tcl_NewStringObj(PQfname(result, i), -1)
1597 ) == TCL_ERROR
1598
1599 || Tcl_ListObjAppendElement(interp, subList,
1600 Tcl_NewLongObj((long)PQftype(result, i))
1601 ) == TCL_ERROR
1602
1603 || Tcl_ListObjAppendElement(interp, subList,
1604 Tcl_NewIntObj(PQfsize(result, i))
1605 ) == TCL_ERROR
1606
1607 || Tcl_ListObjAppendElement(interp, subList,
1608 Tcl_NewIntObj(PQfmod(result, i))
1609 ) == TCL_ERROR
1610
1611 || Tcl_ListObjAppendElement(interp, subList,
1612 Tcl_NewIntObj(PQfformat(result, i))
1613 ) == TCL_ERROR
1614
1615 || Tcl_ListObjAppendElement(interp, subList,
1616 Tcl_NewLongObj((long)PQftable(result, i))
1617 ) == TCL_ERROR
1618
1619 || Tcl_ListObjAppendElement(interp, subList,
1620 Tcl_NewLongObj((long)PQftablecol(result, i))
1621 ) == TCL_ERROR
1622
1623 || Tcl_ListObjAppendElement(interp, resultObj, subList)
1624 == TCL_ERROR)
1625 {
1626 Tcl_DecrRefCount(subList);
1627 return TCL_ERROR;
1628 }
1629 Tcl_DecrRefCount(subList);
1630 }
1631 return TCL_OK;
1632 }
1633
1634 case OPT_LIST:
1635 {
1636 Tcl_Obj *listObj;
1637 Tcl_Obj *subListObj;
1638 int nrows = PQntuples(result);
1639
1640 if (objc != 3)
1641 {
1642 Tcl_WrongNumArgs(interp, 3, objv, NULL);
1643 return TCL_ERROR;
1644 }
1645
1646 listObj = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1647 Tcl_IncrRefCount(listObj);
1648
1649 /*
1650 ** Loop through the tuple, and append each
1651 ** value to the list
1652 **
1653 ** This option appends all of the values
1654 ** for each tuple to the same list
1655 **
1656 ** According to brett, it performs better when you make a
1657 ** sublist for each tuple and append the sublist to a main
1658 ** list, rather than appending each value separately.
1659 ** That's why this uses get_row_list_obj().
1660 */
1661 for (tupno = 0; tupno < nrows; tupno++)
1662 {
1663 subListObj = get_row_list_obj(interp, result, tupno);
1664 if (!subListObj)
1665 {
1666 Tcl_DecrRefCount(listObj);
1667 return TCL_ERROR;
1668 }
1669 Tcl_IncrRefCount(subListObj);
1670 if (Tcl_ListObjAppendList(interp, listObj, subListObj) != TCL_OK)
1671 {
1672 Tcl_DecrRefCount(listObj);
1673 Tcl_DecrRefCount(subListObj);
1674 return TCL_ERROR;
1675 }
1676 Tcl_DecrRefCount(subListObj);
1677 }
1678 Tcl_SetObjResult(interp, listObj);
1679 Tcl_DecrRefCount(listObj);
1680 return TCL_OK;
1681 }
1682
1683 case OPT_LLIST:
1684 {
1685 Tcl_Obj *listObj;
1686 Tcl_Obj *subListObj;
1687 int nrows = PQntuples(result);
1688
1689 if (objc != 3)
1690 {
1691 Tcl_WrongNumArgs(interp, 3, objv, NULL);
1692 return TCL_ERROR;
1693 }
1694
1695 listObj = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1696 Tcl_IncrRefCount(listObj);
1697
1698 /*
1699 ** This is the top level list. This
1700 ** contains the other lists
1701 **
1702 ** This option contructs a list of
1703 ** values for each tuple, and
1704 ** appends that to the main list.
1705 ** This is a list of lists
1706 */
1707 for (tupno = 0; tupno < nrows; tupno++)
1708 {
1709 subListObj = get_row_list_obj(interp, result, tupno);
1710 if (!subListObj)
1711 {
1712 Tcl_DecrRefCount(listObj);
1713 return TCL_ERROR;
1714 }
1715 Tcl_IncrRefCount(subListObj);
1716 if (Tcl_ListObjAppendElement(interp, listObj, subListObj) != TCL_OK)
1717 {
1718 Tcl_DecrRefCount(listObj);
1719 Tcl_DecrRefCount(subListObj);
1720 return TCL_ERROR;
1721 }
1722 Tcl_DecrRefCount(subListObj);
1723 }
1724
1725 Tcl_SetObjResult(interp, listObj);
1726 Tcl_DecrRefCount(listObj);
1727 return TCL_OK;
1728 }
1729
1730 case OPT_GETNULL:
1731 {
1732 Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
1733 int ncols = PQnfields(result);
1734 Tcl_Obj *trueObj, *falseObj;
1735
1736 if (objc != 4)
1737 {
1738 Tcl_WrongNumArgs(interp, 3, objv, "tuple_number");
1739 return TCL_ERROR;
1740 }
1741
1742 if (Tcl_GetIntFromObj(interp, objv[3], &tupno) == TCL_ERROR)
1743 return TCL_ERROR;
1744
1745 if (tupno < 0 || tupno >= PQntuples(result))
1746 {
1747 Tcl_AppendResult(interp, "argument to getNull cannot exceed number of tuples - 1", 0);
1748 return TCL_ERROR;
1749 }
1750
1751 Tcl_SetListObj(resultObj, 0, NULL);
1752 trueObj = Tcl_NewBooleanObj(1);
1753 Tcl_IncrRefCount(trueObj);
1754 falseObj = Tcl_NewBooleanObj(0);
1755 Tcl_IncrRefCount(falseObj);
1756
1757 for (i = 0; i < ncols; i++)
1758 {
1759 Tcl_ListObjAppendElement(interp, resultObj,
1760 PQgetisnull(result, tupno, i) ? trueObj : falseObj);
1761 }
1762 Tcl_DecrRefCount(trueObj);
1763 Tcl_DecrRefCount(falseObj);
1764
1765 return TCL_OK;
1766 }
1767
1768 #ifdef HAVE_PQDESCRIBEPREPARED /* PostgreSQL >= 8.2.0 */
1769 case OPT_NUMPARAMS:
1770 {
1771 if (objc != 3)
1772 {
1773 Tcl_WrongNumArgs(interp, 3, objv, NULL);
1774 return TCL_ERROR;
1775 }
1776
1777 Tcl_SetIntObj(Tcl_GetObjResult(interp), PQnparams(result));
1778 return TCL_OK;
1779 }
1780 #endif
1781
1782 #ifdef HAVE_PQDESCRIBEPREPARED /* PostgreSQL >= 8.2.0 */
1783 case OPT_PARAMTYPES:
1784 {
1785 Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
1786 int nparams = PQnparams(result);
1787
1788 if (objc != 3)
1789 {
1790 Tcl_WrongNumArgs(interp, 3, objv, NULL);
1791 return TCL_ERROR;
1792 }
1793
1794 Tcl_SetListObj(resultObj, 0, NULL);
1795
1796 /* Loop over parameters to the prepared query */
1797 for (i = 0; i < nparams; i++)
1798 {
1799 if (Tcl_ListObjAppendElement(interp, resultObj,
1800 Tcl_NewIntObj(PQparamtype(result, i))) == TCL_ERROR) {
1801 return TCL_ERROR;
1802 }
1803 }
1804 return TCL_OK;
1805 }
1806 #endif
1807
1808 case OPT_DICT: /* Tcl 8.5 or higher */
1809 {
1810 Tcl_Obj *dict;
1811 int nrows = PQntuples(result);
1812 int ncols = PQnfields(result);
1813 Tcl_Obj *keyv[2]; /* 2-level dictionary key */
1814 Tcl_Obj *valueObj;
1815 Tcl_Obj **fieldNames; /* Array of field names */
1816 int status = TCL_OK;
1817
1818 if (objc != 3)
1819 {
1820 Tcl_WrongNumArgs(interp, 3, objv, NULL);
1821 return TCL_ERROR;
1822 }
1823
1824 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 5 || TCL_MAJOR_VERSION < 8
1825 Tcl_AppendResult(interp,
1826 "pg_result -dict requires Tcl dictionary support\n", NULL);
1827 return TCL_ERROR;
1828 #else
1829 /*
1830 * Note: If this is built with Tcl8.5 stubs, but run under 8.4,
1831 * calling Tcl_NewDictObj() will crash. To avoid that, because
1832 * pgtclng does otherwise test out OK in that setup, do a
1833 * runtime check for Tcl version.
1834 */
1835 if (pgtcl_tcl_version < 8.5)
1836 {
1837 Tcl_AppendResult(interp,
1838 "pg_result -dict requires Tcl dictionary support\n",
1839 NULL);
1840 return TCL_ERROR;
1841 }
1842
1843 dict = Tcl_NewDictObj();
1844 Tcl_IncrRefCount(dict);
1845
1846 /*
1847 * Make an array of objects holding field names, for use
1848 * in the dictionary keys.
1849 */
1850 fieldNames = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * ncols);
1851 for (i = 0; i < ncols; i++)
1852 {
1853 fieldNames[i] = Tcl_NewStringObj(PQfname(result, i), -1);
1854 Tcl_IncrRefCount(fieldNames[i]);
1855 }
1856
1857 /*
1858 * Create a 2-level dictionary of query result values,
1859 * with keys: rownum, fieldname.
1860 */
1861 for (tupno = 0; tupno < nrows && status == TCL_OK; tupno++)
1862 {
1863 keyv[0] = Tcl_NewIntObj(tupno); /* 1st level key */
1864 Tcl_IncrRefCount(keyv[0]);
1865
1866 for (i = 0; i < ncols && status == TCL_OK; i++)
1867 {
1868 keyv[1] = fieldNames[i]; /* 2nd level key: field name */
1869 valueObj = result_get_obj(result, tupno, i);
1870 Tcl_IncrRefCount(valueObj);
1871 status = Tcl_DictObjPutKeyList(interp, dict, 2, keyv,
1872 valueObj);
1873 Tcl_DecrRefCount(valueObj);
1874 }
1875 Tcl_DecrRefCount(keyv[0]);
1876 }
1877
1878 /* Cleanup */
1879 for (i = 0; i < ncols; i++)
1880 Tcl_DecrRefCount(fieldNames[i]);
1881 ckfree((void *)fieldNames);
1882
1883 if (status == TCL_OK)
1884 Tcl_SetObjResult(interp, dict);
1885 Tcl_DecrRefCount(dict);
1886 return status;
1887 #endif /* Tcl >= 8.5 has dictionaries */
1888 }
1889
1890 default:
1891 /*
1892 * Note: This should never happen, since Tcl_GetIndexFromObj
1893 * already checked for a valid switch.
1894 */
1895 Tcl_AppendResult(interp, "pg_result: invalid option\n", NULL);
1896 return TCL_ERROR;
1897 }
1898 }
1899
1900 /**********************************
1901 * result_get_obj
1902
1903 Return a single result value as a Tcl_Obj. For Text format columns, return
1904 a StringObj. For Binary format columns, return a ByteArray object.
1905 The returned object has reference count 0.
1906 Note: This should be the *only* place in the package where we fetch a
1907 value from a query result - the only place libpq's PQgetvalue is used.
1908 **********************************/
1909 static Tcl_Obj *
result_get_obj(PGresult * result,int tupno,int colno)1910 result_get_obj(PGresult *result, int tupno, int colno)
1911 {
1912 if (PQfformat(result, colno) == 0)
1913 /* This is a Text format column */
1914 return Tcl_NewStringObj(PQgetvalue(result, tupno, colno), -1);
1915
1916 /* This is a Binary format column */
1917 return Tcl_NewByteArrayObj((unsigned char *)PQgetvalue(result, tupno, colno),
1918 PQgetlength(result, tupno, colno));
1919 }
1920
1921 /**********************************
1922 * get_row_list_obj
1923
1924 Return the values for a result row as a list object.
1925 The row number tupno must be within range (checked by caller).
1926 On error (unlikely), returns NULL and leaves an error message in the
1927 interpreter.
1928 The returned object has reference count 0.
1929 **********************************/
1930 static Tcl_Obj *
get_row_list_obj(Tcl_Interp * interp,PGresult * result,int tupno)1931 get_row_list_obj(Tcl_Interp *interp, PGresult *result, int tupno)
1932 {
1933 int colno;
1934 Tcl_Obj *resultObj = Tcl_NewListObj(0, NULL);
1935 int ncols = PQnfields(result);
1936
1937 for (colno = 0; colno < ncols; colno++)
1938 {
1939 if (Tcl_ListObjAppendElement(interp, resultObj,
1940 result_get_obj(result, tupno, colno)) == TCL_ERROR)
1941 {
1942 Tcl_DecrRefCount(resultObj); /* Free the object */
1943 return NULL;
1944 }
1945 }
1946 return resultObj; /* Return an object with refCount=0 */
1947 }
1948
1949
1950 /**********************************
1951 * pg_execute
1952 send a query string to the backend connection and process the result
1953
1954 syntax:
1955 pg_execute ?-array name? ?-oid varname? connection query ?loop_body?
1956
1957 the return result is the number of tuples processed. If the query
1958 returns tuples (i.e. a SELECT statement), the result is placed into
1959 variables
1960 **********************************/
1961
1962 int
Pg_execute(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])1963 Pg_execute(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
1964 {
1965 Pg_ConnectionId *connid;
1966 PGconn *conn;
1967 PGresult *result;
1968 int i;
1969 int tupno;
1970 int ntup;
1971 int loop_rc = TCL_OK;
1972 char *array_varname = NULL;
1973 char *arg;
1974 char *connString;
1975 char *queryString;
1976
1977 Tcl_Obj *oid_varnameObj = NULL;
1978 Tcl_Obj *evalObj;
1979 Tcl_Obj *resultObj;
1980
1981 char *usage = "?-array arrayname? ?-oid varname? "
1982 "connection queryString ?loop_body?";
1983
1984 /*
1985 * First we parse the options
1986 */
1987 i = 1;
1988 while (i < objc)
1989 {
1990 arg = Tcl_GetString(objv[i]);
1991 if (arg[0] != '-')
1992 break;
1993
1994 if (strcmp(arg, "-array") == 0)
1995 {
1996 /*
1997 * The rows should appear in an array vs. to single variables
1998 */
1999 i++;
2000 if (i == objc)
2001 {
2002 Tcl_WrongNumArgs(interp, 1, objv, usage);
2003 return TCL_ERROR;
2004 }
2005
2006 array_varname = Tcl_GetString(objv[i++]);
2007 continue;
2008 }
2009
2010 arg = Tcl_GetString(objv[i]);
2011
2012 if (strcmp(arg, "-oid") == 0)
2013 {
2014 /*
2015 * We should place PQoidValue() somewhere
2016 */
2017 i++;
2018 if (i == objc)
2019 {
2020 Tcl_WrongNumArgs(interp, 1, objv, usage);
2021 return TCL_ERROR;
2022 }
2023 oid_varnameObj = objv[i++];
2024 continue;
2025 }
2026
2027 Tcl_WrongNumArgs(interp, 1, objv, usage);
2028 return TCL_ERROR;
2029 }
2030
2031 /*
2032 * Check that after option parsing at least 'connection' and 'query'
2033 * are left
2034 */
2035 if (objc - i < 2)
2036 {
2037 Tcl_WrongNumArgs(interp, 1, objv, usage);
2038 return TCL_ERROR;
2039 }
2040
2041 /*
2042 * Get the connection and make sure no COPY command is pending
2043 */
2044 connString = Tcl_GetString(objv[i++]);
2045 conn = PgGetConnectionId(interp, connString, &connid);
2046 if (!PgQueryOK(interp, conn, connid, 0))
2047 return TCL_ERROR;
2048
2049 /*
2050 * Execute the query
2051 */
2052 queryString = Tcl_GetString(objv[i++]);
2053 result = PQexec(conn, queryString);
2054
2055 /*
2056 * Transfer any notify events from libpq to Tcl event queue.
2057 */
2058 PgNotifyTransferEvents(connid);
2059
2060 /*
2061 * Check for errors
2062 */
2063 if (result == NULL)
2064 {
2065 Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE);
2066 return TCL_ERROR;
2067 }
2068
2069 /*
2070 * Set the oid variable to the returned oid of an INSERT statement if
2071 * requested (or 0 if it wasn't an INSERT)
2072 */
2073 if (oid_varnameObj != NULL)
2074 {
2075 Tcl_Obj *oidValue = Tcl_NewLongObj((long)PQoidValue(result));
2076 Tcl_IncrRefCount(oidValue);
2077 if (Tcl_ObjSetVar2(interp, oid_varnameObj, NULL, oidValue,
2078 TCL_LEAVE_ERR_MSG) == NULL)
2079 {
2080 PQclear(result);
2081 Tcl_DecrRefCount(oidValue);
2082 return TCL_ERROR;
2083 }
2084 Tcl_DecrRefCount(oidValue);
2085 }
2086
2087 /*
2088 * Decide how to go on based on the result status
2089 */
2090 switch (PQresultStatus(result))
2091 {
2092 case PGRES_TUPLES_OK:
2093 /* fall through if we have tuples */
2094 break;
2095
2096 case PGRES_EMPTY_QUERY:
2097 case PGRES_COMMAND_OK:
2098 /* tell the number of affected tuples for non-SELECT queries */
2099 Tcl_SetObjResult(interp,
2100 Tcl_NewStringObj(PQcmdTuples(result), -1));
2101 PQclear(result);
2102 return TCL_OK;
2103
2104 /*
2105 * Note: COPY_IN and COPY_OUT are not allowed with pg_execute
2106 * because there is no result handle returned, and copy needs one.
2107 * Return an error, but it probably is not recoverable because
2108 * the connection is already in COPY mode.
2109 */
2110 case PGRES_COPY_IN:
2111 case PGRES_COPY_OUT:
2112 Tcl_SetResult(interp, "Not allowed to start COPY with pg_execute",
2113 TCL_STATIC);
2114 PQclear(result);
2115 return TCL_ERROR;
2116
2117 default:
2118 /* anything else must be an error */
2119 /* set the result object to be an empty list */
2120 resultObj = Tcl_GetObjResult(interp);
2121 Tcl_SetListObj(resultObj, 0, NULL);
2122 if (Tcl_ListObjAppendElement(interp, resultObj,
2123 Tcl_NewStringObj(PQresStatus(PQresultStatus(result)), -1))
2124 == TCL_ERROR)
2125 return TCL_ERROR;
2126
2127 if (Tcl_ListObjAppendElement(interp, resultObj,
2128 Tcl_NewStringObj(PQresultErrorMessage(result), -1))
2129 == TCL_ERROR)
2130 return TCL_ERROR;
2131
2132 PQclear(result);
2133 return TCL_ERROR;
2134 }
2135
2136 /*
2137 * We reach here only for queries that returned tuples
2138 */
2139 if (i == objc)
2140 {
2141 /*
2142 * We don't have a loop body. If we have at least one result row,
2143 * we set all the variables to the first one and return.
2144 */
2145 if (PQntuples(result) > 0)
2146 {
2147 if (execute_put_values(interp, array_varname, result, 0) != TCL_OK)
2148 {
2149 PQclear(result);
2150 return TCL_ERROR;
2151 }
2152 }
2153
2154 Tcl_SetObjResult(interp, Tcl_NewIntObj(PQntuples(result)));
2155 PQclear(result);
2156 return TCL_OK;
2157 }
2158
2159 /*
2160 * We have a loop body. For each row in the result set, put the values
2161 * into the Tcl variables and execute the body.
2162 */
2163 ntup = PQntuples(result);
2164 evalObj = objv[i];
2165 for (tupno = 0; tupno < ntup; tupno++)
2166 {
2167 if (execute_put_values(interp, array_varname, result, tupno) != TCL_OK)
2168 {
2169 PQclear(result);
2170 return TCL_ERROR;
2171 }
2172
2173 loop_rc = Tcl_EvalObjEx(interp, evalObj, 0);
2174
2175 /* The returncode of the loop body controls the loop execution */
2176 if (loop_rc == TCL_CONTINUE)
2177 {
2178 loop_rc = TCL_OK; /* Continue is the same as OK from here on */
2179 }
2180 else if (loop_rc != TCL_OK) /* Not OK or Continue - stop looping */
2181 {
2182 if (loop_rc == TCL_ERROR)
2183 {
2184 /* Show where the error occurred */
2185 char msg[60];
2186
2187 sprintf(msg, "\n (\"pg_execute\" body line %d)",
2188 Get_ErrorLine(interp));
2189 Tcl_AddErrorInfo(interp, msg);
2190 }
2191 else if (loop_rc == TCL_BREAK)
2192 {
2193 /* On break, break out but return OK */
2194 loop_rc = TCL_OK;
2195 }
2196 break;
2197 }
2198 }
2199
2200 /*
2201 * At the end of the loop we put the number of rows we got into the
2202 * interpreter result, but only on normal return, and clear the result set.
2203 */
2204 if (loop_rc == TCL_OK)
2205 Tcl_SetObjResult(interp, Tcl_NewIntObj(ntup));
2206 PQclear(result);
2207
2208 return loop_rc;
2209 }
2210
2211
2212 /**********************************
2213 * execute_put_values
2214
2215 Put the values of one tuple into Tcl variables named like the
2216 column names, or into an array indexed by the column names.
2217 **********************************/
2218 static int
execute_put_values(Tcl_Interp * interp,char * array_varname,PGresult * result,int tupno)2219 execute_put_values(Tcl_Interp *interp, char *array_varname,
2220 PGresult *result, int tupno)
2221 {
2222 int i;
2223 int n;
2224 Tcl_Obj *value;
2225 /*
2226 * Note: "gcc -Wall" reports that the following two variables
2227 * "may be used uninitialized" if not assigned here. That is
2228 * not possible, but initialize them anyway to quiet gcc.
2229 */
2230 char *varname = NULL;
2231 char *indexname = NULL;
2232
2233 /*
2234 * Loop-invariant parts of variable name varname(indexname):
2235 */
2236 if (array_varname != NULL)
2237 varname = array_varname;
2238 else
2239 indexname = NULL;
2240
2241 /*
2242 * For each column get the column name and value and put it into a Tcl
2243 * variable (either scalar or array item)
2244 */
2245 n = PQnfields(result);
2246 for (i = 0; i < n; i++)
2247 {
2248 value = result_get_obj(result, tupno, i);
2249 Tcl_IncrRefCount(value);
2250
2251 /*
2252 * Loop-variant parts of variable name varname(indexname):
2253 */
2254 if (array_varname != NULL)
2255 indexname = PQfname(result, i);
2256 else
2257 varname = PQfname(result, i);
2258
2259 if (Tcl_SetVar2Ex(interp, varname, indexname, value,
2260 TCL_LEAVE_ERR_MSG) == NULL)
2261 {
2262 Tcl_DecrRefCount(value);
2263 return TCL_ERROR;
2264 }
2265 Tcl_DecrRefCount(value);
2266 }
2267 return TCL_OK;
2268 }
2269
2270 /**********************************
2271 * pg_lo_open
2272 open a large object
2273
2274 syntax:
2275 pg_lo_open conn objOid mode
2276
2277 where mode can be either 'r', 'w', or 'rw'
2278
2279 returns: a large object file ID
2280 on error: throws a Tcl error.
2281 **********************/
2282
2283 int
Pg_lo_open(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])2284 Pg_lo_open(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
2285 {
2286 PGconn *conn;
2287 int lobjId;
2288 int mode;
2289 int fd;
2290 char *connString;
2291 char *modeString;
2292 int modeStringLen;
2293
2294 if (objc != 4)
2295 {
2296 Tcl_WrongNumArgs(interp, 1, objv, "connection lobjOid mode");
2297 return TCL_ERROR;
2298 }
2299
2300 connString = Tcl_GetString(objv[1]);
2301 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
2302 if (conn == (PGconn *)NULL)
2303 return TCL_ERROR;
2304
2305 if (Tcl_GetIntFromObj(interp, objv[2], &lobjId) == TCL_ERROR)
2306 return TCL_ERROR;
2307
2308 modeString = Tcl_GetStringFromObj(objv[3], &modeStringLen);
2309 if ((modeStringLen < 1) || (modeStringLen > 2))
2310 {
2311 Tcl_AppendResult(interp, "mode argument must be 'r', 'w', or 'rw'", 0);
2312 return TCL_ERROR;
2313 }
2314
2315 switch (modeString[0])
2316 {
2317 case 'r':
2318 case 'R':
2319 mode = INV_READ;
2320 break;
2321 case 'w':
2322 case 'W':
2323 mode = INV_WRITE;
2324 break;
2325 default:
2326 Tcl_AppendResult(interp, "mode argument must be 'r', 'w', or 'rw'", 0);
2327 return TCL_ERROR;
2328 }
2329
2330 switch (modeString[1])
2331 {
2332 case '\0':
2333 break;
2334 case 'r':
2335 case 'R':
2336 mode |= INV_READ;
2337 break;
2338 case 'w':
2339 case 'W':
2340 mode |= INV_WRITE;
2341 break;
2342 default:
2343 Tcl_AppendResult(interp, "mode argument must be 'r', 'w', or 'rw'", 0);
2344 return TCL_ERROR;
2345 }
2346
2347 fd = lo_open(conn, lobjId, mode);
2348 /* Note: undocumented but true, lo_open returns -1 on error */
2349 if (fd == -1)
2350 {
2351 Tcl_AppendResult(interp, "Large Object open failed\n",
2352 PQerrorMessage(conn), NULL);
2353 return TCL_ERROR;
2354 }
2355 Tcl_SetObjResult(interp, Tcl_NewIntObj(fd));
2356 return TCL_OK;
2357 }
2358
2359 /**********************************
2360 * pg_lo_close
2361 close a large object
2362
2363 syntax:
2364 pg_lo_close conn fd
2365
2366 returns: nothing
2367 on error: throws a Tcl error.
2368 **********************/
2369 int
Pg_lo_close(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])2370 Pg_lo_close(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
2371 {
2372 PGconn *conn;
2373 int fd;
2374 char *connString;
2375
2376 if (objc != 3)
2377 {
2378 Tcl_WrongNumArgs(interp, 1, objv, "connection fd");
2379 return TCL_ERROR;
2380 }
2381
2382 connString = Tcl_GetString(objv[1]);
2383 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
2384 if (conn == (PGconn *)NULL)
2385 return TCL_ERROR;
2386
2387 if (Tcl_GetIntFromObj(interp, objv[2], &fd) != TCL_OK)
2388 return TCL_ERROR;
2389
2390 if (lo_close(conn, fd) < 0)
2391 {
2392 Tcl_AppendResult(interp, "Large Object close failed\n",
2393 PQerrorMessage(conn), NULL);
2394 return TCL_ERROR;
2395 }
2396 return TCL_OK;
2397 }
2398
2399 /**********************************
2400 * pg_lo_read
2401 reads at most len bytes from a large object into a variable named
2402 bufVar
2403
2404 syntax:
2405 pg_lo_read conn fd bufVar len
2406
2407 bufVar is the name of a variable in which to store the contents of the read
2408
2409 returns: the number of bytes read.
2410 on error: on parameter error, throws a Tcl error, but on a database error
2411 returns a negative number and status TCL_OK. It should throw an error in
2412 this case too, but too late - it was already documented to work this way.
2413 **********************/
2414 int
Pg_lo_read(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])2415 Pg_lo_read(ClientData cData, Tcl_Interp *interp, int objc,
2416 Tcl_Obj *CONST objv[])
2417 {
2418 PGconn *conn;
2419 int fd;
2420 int nbytes = 0;
2421 char *buf;
2422 Tcl_Obj *bufVar;
2423 Tcl_Obj *bufObj;
2424 int len;
2425 int rc = TCL_OK;
2426
2427 if (objc != 5)
2428 {
2429 Tcl_WrongNumArgs(interp, 1, objv, "conn fd bufVar len");
2430 return TCL_ERROR;
2431 }
2432
2433 conn = PgGetConnectionId(interp, Tcl_GetString(objv[1]),
2434 (Pg_ConnectionId **) NULL);
2435 if (conn == (PGconn *)NULL)
2436 return TCL_ERROR;
2437
2438 if (Tcl_GetIntFromObj(interp, objv[2], &fd) != TCL_OK)
2439 return TCL_ERROR;
2440
2441 bufVar = objv[3];
2442
2443 if (Tcl_GetIntFromObj(interp, objv[4], &len) != TCL_OK)
2444 return TCL_ERROR;
2445
2446 if (len <= 0)
2447 {
2448 Tcl_SetObjResult(interp, Tcl_NewIntObj(nbytes));
2449 return TCL_OK;
2450 }
2451
2452 buf = ckalloc(len + 1);
2453
2454 nbytes = lo_read(conn, fd, buf, len);
2455
2456 if (nbytes >= 0)
2457 {
2458 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1 || TCL_MAJOR_VERSION > 8
2459 bufObj = Tcl_NewByteArrayObj((unsigned char *)buf, nbytes);
2460 #else
2461 bufObj = Tcl_NewStringObj(buf, nbytes);
2462 #endif
2463 Tcl_IncrRefCount(bufObj);
2464 if (Tcl_ObjSetVar2(interp, bufVar, NULL, bufObj,
2465 TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1) == NULL)
2466 rc = TCL_ERROR;
2467 Tcl_DecrRefCount(bufObj);
2468 }
2469
2470 if (rc == TCL_OK)
2471 Tcl_SetObjResult(interp, Tcl_NewIntObj(nbytes));
2472
2473 ckfree(buf);
2474 return rc;
2475 }
2476
2477 /***********************************
2478 Pg_lo_write
2479 write at most len bytes to a large object
2480
2481 syntax:
2482 pg_lo_write conn fd buf len
2483
2484 returns: the number of bytes written.
2485 on error: on parameter error, throws a Tcl error, but on a database error
2486 returns a negative number and status TCL_OK. It should throw an error in
2487 this case too, but too late - it was already documented to work this way.
2488 ***********************************/
2489 int
Pg_lo_write(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])2490 Pg_lo_write(ClientData cData, Tcl_Interp *interp, int objc,
2491 Tcl_Obj *CONST objv[])
2492 {
2493 PGconn *conn;
2494 char *buf;
2495 int fd;
2496 int nbytes = 0;
2497 int len;
2498
2499 if (objc != 5)
2500 {
2501 Tcl_WrongNumArgs(interp, 1, objv, "conn fd buf len");
2502 return TCL_ERROR;
2503 }
2504
2505 conn = PgGetConnectionId(interp, Tcl_GetString(objv[1]),
2506 (Pg_ConnectionId **) NULL);
2507 if (conn == (PGconn *)NULL)
2508 return TCL_ERROR;
2509
2510 if (Tcl_GetIntFromObj(interp, objv[2], &fd) != TCL_OK)
2511 return TCL_ERROR;
2512
2513 #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1 || TCL_MAJOR_VERSION > 8
2514 buf = (char *)Tcl_GetByteArrayFromObj(objv[3], &nbytes);
2515 #else
2516 buf = Tcl_GetStringFromObj(objv[3], &nbytes);
2517 #endif
2518
2519 if (Tcl_GetIntFromObj(interp, objv[4], &len) != TCL_OK)
2520 return TCL_ERROR;
2521
2522 if (len > nbytes)
2523 len = nbytes;
2524
2525 if (len <= 0)
2526 nbytes = 0;
2527 else
2528 nbytes = lo_write(conn, fd, buf, len);
2529
2530 Tcl_SetObjResult(interp, Tcl_NewIntObj(nbytes));
2531 return TCL_OK;
2532 }
2533
2534 /***********************************
2535 Pg_lo_lseek
2536 seek to a certain position in a large object
2537
2538 syntax
2539 pg_lo_lseek conn fd offset whence
2540
2541 whence can be either
2542 "SEEK_CUR", "SEEK_END", or "SEEK_SET"
2543
2544 returns: the new position in the object
2545 on error: throws a Tcl error.
2546 ***********************************/
2547 int
Pg_lo_lseek(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])2548 Pg_lo_lseek(ClientData cData, Tcl_Interp *interp, int objc,
2549 Tcl_Obj *CONST objv[])
2550 {
2551 PGconn *conn;
2552 int fd;
2553 char *whenceStr;
2554 int offset;
2555 int whence;
2556 char *connString;
2557 int newOffset;
2558
2559 if (objc != 5)
2560 {
2561 Tcl_WrongNumArgs(interp, 1, objv, "conn fd offset whence");
2562 return TCL_ERROR;
2563 }
2564
2565 connString = Tcl_GetString(objv[1]);
2566 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
2567 if (conn == (PGconn *)NULL)
2568 return TCL_ERROR;
2569
2570 if (Tcl_GetIntFromObj(interp, objv[2], &fd) != TCL_OK)
2571 return TCL_ERROR;
2572
2573 if (Tcl_GetIntFromObj(interp, objv[3], &offset) == TCL_ERROR)
2574 return TCL_ERROR;
2575
2576 whenceStr = Tcl_GetString(objv[4]);
2577
2578 if (strcmp(whenceStr, "SEEK_SET") == 0)
2579 whence = SEEK_SET;
2580 else if (strcmp(whenceStr, "SEEK_CUR") == 0)
2581 whence = SEEK_CUR;
2582 else if (strcmp(whenceStr, "SEEK_END") == 0)
2583 whence = SEEK_END;
2584 else
2585 {
2586 Tcl_AppendResult(interp, "'whence' must be SEEK_SET, SEEK_CUR or SEEK_END", 0);
2587 return TCL_ERROR;
2588 }
2589
2590 newOffset = lo_lseek(conn, fd, offset, whence);
2591 if (newOffset == -1)
2592 {
2593 Tcl_AppendResult(interp, "Large Object seek failed\n",
2594 PQerrorMessage(conn), NULL);
2595 return TCL_ERROR;
2596 }
2597
2598 Tcl_SetObjResult(interp, Tcl_NewIntObj(newOffset));
2599 return TCL_OK;
2600 }
2601
2602 /***********************************
2603 Pg_lo_lseek64
2604 seek to a certain position in a large object, 64-bit version
2605
2606 syntax
2607 pg_lo_lseek64 conn fd offset whence
2608
2609 whence can be either
2610 "SEEK_CUR", "SEEK_END", or "SEEK_SET"
2611
2612 returns: the new position in the object
2613 on error: throws a Tcl error.
2614 ***********************************/
2615 #ifdef HAVE_LO_TELL64 /* lo_lseek64 was added together with lo_tell64 */
2616 int
Pg_lo_lseek64(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])2617 Pg_lo_lseek64(ClientData cData, Tcl_Interp *interp, int objc,
2618 Tcl_Obj *CONST objv[])
2619 {
2620 PGconn *conn;
2621 int fd;
2622 char *whenceStr;
2623 Tcl_WideInt toffset64;
2624 pg_int64 offset, newOffset;
2625 int whence;
2626 char *connString;
2627
2628 if (objc != 5)
2629 {
2630 Tcl_WrongNumArgs(interp, 1, objv, "conn fd offset whence");
2631 return TCL_ERROR;
2632 }
2633
2634 connString = Tcl_GetString(objv[1]);
2635 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
2636 if (conn == (PGconn *)NULL)
2637 return TCL_ERROR;
2638
2639 if (Tcl_GetIntFromObj(interp, objv[2], &fd) != TCL_OK)
2640 return TCL_ERROR;
2641
2642 /* The Tcl_WideInt and pg_int64 types might be identical, but it seems
2643 to be safer to assume they are assignment-compatible rather than
2644 allowing a pointer to one to be used in a function expecting the
2645 other.
2646 */
2647 if (Tcl_GetWideIntFromObj(interp, objv[3], &toffset64) == TCL_ERROR)
2648 return TCL_ERROR;
2649 offset = toffset64; /* "Type" conversion */
2650
2651 whenceStr = Tcl_GetString(objv[4]);
2652
2653 if (strcmp(whenceStr, "SEEK_SET") == 0)
2654 whence = SEEK_SET;
2655 else if (strcmp(whenceStr, "SEEK_CUR") == 0)
2656 whence = SEEK_CUR;
2657 else if (strcmp(whenceStr, "SEEK_END") == 0)
2658 whence = SEEK_END;
2659 else
2660 {
2661 Tcl_AppendResult(interp, "'whence' must be SEEK_SET, SEEK_CUR or SEEK_END", 0);
2662 return TCL_ERROR;
2663 }
2664
2665 newOffset = lo_lseek64(conn, fd, offset, whence);
2666
2667 if (newOffset == -1)
2668 {
2669 Tcl_AppendResult(interp, "Large Object seek failed\n",
2670 PQerrorMessage(conn), NULL);
2671 return TCL_ERROR;
2672 }
2673
2674 toffset64 = newOffset; /* Possible type conversion */
2675 Tcl_SetObjResult(interp, Tcl_NewWideIntObj(toffset64));
2676 return TCL_OK;
2677 }
2678 #endif
2679
2680
2681 /***********************************
2682 Pg_lo_creat
2683 create a new large object with mode
2684
2685 syntax:
2686 pg_lo_creat conn mode
2687
2688 mode can be any OR'ing together of INV_READ, INV_WRITE,
2689 for now, we don't support any additional storage managers.
2690
2691 returns: a large object OID
2692 on error: throws a Tcl error.
2693 ***********************************/
2694 int
Pg_lo_creat(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])2695 Pg_lo_creat(ClientData cData, Tcl_Interp *interp, int objc,
2696 Tcl_Obj *CONST objv[])
2697 {
2698 PGconn *conn;
2699 char *modeStr;
2700 char *modeWord;
2701 int mode;
2702 char *connString;
2703 int loid;
2704
2705 if (objc != 3)
2706 {
2707 Tcl_WrongNumArgs(interp, 1, objv, "conn mode");
2708 return TCL_ERROR;
2709 }
2710
2711 connString = Tcl_GetString(objv[1]);
2712 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
2713 if (conn == (PGconn *)NULL)
2714 return TCL_ERROR;
2715
2716 modeStr = Tcl_GetString(objv[2]);
2717
2718 modeWord = strtok(modeStr, "|");
2719 if (strcmp(modeWord, "INV_READ") == 0)
2720 mode = INV_READ;
2721 else if (strcmp(modeWord, "INV_WRITE") == 0)
2722 mode = INV_WRITE;
2723 else
2724 {
2725 Tcl_AppendResult(interp,
2726 "mode must be some OR'd combination of INV_READ, and INV_WRITE", 0);
2727 return TCL_ERROR;
2728 }
2729
2730 while ((modeWord = strtok((char *)NULL, "|")) != NULL)
2731 {
2732 if (strcmp(modeWord, "INV_READ") == 0)
2733 mode |= INV_READ;
2734 else if (strcmp(modeWord, "INV_WRITE") == 0)
2735 mode |= INV_WRITE;
2736 else
2737 {
2738 Tcl_AppendResult(interp,
2739 "mode must be some OR'd combination of INV_READ, INV_WRITE", 0);
2740 return TCL_ERROR;
2741 }
2742 }
2743
2744 loid = lo_creat(conn, mode);
2745 /* Note: undocumented but true, lo_creat returns InvalidOid on error */
2746 if (loid == InvalidOid)
2747 {
2748 Tcl_AppendResult(interp, "Large Object create failed\n",
2749 PQerrorMessage(conn), NULL);
2750 return TCL_ERROR;
2751 }
2752 Tcl_SetObjResult(interp, Tcl_NewIntObj(loid));
2753 return TCL_OK;
2754 }
2755
2756 /***********************************
2757 Pg_lo_tell
2758 returns the current seek location of the large object
2759
2760 syntax:
2761 pg_lo_tell conn fd
2762
2763 returns: the current position in the object
2764 on error: throws a Tcl error.
2765 ***********************************/
2766 int
Pg_lo_tell(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])2767 Pg_lo_tell(ClientData cData, Tcl_Interp *interp, int objc,
2768 Tcl_Obj *CONST objv[])
2769 {
2770 PGconn *conn;
2771 int fd;
2772 char *connString;
2773 int offset;
2774
2775 if (objc != 3)
2776 {
2777 Tcl_WrongNumArgs(interp, 1, objv, "conn fd");
2778 return TCL_ERROR;
2779 }
2780
2781 connString = Tcl_GetString(objv[1]);
2782 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
2783 if (conn == (PGconn *)NULL)
2784 return TCL_ERROR;
2785
2786 if (Tcl_GetIntFromObj(interp, objv[2], &fd) != TCL_OK)
2787 return TCL_ERROR;
2788
2789 offset = lo_tell(conn, fd);
2790 if (offset == -1)
2791 {
2792 Tcl_AppendResult(interp, "Large Object tell offset failed\n",
2793 PQerrorMessage(conn), NULL);
2794 return TCL_ERROR;
2795 }
2796 Tcl_SetObjResult(interp, Tcl_NewIntObj(offset));
2797 return TCL_OK;
2798 }
2799
2800 /***********************************
2801 Pg_lo_tell64
2802 returns the current seek location of the large object, 64-bit version
2803
2804 syntax:
2805 pg_lo_tell64 conn fd
2806
2807 returns: the current position in the object
2808 on error: throws a Tcl error.
2809 ***********************************/
2810 #ifdef HAVE_LO_TELL64
2811 int
Pg_lo_tell64(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])2812 Pg_lo_tell64(ClientData cData, Tcl_Interp *interp, int objc,
2813 Tcl_Obj *CONST objv[])
2814 {
2815 PGconn *conn;
2816 int fd;
2817 char *connString;
2818 pg_int64 offset;
2819 Tcl_WideInt toffset64;
2820
2821 if (objc != 3)
2822 {
2823 Tcl_WrongNumArgs(interp, 1, objv, "conn fd");
2824 return TCL_ERROR;
2825 }
2826
2827 connString = Tcl_GetString(objv[1]);
2828 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
2829 if (conn == (PGconn *)NULL)
2830 return TCL_ERROR;
2831
2832 if (Tcl_GetIntFromObj(interp, objv[2], &fd) != TCL_OK)
2833 return TCL_ERROR;
2834
2835 offset = lo_tell64(conn, fd);
2836 if (offset == -1)
2837 {
2838 Tcl_AppendResult(interp, "Large Object tell offset failed\n",
2839 PQerrorMessage(conn), NULL);
2840 return TCL_ERROR;
2841 }
2842 toffset64 = offset; /* Possible "type" conversion */
2843 Tcl_SetObjResult(interp, Tcl_NewWideIntObj(toffset64));
2844 return TCL_OK;
2845 }
2846 #endif
2847
2848 /***********************************
2849 Pg_lo_unlink
2850 unlink a file based on lobject id
2851
2852 syntax:
2853 pg_lo_unlink conn lobjId
2854
2855
2856 returns: nothing
2857 on error: throws a Tcl error.
2858 ***********************************/
2859 int
Pg_lo_unlink(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])2860 Pg_lo_unlink(ClientData cData, Tcl_Interp *interp, int objc,
2861 Tcl_Obj *CONST objv[])
2862 {
2863 PGconn *conn;
2864 int lobjId;
2865 char *connString;
2866
2867 if (objc != 3)
2868 {
2869 Tcl_WrongNumArgs(interp, 1, objv, "conn fd");
2870 return TCL_ERROR;
2871 }
2872
2873 connString = Tcl_GetString(objv[1]);
2874 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
2875 if (conn == (PGconn *)NULL)
2876 return TCL_ERROR;
2877
2878 if (Tcl_GetIntFromObj(interp, objv[2], &lobjId) == TCL_ERROR)
2879 return TCL_ERROR;
2880
2881 if (lo_unlink(conn, lobjId) < 0)
2882 {
2883 Tcl_AppendResult(interp, "Large Object unlink failed\n",
2884 PQerrorMessage(conn), NULL);
2885 return TCL_ERROR;
2886 }
2887 return TCL_OK;
2888 }
2889
2890 /***********************************
2891 Pg_lo_import
2892 import a Unix file into an (inversion) large objct
2893
2894 syntax:
2895 pg_lo_import conn filename
2896
2897 returns: OID of the imported large object
2898 on error: throws a Tcl error.
2899 ***********************************/
2900
2901 int
Pg_lo_import(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])2902 Pg_lo_import(ClientData cData, Tcl_Interp *interp, int objc,
2903 Tcl_Obj *CONST objv[])
2904 {
2905 PGconn *conn;
2906 const char *filename;
2907 Oid lobjId;
2908 char *connString;
2909
2910 if (objc != 3)
2911 {
2912 Tcl_WrongNumArgs(interp, 1, objv, "conn filename");
2913 return TCL_ERROR;
2914 }
2915
2916 connString = Tcl_GetString(objv[1]);
2917 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
2918 if (conn == (PGconn *)NULL)
2919 return TCL_ERROR;
2920
2921 filename = Tcl_GetString(objv[2]);
2922
2923 lobjId = lo_import(conn, filename);
2924 if (lobjId == InvalidOid)
2925 {
2926 Tcl_AppendResult(interp, "Large Object import of '", filename,
2927 "' failed\n", PQerrorMessage(conn), NULL);
2928 return TCL_ERROR;
2929 }
2930
2931 Tcl_SetLongObj(Tcl_GetObjResult(interp), (long)lobjId);
2932 return TCL_OK;
2933 }
2934
2935 /***********************************
2936 Pg_lo_export
2937 export an Inversion large object to a Unix file
2938
2939 syntax:
2940 pg_lo_export conn lobjId filename
2941
2942 returns: nothing
2943 on error: throws a Tcl error.
2944 ***********************************/
2945
2946 int
Pg_lo_export(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])2947 Pg_lo_export(ClientData cData, Tcl_Interp *interp, int objc,
2948 Tcl_Obj *CONST objv[])
2949 {
2950 PGconn *conn;
2951 const char *filename;
2952 Oid lobjId;
2953 char *connString;
2954
2955 if (objc != 4)
2956 {
2957 Tcl_WrongNumArgs(interp, 1, objv, "conn lobjId filename");
2958 return TCL_ERROR;
2959 }
2960
2961 connString = Tcl_GetString(objv[1]);
2962 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
2963 if (conn == (PGconn *)NULL)
2964 return TCL_ERROR;
2965
2966 /*
2967 * Note: casting Oid lobjId to int for GetIntFromObj just hides the
2968 * real problem - lack of unsigned int in Tcl objects.
2969 */
2970 if (Tcl_GetIntFromObj(interp, objv[2], (int *)&lobjId) == TCL_ERROR)
2971 return TCL_ERROR;
2972
2973 filename = Tcl_GetString(objv[3]);
2974
2975 if (lo_export(conn, lobjId, filename) == -1)
2976 {
2977 Tcl_AppendResult(interp, "Large Object export to '", filename,
2978 "' failed\n", PQerrorMessage(conn), NULL);
2979 return TCL_ERROR;
2980 }
2981 return TCL_OK;
2982 }
2983
2984 /***********************************
2985 Pg_lo_truncate
2986 Truncate (or extend) the size of a large object
2987 Note: This requires PostgreSQL libpq >= 8.3
2988
2989 syntax
2990 pg_lo_truncate conn fd length
2991
2992 returns zero if OK.
2993 on error: throws a Tcl error.
2994 ***********************************/
2995 #ifdef HAVE_LO_TRUNCATE /* PostgreSQL >= 8.3.0 */
2996 int
Pg_lo_truncate(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])2997 Pg_lo_truncate(ClientData cData, Tcl_Interp *interp, int objc,
2998 Tcl_Obj *CONST objv[])
2999 {
3000 PGconn *conn;
3001 int fd;
3002 int length;
3003 char *connString;
3004 int result;
3005
3006 if (objc != 4)
3007 {
3008 Tcl_WrongNumArgs(interp, 1, objv, "conn fd length");
3009 return TCL_ERROR;
3010 }
3011
3012 connString = Tcl_GetString(objv[1]);
3013 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
3014 if (conn == (PGconn *)NULL)
3015 return TCL_ERROR;
3016
3017 if (Tcl_GetIntFromObj(interp, objv[2], &fd) != TCL_OK)
3018 return TCL_ERROR;
3019
3020 if (Tcl_GetIntFromObj(interp, objv[3], &length) == TCL_ERROR)
3021 return TCL_ERROR;
3022
3023 result = lo_truncate(conn, fd, length);
3024 if (result < 0)
3025 {
3026 Tcl_AppendResult(interp, "Large Object truncate failed\n",
3027 PQerrorMessage(conn), NULL);
3028 return TCL_ERROR;
3029 }
3030
3031 Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
3032 return TCL_OK;
3033 }
3034 #endif
3035
3036 /***********************************
3037 Pg_lo_truncate64
3038 Truncate (or extend) the size of a large object, 64-bit version
3039
3040 syntax
3041 pg_lo_truncate64 conn fd length
3042
3043 returns zero if OK.
3044 on error: throws a Tcl error.
3045 ***********************************/
3046 #ifdef HAVE_LO_TELL64 /* lo_truncate64 was added together with lo_tell64 */
3047 int
Pg_lo_truncate64(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])3048 Pg_lo_truncate64(ClientData cData, Tcl_Interp *interp, int objc,
3049 Tcl_Obj *CONST objv[])
3050 {
3051 PGconn *conn;
3052 int fd;
3053 Tcl_WideInt tlength;
3054 pg_int64 length;
3055 char *connString;
3056 int result;
3057
3058 if (objc != 4)
3059 {
3060 Tcl_WrongNumArgs(interp, 1, objv, "conn fd length");
3061 return TCL_ERROR;
3062 }
3063
3064 connString = Tcl_GetString(objv[1]);
3065 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
3066 if (conn == (PGconn *)NULL)
3067 return TCL_ERROR;
3068
3069 if (Tcl_GetIntFromObj(interp, objv[2], &fd) != TCL_OK)
3070 return TCL_ERROR;
3071
3072 if (Tcl_GetWideIntFromObj(interp, objv[3], &tlength) == TCL_ERROR)
3073 return TCL_ERROR;
3074 length = tlength; /* Possible "type" conversion */
3075
3076 result = lo_truncate64(conn, fd, length);
3077 if (result < 0)
3078 {
3079 Tcl_AppendResult(interp, "Large Object truncate failed\n",
3080 PQerrorMessage(conn), NULL);
3081 return TCL_ERROR;
3082 }
3083
3084 Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
3085 return TCL_OK;
3086 }
3087 #endif
3088
3089 /**********************************
3090 pg_select_helper - Helper for pg_select
3091
3092 This is the core processing for pg_select.
3093 (This is a separate function to make error handling easier to follow.)
3094 Returns a TCL status: TCL_OK if OK, else TCL_ERROR, or a status returned
3095 from the script (such as TCL_RETURN or another code).
3096 **********************************/
3097
3098 static int
pg_select_helper(Tcl_Interp * interp,PGresult * result,Tcl_Obj * varNameObj,Tcl_Obj ** column_names,Tcl_Obj * script)3099 pg_select_helper(Tcl_Interp *interp, PGresult *result, Tcl_Obj *varNameObj,
3100 Tcl_Obj **column_names, Tcl_Obj *script)
3101 {
3102 int tupno,
3103 ntuples,
3104 column,
3105 ncols,
3106 r,
3107 err;
3108 Tcl_Obj *value;
3109 char *varNameString;
3110 char msg[60];
3111
3112
3113 varNameString = Tcl_GetString(varNameObj);
3114
3115 ncols = PQnfields(result);
3116 ntuples = PQntuples(result);
3117
3118 /* Loop over all the rows of the query result: */
3119 for (tupno = 0; tupno < ntuples; tupno++)
3120 {
3121 /* Set Array(.tupno) to the row number: */
3122 if (Tcl_SetVar2Ex(interp, varNameString, ".tupno",
3123 Tcl_NewIntObj(tupno), TCL_LEAVE_ERR_MSG) == NULL)
3124 return TCL_ERROR;
3125
3126 for (column = 0; column < ncols; column++)
3127 {
3128 value = result_get_obj(result, tupno, column);
3129 Tcl_IncrRefCount(value);
3130 err = (Tcl_ObjSetVar2(interp, varNameObj, column_names[column],
3131 value, TCL_LEAVE_ERR_MSG) == NULL);
3132 Tcl_DecrRefCount(value);
3133 if (err)
3134 return TCL_ERROR;
3135 }
3136
3137 r = Tcl_EvalObjEx(interp, script, 0);
3138 if (r != TCL_OK && r != TCL_CONTINUE)
3139 {
3140 if (r == TCL_BREAK)
3141 break; /* exit loop, but return TCL_OK */
3142
3143 if (r == TCL_ERROR)
3144 {
3145 sprintf(msg, "\n (\"pg_select\" body line %d)",
3146 Get_ErrorLine(interp));
3147 Tcl_AddErrorInfo(interp, msg);
3148 }
3149 return r;
3150 }
3151 }
3152 return TCL_OK;
3153 }
3154
3155 /**********************************
3156 * pg_select
3157 send a select query string to the backend connection and loop over the result rows.
3158
3159 syntax:
3160 pg_select connection query var proc
3161
3162 The query must be a select statement
3163 The var is used in the proc as an array
3164 The proc is run once for each row found
3165
3166 The return is either TCL_OK, TCL_ERROR or TCL_RETURN and interp->result
3167 may contain more information.
3168 **********************************/
3169
3170 int
Pg_select(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])3171 Pg_select(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
3172 {
3173 Pg_ConnectionId *connid;
3174 PGconn *conn;
3175 PGresult *result;
3176 int retval;
3177 int column;
3178 int ncols;
3179 char *connString;
3180 char *queryString;
3181 char *varNameString;
3182 Tcl_Obj *varNameObj;
3183 Tcl_Obj *procStringObj;
3184 Tcl_Obj *columnListObj;
3185 Tcl_Obj **columnNameObjs;
3186
3187 if (objc != 5)
3188 {
3189 Tcl_WrongNumArgs(interp, 1, objv, "connection queryString var proc");
3190 return TCL_ERROR;
3191 }
3192
3193 retval = TCL_OK;
3194
3195 connString = Tcl_GetString(objv[1]);
3196 queryString = Tcl_GetString(objv[2]);
3197
3198 varNameObj = objv[3];
3199 varNameString = Tcl_GetString(varNameObj);
3200
3201 procStringObj = objv[4];
3202
3203 conn = PgGetConnectionId(interp, connString, &connid);
3204 if (!PgQueryOK(interp, conn, connid, 0))
3205 return TCL_ERROR;
3206
3207 /* Execute the query: */
3208 if ((result = PQexec(conn, queryString)) == NULL)
3209 {
3210 /* error occurred sending the query */
3211 Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE);
3212 return TCL_ERROR;
3213 }
3214
3215 /* Transfer any notify events from libpq to Tcl event queue. */
3216 PgNotifyTransferEvents(connid);
3217
3218 /* Check query result status: */
3219 if (PQresultStatus(result) != PGRES_TUPLES_OK)
3220 {
3221 /* query failed, or it wasn't SELECT (which is also an error). */
3222 Tcl_SetResult(interp, (char *)PQresultErrorMessage(result),
3223 TCL_VOLATILE);
3224 PQclear(result);
3225 return TCL_ERROR;
3226 }
3227
3228 ncols = PQnfields(result);
3229
3230 /* Allocate space and fill an array of column names as Tcl objects: */
3231 columnNameObjs = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * ncols);
3232 for (column = 0; column < ncols; column++)
3233 {
3234 columnNameObjs[column] = Tcl_NewStringObj(PQfname(result, column), -1);
3235 Tcl_IncrRefCount(columnNameObjs[column]);
3236 }
3237
3238
3239 /* Set Array(.numcols) to the number of result columns.
3240 Note: This used to set Array(.command) = "update" but that was
3241 never documented or explained and seemed to have no purpose.
3242 */
3243 if (Tcl_SetVar2Ex(interp, varNameString, ".numcols", Tcl_NewIntObj(ncols),
3244 TCL_LEAVE_ERR_MSG) == NULL)
3245 retval = TCL_ERROR;
3246 else {
3247 /* Set Array(.headers) to be a Tcl list of column names: */
3248 columnListObj = Tcl_NewListObj(ncols, columnNameObjs);
3249 Tcl_IncrRefCount(columnListObj);
3250 if (Tcl_SetVar2Ex(interp, varNameString, ".headers", columnListObj,
3251 TCL_LEAVE_ERR_MSG) == NULL)
3252 retval = TCL_ERROR;
3253 Tcl_DecrRefCount(columnListObj);
3254 }
3255
3256 /* The helper function does the rest of the work. */
3257 if (retval != TCL_ERROR)
3258 retval = pg_select_helper(interp, result, varNameObj, columnNameObjs, procStringObj);
3259
3260 /* Cleanup - deallocate space, free objects, free the result structure */
3261 for (column = 0; column < ncols; column++)
3262 Tcl_DecrRefCount(columnNameObjs[column]);
3263 ckfree((void *)columnNameObjs);
3264 Tcl_UnsetVar(interp, varNameString, 0);
3265 PQclear(result);
3266 return retval;
3267 }
3268
3269 /*
3270 * Test whether any callbacks are registered on this connection for
3271 * the given relation name. NB: supplied name must be case-folded already.
3272 */
3273
3274 static int
Pg_have_listener(Pg_ConnectionId * connid,CONST char * relname)3275 Pg_have_listener(Pg_ConnectionId * connid, CONST char *relname)
3276 {
3277 Pg_TclNotifies *notifies;
3278 Tcl_HashEntry *entry;
3279
3280 for (notifies = connid->notify_list;
3281 notifies != NULL;
3282 notifies = notifies->next)
3283 {
3284 Tcl_Interp *interp = notifies->interp;
3285
3286 if (interp == NULL)
3287 continue; /* ignore deleted interpreter */
3288
3289 entry = Tcl_FindHashEntry(¬ifies->notify_hash, (char *)relname);
3290 if (entry == NULL)
3291 continue; /* no pg_listen in this interpreter */
3292
3293 return TRUE; /* OK, there is a listener */
3294 }
3295
3296 return FALSE; /* Found no listener */
3297 }
3298
3299 /*
3300 * Find or make a Pg_TclNotifies struct for this interp and connection.
3301 * This is used by Pg_listen() and Pg_on_connection_loss().
3302 */
3303 static Pg_TclNotifies *
Pg_get_notifies(Tcl_Interp * interp,Pg_ConnectionId * connid)3304 Pg_get_notifies(Tcl_Interp *interp, Pg_ConnectionId *connid)
3305 {
3306 Pg_TclNotifies *notifies;
3307
3308 for (notifies = connid->notify_list; notifies; notifies = notifies->next)
3309 {
3310 if (notifies->interp == interp)
3311 break;
3312 }
3313
3314 if (notifies == NULL)
3315 {
3316 notifies = (Pg_TclNotifies *) ckalloc(sizeof(Pg_TclNotifies));
3317 notifies->interp = interp;
3318 Tcl_InitHashTable(¬ifies->notify_hash, TCL_STRING_KEYS);
3319 notifies->conn_loss_cmd = NULL;
3320 notifies->next = connid->notify_list;
3321 connid->notify_list = notifies;
3322 Tcl_CallWhenDeleted(interp, PgNotifyInterpDelete, (ClientData)notifies);
3323 }
3324 return notifies;
3325 }
3326
3327
3328 /***********************************
3329 Pg_listen
3330 create or remove a callback request for notifies on a given name
3331
3332 syntax:
3333 pg_listen ?-pid? conn notifyname ?callbackcommand?
3334
3335 With a callbackcommand arg, creates or changes the callback command for
3336 notifies on the given name; without, cancels the callback request.
3337
3338 The -pid argument results in appending the notifying process' PID to
3339 the callback as an argument. If the NOTIFY message includes a non-empty
3340 payload (available with PostgreSQL-9.0 and up), then the payload will be
3341 appended to the command as an argument. The callback command (function)
3342 must defined the payload as an optional argument.
3343
3344 The callback is stored in a hash table from the connection structure.
3345 A flag is set in the table if -pid was provided. This tells
3346 Pg_Notify_EventProc() in pgtclId.c to include the PID argument to the
3347 callback.
3348
3349 Callbacks can occur whenever Tcl is executing its event loop.
3350 This is the normal idle loop in Tk; in plain tclsh applications,
3351 vwait or update can be used to enter the Tcl event loop.
3352 ***********************************/
3353 int
Pg_listen(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])3354 Pg_listen(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
3355 {
3356 const char *origrelname;
3357 char *caserelname;
3358 char *callback = NULL;
3359 Pg_TclNotifies *notifies;
3360 Tcl_HashEntry *entry;
3361 Pg_ConnectionId *connid;
3362 PGconn *conn;
3363 PGresult *result;
3364 int new;
3365 char *connString;
3366 int callbackStrlen = 0;
3367 int origrelnameStrlen;
3368 Pg_notify_command *notifCmd;
3369 int pass_pid = 0; /* Flag: -pid was used? */
3370 int arg_n = 1; /* Argument pointer */
3371
3372 /* Check for -pid argument */
3373 if (objc > 1 && strcmp(Tcl_GetString(objv[1]), "-pid") == 0)
3374 {
3375 pass_pid = 1;
3376 arg_n++;
3377 objc--;
3378 }
3379
3380 if (objc < 3 || objc > 4)
3381 {
3382 Tcl_WrongNumArgs(interp, 1, objv, "?options? connection relname ?callback?");
3383 return TCL_ERROR;
3384 }
3385
3386 /*
3387 * Get the command arguments. Note that the relation name will be
3388 * copied by Tcl_CreateHashEntry while the callback string must be
3389 * allocated by us.
3390 */
3391 connString = Tcl_GetString(objv[arg_n++]);
3392 conn = PgGetConnectionId(interp, connString, &connid);
3393 if (!PgQueryOK(interp, conn, connid, 0))
3394 return TCL_ERROR;
3395
3396 /*
3397 * LISTEN/NOTIFY do not preserve case unless the relation name is
3398 * quoted. We have to do the same thing to ensure that we will find
3399 * the desired pg_listen item.
3400 */
3401 origrelname = Tcl_GetStringFromObj(objv[arg_n++], &origrelnameStrlen);
3402 caserelname = (char *)ckalloc((unsigned)(origrelnameStrlen + 1));
3403 if (*origrelname == '"')
3404 {
3405 /* Copy a quoted string without downcasing */
3406 strcpy(caserelname, origrelname + 1);
3407 caserelname[origrelnameStrlen - 2] = '\0';
3408 }
3409 else
3410 {
3411 /* Downcase it */
3412 const char *rels = origrelname;
3413 char *reld = caserelname;
3414
3415 while (*rels)
3416 *reld++ = tolower((unsigned char)*rels++);
3417 *reld = '\0';
3418 }
3419
3420 if (objc > 3)
3421 {
3422 char *callbackStr;
3423
3424 callbackStr = Tcl_GetStringFromObj(objv[arg_n++], &callbackStrlen);
3425 callback = ckalloc(callbackStrlen + 1);
3426 strcpy(callback, callbackStr);
3427 }
3428
3429 /* Find or make a Pg_TclNotifies struct for this interp and connection */
3430 notifies = Pg_get_notifies(interp, connid);
3431
3432 if (callback)
3433 {
3434 /*
3435 * Create or update a callback for a relation
3436 */
3437 int alreadyHadListener = Pg_have_listener(connid, caserelname);
3438
3439 entry = Tcl_CreateHashEntry(¬ifies->notify_hash, caserelname, &new);
3440 /* If update, free the old callback string and containing struct */
3441 if (!new)
3442 {
3443 notifCmd = (Pg_notify_command *)Tcl_GetHashValue(entry);
3444 if (notifCmd->callback) ckfree(notifCmd->callback);
3445 ckfree((char *)notifCmd);
3446 }
3447
3448 /* Store the new callback string */
3449 notifCmd = (Pg_notify_command *)ckalloc(sizeof(Pg_notify_command));
3450 notifCmd->callback = callback;
3451 notifCmd->use_pid = pass_pid;
3452 Tcl_SetHashValue(entry, notifCmd);
3453
3454 /* Start the notify event source if it isn't already running */
3455 PgStartNotifyEventSource(connid);
3456
3457 /*
3458 * Send a LISTEN command if this is the first listener.
3459 */
3460 if (!alreadyHadListener)
3461 {
3462 char *cmd = (char *)ckalloc((unsigned)(origrelnameStrlen + 8));
3463
3464 sprintf(cmd, "LISTEN %s", origrelname);
3465 result = PQexec(conn, cmd);
3466 ckfree(cmd);
3467 /* Transfer any notify events from libpq to Tcl event queue. */
3468 PgNotifyTransferEvents(connid);
3469 if (PQresultStatus(result) != PGRES_COMMAND_OK)
3470 {
3471 /* Error occurred during the execution of command */
3472 PQclear(result);
3473 ckfree(callback);
3474 ckfree((char *)notifCmd);
3475 Tcl_DeleteHashEntry(entry);
3476 ckfree(caserelname);
3477 Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE);
3478 return TCL_ERROR;
3479 }
3480 PQclear(result);
3481 }
3482 }
3483 else
3484 {
3485 /*
3486 * Remove a callback for a relation
3487 */
3488 entry = Tcl_FindHashEntry(¬ifies->notify_hash, caserelname);
3489 if (entry == NULL)
3490 {
3491 Tcl_AppendResult(interp, "not listening on ", origrelname, 0);
3492 ckfree(caserelname);
3493 return TCL_ERROR;
3494 }
3495
3496 notifCmd = (Pg_notify_command *)Tcl_GetHashValue(entry);
3497 if (notifCmd->callback) ckfree(notifCmd->callback);
3498 ckfree((char *)notifCmd);
3499 Tcl_DeleteHashEntry(entry);
3500
3501 /*
3502 * Send an UNLISTEN command if that was the last listener. Note:
3503 * we don't attempt to turn off the notify mechanism if no LISTENs
3504 * remain active; not worth the trouble.
3505 */
3506 if (!Pg_have_listener(connid, caserelname))
3507 {
3508 char *cmd = (char *)
3509 ckalloc((unsigned)(origrelnameStrlen + 10));
3510
3511 sprintf(cmd, "UNLISTEN %s", origrelname);
3512 result = PQexec(conn, cmd);
3513 ckfree(cmd);
3514 /* Transfer any notify events from libpq to Tcl event queue. */
3515 PgNotifyTransferEvents(connid);
3516 if (PQresultStatus(result) != PGRES_COMMAND_OK)
3517 {
3518 /* Error occurred during the execution of command */
3519 PQclear(result);
3520 ckfree(caserelname);
3521 Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE);
3522 return TCL_ERROR;
3523 }
3524 PQclear(result);
3525 }
3526 }
3527
3528 ckfree(caserelname);
3529 return TCL_OK;
3530 }
3531
3532 /**********************************
3533 * pg_sendquery
3534 send a query string to the backend connection
3535
3536 syntax:
3537 pg_sendquery connection query ?param...?
3538
3539 Optional args are used as parameters to PQsendQueryParams(). This allows
3540 only text format, untyped parameters.
3541
3542 Returns OK status if the command was dispatched, or throws a Tcl error
3543 on error.
3544 **********************************/
3545 int
Pg_sendquery(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])3546 Pg_sendquery(ClientData cData, Tcl_Interp *interp, int objc,
3547 Tcl_Obj *CONST objv[])
3548 {
3549 Pg_ConnectionId *connid;
3550 PGconn *conn;
3551 char *connString;
3552 char *execString;
3553 int status;
3554 const char *const *paramValues;
3555 int nParams;
3556
3557 nParams = objc - 3;
3558 if (nParams < 0)
3559 {
3560 Tcl_WrongNumArgs(interp, 1, objv, "connection queryString ?param...?");
3561 return TCL_ERROR;
3562 }
3563
3564 connString = Tcl_GetString(objv[1]);
3565
3566 conn = PgGetConnectionId(interp, connString, &connid);
3567 if (!PgQueryOK(interp, conn, connid, 1))
3568 return TCL_ERROR;
3569
3570 execString = Tcl_GetString(objv[2]);
3571
3572 if (nParams > 0)
3573 {
3574 get_param_values(interp, &objv[3], nParams, /* allParamsText = */ 1,
3575 /* paramFormats = */ NULL, ¶mValues,
3576 /* paramLengths_result = */ NULL);
3577
3578 status = PQsendQueryParams(conn, execString, nParams, NULL,
3579 paramValues, NULL, NULL, /* resultFormat= */ 0);
3580
3581 if (paramValues)
3582 Tcl_Free((char *)paramValues);
3583
3584 } else {
3585 status = PQsendQuery(conn, execString);
3586 }
3587
3588 /* Transfer any notify events from libpq to Tcl event queue. */
3589 PgNotifyTransferEvents(connid);
3590
3591 if (status)
3592 return TCL_OK;
3593 else
3594 {
3595 /* error occurred during the query */
3596 Tcl_SetObjResult(interp, Tcl_NewStringObj(PQerrorMessage(conn), -1));
3597 return TCL_ERROR;
3598 }
3599 }
3600
3601 /**********************************
3602 * pg_sendquery_prepared
3603 send a query using a prepared query to the backend connection
3604
3605 syntax:
3606 pg_sendquery_prepared connection statementName resultFormatList \
3607 argFormatList ?param...?
3608
3609 This is similar to pg_exec_prepared, but asynchronous like pg_sendquery.
3610
3611 argFormatList is empty (= same as T), a single word T|B|TEXT|BINARY, or
3612 a list of those words, describing each argument as text or binary. If a
3613 single word, it applies to all arguments. (Actually, anything starting
3614 with B means Binary, and anything else means Text. There is no error
3615 checking.)
3616
3617 resultFormatList is similar to argFormatList except that it applies to the
3618 columns of the results. Currently, all result parameters must be text, or
3619 all must be binary (this is a libpq limitation, not a PostgreSQL
3620 limitation). So you might as well specify a single word BINARY or leave it
3621 empty.
3622
3623 Returns OK status if the command was dispatched, or throws a Tcl error
3624 on error.
3625 **********************************/
3626 int
Pg_sendquery_prepared(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])3627 Pg_sendquery_prepared(ClientData cData, Tcl_Interp *interp, int objc,
3628 Tcl_Obj *CONST objv[])
3629 {
3630 Pg_ConnectionId *connid;
3631 PGconn *conn;
3632 char *connString;
3633 char *statementName;
3634 int nParams;
3635 int allParamsText;
3636 int resultFormat;
3637 int *paramFormats;
3638 int *paramLengths;
3639 const char *const *paramValues;
3640 int returnValue;
3641 int status;
3642
3643 nParams = objc - 5;
3644 if (nParams < 0)
3645 {
3646 Tcl_WrongNumArgs(interp, 1, objv, "connection statementName "
3647 "resultFormat argFormatList ?param...?");
3648 return TCL_ERROR;
3649 }
3650
3651 connString = Tcl_GetString(objv[1]);
3652
3653 conn = PgGetConnectionId(interp, connString, &connid);
3654 if (!PgQueryOK(interp, conn, connid, 1))
3655 return TCL_ERROR;
3656
3657 statementName = Tcl_GetString(objv[2]);
3658
3659 /* Parse resultFormatList and make resultFormat argument. */
3660 if (get_result_format(interp, objv[3], &resultFormat) != TCL_OK)
3661 return TCL_ERROR;
3662
3663 /* Parse argFormat list and make paramFormats argument and all-text flag */
3664 if (get_param_formats(interp, objv[4], nParams, &allParamsText,
3665 ¶mFormats) != TCL_OK)
3666 return TCL_ERROR;
3667
3668 /* Copy query parameters, and lengths if binary format */
3669 get_param_values(interp, &objv[5], nParams, allParamsText, paramFormats,
3670 ¶mValues, ¶mLengths);
3671
3672 /* Now dispatch the prepared query */
3673 status = PQsendQueryPrepared(conn, statementName, nParams, paramValues,
3674 paramLengths, paramFormats, resultFormat);
3675
3676 /* Transfer any notify events from libpq to Tcl event queue. */
3677 PgNotifyTransferEvents(connid);
3678
3679 if (status)
3680 returnValue = TCL_OK;
3681 else
3682 {
3683 /* error occurred when sending the query */
3684 Tcl_SetObjResult(interp, Tcl_NewStringObj(PQerrorMessage(conn), -1));
3685 returnValue = TCL_ERROR;
3686 }
3687
3688 if (paramFormats)
3689 Tcl_Free((char *)paramFormats);
3690 if (paramLengths)
3691 Tcl_Free((char *)paramLengths);
3692 if (paramValues)
3693 Tcl_Free((char *)paramValues);
3694
3695 return returnValue;
3696 }
3697
3698 /**********************************
3699 * pg_sendquery_params
3700 Parse, bind parameters, and send a query using a prepared query to the
3701 backend connection for asynchronous execution.
3702
3703 syntax:
3704 pg_sendquery_params connection query resultFormatList argFormatList \
3705 argTypeList ?param...?
3706
3707 query is an SQL statement with parameter placeholders specified as
3708 $1, $2, etc.
3709
3710 argFormatList is empty (= same as T), a single word T|B|TEXT|BINARY, or
3711 a list of those words, describing each argument as text or binary. If a
3712 single word, it applies to all arguments. (Actually, anything starting
3713 with B means Binary, and anything else means Text. There is no error
3714 checking.)
3715
3716 resultFormatList is similar to argFormatList except that it applies to the
3717 columns of the results. Currently, all result parameters must be text, or
3718 all must be binary (this is a libpq limitation, not a PostgreSQL
3719 limitation). So you might as well specify a single word BINARY or leave it
3720 empty.
3721
3722 argTypeList is a list of PostgreSQL type OIDs for the query parameter
3723 arguments. Type OIDs must be supplied for each binary-format argument.
3724 If there are any binary format arguments, the argTypeList must contain
3725 an entry for each argument, although the actual value will be ignored
3726 for text-mode arguments.
3727
3728 This is similar to pg_exec_params, but asynchronous like pg_sendquery.
3729 Note: If you are using all text arguments, it is easier to use pg_sendquery
3730 with the optional parameter arguments.
3731
3732 Returns OK status if the command was dispatched, or throws a Tcl error
3733 on error.
3734 **********************************/
3735 int
Pg_sendquery_params(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])3736 Pg_sendquery_params(ClientData cData, Tcl_Interp *interp, int objc,
3737 Tcl_Obj *CONST objv[])
3738 {
3739 Pg_ConnectionId *connid;
3740 PGconn *conn;
3741 char *connString;
3742 char *queryString;
3743 int nParams;
3744 int allParamsText;
3745 int resultFormat;
3746 int *paramFormats;
3747 int *paramLengths;
3748 const char *const *paramValues;
3749 Oid *paramTypes;
3750 int returnValue;
3751 int status;
3752
3753 nParams = objc - 6;
3754 if (nParams < 0)
3755 {
3756 Tcl_WrongNumArgs(interp, 1, objv, "connection queryString "
3757 "resultFormat argFormatList argTypeList ?param...?");
3758 return TCL_ERROR;
3759 }
3760
3761 connString = Tcl_GetString(objv[1]);
3762
3763 conn = PgGetConnectionId(interp, connString, &connid);
3764 if (!PgQueryOK(interp, conn, connid, 1))
3765 return TCL_ERROR;
3766
3767 queryString = Tcl_GetString(objv[2]);
3768
3769 /* Parse resultFormatList and make resultFormat argument. */
3770 if (get_result_format(interp, objv[3], &resultFormat) != TCL_OK)
3771 return TCL_ERROR;
3772
3773 /* Parse argFormat list and make paramFormats argument and all-text flag */
3774 if (get_param_formats(interp, objv[4], nParams, &allParamsText,
3775 ¶mFormats) != TCL_OK)
3776 return TCL_ERROR;
3777
3778 /* Get the parameter type OID list into an array */
3779 if (get_param_types(interp, objv[5], nParams, ¶mTypes) != TCL_OK) {
3780 if (paramFormats)
3781 Tcl_Free((char *)paramFormats);
3782 return TCL_ERROR;
3783 }
3784
3785 /* Copy query parameters, and lengths if binary format */
3786 get_param_values(interp, &objv[6], nParams, allParamsText, paramFormats,
3787 ¶mValues, ¶mLengths);
3788
3789 /* Now dispatch the parameterized query to the backend */
3790 status = PQsendQueryParams(conn, queryString, nParams, paramTypes,
3791 paramValues, paramLengths, paramFormats, resultFormat);
3792
3793 /* Transfer any notify events from libpq to Tcl event queue. */
3794 PgNotifyTransferEvents(connid);
3795
3796 if (status)
3797 returnValue = TCL_OK;
3798 else {
3799 /* error occurred when sending the query */
3800 Tcl_SetObjResult(interp, Tcl_NewStringObj(PQerrorMessage(conn), -1));
3801 returnValue = TCL_ERROR;
3802 }
3803
3804 if (paramFormats)
3805 Tcl_Free((char *)paramFormats);
3806 if (paramLengths)
3807 Tcl_Free((char *)paramLengths);
3808 if (paramValues)
3809 Tcl_Free((char *)paramValues);
3810 if (paramTypes)
3811 Tcl_Free((char *)paramTypes);
3812
3813 return returnValue;
3814 }
3815
3816 /**********************************
3817 * pg_result_callback
3818 register or remove a callback for the next pg_sendquery to complete
3819
3820 syntax:
3821 pg_result_callback connection ?callback?
3822
3823 Original version written by msofer
3824 **********************************/
3825 int
Pg_result_callback(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])3826 Pg_result_callback(ClientData cData, Tcl_Interp *interp, int objc,
3827 Tcl_Obj *CONST objv[])
3828 {
3829 Pg_ConnectionId *connid;
3830 PGconn *conn;
3831 char *connString;
3832
3833 if (objc < 2 || 3 < objc)
3834 {
3835 Tcl_WrongNumArgs(interp, 1, objv, "connection ?callback?");
3836 return TCL_ERROR;
3837 }
3838
3839 connString = Tcl_GetString(objv[1]);
3840 conn = PgGetConnectionId(interp, connString, &connid);
3841 if (conn == NULL)
3842 return TCL_ERROR;
3843
3844 /* Forget any existing result callback */
3845 PgClearResultCallback(connid);
3846
3847 if (objc > 2)
3848 {
3849 /* Establish a result callback */
3850
3851 /* Start the notify event source if it isn't already running */
3852 PgStartNotifyEventSource(connid);
3853
3854 connid->callbackPtr = objv[2];
3855 connid->callbackInterp = interp;
3856
3857 Tcl_IncrRefCount(objv[2]);
3858 Tcl_Preserve((ClientData) interp);
3859 }
3860
3861 return TCL_OK;
3862 }
3863
3864
3865 /**********************************
3866 * pg_getresult
3867 wait for the next result from a prior pg_sendquery
3868
3869 syntax:
3870 pg_getresult connection
3871
3872 the return result is either an error message, nothing, or a handle for a query
3873 result. Handles start with the prefix "pgp"
3874 **********************************/
3875
3876 int
Pg_getresult(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])3877 Pg_getresult(ClientData cData, Tcl_Interp *interp, int objc,
3878 Tcl_Obj *CONST objv[])
3879 {
3880 Pg_ConnectionId *connid;
3881 PGconn *conn;
3882 PGresult *result;
3883 char *connString;
3884
3885 if (objc != 2)
3886 {
3887 Tcl_WrongNumArgs(interp, 1, objv, "connection");
3888 return TCL_ERROR;
3889 }
3890
3891 connString = Tcl_GetString(objv[1]);
3892
3893 conn = PgGetConnectionId(interp, connString, &connid);
3894 if (conn == (PGconn *)NULL)
3895 return TCL_ERROR;
3896
3897 /* Cancel any callback script: the user lost patience */
3898 PgClearResultCallback(connid);
3899
3900 result = PQgetResult(conn);
3901
3902 /* Transfer any notify events from libpq to Tcl event queue. */
3903 PgNotifyTransferEvents(connid);
3904
3905 /* if there's a non-null result, give the caller the handle */
3906 if (result)
3907 {
3908 int rId = PgSetResultId(interp, connString, result);
3909 ExecStatusType rStat;
3910
3911 if (rId == -1)
3912 {
3913 /* There is a result available, but unable to allocate a result
3914 * slot for it. Return error; PgSetResultId left a message.
3915 */
3916 PQclear(result);
3917 return TCL_ERROR;
3918 }
3919 rStat = PQresultStatus(result);
3920
3921 if (rStat == PGRES_COPY_IN || rStat == PGRES_COPY_OUT)
3922 {
3923 connid->res_copyStatus = RES_COPY_INPROGRESS;
3924 connid->res_copy = rId;
3925 }
3926 }
3927 return TCL_OK;
3928 }
3929
3930 /**********************************
3931 * pg_isbusy
3932 see if a query is busy, i.e. pg_getresult would block.
3933
3934 syntax:
3935 pg_isbusy connection
3936
3937 return is 1 if it's busy and pg_getresult would block, 0 otherwise
3938 **********************************/
3939
3940 int
Pg_isbusy(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])3941 Pg_isbusy(ClientData cData, Tcl_Interp *interp, int objc,
3942 Tcl_Obj *CONST objv[])
3943 {
3944 PGconn *conn;
3945 char *connString;
3946
3947 if (objc != 2)
3948 {
3949 Tcl_WrongNumArgs(interp, 1, objv, "connection");
3950 return TCL_ERROR;
3951 }
3952
3953 connString = Tcl_GetString(objv[1]);
3954
3955 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
3956 if (conn == (PGconn *)NULL)
3957 return TCL_ERROR;
3958
3959 PQconsumeInput(conn);
3960
3961 Tcl_SetIntObj(Tcl_GetObjResult(interp), PQisBusy(conn));
3962 return TCL_OK;
3963 }
3964
3965 /**********************************
3966 * pg_blocking
3967 see or set whether or not a connection is set to blocking or nonblocking
3968
3969 Syntax:
3970 pg_blocking connection ?newSetting?
3971
3972 returns:
3973 If newSetting is provided, returns the blocking state - 1 if blocking, 0
3974 if non-blocking - before changing to the new setting.
3975 If newSetting is not provided, returns the current blocking state.
3976 **********************************/
3977
3978 int
Pg_blocking(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])3979 Pg_blocking(ClientData cData, Tcl_Interp *interp, int objc,
3980 Tcl_Obj *CONST objv[])
3981 {
3982 PGconn *conn;
3983 char *connString;
3984 int boolean;
3985
3986 if ((objc < 2) || (objc > 3))
3987 {
3988 Tcl_WrongNumArgs(interp, 1, objv, "connection ?bool?");
3989 return TCL_ERROR;
3990 }
3991
3992 connString = Tcl_GetString(objv[1]);
3993
3994 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
3995 if (conn == (PGconn *)NULL)
3996 return TCL_ERROR;
3997
3998 /* Return the current value */
3999 Tcl_SetBooleanObj(Tcl_GetObjResult(interp), !PQisnonblocking(conn));
4000
4001 /* If new setting provided, change it: */
4002 if (objc == 3)
4003 {
4004 if (Tcl_GetBooleanFromObj(interp, objv[2], &boolean) == TCL_ERROR)
4005 return TCL_ERROR;
4006 PQsetnonblocking(conn, !boolean); /* Non-blocking if arg is 1 */
4007 }
4008 return TCL_OK;
4009 }
4010
4011 /**********************************
4012 * pg_cancelrequest
4013 request that postgresql abandon processing of the current command
4014
4015 syntax:
4016 pg_cancelrequest connection
4017
4018 returns nothing if the command successfully dispatched or if nothing was
4019 going on, otherwise an error
4020 **********************************/
4021
4022 int
Pg_cancelrequest(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])4023 Pg_cancelrequest(ClientData cData, Tcl_Interp *interp, int objc,
4024 Tcl_Obj *CONST objv[])
4025 {
4026 Pg_ConnectionId *connid;
4027 PGconn *conn;
4028 char *connString;
4029
4030 if (objc != 2)
4031 {
4032 Tcl_WrongNumArgs(interp, 1, objv, "connection");
4033 return TCL_ERROR;
4034 }
4035
4036 connString = Tcl_GetString(objv[1]);
4037
4038 conn = PgGetConnectionId(interp, connString, &connid);
4039 if (conn == NULL)
4040 return TCL_ERROR;
4041
4042 /* Cancel any callback script */
4043 PgClearResultCallback(connid);
4044
4045 if (PQrequestCancel(conn) == 0)
4046 {
4047 Tcl_SetObjResult(interp,
4048 Tcl_NewStringObj(PQerrorMessage(conn), -1));
4049 return TCL_ERROR;
4050 }
4051 return TCL_OK;
4052 }
4053
4054 /***********************************
4055 Pg_on_connection_loss
4056 create or remove a callback request for unexpected connection loss
4057
4058 syntax:
4059 pg_on_connection_loss conn ?callbackcommand?
4060
4061 With a third arg, creates or changes the callback command for
4062 connection loss; without, cancels the callback request.
4063
4064 Callbacks can occur whenever Tcl is executing its event loop.
4065 This is the normal idle loop in Tk; in plain tclsh applications,
4066 vwait or update can be used to enter the Tcl event loop.
4067 ***********************************/
4068 int
Pg_on_connection_loss(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])4069 Pg_on_connection_loss(ClientData cData, Tcl_Interp *interp, int objc,
4070 Tcl_Obj *CONST objv[])
4071 {
4072 char *callback = NULL;
4073 Pg_TclNotifies *notifies;
4074 Pg_ConnectionId *connid;
4075 PGconn *conn;
4076 char *connString;
4077
4078 if (objc < 2 || objc > 3)
4079 {
4080 Tcl_WrongNumArgs(interp, 1, objv, "connection ?callback?");
4081 return TCL_ERROR;
4082 }
4083
4084 /*
4085 * Get the command arguments.
4086 */
4087 connString = Tcl_GetString(objv[1]);
4088 conn = PgGetConnectionId(interp, connString, &connid);
4089 if (conn == (PGconn *) NULL)
4090 return TCL_ERROR;
4091
4092 if (objc > 2)
4093 {
4094 int callbackStrLen;
4095 char *callbackStr;
4096
4097 /* there is probably a better way to do this, like incrementing
4098 * the reference count (?) */
4099 callbackStr = Tcl_GetStringFromObj(objv[2], &callbackStrLen);
4100 callback = (char *) ckalloc((unsigned) (callbackStrLen + 1));
4101 strcpy(callback, callbackStr);
4102 }
4103
4104 /* Find or make a Pg_TclNotifies struct for this interp and connection */
4105 notifies = Pg_get_notifies(interp, connid);
4106
4107 /* Store new callback setting */
4108
4109 if (notifies->conn_loss_cmd)
4110 ckfree((void *) notifies->conn_loss_cmd);
4111 notifies->conn_loss_cmd = callback;
4112
4113 if (callback)
4114 {
4115 /*
4116 * Start the notify event source if it isn't already running. The
4117 * notify source will cause Tcl to watch read-ready on the
4118 * connection socket, so that we find out quickly if the
4119 * connection drops.
4120 */
4121 PgStartNotifyEventSource(connid);
4122 }
4123
4124 return TCL_OK;
4125 }
4126
4127 /***********************************
4128 Pg_escape_string
4129 escape string for inclusion in SQL queries
4130 See also Pg_quote and Pg_escape_literal
4131
4132 syntax:
4133 pg_escape_string ?conn? string
4134
4135 If the optional connection handle argument is supplied, it calls the
4136 newer libpq escape function that uses connection-specific information
4137 about encoding and standard_conforming_strings.
4138
4139 Note: This was first added to another pgtcl implementation, as a wrapper
4140 around the libpq PQescapeString function. Later it was removed from there,
4141 and a new command pg_quote was added, which includes the containing quotes
4142 in the return value.
4143 Both pgtcl-ng and pgin.tcl implemented pg_escape_string (without quotes)
4144 and pg_quote (with quotes). But then the other pgtcl implementation re-added
4145 pg_escape_string, but this time it included the quotes in the return value.
4146 However, pgtcl-ng and pgin.tcl had already released versions with
4147 pg_escape_string not including the quotes. The choice was to break
4148 compatibility with itself, or with the other pgtcl.
4149 So pg_escape_string is NOT compatible with the other Pgtcl implementation.
4150
4151 ***********************************/
4152 int
Pg_escape_string(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])4153 Pg_escape_string(ClientData cData, Tcl_Interp *interp, int objc,
4154 Tcl_Obj *CONST objv[])
4155 {
4156 char *fromString;
4157 char *toString;
4158 int fromStringLen;
4159 int toStringLen;
4160 PGconn *conn;
4161
4162 if (objc == 3)
4163 {
4164 conn = PgGetConnectionId(interp, Tcl_GetString(objv[1]), NULL);
4165 if (!conn)
4166 return TCL_ERROR;
4167 fromString = Tcl_GetStringFromObj(objv[2], &fromStringLen);
4168 } else if (objc == 2) {
4169 conn = NULL;
4170 fromString = Tcl_GetStringFromObj(objv[1], &fromStringLen);
4171 } else {
4172 Tcl_WrongNumArgs(interp, 1, objv, "?conn? string");
4173 return TCL_ERROR;
4174 }
4175
4176 /*
4177 * Allocate the "to" string. Max size is documented in the
4178 * PostgreSQL docs as 2 * fromStringLen + 1
4179 */
4180 toString = (char *) ckalloc((2 * fromStringLen) + 1);
4181
4182 /*
4183 * Call the library routine to escape the string, and return
4184 * the command result as a Tcl object.
4185 */
4186
4187 #ifdef HAVE_PQESCAPESTRINGCONN
4188 if (conn)
4189 toStringLen = PQescapeStringConn (conn, toString, fromString, fromStringLen, NULL);
4190 else
4191 #endif
4192 toStringLen = PQescapeString (toString, fromString, fromStringLen);
4193
4194 Tcl_SetObjResult(interp, Tcl_NewStringObj(toString, toStringLen));
4195 ckfree(toString);
4196
4197 return TCL_OK;
4198 }
4199
4200 /***********************************
4201 Pg_quote
4202 escape and quote string for inclusion in SQL queries
4203 See also Pg_escape_string and note on compatibility with other pgtcl's.
4204 See also Pg_escape_literal
4205 syntax:
4206 pg_quote ?conn? string
4207
4208 ***********************************/
4209 int
Pg_quote(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])4210 Pg_quote(ClientData cData, Tcl_Interp *interp, int objc,
4211 Tcl_Obj *CONST objv[])
4212 {
4213 char *fromString;
4214 char *toString;
4215 int fromStringLen;
4216 int toStringLen;
4217 PGconn *conn;
4218
4219 if (objc == 3)
4220 {
4221 conn = PgGetConnectionId(interp, Tcl_GetString(objv[1]), NULL);
4222 if (!conn)
4223 return TCL_ERROR;
4224 fromString = Tcl_GetStringFromObj(objv[2], &fromStringLen);
4225 } else if (objc == 2) {
4226 conn = NULL;
4227 fromString = Tcl_GetStringFromObj(objv[1], &fromStringLen);
4228 } else {
4229 Tcl_WrongNumArgs(interp, 1, objv, "?conn? string");
4230 return TCL_ERROR;
4231 }
4232
4233 /*
4234 * Allocate the "to" string. Max size is documented in the
4235 * PostgreSQL docs as 2 * fromStringLen + 1. Add 2 for quotes,
4236 * and subtract 1 because NewStringObj doesn't need the ending null.
4237 */
4238 toString = (char *) ckalloc((2 * fromStringLen) + 2);
4239
4240 /*
4241 * Call the library routine to escape the string, and return
4242 * the command result as a Tcl object with quote marks around it.
4243 */
4244
4245
4246 toString[0] = '\'';
4247 #ifdef HAVE_PQESCAPESTRINGCONN
4248 if (conn)
4249 toStringLen = 1 + PQescapeStringConn (conn, toString+1, fromString, fromStringLen, NULL);
4250 else
4251 #endif
4252 toStringLen = 1 + PQescapeString (toString+1, fromString, fromStringLen);
4253 toString[toStringLen++] = '\'';
4254 Tcl_SetObjResult(interp, Tcl_NewStringObj(toString, toStringLen));
4255 ckfree(toString);
4256
4257 return TCL_OK;
4258 }
4259
4260
4261 /***********************************
4262 Pg_escape_l_i
4263
4264 Escape string as literal or identifier, for inclusion in SQL queries
4265 See also Pg_escape_string and Pg_quote
4266
4267 This implements both pg_escape_literal pg_escape_identifier, based on
4268 ClientData: ClientData=1 for pg_escape_literal, 2 for pg_escape_identifier
4269
4270 syntax:
4271 pg_escape_literal conn string
4272 pg_escape_identifier conn string
4273
4274 Note: pg_escape_literal is effectively equivalent to pg_quote. It
4275 wraps libpq PQescapeLiteral() which was added after pg_quote was
4276 implemented. Like pg_quote, it escapes a string and returns it inside
4277 single quotes. Unlike pg_quote (and its underlying pg_escape_string),
4278 the implementation is not dependent on standard_conforming_strings.
4279
4280 pg_escape_identifier wraps libpq PQescapeIdentifier. Both of these
4281 were added to libpq in PostgreSQL-9.0.
4282
4283 Also unlike pg_quote and pg_escape_string, the $conn argument is
4284 required for both commands. It is used to handle encoding / multibyte issues.
4285
4286 ***********************************/
4287 #ifdef HAVE_PQESCAPELITERAL /* Added in PostgreSQL-9.0 */
4288 int
Pg_escape_l_i(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])4289 Pg_escape_l_i(ClientData cData, Tcl_Interp *interp, int objc,
4290 Tcl_Obj *CONST objv[])
4291 {
4292 char *fromString;
4293 char *toString;
4294 int fromStringLen;
4295 PGconn *conn;
4296
4297 if (objc != 3)
4298 {
4299 Tcl_WrongNumArgs(interp, 1, objv, "conn string");
4300 return TCL_ERROR;
4301 }
4302
4303 conn = PgGetConnectionId(interp, Tcl_GetString(objv[1]), NULL);
4304 if (!conn)
4305 return TCL_ERROR;
4306
4307 fromString = Tcl_GetStringFromObj(objv[2], &fromStringLen);
4308 if ((int)cData == 1)
4309 {
4310 toString = PQescapeLiteral(conn, fromString, fromStringLen);
4311 }
4312 else if ((int)cData == 2)
4313 {
4314 toString = PQescapeIdentifier(conn, fromString, fromStringLen);
4315 }
4316 else toString = NULL; /* This should never happen */
4317
4318 if (!toString)
4319 {
4320 Tcl_SetObjResult(interp, Tcl_NewStringObj(PQerrorMessage(conn), -1));
4321 return TCL_ERROR;
4322 }
4323
4324 Tcl_SetObjResult(interp, Tcl_NewStringObj(toString, -1));
4325 PQfreemem(toString);
4326 return TCL_OK;
4327 }
4328 #endif
4329
4330
4331 /***********************************
4332 * Pg_escape_bytea
4333 Escape a binary string for inclusion in SQL queries as a bytea type.
4334 See libpq PQescapeBytea, PQescapeByteaConn.
4335
4336 If the optional connection handle argument is supplied, it calls the
4337 newer libpq escape function that uses connection-specific information
4338 about standard_conforming_strings. With no connection handle, the
4339 original libpq call is used, which makes its best guess as to whether
4340 standard_conforming_strings is on or not. (The guess will always be
4341 correct for applications using a single database connection at a time.)
4342
4343 The escaping (as of PostgreSQL-8.3 or so) is as follows:
4344 Single quote (') is doubled ('').
4345 Backslash (\) produces 2 (\\) in standard_conforming_strings mode,
4346 or 4 (\\\\) in non-standard_conforming_strings mode.
4347 All characters below ASCII 0x20 (space) or above 0x7e (~) are encoded
4348 as 3 octal digits ooo, and then output as
4349 \ooo in standard_conforming_strings mode,
4350 \\ooo in non-standard_conforming_strings_mode.
4351
4352 The doubling of backslashes (in non-standard_conforming_strings mode) is
4353 due to PostgreSQL parsing the data once for SQL syntax, and again for
4354 bytea input.
4355 Note: This function is NOT the inverse of Pg_unescape_bytea (cf).
4356
4357 Syntax:
4358 pg_escape_bytea ?conn? binary_string
4359
4360 ***********************************/
4361 int
Pg_escape_bytea(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])4362 Pg_escape_bytea(ClientData cData, Tcl_Interp *interp, int objc,
4363 Tcl_Obj *CONST objv[])
4364 {
4365 unsigned char *from_binary;
4366 int from_len;
4367 char *to_string;
4368 size_t to_len;
4369 PGconn *conn;
4370
4371 if (objc == 3)
4372 {
4373 conn = PgGetConnectionId(interp, Tcl_GetString(objv[1]), NULL);
4374 if (!conn)
4375 return TCL_ERROR;
4376 from_binary = Tcl_GetByteArrayFromObj(objv[2], &from_len);
4377 } else if (objc == 2) {
4378 conn = NULL;
4379 from_binary = Tcl_GetByteArrayFromObj(objv[1], &from_len);
4380 } else {
4381 Tcl_WrongNumArgs(interp, 1, objv, "?conn? binaryString");
4382 return TCL_ERROR;
4383 }
4384
4385 /*
4386 * Escape the data. libpq allocates the memory for us.
4387 * Note to_len includes the terminating null byte.
4388 */
4389 #ifdef HAVE_PQESCAPEBYTEACONN
4390 if (conn)
4391 to_string = (char *)PQescapeByteaConn(conn, from_binary, (size_t)from_len, &to_len);
4392 else
4393 #endif
4394 to_string = (char *)PQescapeBytea(from_binary, (size_t)from_len, &to_len);
4395 if (!to_string)
4396 {
4397 Tcl_AppendResult(interp, "pg_escape_bytea: failed to get memory\n", 0);
4398 return TCL_ERROR;
4399 }
4400
4401 /*
4402 * Copy the result to the interpreter as a string object.
4403 */
4404 Tcl_SetObjResult(interp, Tcl_NewStringObj(to_string, to_len-1));
4405
4406 /*
4407 * Free libpq-allocated memory
4408 */
4409 PQfreemem(to_string);
4410
4411 return TCL_OK;
4412 }
4413
4414 /***********************************
4415 * Pg_unescape_bytea
4416 Unescape a string from a PostgreSQL bytea data type and return the
4417 original binary data as a Tcl binary object.
4418 See libpq PQunescapeBytea.
4419 In summary, this takes \nnn octal escapes and produces the byte
4420 equivalent to nnn, and any other \c becomes c.
4421
4422 Note: This function is NOT the inverse of Pg_escape_bytea. That
4423 function produces doubled backslashes, and this function expects
4424 single backslashes. That's because pg_escape_bytea is meant to
4425 escape binary data for quoted SQL strings in SELECT, INSERT, etc.
4426 which goes through two levels of parsing. pg_unescape_bytea is
4427 used to retrieve binary data returned by a query on a bytea column,
4428 which has only had one level of escaping performed on it.
4429
4430 Syntax:
4431 pg_unescape_bytea string
4432
4433 ***********************************/
4434 int
Pg_unescape_bytea(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])4435 Pg_unescape_bytea(ClientData cData, Tcl_Interp *interp, int objc,
4436 Tcl_Obj *CONST objv[])
4437 {
4438 unsigned char *to_binary;
4439 size_t to_len;
4440
4441 if (objc != 2)
4442 {
4443 Tcl_WrongNumArgs(interp, 1, objv, "string");
4444 return TCL_ERROR;
4445 }
4446
4447 /*
4448 * Unescape the data. libpq allocates the memory for us.
4449 */
4450 to_binary = PQunescapeBytea((unsigned char *)Tcl_GetString(objv[1]), &to_len);
4451 if (!to_binary)
4452 {
4453 Tcl_AppendResult(interp, "pg_unescape_bytea: failed to get memory\n", 0);
4454 return TCL_ERROR;
4455 }
4456
4457 /*
4458 * Copy the result to the interpreter as a ByteArray (binary) object.
4459 */
4460 Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(to_binary, to_len));
4461
4462 /*
4463 * Free libpq-allocated memory
4464 */
4465 PQfreemem(to_binary);
4466
4467 return TCL_OK;
4468 }
4469
4470 /**********************************
4471 * pg_transaction_status
4472 Return the transaction status of a connection
4473
4474 syntax:
4475 pg_transaction_status connection
4476
4477 The argument passed in must be a connection pointer.
4478 Returns one of the following strings: IDLE ACTIVE INTRANS INERROR UNKNOWN
4479 For more information, see the PostgreSQL libpq PQtransactionStatus() function.
4480
4481 **********************************/
4482
4483 int
Pg_transaction_status(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])4484 Pg_transaction_status(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
4485 {
4486 PGconn *conn;
4487 char *connString;
4488 char *result;
4489
4490 if (objc != 2)
4491 {
4492 Tcl_WrongNumArgs(interp, 1, objv, "connection");
4493 return TCL_ERROR;
4494 }
4495
4496 connString = Tcl_GetString(objv[1]);
4497
4498 /* Get and validate the libpq connection handle. */
4499 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
4500 if (!conn)
4501 return TCL_ERROR;
4502
4503 switch (PQtransactionStatus(conn))
4504 {
4505 case PQTRANS_IDLE:
4506 result = "IDLE";
4507 break;
4508
4509 case PQTRANS_ACTIVE:
4510 result = "ACTIVE";
4511 break;
4512
4513 case PQTRANS_INTRANS:
4514 result = "INTRANS";
4515 break;
4516
4517 case PQTRANS_INERROR:
4518 result = "INERROR";
4519 break;
4520
4521 /* Treat anything else as PQTRANS_UNKNOWN */
4522 default:
4523 result = "UNKNOWN";
4524 break;
4525 }
4526 Tcl_SetResult(interp, result, TCL_STATIC);
4527 return TCL_OK;
4528 }
4529
4530 /**********************************
4531 * pg_parameter_status
4532 Return the value of a server-side parameter
4533
4534 Syntax:
4535 pg_parameter_status connection parameter_name
4536
4537 The return value is the value of the named server parameter, or an empty
4538 string if there is no such parameter. This does not communicate with the
4539 server, but requires a valid connection, as libpq stores all the parameters
4540 sent by the server at connect time.
4541
4542 For more information, see the PostgreSQL libpq PQparameterStatus() function.
4543
4544 **********************************/
4545
4546 int
Pg_parameter_status(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])4547 Pg_parameter_status(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
4548 {
4549 PGconn *conn;
4550 char *connString;
4551 char *paramName;
4552 CONST char *paramValue;
4553
4554 if (objc != 3)
4555 {
4556 Tcl_WrongNumArgs(interp, 1, objv, "connection parameterName");
4557 return TCL_ERROR;
4558 }
4559
4560 connString = Tcl_GetString(objv[1]);
4561 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
4562 if (!conn)
4563 return TCL_ERROR;
4564
4565 paramName = Tcl_GetString(objv[2]);
4566
4567 if ((paramValue = PQparameterStatus(conn, paramName)) != NULL)
4568 /* paramValue points to storage owned by libpq, so let Tcl copy it */
4569 Tcl_SetResult(interp, (char *)paramValue, TCL_VOLATILE);
4570
4571 return TCL_OK;
4572 }
4573
4574 /**********************************
4575 * pg_backend_pid
4576 Return the backend process id (PID) for this connection
4577
4578 Syntax:
4579 pg_backend_pid connection
4580
4581 For more information, see the PostgreSQL libpq PQbackendPID() function.
4582
4583 **********************************/
4584
4585 int
Pg_backend_pid(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])4586 Pg_backend_pid(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
4587 {
4588 PGconn *conn;
4589 char *connString;
4590
4591 if (objc != 2)
4592 {
4593 Tcl_WrongNumArgs(interp, 1, objv, "connection");
4594 return TCL_ERROR;
4595 }
4596
4597 connString = Tcl_GetString(objv[1]);
4598 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
4599 if (!conn)
4600 return TCL_ERROR;
4601
4602 Tcl_SetObjResult(interp, Tcl_NewIntObj(PQbackendPID(conn)));
4603 return TCL_OK;
4604 }
4605
4606 /**********************************
4607 * pg_server_version
4608 Return the server version as an integer.
4609
4610 Syntax:
4611 pg_server_version connection
4612
4613 For more information, see the PostgreSQL libpq PQserverVersion() function.
4614
4615 **********************************/
4616
4617 int
Pg_server_version(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])4618 Pg_server_version(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
4619 {
4620 PGconn *conn;
4621 char *connString;
4622
4623 if (objc != 2)
4624 {
4625 Tcl_WrongNumArgs(interp, 1, objv, "connection");
4626 return TCL_ERROR;
4627 }
4628
4629 connString = Tcl_GetString(objv[1]);
4630 conn = PgGetConnectionId(interp, connString, (Pg_ConnectionId **) NULL);
4631 if (!conn)
4632 return TCL_ERROR;
4633
4634 Tcl_SetObjResult(interp, Tcl_NewIntObj(PQserverVersion(conn)));
4635 return TCL_OK;
4636 }
4637
4638 /*
4639 * Notice handler procedure. Arg is a pointer to the Pg_ConnectionId
4640 * structure describing the connection. This includes a pointer to the
4641 * Tcl interpreter, which is needed to execute code. The Tcl code to execute
4642 * can be found in the Tcl object connid->notice_command. If NULL, do
4643 * nothing, else append the message and execute. Errors are ignored.
4644 * It is probably a bad idea to borrow the interpreter to execute the handler
4645 * code, but it will only happen during a query sending command (PQexec)
4646 * so it should be safe. Also the interp value is saved and restored to
4647 * ensure the handler doesn't overwrite anything.
4648 */
4649 static void
PgNoticeProcessor(void * arg,const char * message)4650 PgNoticeProcessor(void *arg, const char *message)
4651 {
4652 Pg_ConnectionId *connid = (Pg_ConnectionId *)arg;
4653 Tcl_Interp *interp = connid->interp;
4654 Tcl_Obj *messageObj;
4655 Tcl_Obj *cmdObj;
4656 Tcl_Obj *savedInterpResult;
4657
4658 /* Empty handler command means ignore messages. */
4659 if (connid->notice_command == NULL || interp == NULL)
4660 return;
4661
4662 /* Build the command with the message appended as a single list element */
4663 cmdObj = Tcl_DuplicateObj(connid->notice_command);
4664 Tcl_IncrRefCount(cmdObj);
4665 messageObj = Tcl_NewStringObj(message, -1);
4666 Tcl_IncrRefCount(messageObj);
4667
4668 savedInterpResult = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
4669 Tcl_IncrRefCount(savedInterpResult);
4670
4671 if (Tcl_ListObjAppendElement(interp, cmdObj, messageObj) == TCL_OK)
4672 {
4673 /*
4674 * Ignore the return status, since the interpreter isn't expecting
4675 * anything to happen at this point.
4676 */
4677 Tcl_EvalObjEx(interp, cmdObj, TCL_EVAL_GLOBAL);
4678 }
4679 Tcl_DecrRefCount(messageObj);
4680 Tcl_DecrRefCount(cmdObj);
4681 Tcl_SetObjResult(interp, savedInterpResult);
4682 Tcl_DecrRefCount(savedInterpResult);
4683 }
4684
4685 /**********************************
4686 * pg_notice_handler
4687 Establish a Tcl command to call on Notice or Warning messages.
4688
4689 Syntax:
4690 pg_set_notice_handler connection ?command?
4691
4692 If command is supplied, it becomes the new Notice handler. The text of
4693 the message is appended to the command as a list element.
4694
4695 If command is empty, ignore notice and warning messages.
4696
4697 Returns: The current value of the notice handler command (before it is
4698 changed by a supplied command argument, if any).
4699
4700 **********************************/
4701
4702 int
Pg_notice_handler(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])4703 Pg_notice_handler(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
4704 {
4705 PGconn *conn;
4706 Pg_ConnectionId *connid;
4707 char *command;
4708 static char default_notice_handler[] = "puts -nonewline stderr";
4709
4710
4711 if (objc < 2 || objc > 3)
4712 {
4713 Tcl_WrongNumArgs(interp, 0, objv, "connection ?command?");
4714 return TCL_ERROR;
4715 }
4716 conn = PgGetConnectionId(interp, Tcl_GetString(objv[1]), &connid);
4717 if (!conn)
4718 return TCL_ERROR;
4719
4720 if (objc == 3)
4721 command = Tcl_GetString(objv[2]);
4722 else
4723 command = NULL;
4724
4725 /*
4726 * Return the previous notice handler. If no handler was set,
4727 * pretend that "puts -nonewline stderr" is the notice handler,
4728 * since that is equivalent to the libpq default handler.
4729 */
4730 if (connid->notice_command)
4731 Tcl_SetObjResult(interp, connid->notice_command);
4732 else
4733 Tcl_SetResult(interp, default_notice_handler, TCL_STATIC);
4734
4735 if (command)
4736 {
4737 /*
4738 * Change the notice handler.
4739 * If this is the first time the handler is being set, establish
4740 * the notice processor function using libpq. The first-time
4741 * handler setup is indicated by a null "interp" field. A null
4742 * notice_command, on the other hand, means ignore notices.
4743 */
4744 if (connid->interp == NULL)
4745 {
4746 connid->notice_command = Tcl_NewStringObj(default_notice_handler, -1);
4747 Tcl_IncrRefCount(connid->notice_command);
4748 PQsetNoticeProcessor(conn, PgNoticeProcessor, (void *)connid);
4749 }
4750 /*
4751 * Remember which interp last set a handler. This is the
4752 * interpreter which will be used to execute the handler.
4753 */
4754 connid->interp = interp;
4755
4756 /*
4757 * Free any previous handler, and store the new handler command:
4758 */
4759 if (connid->notice_command)
4760 Tcl_DecrRefCount(connid->notice_command);
4761 if (*command)
4762 {
4763 connid->notice_command = Tcl_NewStringObj(command, -1);
4764 Tcl_IncrRefCount(connid->notice_command);
4765 }
4766 else
4767 connid->notice_command = NULL;
4768 }
4769 return TCL_OK;
4770 }
4771
4772 /**********************************
4773 pg_describe_cursor
4774 Return a result structure with information about a cursor
4775
4776 Syntax:
4777 pg_describe_cursor connection cursor_name
4778
4779 The return value is a result structure (with no data). It can be used
4780 with pg_result to find information about the cursor.
4781
4782 For more information, see the PostgreSQL libpq PQdescribePortal() function.
4783 (PostgreSQL refers to cursors as 'portals', but 'cursors' is more common.)
4784
4785 **********************************/
4786
4787 #ifdef HAVE_PQDESCRIBEPREPARED /* PostgreSQL >= 8.2.0 */
4788 int
Pg_describe_cursor(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])4789 Pg_describe_cursor(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
4790 {
4791 PGconn *conn;
4792 char *connString;
4793 Pg_ConnectionId *connid;
4794 const char *cursorName;
4795 PGresult *result;
4796
4797 if (objc != 3)
4798 {
4799 Tcl_WrongNumArgs(interp, 1, objv, "connection cursorName");
4800 return TCL_ERROR;
4801 }
4802
4803 connString = Tcl_GetString(objv[1]);
4804 conn = PgGetConnectionId(interp, connString, &connid);
4805 if (!conn)
4806 return TCL_ERROR;
4807
4808 cursorName = Tcl_GetString(objv[2]);
4809 /* Note: PQdescribePortal accepts an empty string (or NULL) to get
4810 information about the 'unnamed cursor'. I don't think that makes
4811 any sense in this context, however it is possible, so we will
4812 not check and exclude an empty cursor name.
4813 */
4814 result = PQdescribePortal(conn, cursorName);
4815
4816 /* Transfer any notify events from libpq to Tcl event queue. */
4817 PgNotifyTransferEvents(connid);
4818
4819 if (!result)
4820 {
4821 Tcl_SetObjResult(interp, Tcl_NewStringObj(PQerrorMessage(conn), -1));
4822 return TCL_ERROR;
4823 }
4824
4825 if (PgSetResultId(interp, connString, result) == -1)
4826 {
4827 /* Response OK but failed to get a result slot. */
4828 PQclear(result);
4829 return TCL_ERROR;
4830 }
4831 return TCL_OK;
4832 }
4833 #endif
4834
4835 /**********************************
4836 pg_describe_prepared
4837 Return a result structure with information about a prepared statement
4838
4839 Syntax:
4840 pg_describe_prepared connection prepared_statement_name
4841
4842 The return value is a result structure (with no data). It can be used
4843 with pg_result to find information about the prepared statement. In
4844 particular, two pg_result options are specifically for prepared statement
4845 results: -paramTypes and -numParams
4846
4847 For more information, see the PostgreSQL libpq PQdescribePrepared() function.
4848
4849 **********************************/
4850
4851 #ifdef HAVE_PQDESCRIBEPREPARED /* PostgreSQL >= 8.2.0 */
4852 int
Pg_describe_prepared(ClientData cData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])4853 Pg_describe_prepared(ClientData cData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
4854 {
4855 PGconn *conn;
4856 char *connString;
4857 Pg_ConnectionId *connid;
4858 const char *statementName;
4859 PGresult *result;
4860
4861 if (objc != 3)
4862 {
4863 Tcl_WrongNumArgs(interp, 1, objv, "connection statementName");
4864 return TCL_ERROR;
4865 }
4866
4867 connString = Tcl_GetString(objv[1]);
4868 conn = PgGetConnectionId(interp, connString, &connid);
4869 if (!conn)
4870 return TCL_ERROR;
4871
4872 statementName = Tcl_GetString(objv[2]);
4873 /* Note: PQdescribePrepared accepts an empty string (or NULL) to get
4874 information about the 'unnamed prepared statement'. I don't think
4875 that makes any sense in this context, however it is possible, so
4876 we will not check and exclude an empty prepared statement name.
4877 */
4878 result = PQdescribePrepared(conn, statementName);
4879
4880 /* Transfer any notify events from libpq to Tcl event queue. */
4881 PgNotifyTransferEvents(connid);
4882
4883 if (!result)
4884 {
4885 Tcl_SetObjResult(interp, Tcl_NewStringObj(PQerrorMessage(conn), -1));
4886 return TCL_ERROR;
4887 }
4888
4889 if (PgSetResultId(interp, connString, result) == -1)
4890 {
4891 /* Response OK but failed to get a result slot. */
4892 PQclear(result);
4893 return TCL_ERROR;
4894 }
4895 return TCL_OK;
4896 }
4897 #endif
4898