Mercurial > hg > xemacs-beta

comparison modules/postgresql/postgresql.c @ 996:25e260cb7994

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2002-09-10 15:27:02 by james] Enable unloading of dynamic modules. Create the first two internal XEmacs modules: LDAP and postgreSQL. Update the sample directory to contain a sample internal XEmacs module and a sample external XEmacs module. Improve support for autoloading modules. Make internal module code compile into the XEmacs binary if XEmacs is configured without module support. Make the internal module directories self-contained so that they can be distributed separately from XEmacs.
author james
date Tue, 10 Sep 2002 15:27:39 +0000
parents
children 184461bc8de4
comparison
equal deleted inserted replaced
995:4575a219af58 996:25e260cb7994
1 /*
2 postgresql.c -- Emacs Lisp binding to libpq.so
3 Copyright (C) 2000 Electrotechnical Laboratory, JAPAN.
4 Licensed to the Free Software Foundation.
5
6 Author: SL Baur <steve@beopen.com>
7 Maintainer: SL Baur <steve@beopen.com>
8
9 Please send patches to this file to me first before submitting them to
10 xemacs-patches.
11
12
13 KNOWN PROBLEMS (Last update 15-March-2000)
14 + None.
15
16 Implementation notes:
17 0. Supported PostgreSQL versions
18 This code was developed against libpq-6.5.3 and libpq-7.0-beta1. Earlier
19 versions may work. V7 support is more complete than V6.5 support.
20 1. Mule
21 Non-ASCII databases have been tested on both 6.5 and 7.0.
22 2. Asynchronous Operation
23 Starting with libpq-7.0, an asynchronous interface is offered. This
24 binding supports the asynchronous calls to a limited extent. Since the
25 XEmacs 21.2 core does not support a sensible interface to add managed but
26 unreadable (by XEmacs) file descriptors to the main select code, polling
27 is required to drive the asynchronous calls. XtAppAddInput would work
28 fine, but we want to be able to use the database when running strictly in
29 tty mode.
30 3. Completeness
31 Various calls have been deliberately not exported to Lisp. The
32 unexported calls are either left-over backwards compatibility code that
33 aren't needed, calls that cannot be implemented sensibly, or calls that
34 cannot be implemented safely. A list of all global functions in libpq
35 but not exported to Lisp is below.
36 4. Policy
37 This interface tries very hard to not set any policy towards how database
38 code in Emacs Lisp will be written.
39 5. Documentation
40 For full lisp programming documentation, see the XEmacs Lisp Reference
41 Manual. For PostgreSQL documentation, see the PostgreSQL distribution.
42
43 TODO (in rough order of priority):
44 1. Asynchronous notifies need to be implemented to the extent they can be.
45 2. The large object interface needs work with Emacs buffers in addition
46 to files. Need two functions buffer->large_object, and large_object->
47 buffer.
48 */
49
50 /*
51 Unimplemented functions: [TODO]
52 PQsetNoticeProcessor
53
54 Implemented, but undocumented functions: [TODO]
55 PQgetline (copy in/out)
56 PQputline (copy in/out)
57 PQgetlineAsync (copy in/out Asynch.)
58 PQputnbytes (copy in/out Asynch.)
59 PQendcopy (copy in/out)
60
61 Unsupported functions:
62 PQsetdbLogin -- This function is deprecated, has a subset of the
63 functionality of PQconnectdb, and is better done in Lisp.
64 PQsetdb -- Same as for PQsetdbLogin
65 PQsocket -- Abstraction error, file descriptors should not be leaked
66 into Lisp code
67 PQprint -- print to a file descriptor, deprecated, better done in Lisp
68 PQdisplayTuples -- deprecated
69 PQprintTuples -- really, really deprecated
70 PQmblen -- Returns the length in bytes of multibyte character encoded
71 string.
72 PQtrace -- controls debug print tracing to a tty.
73 PQuntrace -- Ditto. I don't see any way to do this sensibly.
74 PQoidStatus -- deprecated and nearly identical to PQoidValue
75 PQfn -- "Fast path" interface
76 lo_open (large object) [*]
77 lo_close (large object) [*]
78 lo_read (large object) [*]
79 lo_write (large object) [*]
80 lo_lseek (large object) [*]
81 lo_creat (large object) [*]
82 lo_tell (large object) [*]
83 lo_unlink (large object) [*]
84 */
85
86 #include <config.h>
87
88 /* This must be portable with XEmacs 21.1 so long as it is the official
89 released version of XEmacs and provides the basis of InfoDock. The
90 interface to lcrecord handling has changed with 21.2, so unfortunately
91 we will need a few snippets of backwards compatibility code.
92 */
93 #if (EMACS_MAJOR_VERSION == 21) && (EMACS_MINOR_VERSION < 2)
94 #define RUNNING_XEMACS_21_1 1
95 #endif
96
97 /* #define POSTGRES_LO_IMPORT_IS_VOID 1 */
98
99 #include "lisp.h"
100 #include "sysdep.h"
101
102 #include "buffer.h"
103 #include "postgresql.h"
104 #include "process.h"
105
106 #ifdef RUNNING_XEMACS_21_1 /* handle interface changes */
107 #define PG_OS_CODING FORMAT_FILENAME
108 #define TO_EXTERNAL_FORMAT(a,from,b,to,c) GET_C_STRING_EXT_DATA_ALLOCA(from,FORMAT_FILENAME,to)
109 #else
110 #ifdef MULE
111 #define PG_OS_CODING get_coding_system_for_text_file (Vpg_coding_system, 1)
112 #else
113 #define PG_OS_CODING Qnative
114 #endif
115 Lisp_Object Vpg_coding_system;
116 #endif
117
118 #define CHECK_LIVE_CONNECTION(P) do { \
119 if (!P || (PQstatus (P) != CONNECTION_OK)) { \
120 char *e = "bad value"; \
121 if (P) e = PQerrorMessage (P); \
122 signal_ferror (Qprocess_error, "dead connection [%s]", e); \
123 } } while (0)
124 #define PUKE_IF_NULL(p) do { \
125 if (!p) signal_error (Qinvalid_argument, "bad value", Qunbound); \
126 } while (0)
127
128 static Lisp_Object VXPGHOST;
129 static Lisp_Object VXPGUSER;
130 static Lisp_Object VXPGOPTIONS;
131 static Lisp_Object VXPGPORT;
132 static Lisp_Object VXPGTTY; /* This needs to be blanked! */
133 static Lisp_Object VXPGDATABASE;
134 static Lisp_Object VXPGREALM;
135 #ifdef MULE
136 static Lisp_Object VXPGCLIENTENCODING;
137 #endif /* MULE */
138
139 /* Other variables:
140 PGAUTHTYPE -- not used after PostgreSQL 6.5
141 PGGEQO
142 PGCOSTINDEX
143 PGCOSTHEAP
144 PGTZ
145 PGDATESTYLE
146 */
147 #ifndef HAVE_POSTGRESQLV7
148 static Lisp_Object VXPGAUTHTYPE;
149 #endif
150 static Lisp_Object VXPGGEQO, VXPGCOSTINDEX, VXPGCOSTHEAP, VXPGTZ, VXPGDATESTYLE;
151
152 static Lisp_Object Qpostgresql;
153 static Lisp_Object Qpg_connection_ok, Qpg_connection_bad;
154 static Lisp_Object Qpg_connection_started, Qpg_connection_made;
155 static Lisp_Object Qpg_connection_awaiting_response, Qpg_connection_auth_ok;
156 static Lisp_Object Qpg_connection_setenv;
157
158 static Lisp_Object Qpqdb, Qpquser, Qpqpass, Qpqhost, Qpqport, Qpqtty;
159 static Lisp_Object Qpqoptions, Qpqstatus, Qpqerrormessage, Qpqbackendpid;
160
161 static Lisp_Object Qpgres_empty_query, Qpgres_command_ok, Qpgres_tuples_ok;
162 static Lisp_Object Qpgres_copy_out, Qpgres_copy_in, Qpgres_bad_response;
163 static Lisp_Object Qpgres_nonfatal_error, Qpgres_fatal_error;
164
165 static Lisp_Object Qpgres_polling_failed, Qpgres_polling_reading;
166 static Lisp_Object Qpgres_polling_writing, Qpgres_polling_ok;
167 static Lisp_Object Qpgres_polling_active;
168 /****/
169
170 /* PGconn is an opaque object and we need to be able to store them in
171 Lisp code because libpq supports multiple connections.
172 */
173 Lisp_Object Qpgconnp;
174
175 static Lisp_Object
176 make_pgconn (Lisp_PGconn *pgconn)
177 {
178 return wrap_pgconn (pgconn);
179 }
180
181 #ifdef USE_KKCC
182 static const struct lrecord_description pgconn_description [] = {
183 { XD_END }
184 };
185 #endif /* USE_KKCC */
186
187 static Lisp_Object
188 #ifdef RUNNING_XEMACS_21_1
189 mark_pgconn (Lisp_Object obj, void (*markobj) (Lisp_Object))
190 #else
191 mark_pgconn (Lisp_Object obj)
192 #endif
193 {
194 return Qnil;
195 }
196
197 static void
198 print_pgconn (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
199 {
200 char buf[256];
201 PGconn *P;
202 ConnStatusType cst;
203 char *host="", *db="", *user="", *port="";
204
205 P = (XPGCONN (obj))->pgconn;
206
207 if (!P) /* this may happen since we allow PQfinish() to be called */
208 strcpy (buf, "#<PGconn DEAD>"); /* evil! */
209 else if ((cst = PQstatus (P)) == CONNECTION_OK)
210 {
211 if (!(host = PQhost (P)))
212 host = "";
213 port = PQport (P);
214 db = PQdb (P);
215 if (!(user = PQuser (P)))
216 user = "";
217 sprintf (buf, "#<PGconn %s:%s %s/%s>", /* evil! */
218 !strlen (host) ? "localhost" : host,
219 port,
220 user,
221 db);
222 }
223 else if (cst == CONNECTION_BAD)
224 strcpy (buf, "#<PGconn BAD>"); /* evil! */
225 else
226 strcpy (buf, "#<PGconn connecting>"); /* evil! */
227
228 if (print_readably)
229 printing_unreadable_object ("%s", buf);
230 else
231 write_c_string (printcharfun, buf);
232 }
233
234 static Lisp_PGconn *
235 allocate_pgconn (void)
236 {
237 #ifdef RUNNING_XEMACS_21_1
238 Lisp_PGconn *pgconn = alloc_lcrecord_type (Lisp_PGconn,
239 lrecord_pgconn);
240 #else
241 Lisp_PGconn *pgconn = alloc_lcrecord_type (Lisp_PGconn,
242 &lrecord_pgconn);
243 #endif
244 pgconn->pgconn = (PGconn *)NULL;
245 return pgconn;
246 }
247
248 static void
249 finalize_pgconn (void *header, int for_disksave)
250 {
251 Lisp_PGconn *pgconn = (Lisp_PGconn *)header;
252
253 if (for_disksave)
254 invalid_operation ("Can't dump an emacs containing PGconn objects",
255 make_pgconn (pgconn));
256
257 if (pgconn->pgconn)
258 {
259 PQfinish (pgconn->pgconn);
260 pgconn->pgconn = (PGconn *)NULL;
261 }
262 }
263
264 #ifdef RUNNING_XEMACS_21_1
265 DEFINE_LRECORD_IMPLEMENTATION ("pgconn", pgconn,
266 mark_pgconn, print_pgconn, finalize_pgconn,
267 NULL, NULL,
268 Lisp_PGconn);
269 #else
270 #ifdef USE_KKCC
271 DEFINE_LRECORD_IMPLEMENTATION ("pgconn", pgconn,
272 0, /*dumpable-flag*/
273 mark_pgconn, print_pgconn, finalize_pgconn,
274 NULL, NULL,
275 pgconn_description,
276 Lisp_PGconn);
277 #else /* not USE_KKCC */
278 DEFINE_LRECORD_IMPLEMENTATION ("pgconn", pgconn,
279 mark_pgconn, print_pgconn, finalize_pgconn,
280 NULL, NULL,
281 0,
282 Lisp_PGconn);
283 #endif /* not USE_KKCC */
284 #endif
285 /****/
286
287 /* PGresult is an opaque object and we need to be able to store them in
288 Lisp code.
289 */
290 Lisp_Object Qpgresultp;
291
292 static Lisp_Object
293 make_pgresult (Lisp_PGresult *pgresult)
294 {
295 return wrap_pgresult (pgresult);
296 }
297
298 #ifdef USE_KKCC
299 static const struct lrecord_description pgresult_description [] = {
300 { XD_END }
301 };
302 #endif /* USE_KKCC */
303
304
305 static Lisp_Object
306 #ifdef RUNNING_XEMACS_21_1
307 mark_pgresult (Lisp_Object obj, void (*markobj) (Lisp_Object))
308 #else
309 mark_pgresult (Lisp_Object obj)
310 #endif
311 {
312 return Qnil;
313 }
314
315 #define RESULT_TUPLES_FMT "#<PGresult %s[%d] - %s>"
316 #define RESULT_CMD_TUPLES_FMT "#<PGresult %s[%s] - %s>"
317 #define RESULT_DEFAULT_FMT "#<PGresult %s - %s>"
318 static void
319 print_pgresult (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
320 {
321 char buf[1024];
322 PGresult *res;
323
324 res = (XPGRESULT (obj))->pgresult;
325
326 if (res)
327 {
328 switch (PQresultStatus (res))
329 {
330 case PGRES_TUPLES_OK:
331 /* Add number of tuples of result to output */
332 sprintf (buf, RESULT_TUPLES_FMT, /* evil! */
333 PQresStatus (PQresultStatus (res)),
334 PQntuples (res),
335 PQcmdStatus (res));
336 break;
337 case PGRES_COMMAND_OK:
338 /* Add number of tuples affected by output-less command */
339 if (!strlen (PQcmdTuples (res))) goto notuples;
340 sprintf (buf, RESULT_CMD_TUPLES_FMT, /* evil! */
341 PQresStatus (PQresultStatus (res)),
342 PQcmdTuples (res),
343 PQcmdStatus (res));
344 break;
345 default:
346 notuples:
347 /* No counts to print */
348 sprintf (buf, RESULT_DEFAULT_FMT, /* evil! */
349 PQresStatus (PQresultStatus (res)),
350 PQcmdStatus (res));
351 break;
352 }
353 }
354 else
355 strcpy (buf, "#<PGresult DEAD>"); /* evil! */
356
357 if (print_readably)
358 printing_unreadable_object ("%s", buf);
359 else
360 write_c_string (printcharfun, buf);
361 }
362
363 #undef RESULT_TUPLES_FMT
364 #undef RESULT_CMD_TUPLES_FMT
365 #undef RESULT_DEFAULT_FMT
366
367 static Lisp_PGresult *
368 allocate_pgresult (void)
369 {
370 #ifdef RUNNING_XEMACS_21_1
371 Lisp_PGresult *pgresult = alloc_lcrecord_type (Lisp_PGresult,
372 lrecord_pgresult);
373 #else
374 Lisp_PGresult *pgresult = alloc_lcrecord_type (Lisp_PGresult,
375 &lrecord_pgresult);
376 #endif
377 pgresult->pgresult = (PGresult *)NULL;
378 return pgresult;
379 }
380
381 static void
382 finalize_pgresult (void *header, int for_disksave)
383 {
384 Lisp_PGresult *pgresult = (Lisp_PGresult *)header;
385
386 if (for_disksave)
387 invalid_operation ("Can't dump an emacs containing PGresult objects",
388 make_pgresult (pgresult));
389
390 if (pgresult->pgresult)
391 {
392 PQclear (pgresult->pgresult);
393 pgresult->pgresult = (PGresult *)NULL;
394 }
395 }
396
397 #ifdef RUNNING_XEMACS_21_1
398 DEFINE_LRECORD_IMPLEMENTATION ("pgresult", pgresult,
399 mark_pgresult, print_pgresult, finalize_pgresult,
400 NULL, NULL,
401 Lisp_PGresult);
402 #else
403 #ifdef USE_KKCC
404 DEFINE_LRECORD_IMPLEMENTATION ("pgresult", pgresult,
405 0, /*dumpable-flag*/
406 mark_pgresult, print_pgresult, finalize_pgresult,
407 NULL, NULL,
408 pgresult_description,
409 Lisp_PGresult);
410 #else /* not USE_KKCC */
411 DEFINE_LRECORD_IMPLEMENTATION ("pgresult", pgresult,
412 mark_pgresult, print_pgresult, finalize_pgresult,
413 NULL, NULL,
414 0,
415 Lisp_PGresult);
416 #endif /* not USE_KKCC */
417 #endif
418
419 /***********************/
420
421 /* notices */
422 static void
423 xemacs_notice_processor (void *arg, const char *msg)
424 {
425 warn_when_safe (Qpostgresql, Qnotice, "%s", msg);
426 }
427
428 /* There are four ways (as of PostgreSQL v7) to connect to a database.
429 Two of them, PQsetdb and PQsetdbLogin, are deprecated. Both of those
430 routines take a number of positional parameters and are better done in Lisp.
431 Note that PQconnectStart does not exist prior to v7.
432 */
433
434 /* ###autoload */
435 DEFUN ("pq-conn-defaults", Fpq_conn_defaults, 0, 0, 0, /*
436 Return a connection default structure.
437 */
438 ())
439 {
440 /* This function can GC */
441 PQconninfoOption *pcio;
442 Lisp_Object temp, temp1;
443 int i;
444
445 pcio = PQconndefaults();
446 if (!pcio) return Qnil; /* can never happen in libpq-7.0 */
447 temp = list1 (Fcons (build_ext_string (pcio[0].keyword, PG_OS_CODING),
448 Fcons (build_ext_string (pcio[0].envvar, PG_OS_CODING),
449 Fcons (build_ext_string (pcio[0].compiled, PG_OS_CODING),
450 Fcons (build_ext_string (pcio[0].val, PG_OS_CODING),
451 Fcons (build_ext_string (pcio[0].label, PG_OS_CODING),
452 Fcons (build_ext_string (pcio[0].dispchar, PG_OS_CODING),
453 Fcons (make_int (pcio[0].dispsize), Qnil))))))));
454
455 for (i = 1; pcio[i].keyword; i++)
456 {
457 temp1 = list1 (Fcons (build_ext_string (pcio[i].keyword, PG_OS_CODING),
458 Fcons (build_ext_string (pcio[i].envvar, PG_OS_CODING),
459 Fcons (build_ext_string (pcio[i].compiled, PG_OS_CODING),
460 Fcons (build_ext_string (pcio[i].val, PG_OS_CODING),
461 Fcons (build_ext_string (pcio[i].label, PG_OS_CODING),
462 Fcons (build_ext_string (pcio[i].dispchar, PG_OS_CODING),
463 Fcons (make_int (pcio[i].dispsize), Qnil))))))));
464 {
465 Lisp_Object args[2];
466 args[0] = temp;
467 args[1] = temp1;
468 /* Fappend GCPROs its arguments */
469 temp = Fappend (2, args);
470 }
471 }
472
473 return temp;
474 }
475
476 /* PQconnectdb Makes a new connection to a backend.
477 PGconn *PQconnectdb(const char *conninfo)
478 */
479
480 /* ###autoload */
481 DEFUN ("pq-connectdb", Fpq_connectdb, 1, 1, 0, /*
482 Make a new connection to a PostgreSQL backend.
483 */
484 (conninfo))
485 {
486 PGconn *P;
487 Lisp_PGconn *lisp_pgconn;
488 char *error_message = "Out of Memory?";
489 char *c_conninfo;
490
491 CHECK_STRING (conninfo);
492
493 TO_EXTERNAL_FORMAT(LISP_STRING, conninfo,
494 C_STRING_ALLOCA, c_conninfo, Qnative);
495 P = PQconnectdb (c_conninfo);
496 if (P && (PQstatus (P) == CONNECTION_OK))
497 {
498 (void)PQsetNoticeProcessor (P, xemacs_notice_processor, NULL);
499 lisp_pgconn = allocate_pgconn();
500 lisp_pgconn->pgconn = P;
501 return make_pgconn (lisp_pgconn);
502 }
503 else
504 {
505 /* Connection failed. Destroy the connection and signal an error. */
506 char buf[BLCKSZ];
507 strcpy (buf, error_message);
508 if (P)
509 {
510 /* storage for the error message gets erased when call PQfinish */
511 /* so we must temporarily stash it somewhere */
512 strncpy (buf, PQerrorMessage (P), sizeof (buf));
513 buf[sizeof (buf) - 1] = '\0';
514 PQfinish (P);
515 }
516 signal_ferror (Qprocess_error, "libpq: %s", buf);
517 }
518 }
519
520 /* PQconnectStart Makes a new asynchronous connection to a backend.
521 PGconn *PQconnectStart(const char *conninfo)
522 */
523
524 #ifdef HAVE_POSTGRESQLV7
525 /* ###autoload */
526 DEFUN ("pq-connect-start", Fpq_connect_start, 1, 1, 0, /*
527 Make a new asynchronous connection to a PostgreSQL backend.
528 */
529 (conninfo))
530 {
531 PGconn *P;
532 Lisp_PGconn *lisp_pgconn;
533 char *error_message = "Out of Memory?";
534 char *c_conninfo;
535
536 CHECK_STRING (conninfo);
537 TO_EXTERNAL_FORMAT (LISP_STRING, conninfo,
538 C_STRING_ALLOCA, c_conninfo, Qnative);
539 P = PQconnectStart (c_conninfo);
540
541 if (P && (PQstatus (P) != CONNECTION_BAD))
542 {
543 (void)PQsetNoticeProcessor (P, xemacs_notice_processor, NULL);
544 lisp_pgconn = allocate_pgconn();
545 lisp_pgconn->pgconn = P;
546
547 return make_pgconn (lisp_pgconn);
548 }
549 else
550 {
551 /* capture the error message before destroying the object */
552 char buf[BLCKSZ];
553 strcpy (buf, error_message);
554 if (P)
555 {
556 strncpy (buf, PQerrorMessage (P), sizeof (buf));
557 buf[sizeof (buf) - 1] = '\0';
558 PQfinish (P);
559 }
560 signal_ferror (Qprocess_error, "libpq: %s", buf);
561 }
562 }
563
564 DEFUN ("pq-connect-poll", Fpq_connect_poll, 1, 1, 0, /*
565 Poll an asynchronous connection for completion
566 */
567 (conn))
568 {
569 PGconn *P;
570 PostgresPollingStatusType polling_status;
571
572 CHECK_PGCONN (conn);
573
574 P = (XPGCONN (conn))->pgconn;
575 CHECK_LIVE_CONNECTION (P);
576
577 polling_status = PQconnectPoll (P);
578 switch (polling_status)
579 {
580 case PGRES_POLLING_FAILED:
581 /* Something Bad has happened */
582 {
583 char *e = PQerrorMessage (P);
584 signal_ferror (Qprocess_error, "libpq: %s", e);
585 }
586 case PGRES_POLLING_OK:
587 return Qpgres_polling_ok;
588 case PGRES_POLLING_READING:
589 return Qpgres_polling_reading;
590 case PGRES_POLLING_WRITING:
591 return Qpgres_polling_writing;
592 case PGRES_POLLING_ACTIVE:
593 return Qpgres_polling_active;
594 default:
595 /* they've added a new field we don't know about */
596 signal_ferror (Qprocess_error, "Help! Unknown status code %08x from backend!", polling_status);
597 }
598 }
599
600 #ifdef MULE
601 DEFUN ("pq-client-encoding", Fpq_client_encoding, 1, 1, 0, /*
602 Return client coding system.
603 */
604 (conn))
605 {
606 PGconn *P;
607
608 CHECK_PGCONN (conn);
609 P = (XPGCONN (conn))->pgconn;
610 CHECK_LIVE_CONNECTION (P);
611
612 return make_int (PQclientEncoding (P));
613 }
614
615 DEFUN ("pq-set-client-encoding", Fpq_set_client_encoding, 2, 2, 0, /*
616 Set client coding system.
617 */
618 (conn, encoding))
619 {
620 PGconn *P;
621 int rc;
622 char *c_encoding;
623
624 CHECK_PGCONN (conn);
625 CHECK_STRING (encoding);
626
627 P = (XPGCONN (conn))->pgconn;
628 CHECK_LIVE_CONNECTION (P);
629
630 TO_EXTERNAL_FORMAT (LISP_STRING, encoding,
631 C_STRING_ALLOCA, c_encoding, Qnative);
632
633 if ((rc = PQsetClientEncoding (P, c_encoding)) < 0)
634 signal_error (Qinvalid_argument, "bad encoding", Qunbound);
635 else
636 return make_int (rc);
637 }
638
639 #endif
640 #endif /* HAVE_POSTGRESQLV7 */
641
642 /* PQfinish Close the connection to the backend. Also frees memory
643 used by the PGconn object.
644 void PQfinish(PGconn *conn)
645 */
646 DEFUN ("pq-finish", Fpq_finish, 1, 1, 0, /*
647 Close the connection to the backend.
648 */
649 (conn))
650 {
651 PGconn *P;
652
653 CHECK_PGCONN (conn);
654 P = (XPGCONN (conn))->pgconn;
655 PUKE_IF_NULL (P);
656
657 PQfinish (P);
658 /* #### PQfinish deallocates the PGconn structure, so we now have a
659 dangling pointer. */
660 /* Genocided all @'s ... */
661 (XPGCONN (conn))->pgconn = (PGconn *)NULL; /* You feel DEAD inside */
662 return Qnil;
663 }
664
665 DEFUN ("pq-clear", Fpq_clear, 1, 1, 0, /*
666 Forcibly erase a PGresult object.
667 */
668 (res))
669 {
670 PGresult *R;
671
672 CHECK_PGRESULT (res);
673 R = (XPGRESULT (res))->pgresult;
674 PUKE_IF_NULL (R);
675
676 PQclear (R);
677 /* Genocided all @'s ... */
678 (XPGRESULT (res))->pgresult = (PGresult *)NULL; /* You feel DEAD inside */
679
680 return Qnil;
681 }
682
683 DEFUN ("pq-is-busy", Fpq_is_busy, 1, 1, 0, /*
684 Return t if PQgetResult would block waiting for input.
685 */
686 (conn))
687 {
688 PGconn *P;
689
690 CHECK_PGCONN (conn);
691 P = (XPGCONN (conn))->pgconn;
692 CHECK_LIVE_CONNECTION (P);
693
694 return PQisBusy (P) ? Qt : Qnil;
695 }
696
697 DEFUN ("pq-consume-input", Fpq_consume_input, 1, 1, 0, /*
698 Consume any available input from the backend.
699 Returns nil if something bad happened.
700 */
701 (conn))
702 {
703 PGconn *P;
704
705 CHECK_PGCONN (conn);
706 P = (XPGCONN (conn))->pgconn;
707 CHECK_LIVE_CONNECTION (P);
708
709 return PQconsumeInput (P) ? Qt : Qnil;
710 }
711
712 /* PQreset Reset the communication port with the backend.
713 void PQreset(PGconn *conn)
714 */
715 DEFUN ("pq-reset", Fpq_reset, 1, 1, 0, /*
716 Reset the connection to the backend.
717 This function will close the connection to the backend and attempt to
718 reestablish a new connection to the same postmaster, using all the same
719 parameters previously used. This may be useful for error recovery if a
720 working connection is lost.
721 */
722 (conn))
723 {
724 PGconn *P;
725
726 CHECK_PGCONN (conn);
727 P = (XPGCONN (conn))->pgconn;
728 PUKE_IF_NULL (P);/* we can resurrect a BAD connection, but not a dead one. */
729
730 PQreset (P);
731
732 return Qnil;
733 }
734
735 #ifdef HAVE_POSTGRESQLV7
736 DEFUN ("pq-reset-start", Fpq_reset_start, 1, 1, 0, /*
737 Reset connection to the backend asynchronously.
738 */
739 (conn))
740 {
741 PGconn *P;
742
743 CHECK_PGCONN (conn);
744 P = (XPGCONN (conn))->pgconn;
745 CHECK_LIVE_CONNECTION (P);
746
747 if (PQresetStart (P)) return Qt;
748 {
749 char *e = PQerrorMessage (P);
750 signal_ferror (Qprocess_error, "libpq: %s", e);
751 }
752 }
753
754 DEFUN ("pq-reset-poll", Fpq_reset_poll, 1, 1, 0, /*
755 Poll an asynchronous reset for completion.
756 */
757 (conn))
758 {
759 PGconn *P;
760 PostgresPollingStatusType polling_status;
761
762 CHECK_PGCONN (conn);
763
764 P = (XPGCONN (conn))->pgconn;
765 CHECK_LIVE_CONNECTION (P);
766
767 polling_status = PQresetPoll (P);
768 switch (polling_status)
769 {
770 case PGRES_POLLING_FAILED:
771 /* Something Bad has happened */
772 {
773 char *e = PQerrorMessage (P);
774 signal_ferror (Qprocess_error, "libpq: %s", e);
775 }
776 case PGRES_POLLING_OK:
777 return Qpgres_polling_ok;
778 case PGRES_POLLING_READING:
779 return Qpgres_polling_reading;
780 case PGRES_POLLING_WRITING:
781 return Qpgres_polling_writing;
782 case PGRES_POLLING_ACTIVE:
783 return Qpgres_polling_active;
784 default:
785 /* they've added a new field we don't know about */
786 signal_ferror (Qprocess_error, "Help! Unknown status code %08x from backend!", polling_status);
787 }
788 }
789 #endif
790
791 DEFUN ("pq-request-cancel", Fpq_request_cancel, 1, 1, 0, /*
792 Attempt to request cancellation of the current operation.
793
794 The return value is t if the cancel request was successfully
795 dispatched, nil if not (in which case conn->errorMessage is set).
796 Note: successful dispatch is no guarantee that there will be any effect at
797 the backend. The application must read the operation result as usual.
798 */
799 (conn))
800 {
801 PGconn *P;
802
803 CHECK_PGCONN (conn);
804 P = (XPGCONN (conn))->pgconn;
805 CHECK_LIVE_CONNECTION (P);
806
807 return PQrequestCancel (P) ? Qt : Qnil;
808 }
809
810 /* accessor function for the PGconn object */
811 DEFUN ("pq-pgconn", Fpq_pgconn, 2, 2, 0, /*
812 Accessor function for the PGconn object.
813 Currently recognized symbols for the field:
814 pq::db Database name
815 pq::user Database user name
816 pq::pass Database user's password
817 pq::host Hostname of PostgreSQL backend connected to
818 pq::port TCP port number of connection
819 pq::tty Debugging TTY (not used in Emacs)
820 pq::options Additional backend options
821 pq::status Connection status (either OK or BAD)
822 pq::error-message Last error message from the backend
823 pq::backend-pid Process ID of backend process
824 */
825 (conn, field))
826 {
827 PGconn *P;
828
829 CHECK_PGCONN (conn);
830 P = (XPGCONN (conn))->pgconn;
831 PUKE_IF_NULL (P); /* BAD connections still have state to query */
832
833 if (EQ(field, Qpqdb))
834 /* PQdb Returns the database name of the connection.
835 char *PQdb(PGconn *conn)
836 */
837 return build_ext_string (PQdb(P), PG_OS_CODING);
838 else if (EQ (field, Qpquser))
839 /* PQuser Returns the user name of the connection.
840 char *PQuser(PGconn *conn)
841 */
842 return build_ext_string (PQuser(P), PG_OS_CODING);
843 else if (EQ (field, Qpqpass))
844 /* PQpass Returns the password of the connection.
845 char *PQpass(PGconn *conn)
846 */
847 return build_ext_string (PQpass(P), PG_OS_CODING);
848 else if (EQ (field, Qpqhost))
849 /* PQhost Returns the server host name of the connection.
850 char *PQhost(PGconn *conn)
851 */
852 return build_ext_string (PQhost(P), PG_OS_CODING);
853 else if (EQ (field, Qpqport))
854 {
855 char *p;
856 /* PQport Returns the port of the connection.
857 char *PQport(PGconn *conn)
858 */
859 if ((p = PQport(P)))
860 return make_int(atoi(p));
861 else
862 return make_int(-1);
863 }
864 else if (EQ (field, Qpqtty))
865 /* PQtty Returns the debug tty of the connection.
866 char *PQtty(PGconn *conn)
867 */
868 return build_ext_string (PQtty(P), PG_OS_CODING);
869 else if (EQ (field, Qpqoptions))
870 /* PQoptions Returns the backend options used in the connection.
871 char *PQoptions(PGconn *conn)
872 */
873 return build_ext_string (PQoptions(P), PG_OS_CODING);
874 else if (EQ (field, Qpqstatus))
875 {
876 ConnStatusType cst;
877 /* PQstatus Returns the status of the connection. The status can be
878 CONNECTION_OK or CONNECTION_BAD.
879 ConnStatusType PQstatus(PGconn *conn)
880 */
881 switch ((cst = PQstatus (P)))
882 {
883 case CONNECTION_OK: return Qpg_connection_ok;
884 case CONNECTION_BAD: return Qpg_connection_bad;
885 #ifdef HAVE_POSTGRESQLV7
886 case CONNECTION_STARTED: return Qpg_connection_started;
887 case CONNECTION_MADE: return Qpg_connection_made;
888 case CONNECTION_AWAITING_RESPONSE: return Qpg_connection_awaiting_response;
889 case CONNECTION_AUTH_OK: return Qpg_connection_auth_ok;
890 case CONNECTION_SETENV: return Qpg_connection_setenv;
891 #endif /* HAVE_POSTGRESQLV7 */
892 default:
893 /* they've added a new field we don't know about */
894 signal_ferror (Qprocess_error, "Help! Unknown connection status code %08x from backend!", cst);
895 }
896 }
897 else if (EQ (field, Qpqerrormessage))
898 /* PQerrorMessage Returns the error message most recently generated
899 by an operation on the connection.
900 char *PQerrorMessage(PGconn* conn);
901 */
902 return build_ext_string (PQerrorMessage(P), PG_OS_CODING);
903 else if (EQ (field, Qpqbackendpid))
904 /* PQbackendPID Returns the process ID of the backend server handling
905 this connection.
906 int PQbackendPID(PGconn *conn);
907 */
908 return make_int (PQbackendPID(P));
909 else
910 signal_error (Qinvalid_argument, "bad PGconn accessor", Qunbound);
911 }
912
913 /* Query functions */
914 DEFUN ("pq-exec", Fpq_exec, 2, 2, 0, /*
915 Submit a query to Postgres and wait for the result.
916 */
917 (conn, query))
918 {
919 PGconn *P;
920 Lisp_PGresult *lisp_pgresult;
921 PGresult *R;
922 char *c_query;
923
924 CHECK_PGCONN (conn);
925 CHECK_STRING (query);
926
927 P = (XPGCONN (conn))->pgconn;
928 CHECK_LIVE_CONNECTION (P);
929
930 TO_EXTERNAL_FORMAT (LISP_STRING, query,
931 C_STRING_ALLOCA, c_query, Qnative);
932
933 R = PQexec (P, c_query);
934 {
935 char *tag, buf[BLCKSZ];
936
937 if (!R) out_of_memory ("query: out of memory", Qunbound);
938 else
939 switch (PQresultStatus (R))
940 {
941 case PGRES_BAD_RESPONSE:
942 tag = "bad response [%s]";
943 goto err;
944 case PGRES_NONFATAL_ERROR:
945 tag = "non-fatal error [%s]";
946 goto err;
947 case PGRES_FATAL_ERROR:
948 tag = "fatal error [%s]";
949 err:
950 strncpy (buf, PQresultErrorMessage (R), sizeof (buf));
951 buf [sizeof (buf) - 1] = '\0';
952 PQclear (R);
953 signal_ferror (Qprocess_error, tag, buf);
954 /*NOTREACHED*/
955 default:
956 break;
957 }
958 }
959
960 lisp_pgresult = allocate_pgresult ();
961 lisp_pgresult->pgresult = R;
962
963 return make_pgresult (lisp_pgresult);
964 }
965
966 DEFUN ("pq-send-query", Fpq_send_query, 2, 2, 0, /*
967 Submit a query to Postgres and don't wait for the result.
968 Returns: t if successfully submitted
969 nil if error (conn->errorMessage is set)
970 */
971 (conn, query))
972 {
973 PGconn *P;
974 char *c_query;
975
976 CHECK_PGCONN (conn);
977 CHECK_STRING (query);
978
979 P = (XPGCONN (conn))->pgconn;
980 CHECK_LIVE_CONNECTION (P);
981
982 TO_EXTERNAL_FORMAT (LISP_STRING, query,
983 C_STRING_ALLOCA, c_query, Qnative);
984
985 if (PQsendQuery (P, c_query)) return Qt;
986 else signal_ferror (Qprocess_error, "async query: %s", PQerrorMessage (P));
987 }
988
989 DEFUN ("pq-get-result", Fpq_get_result, 1, 1, 0, /*
990 Retrieve an asynchronous result from a query.
991 NIL is returned when no more query work remains.
992 */
993 (conn))
994 {
995 PGconn *P;
996 Lisp_PGresult *lisp_pgresult;
997 PGresult *R;
998
999 CHECK_PGCONN (conn);
1000
1001 P = (XPGCONN (conn))->pgconn;
1002 CHECK_LIVE_CONNECTION (P);
1003
1004 R = PQgetResult (P);
1005 if (!R) return Qnil; /* not an error, there's no more data to get */
1006
1007 {
1008 char *tag, buf[BLCKSZ];
1009
1010 switch (PQresultStatus (R))
1011 {
1012 case PGRES_BAD_RESPONSE:
1013 tag = "bad response [%s]";
1014 goto err;
1015 case PGRES_NONFATAL_ERROR:
1016 tag = "non-fatal error [%s]";
1017 goto err;
1018 case PGRES_FATAL_ERROR:
1019 tag = "fatal error [%s]";
1020 err:
1021 strncpy (buf, PQresultErrorMessage (R), sizeof (buf));
1022 buf[sizeof (buf) - 1] = '\0';
1023 PQclear (R);
1024 signal_ferror (Qprocess_error, tag, buf);
1025 /*NOTREACHED*/
1026 default:
1027 break;
1028 }
1029 }
1030
1031 lisp_pgresult = allocate_pgresult();
1032 lisp_pgresult->pgresult = R;
1033
1034 return make_pgresult (lisp_pgresult);
1035 }
1036
1037 DEFUN ("pq-result-status", Fpq_result_status, 1, 1, 0, /*
1038 Return result status of the query.
1039 */
1040 (result))
1041 {
1042 PGresult *R;
1043 ExecStatusType est;
1044
1045 CHECK_PGRESULT (result);
1046 R = (XPGRESULT (result))->pgresult;
1047 PUKE_IF_NULL (R);
1048
1049 switch ((est = PQresultStatus (R))) {
1050 case PGRES_EMPTY_QUERY: return Qpgres_empty_query;
1051 case PGRES_COMMAND_OK: return Qpgres_command_ok;
1052 case PGRES_TUPLES_OK: return Qpgres_tuples_ok;
1053 case PGRES_COPY_OUT: return Qpgres_copy_out;
1054 case PGRES_COPY_IN: return Qpgres_copy_in;
1055 case PGRES_BAD_RESPONSE: return Qpgres_bad_response;
1056 case PGRES_NONFATAL_ERROR: return Qpgres_nonfatal_error;
1057 case PGRES_FATAL_ERROR: return Qpgres_fatal_error;
1058 default:
1059 /* they've added a new field we don't know about */
1060 signal_ferror (Qprocess_error, "Help! Unknown exec status code %08x from backend!", est);
1061 }
1062 }
1063
1064 DEFUN ("pq-res-status", Fpq_res_status, 1, 1, 0, /*
1065 Return stringified result status of the query.
1066 */
1067 (result))
1068 {
1069 PGresult *R;
1070
1071 CHECK_PGRESULT (result);
1072 R = (XPGRESULT (result))->pgresult;
1073 PUKE_IF_NULL (R);
1074
1075 return build_ext_string (PQresStatus (PQresultStatus (R)), PG_OS_CODING);
1076 }
1077
1078 /* Sundry PGresult accessor functions */
1079 DEFUN ("pq-result-error-message", Fpq_result_error_message, 1, 1, 0, /*
1080 Return last message associated with the query.
1081 */
1082 (result))
1083 {
1084 PGresult *R;
1085
1086 CHECK_PGRESULT (result);
1087 R = (XPGRESULT (result))->pgresult;
1088 PUKE_IF_NULL (R);
1089
1090 return build_ext_string (PQresultErrorMessage (R), PG_OS_CODING);
1091 }
1092
1093 DEFUN ("pq-ntuples", Fpq_ntuples, 1, 1, 0, /*
1094 Return the number of tuples (instances) in the query result.
1095 */
1096 (result))
1097 {
1098 PGresult *R;
1099
1100 CHECK_PGRESULT (result);
1101 R = (XPGRESULT (result))->pgresult;
1102 PUKE_IF_NULL (R);
1103
1104 return make_int (PQntuples (R));
1105 }
1106
1107 DEFUN ("pq-nfields", Fpq_nfields, 1, 1, 0, /*
1108 Return the number of fields (attributes) in each tuple of the query result.
1109 */
1110 (result))
1111 {
1112 PGresult *R;
1113
1114 CHECK_PGRESULT (result);
1115 R = (XPGRESULT (result))->pgresult;
1116 PUKE_IF_NULL (R);
1117
1118 return make_int (PQnfields (R));
1119 }
1120
1121 DEFUN ("pq-binary-tuples", Fpq_binary_tuples, 1, 1, 0, /*
1122 Return t if the query result contains binary data, nil otherwise.
1123 */
1124 (result))
1125 {
1126 PGresult *R;
1127
1128 CHECK_PGRESULT (result);
1129 R = (XPGRESULT (result))->pgresult;
1130 PUKE_IF_NULL (R);
1131
1132 return (PQbinaryTuples (R)) ? Qt : Qnil;
1133 }
1134
1135 DEFUN ("pq-fname", Fpq_fname, 2, 2, 0, /*
1136 Return the field (attribute) name associated with the given field index.
1137 Field indices start at 0.
1138 */
1139 (result, field_index))
1140 {
1141 PGresult *R;
1142
1143 CHECK_PGRESULT (result);
1144 CHECK_INT (field_index);
1145 R = (XPGRESULT (result))->pgresult;
1146 PUKE_IF_NULL (R);
1147
1148 return build_ext_string (PQfname (R, XINT (field_index)), PG_OS_CODING);
1149 }
1150
1151 DEFUN ("pq-fnumber", Fpq_fnumber, 2, 2, 0, /*
1152 Return the number of fields (attributes) in each tuple of the query result.
1153 */
1154 (result, field_name))
1155 {
1156 PGresult *R;
1157 char *c_field_name;
1158
1159 CHECK_PGRESULT (result);
1160 CHECK_STRING (field_name);
1161 R = (XPGRESULT (result))->pgresult;
1162 PUKE_IF_NULL (R);
1163
1164 TO_EXTERNAL_FORMAT (LISP_STRING, field_name,
1165 C_STRING_ALLOCA, c_field_name, Qnative);
1166
1167 return make_int (PQfnumber (R, c_field_name));
1168 }
1169
1170 DEFUN ("pq-ftype", Fpq_ftype, 2, 2, 0, /*
1171 Return the field type associated with the given field index.
1172 The integer returned is the internal coding of the type. Field indices
1173 start at 0.
1174 */
1175 (result, field_num))
1176 {
1177 PGresult *R;
1178
1179 CHECK_PGRESULT (result);
1180 CHECK_INT (field_num);
1181 R = (XPGRESULT (result))->pgresult;
1182 PUKE_IF_NULL (R);
1183
1184 return make_int (PQftype (R, XINT (field_num)));
1185 }
1186
1187 DEFUN ("pq-fsize", Fpq_fsize, 2, 2, 0, /*
1188 Return the field size in bytes associated with the given field index.
1189 Field indices start at 0.
1190 */
1191 (result, field_index))
1192 {
1193 PGresult *R;
1194
1195 CHECK_PGRESULT (result);
1196 CHECK_INT (field_index);
1197 R = (XPGRESULT (result))->pgresult;
1198 PUKE_IF_NULL (R);
1199
1200 return make_int (PQftype (R, XINT (field_index)));
1201 }
1202
1203 DEFUN ("pq-fmod", Fpq_fmod, 2, 2, 0, /*
1204 Return the type modifier associated with a field.
1205 Field indices start at 0.
1206 */
1207 (result, field_index))
1208 {
1209 PGresult *R;
1210
1211 CHECK_PGRESULT (result);
1212 CHECK_INT (field_index);
1213 R = (XPGRESULT (result))->pgresult;
1214 PUKE_IF_NULL (R);
1215
1216 return make_int (PQfmod (R, XINT (field_index)));
1217 }
1218
1219 DEFUN ("pq-get-value", Fpq_get_value, 3, 3, 0, /*
1220 Return a single field (attribute) value of one tuple of a PGresult.
1221 Tuple and field indices start at 0.
1222 */
1223 (result, tup_num, field_num))
1224 {
1225 PGresult *R;
1226
1227 CHECK_PGRESULT (result);
1228 CHECK_INT (tup_num);
1229 CHECK_INT (field_num);
1230 R = (XPGRESULT (result))->pgresult;
1231 PUKE_IF_NULL (R);
1232
1233 return build_ext_string (PQgetvalue (R, XINT (tup_num), XINT (field_num)),
1234 PG_OS_CODING);
1235 }
1236
1237 DEFUN ("pq-get-length", Fpq_get_length, 3, 3, 0, /*
1238 Returns the length of a field value in bytes.
1239 If result is binary, i.e. a result of a binary portal, then the
1240 length returned does NOT include the size field of the varlena. (The
1241 data returned by PQgetvalue doesn't either.)
1242 */
1243 (result, tup_num, field_num))
1244 {
1245 PGresult *R;
1246
1247 CHECK_PGRESULT (result);
1248 CHECK_INT (tup_num);
1249 CHECK_INT (field_num);
1250 R = (XPGRESULT (result))->pgresult;
1251 PUKE_IF_NULL (R);
1252
1253 return make_int (PQgetlength (R, XINT (tup_num), XINT (field_num)));
1254 }
1255
1256 DEFUN ("pq-get-is-null", Fpq_get_is_null, 3, 3, 0, /*
1257 Returns the null status of a field value.
1258 */
1259 (result, tup_num, field_num))
1260 {
1261 PGresult *R;
1262
1263 CHECK_PGRESULT (result);
1264 CHECK_INT (tup_num);
1265 CHECK_INT (field_num);
1266 R = (XPGRESULT (result))->pgresult;
1267 PUKE_IF_NULL (R);
1268
1269 return PQgetisnull (R, XINT (tup_num), XINT (field_num)) ? Qt : Qnil;
1270 }
1271
1272 DEFUN ("pq-cmd-status", Fpq_cmd_status, 1, 1, 0, /*
1273 Returns the command status string from the SQL command that generated the result.
1274 */
1275 (result))
1276 {
1277 PGresult *R;
1278
1279 CHECK_PGRESULT (result);
1280 R = (XPGRESULT (result))->pgresult;
1281 PUKE_IF_NULL (R);
1282
1283 return build_ext_string (PQcmdStatus (R), PG_OS_CODING);
1284 }
1285
1286 DEFUN ("pq-cmd-tuples", Fpq_cmd_tuples, 1, 1, 0, /*
1287 Returns the number of rows affected by the SQL command.
1288 */
1289 (result))
1290 {
1291 PGresult *R;
1292
1293 CHECK_PGRESULT (result);
1294 R = (XPGRESULT (result))->pgresult;
1295 PUKE_IF_NULL (R);
1296
1297 return build_ext_string (PQcmdTuples (R), PG_OS_CODING);
1298 }
1299
1300 DEFUN ("pq-oid-value", Fpq_oid_value, 1, 1, 0, /*
1301 Returns the object id of the tuple inserted.
1302 */
1303 (result))
1304 {
1305 PGresult *R;
1306
1307 CHECK_PGRESULT (result);
1308 R = (XPGRESULT (result))->pgresult;
1309 PUKE_IF_NULL (R);
1310
1311 #ifdef HAVE_POSTGRESQLV7
1312 return make_int (PQoidValue (R));
1313 #else
1314 /* Use the old interface */
1315 return make_int (atoi (PQoidStatus (R)));
1316 #endif
1317 }
1318
1319 #ifdef HAVE_POSTGRESQLV7
1320 DEFUN ("pq-set-nonblocking", Fpq_set_nonblocking, 2, 2, 0, /*
1321 Sets the PGconn's database connection non-blocking if the arg is TRUE
1322 or makes it non-blocking if the arg is FALSE, this will not protect
1323 you from PQexec(), you'll only be safe when using the non-blocking API.
1324
1325 Needs to be called only on a connected database connection.
1326 */
1327 (conn, arg))
1328 {
1329 PGconn *P;
1330
1331 CHECK_PGCONN (conn);
1332 P = (XPGCONN (conn))->pgconn;
1333 CHECK_LIVE_CONNECTION (P);
1334
1335 return make_int (PQsetnonblocking (P, !NILP (arg)));
1336 }
1337
1338 DEFUN ("pq-is-nonblocking", Fpq_is_nonblocking, 1, 1, 0, /*
1339 Return the blocking status of the database connection.
1340 */
1341 (conn))
1342 {
1343 PGconn *P;
1344
1345 CHECK_PGCONN (conn);
1346 P = (XPGCONN (conn))->pgconn;
1347 CHECK_LIVE_CONNECTION (P);
1348
1349 return PQisnonblocking (P) ? Qt : Qnil;
1350 }
1351
1352 DEFUN ("pq-flush", Fpq_flush, 1, 1, 0, /*
1353 Force the write buffer to be written (or at least try).
1354 */
1355 (conn))
1356 {
1357 PGconn *P;
1358
1359 CHECK_PGCONN (conn);
1360 P = (XPGCONN (conn))->pgconn;
1361 CHECK_LIVE_CONNECTION (P);
1362
1363 return make_int (PQflush (P));
1364 }
1365 #endif
1366
1367 DEFUN ("pq-notifies", Fpq_notifies, 1, 1, 0, /*
1368 Return the latest async notification that has not yet been handled.
1369 If there has been a notification, then a list of two elements will be returned.
1370 The first element contains the relation name being notified, the second
1371 element contains the backend process ID number. nil is returned if there
1372 aren't any notifications to process.
1373 */
1374 (conn))
1375 {
1376 /* This function cannot GC */
1377 PGconn *P;
1378 PGnotify *PGN;
1379
1380 CHECK_PGCONN (conn);
1381 P = (XPGCONN (conn))->pgconn;
1382 CHECK_LIVE_CONNECTION (P);
1383
1384 PGN = PQnotifies (P);
1385 if (!PGN)
1386 return Qnil;
1387 else
1388 {
1389 Lisp_Object temp;
1390
1391 temp = list2 (build_ext_string (PGN->relname, PG_OS_CODING), make_int (PGN->be_pid));
1392 free ((void *)PGN);
1393 return temp;
1394 }
1395 }
1396
1397 #if defined (HAVE_POSTGRESQLV7) && defined(MULE)
1398 /* ###autoload */
1399 DEFUN ("pq-env-2-encoding", Fpq_env_2_encoding, 0, 0, 0, /*
1400 Get encoding id from environment variable PGCLIENTENCODING.
1401 */
1402 ())
1403 {
1404 return make_int (PQenv2encoding ());
1405 }
1406 #endif /* MULE */
1407
1408 DEFUN ("pq-lo-import", Fpq_lo_import, 2, 2, 0, /*
1409 */
1410 (conn, filename))
1411 {
1412 PGconn *P;
1413 char *c_filename;
1414
1415 CHECK_PGCONN (conn);
1416 CHECK_STRING (filename);
1417
1418 P = (XPGCONN (conn))->pgconn;
1419 CHECK_LIVE_CONNECTION (P);
1420
1421 TO_EXTERNAL_FORMAT (LISP_STRING, filename,
1422 C_STRING_ALLOCA, c_filename,
1423 Qfile_name);
1424
1425 return make_int ((int)lo_import (P, c_filename));
1426 }
1427
1428 DEFUN ("pq-lo-export", Fpq_lo_export, 3, 3, 0, /*
1429 */
1430 (conn, oid, filename))
1431 {
1432 PGconn *P;
1433 char *c_filename;
1434
1435 CHECK_PGCONN (conn);
1436 CHECK_INT (oid);
1437 CHECK_STRING (filename);
1438
1439 P = (XPGCONN (conn))->pgconn;
1440 CHECK_LIVE_CONNECTION (P);
1441
1442 TO_EXTERNAL_FORMAT (LISP_STRING, filename,
1443 C_STRING_ALLOCA, c_filename, Qfile_name);
1444
1445 return make_int ((int)lo_export (P, XINT (oid), c_filename));
1446 }
1447
1448 DEFUN ("pq-make-empty-pgresult", Fpq_make_empty_pgresult, 2, 2, 0, /*
1449 Make an empty PGresult object with the given status.
1450 */
1451 (conn, status))
1452 {
1453 PGconn *P;
1454 Lisp_PGresult *lpgr;
1455 PGresult *R;
1456 ExecStatusType est;
1457
1458 CHECK_PGCONN (conn);
1459 P = (XPGCONN (conn))->pgconn;
1460 CHECK_LIVE_CONNECTION (P); /* needed here? */
1461
1462 if (EQ (status, Qpgres_empty_query)) est = PGRES_EMPTY_QUERY;
1463 else if (EQ (status, Qpgres_command_ok)) est = PGRES_COMMAND_OK;
1464 else if (EQ (status, Qpgres_tuples_ok)) est = PGRES_TUPLES_OK;
1465 else if (EQ (status, Qpgres_copy_out)) est = PGRES_COPY_OUT;
1466 else if (EQ (status, Qpgres_copy_in)) est = PGRES_COPY_IN;
1467 else if (EQ (status, Qpgres_bad_response)) est = PGRES_BAD_RESPONSE;
1468 else if (EQ (status, Qpgres_nonfatal_error)) est = PGRES_NONFATAL_ERROR;
1469 else if (EQ (status, Qpgres_fatal_error)) est = PGRES_FATAL_ERROR;
1470 else invalid_constant ("bad status symbol", status);
1471
1472 R = PQmakeEmptyPGresult (P, est);
1473 if (!R) out_of_memory (0, Qunbound);
1474
1475 lpgr = allocate_pgresult ();
1476 lpgr->pgresult = R;
1477
1478 return make_pgresult (lpgr);
1479 }
1480
1481 DEFUN ("pq-get-line", Fpq_get_line, 1, 1, 0, /*
1482 Retrieve a line from server in copy in operation.
1483 The return value is a dotted pair where the cons cell is an integer code:
1484 -1: Copying is complete
1485 0: A record is complete
1486 1: A record is incomplete, it will be continued in the next `pq-get-line'
1487 operation.
1488 and the cdr cell is returned string data.
1489
1490 The copy operation is complete when the value `\.' (backslash dot) is
1491 returned.
1492 */
1493 (conn))
1494 {
1495 char buffer[BLCKSZ]; /* size of a Postgres disk block */
1496 PGconn *P;
1497 int ret;
1498
1499 CHECK_PGCONN (conn);
1500 P = (XPGCONN (conn))->pgconn;
1501 CHECK_LIVE_CONNECTION (P);
1502
1503 ret = PQgetline (P, buffer, sizeof (buffer));
1504
1505 return Fcons (make_int (ret), build_ext_string (buffer, PG_OS_CODING));
1506 }
1507
1508 DEFUN ("pq-put-line", Fpq_put_line, 2, 2, 0, /*
1509 Send a line to the server in copy out operation.
1510
1511 Returns t if the operation succeeded, nil otherwise.
1512 */
1513 (conn, string))
1514 {
1515 PGconn *P;
1516 char *c_string;
1517
1518 CHECK_PGCONN (conn);
1519 CHECK_STRING (string);
1520
1521 P = (XPGCONN (conn))->pgconn;
1522 CHECK_LIVE_CONNECTION (P);
1523 TO_EXTERNAL_FORMAT (LISP_STRING, string,
1524 C_STRING_ALLOCA, c_string, Qnative);
1525
1526 return !PQputline (P, c_string) ? Qt : Qnil;
1527 }
1528
1529 DEFUN ("pq-get-line-async", Fpq_get_line_async, 1, 1, 0, /*
1530 Get a line from the server in copy in operation asynchronously.
1531
1532 This routine is for applications that want to do "COPY <rel> to stdout"
1533 asynchronously, that is without blocking. Having issued the COPY command
1534 and gotten a PGRES_COPY_OUT response, the app should call PQconsumeInput
1535 and this routine until the end-of-data signal is detected. Unlike
1536 PQgetline, this routine takes responsibility for detecting end-of-data.
1537
1538 On each call, PQgetlineAsync will return data if a complete newline-
1539 terminated data line is available in libpq's input buffer, or if the
1540 incoming data line is too long to fit in the buffer offered by the caller.
1541 Otherwise, no data is returned until the rest of the line arrives.
1542
1543 If -1 is returned, the end-of-data signal has been recognized (and removed
1544 from libpq's input buffer). The caller *must* next call PQendcopy and
1545 then return to normal processing.
1546
1547 RETURNS:
1548 -1 if the end-of-copy-data marker has been recognized
1549 0 if no data is available
1550 >0 the number of bytes returned.
1551 The data returned will not extend beyond a newline character. If possible
1552 a whole line will be returned at one time. But if the buffer offered by
1553 the caller is too small to hold a line sent by the backend, then a partial
1554 data line will be returned. This can be detected by testing whether the
1555 last returned byte is '\n' or not.
1556 The returned string is *not* null-terminated.
1557 */
1558 (conn))
1559 {
1560 PGconn *P;
1561 char buffer[BLCKSZ];
1562 int ret;
1563
1564 CHECK_PGCONN (conn);
1565
1566 P = (XPGCONN (conn))->pgconn;
1567 CHECK_LIVE_CONNECTION (P);
1568
1569 ret = PQgetlineAsync (P, buffer, sizeof (buffer));
1570
1571 if (ret == -1) return Qt; /* done! */
1572 else if (!ret) return Qnil; /* no data yet */
1573 else return Fcons (make_int (ret),
1574 make_ext_string ((Extbyte *) buffer, ret, PG_OS_CODING));
1575 }
1576
1577 DEFUN ("pq-put-nbytes", Fpq_put_nbytes, 2, 2, 0, /*
1578 Asynchronous copy out.
1579 */
1580 (conn, data))
1581 {
1582 /* NULs are not allowed. I don't think this matters at this time. */
1583 PGconn *P;
1584 char *c_data;
1585
1586 CHECK_PGCONN (conn);
1587 CHECK_STRING (data);
1588
1589 P = (XPGCONN (conn))->pgconn;
1590 CHECK_LIVE_CONNECTION (P);
1591 TO_EXTERNAL_FORMAT (LISP_STRING, data,
1592 C_STRING_ALLOCA, c_data, Qnative);
1593
1594 return !PQputnbytes (P, c_data, strlen (c_data)) ? Qt : Qnil;
1595 }
1596
1597 DEFUN ("pq-end-copy", Fpq_end_copy, 1, 1, 0, /*
1598 End a copying operation.
1599 */
1600 (conn))
1601 {
1602 PGconn *P;
1603
1604 CHECK_PGCONN (conn);
1605 P = (XPGCONN (conn))->pgconn;
1606 CHECK_LIVE_CONNECTION (P);
1607
1608 return PQendcopy (P) ? Qt : Qnil;
1609 }
1610
1611 void
1612 syms_of_postgresql(void)
1613 {
1614 #ifndef RUNNING_XEMACS_21_1
1615 INIT_LRECORD_IMPLEMENTATION (pgconn);
1616 INIT_LRECORD_IMPLEMENTATION (pgresult);
1617 #endif
1618 DEFSYMBOL (Qpostgresql);
1619
1620 /* opaque exported types */
1621 DEFSYMBOL (Qpgconnp);
1622 DEFSYMBOL (Qpgresultp);
1623
1624 /* connection status types */
1625 defsymbol (&Qpg_connection_ok, "pg::connection-ok");
1626 defsymbol (&Qpg_connection_bad, "pg::connection-bad");
1627 defsymbol (&Qpg_connection_started, "pg::connection-started");
1628 defsymbol (&Qpg_connection_made, "pg::connection-made");
1629 defsymbol (&Qpg_connection_awaiting_response, "pg::connection-awaiting-response");
1630 defsymbol (&Qpg_connection_auth_ok, "pg::connection-auth-ok");
1631 defsymbol (&Qpg_connection_setenv, "pg::connection-setenv");
1632
1633 /* Fields of PGconn */
1634 defsymbol (&Qpqdb, "pq::db");
1635 defsymbol (&Qpquser, "pq::user");
1636 defsymbol (&Qpqpass, "pq::pass");
1637 defsymbol (&Qpqhost, "pq::host");
1638 defsymbol (&Qpqport, "pq::port");
1639 defsymbol (&Qpqtty, "pq::tty");
1640 defsymbol (&Qpqoptions, "pq::options");
1641 defsymbol (&Qpqstatus, "pq::status");
1642 defsymbol (&Qpqerrormessage, "pq::error-message");
1643 defsymbol (&Qpqbackendpid, "pq::backend-pid");
1644
1645 /* Query status results */
1646 defsymbol (&Qpgres_empty_query, "pgres::empty-query");
1647 defsymbol (&Qpgres_command_ok, "pgres::command-ok");
1648 defsymbol (&Qpgres_tuples_ok, "pgres::tuples-ok");
1649 defsymbol (&Qpgres_copy_out, "pgres::copy-out");
1650 defsymbol (&Qpgres_copy_in, "pgres::copy-in");
1651 defsymbol (&Qpgres_bad_response, "pgres::bad-response");
1652 defsymbol (&Qpgres_nonfatal_error, "pgres::nonfatal-error");
1653 defsymbol (&Qpgres_fatal_error, "pgres::fatal-error");
1654
1655 /* Poll status results */
1656 defsymbol (&Qpgres_polling_failed, "pgres::polling-failed");
1657 defsymbol (&Qpgres_polling_reading, "pgres::polling-reading");
1658 defsymbol (&Qpgres_polling_writing, "pgres::polling-writing");
1659 defsymbol (&Qpgres_polling_ok, "pgres::polling-ok");
1660 defsymbol (&Qpgres_polling_active, "pgres::polling-active");
1661
1662 #ifdef HAVE_POSTGRESQLV7
1663 DEFSUBR (Fpq_connect_start);
1664 DEFSUBR (Fpq_connect_poll);
1665 #ifdef MULE
1666 DEFSUBR (Fpq_client_encoding);
1667 DEFSUBR (Fpq_set_client_encoding);
1668 #endif /* MULE */
1669 #endif /* HAVE_POSTGRESQLV7 */
1670 DEFSUBR (Fpq_conn_defaults);
1671 DEFSUBR (Fpq_connectdb);
1672 DEFSUBR (Fpq_finish);
1673 DEFSUBR (Fpq_clear);
1674 DEFSUBR (Fpq_is_busy);
1675 DEFSUBR (Fpq_consume_input);
1676
1677 DEFSUBR (Fpq_reset);
1678 #ifdef HAVE_POSTGRESQLV7
1679 DEFSUBR (Fpq_reset_start);
1680 DEFSUBR (Fpq_reset_poll);
1681 #endif
1682 DEFSUBR (Fpq_request_cancel);
1683 DEFSUBR (Fpq_pgconn);
1684
1685 DEFSUBR (Fpq_exec);
1686 DEFSUBR (Fpq_send_query);
1687 DEFSUBR (Fpq_get_result);
1688 DEFSUBR (Fpq_result_status);
1689 DEFSUBR (Fpq_res_status);
1690 DEFSUBR (Fpq_result_error_message);
1691 DEFSUBR (Fpq_ntuples);
1692 DEFSUBR (Fpq_nfields);
1693 DEFSUBR (Fpq_binary_tuples);
1694 DEFSUBR (Fpq_fname);
1695 DEFSUBR (Fpq_fnumber);
1696 DEFSUBR (Fpq_ftype);
1697 DEFSUBR (Fpq_fsize);
1698 DEFSUBR (Fpq_fmod);
1699 /***/
1700 DEFSUBR (Fpq_get_value);
1701 DEFSUBR (Fpq_get_length);
1702 DEFSUBR (Fpq_get_is_null);
1703 DEFSUBR (Fpq_cmd_status);
1704 DEFSUBR (Fpq_cmd_tuples);
1705 DEFSUBR (Fpq_oid_value);
1706
1707 #ifdef HAVE_POSTGRESQLV7
1708 DEFSUBR (Fpq_set_nonblocking);
1709 DEFSUBR (Fpq_is_nonblocking);
1710 DEFSUBR (Fpq_flush);
1711 #endif
1712 DEFSUBR (Fpq_notifies);
1713
1714 #if defined (HAVE_POSTGRESQLV7) && defined(MULE)
1715 DEFSUBR (Fpq_env_2_encoding);
1716 #endif
1717
1718 DEFSUBR (Fpq_lo_import);
1719 DEFSUBR (Fpq_lo_export);
1720
1721 DEFSUBR (Fpq_make_empty_pgresult);
1722
1723 /* copy in/out functions */
1724 DEFSUBR (Fpq_get_line);
1725 DEFSUBR (Fpq_put_line);
1726 DEFSUBR (Fpq_get_line_async);
1727 DEFSUBR (Fpq_put_nbytes);
1728 DEFSUBR (Fpq_end_copy);
1729 }
1730
1731 void
1732 vars_of_postgresql(void)
1733 {
1734 Fprovide (Qpostgresql);
1735 #ifdef HAVE_POSTGRESQLV7
1736 Fprovide (intern ("postgresqlv7"));
1737 #endif
1738 #ifndef RUNNING_XEMACS_21_1
1739 Vpg_coding_system = Qnative;
1740 DEFVAR_LISP ("pg-coding-system", &Vpg_coding_system /*
1741 Default Postgres client coding system.
1742 */ );
1743 #endif
1744
1745 DEFVAR_LISP ("pg:host", &VXPGHOST /*
1746 Default PostgreSQL server name.
1747 If not set, the server running on the local host is used. The
1748 initial value is set from the PGHOST environment variable.
1749 */ );
1750
1751 DEFVAR_LISP ("pg:user", &VXPGUSER /*
1752 Default PostgreSQL user name.
1753 This value is used when connecting to a database for authentication.
1754 The initial value is set from the PGUSER environment variable.
1755 */ );
1756
1757 DEFVAR_LISP ("pg:options", &VXPGOPTIONS /*
1758 Default PostgreSQL user name.
1759 This value is used when connecting to a database for authentication.
1760 The initial value is set from the PGUSER environment variable.
1761 */ );
1762
1763 DEFVAR_LISP ("pg:port", &VXPGPORT /*
1764 Default port to connect to PostgreSQL backend.
1765 This value is used when connecting to a database.
1766 The initial value is set from the PGPORT environment variable.
1767 */ );
1768
1769 DEFVAR_LISP ("pg:tty", &VXPGTTY /*
1770 Default debugging TTY.
1771 There is no useful setting of this variable in the XEmacs Lisp API.
1772 The initial value is set from the PGTTY environment variable.
1773 */ );
1774
1775 DEFVAR_LISP ("pg:database", &VXPGDATABASE /*
1776 Default database to connect to.
1777 The initial value is set from the PGDATABASE environment variable.
1778 */ );
1779
1780 DEFVAR_LISP ("pg:realm", &VXPGREALM /*
1781 Default kerberos realm to use for authentication.
1782 The initial value is set from the PGREALM environment variable.
1783 */ );
1784
1785 #ifdef MULE
1786 /* It's not clear whether this is any use. My intent is to
1787 autodetect the coding system from the database. */
1788 DEFVAR_LISP ("pg:client-encoding", &VXPGCLIENTENCODING /*
1789 Default client encoding to use.
1790 The initial value is set from the PGCLIENTENCODING environment variable.
1791 */ );
1792 #endif
1793
1794 #if !defined(HAVE_POSTGRESQLV7)
1795 DEFVAR_LISP ("pg:authtype", &VXPGAUTHTYPE /*
1796 Default authentication to use.
1797 The initial value is set from the PGAUTHTYPE environment variable.
1798
1799 WARNING: This variable has gone away in versions of PostgreSQL newer
1800 than 6.5.
1801 */ );
1802 #endif
1803
1804 DEFVAR_LISP ("pg:geqo", &VXPGGEQO /*
1805 Genetic Query Optimizer options.
1806 The initial value is set from the PGGEQO environment variable.
1807 */ );
1808
1809 DEFVAR_LISP ("pg:cost-index", &VXPGCOSTINDEX /*
1810 Default cost index options.
1811 The initial value is set from the PGCOSTINDEX environment variable.
1812 */ );
1813
1814 DEFVAR_LISP ("pg:cost-heap", &VXPGCOSTHEAP /*
1815 Default cost heap options.
1816 The initial value is set from the PGCOSTHEAP environment variable.
1817 */ );
1818
1819 DEFVAR_LISP ("pg:tz", &VXPGTZ /*
1820 Default timezone to use.
1821 The initial value is set from the PGTZ environment variable.
1822 */ );
1823
1824 DEFVAR_LISP ("pg:date-style", &VXPGDATESTYLE /*
1825 Default date style to use.
1826 The initial value is set from the PGDATESTYLE environment variable.
1827 */ );
1828
1829 #ifdef HAVE_SHLIB
1830 /* If we are building this as a module, we need the initializing function to
1831 run at module load time. */
1832 init_postgresql_from_environment ();
1833 #endif
1834 }
1835
1836 /* These initializations should not be done at dump-time. */
1837 void
1838 init_postgresql_from_environment (void)
1839 {
1840 Ibyte *p;
1841
1842 #define FROB(envvar, var) \
1843 if ((p = egetenv (envvar))) \
1844 var = build_intstring (p); \
1845 else \
1846 var = Qnil
1847
1848 if (initialized)
1849 {
1850 FROB ("PGHOST", VXPGHOST);
1851 FROB ("PGUSER", VXPGUSER);
1852 FROB ("PGOPTIONS", VXPGOPTIONS);
1853
1854 if ((p = egetenv ("PGPORT")))
1855 VXPGPORT = make_int (atoi ((char *) p));
1856 else
1857 VXPGPORT = Qnil;
1858
1859 FROB ("PGTTY", VXPGTTY);
1860 FROB ("PGDATABASE", VXPGDATABASE);
1861 FROB ("PGREALM", VXPGREALM);
1862 #ifdef MULE
1863 /* It's not clear whether this is any use. My intent is to
1864 autodetect the coding system from the database. */
1865 FROB ("PGCLIENTENCODING", VXPGCLIENTENCODING);
1866 #endif
1867
1868 #if !defined(HAVE_POSTGRESQLV7)
1869 FROB ("PGAUTHTYPE", VXPGAUTHTYPE);
1870 #endif
1871
1872 FROB ("PGGEQO", VXPGGEQO);
1873 FROB ("PGCOSTINDEX", VXPGCOSTINDEX);
1874 FROB ("PGCOSTHEAP", VXPGCOSTHEAP);
1875 FROB ("PGTZ", VXPGTZ);
1876 FROB ("PGDATESTYLE", VXPGDATESTYLE);
1877 #undef FROB
1878 }
1879 }
1880
1881 #ifdef HAVE_SHLIB
1882 void
1883 unload_postgresql (void)
1884 {
1885 #ifndef RUNNING_XEMACS_21_1
1886 /* Remove defined types */
1887 UNDEF_LRECORD_IMPLEMENTATION (pgconn);
1888 UNDEF_LRECORD_IMPLEMENTATION (pgresult);
1889 #endif
1890
1891 /* Remove staticpro'ing of symbols */
1892 unstaticpro_nodump (&Qpostgresql);
1893 unstaticpro_nodump (&Qpgconnp);
1894 unstaticpro_nodump (&Qpgresultp);
1895 unstaticpro_nodump (&Qpg_connection_ok);
1896 unstaticpro_nodump (&Qpg_connection_bad);
1897 unstaticpro_nodump (&Qpg_connection_started);
1898 unstaticpro_nodump (&Qpg_connection_made);
1899 unstaticpro_nodump (&Qpg_connection_awaiting_response);
1900 unstaticpro_nodump (&Qpg_connection_auth_ok);
1901 unstaticpro_nodump (&Qpg_connection_setenv);
1902 unstaticpro_nodump (&Qpqdb);
1903 unstaticpro_nodump (&Qpquser);
1904 unstaticpro_nodump (&Qpqpass);
1905 unstaticpro_nodump (&Qpqhost);
1906 unstaticpro_nodump (&Qpqport);
1907 unstaticpro_nodump (&Qpqtty);
1908 unstaticpro_nodump (&Qpqoptions);
1909 unstaticpro_nodump (&Qpqstatus);
1910 unstaticpro_nodump (&Qpqerrormessage);
1911 unstaticpro_nodump (&Qpqbackendpid);
1912 unstaticpro_nodump (&Qpgres_empty_query);
1913 unstaticpro_nodump (&Qpgres_command_ok);
1914 unstaticpro_nodump (&Qpgres_tuples_ok);
1915 unstaticpro_nodump (&Qpgres_copy_out);
1916 unstaticpro_nodump (&Qpgres_copy_in);
1917 unstaticpro_nodump (&Qpgres_bad_response);
1918 unstaticpro_nodump (&Qpgres_nonfatal_error);
1919 unstaticpro_nodump (&Qpgres_fatal_error);
1920 unstaticpro_nodump (&Qpgres_polling_failed);
1921 unstaticpro_nodump (&Qpgres_polling_reading);
1922 unstaticpro_nodump (&Qpgres_polling_writing);
1923 unstaticpro_nodump (&Qpgres_polling_ok);
1924 unstaticpro_nodump (&Qpgres_polling_active);
1925 }
1926 #endif /* HAVE_SHLIB */