1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 /* Interface to PostgreSQL libpq library */
28
29 #include "scheme.h"
30 #include "prims.h"
31 #include "usrdef.h"
32 #include "os.h"
33
34 #ifdef HAVE_LIBPQ_FE_H
35 # include <libpq-fe.h>
36 #endif
37
38 #define ARG_CONN(n) ((PGconn *) (arg_ulong_integer (n)))
39 #define ARG_RESULT(n) ((PGresult *) (arg_ulong_integer (n)))
40 #define ARG_EXEC_STATUS(n) ((ExecStatusType) (arg_ulong_integer (n)))
41
42 #define ANY_TO_UINT(x) (ulong_to_integer ((unsigned long) (x)))
43 #define ANY_TO_UNSPECIFIC(x) ((x), UNSPECIFIC)
44
45 #define ONE_ARG(get_arg, fn, cvt) \
46 { \
47 PRIMITIVE_HEADER (1); \
48 PRIMITIVE_RETURN (cvt (fn (get_arg (1)))); \
49 }
50
51 #define STRING_TO_UINT(fn) ONE_ARG (STRING_ARG, fn, ANY_TO_UINT)
52
53 #define CONN_TO_UINT(fn) ONE_ARG (ARG_CONN, fn, ANY_TO_UINT)
54 #define CONN_TO_INT(fn) ONE_ARG (ARG_CONN, fn, long_to_integer)
55 #define CONN_TO_UNSPECIFIC(fn) ONE_ARG (ARG_CONN, fn, ANY_TO_UNSPECIFIC)
56 #define CONN_TO_STRING(fn) ONE_ARG (ARG_CONN, fn, char_pointer_to_string)
57
58 #define RESULT_TO_UINT(fn) ONE_ARG (ARG_RESULT, fn, ANY_TO_UINT)
59 #define RESULT_TO_INT(fn) ONE_ARG (ARG_RESULT, fn, long_to_integer)
60 #define RESULT_TO_UNSPECIFIC(fn) ONE_ARG (ARG_RESULT, fn, ANY_TO_UNSPECIFIC)
61 #define RESULT_TO_STRING(fn) ONE_ARG (ARG_RESULT, fn, char_pointer_to_string)
62
63 DEFINE_PRIMITIVE ("PQ-CONNECT-DB", Prim_pq_connect_db, 2, 2, 0)
64 {
65 PRIMITIVE_HEADER (2);
66 CHECK_ARG (2, WEAK_PAIR_P);
67 SET_PAIR_CDR ((ARG_REF (2)), (ANY_TO_UINT (PQconnectdb (STRING_ARG (1)))));
68 PRIMITIVE_RETURN (UNSPECIFIC);
69 }
70
71 DEFINE_PRIMITIVE ("PQ-CONNECT-START", Prim_pq_connect_start, 2, 2, 0)
72 {
73 PRIMITIVE_HEADER (2);
74 CHECK_ARG (2, WEAK_PAIR_P);
75 SET_PAIR_CDR ((ARG_REF (2)),
76 (ANY_TO_UINT (PQconnectStart (STRING_ARG (1)))));
77 PRIMITIVE_RETURN (UNSPECIFIC);
78 }
79
80 DEFINE_PRIMITIVE ("PQ-CONNECT-POLL", Prim_pq_connect_poll, 1, 1, 0)
CONN_TO_UINT(PQconnectPoll)81 CONN_TO_UINT (PQconnectPoll)
82
83 DEFINE_PRIMITIVE ("PQ-STATUS", Prim_pq_status, 1, 1, 0)
84 CONN_TO_UINT (PQstatus)
85
86 DEFINE_PRIMITIVE ("PQ-FINISH", Prim_pq_finish, 1, 1, 0)
87 CONN_TO_UNSPECIFIC (PQfinish)
88
89 DEFINE_PRIMITIVE ("PQ-RESET", Prim_pq_reset, 1, 1, 0)
90 CONN_TO_UNSPECIFIC (PQreset)
91
92 DEFINE_PRIMITIVE ("PQ-RESET-START", Prim_pq_reset_start, 1, 1, 0)
93 CONN_TO_INT (PQresetStart)
94
95 DEFINE_PRIMITIVE ("PQ-RESET-POLL", Prim_pq_reset_poll, 1, 1, 0)
96 CONN_TO_UINT (PQresetPoll)
97
98 DEFINE_PRIMITIVE ("PQ-DB", Prim_pq_db, 1, 1, 0)
99 CONN_TO_STRING (PQdb)
100
101 DEFINE_PRIMITIVE ("PQ-USER", Prim_pq_user, 1, 1, 0)
102 CONN_TO_STRING (PQuser)
103
104 DEFINE_PRIMITIVE ("PQ-PASS", Prim_pq_pass, 1, 1, 0)
105 CONN_TO_STRING (PQpass)
106
107 DEFINE_PRIMITIVE ("PQ-HOST", Prim_pq_host, 1, 1, 0)
108 CONN_TO_STRING (PQhost)
109
110 DEFINE_PRIMITIVE ("PQ-PORT", Prim_pq_port, 1, 1, 0)
111 CONN_TO_STRING (PQport)
112
113 DEFINE_PRIMITIVE ("PQ-TTY", Prim_pq_tty, 1, 1, 0)
114 CONN_TO_STRING (PQtty)
115
116 DEFINE_PRIMITIVE ("PQ-OPTIONS", Prim_pq_options, 1, 1, 0)
117 CONN_TO_STRING (PQoptions)
118
119 DEFINE_PRIMITIVE ("PQ-ERROR-MESSAGE", Prim_pq_error_message, 1, 1, 0)
120 CONN_TO_STRING (PQerrorMessage)
121
122 DEFINE_PRIMITIVE ("PQ-EXEC", Prim_pq_exec, 3, 3, 0)
123 {
124 PRIMITIVE_HEADER (3);
125 CHECK_ARG (3, WEAK_PAIR_P);
126 SET_PAIR_CDR ((ARG_REF (3)),
127 (ANY_TO_UINT (PQexec ((ARG_CONN (1)), (STRING_ARG (2))))));
128 PRIMITIVE_RETURN (UNSPECIFIC);
129 }
130
131 DEFINE_PRIMITIVE ("PQ-MAKE-EMPTY-PG-RESULT", Prim_pq_make_empty_pg_result,
132 3, 3, 0)
133 {
134 PRIMITIVE_HEADER (3);
135 CHECK_ARG (3, WEAK_PAIR_P);
136 SET_PAIR_CDR ((ARG_REF (3)),
137 (ANY_TO_UINT (PQmakeEmptyPGresult ((ARG_CONN (1)),
138 (ARG_EXEC_STATUS (1))))));
139 PRIMITIVE_RETURN (UNSPECIFIC);
140 }
141
142 DEFINE_PRIMITIVE ("PQ-RESULT-STATUS", Prim_pq_result_status, 1, 1, 0)
RESULT_TO_UINT(PQresultStatus)143 RESULT_TO_UINT (PQresultStatus)
144
145 DEFINE_PRIMITIVE ("PQ-RES-STATUS", Prim_pq_res_status, 1, 1, 0)
146 ONE_ARG (ARG_EXEC_STATUS, PQresStatus, char_pointer_to_string)
147
148 DEFINE_PRIMITIVE ("PQ-RESULT-ERROR-MESSAGE", Prim_pq_result_error_message,
149 1, 1, 0)
150 RESULT_TO_STRING (PQresultErrorMessage)
151
152 DEFINE_PRIMITIVE ("PQ-CLEAR", Prim_pq_clear, 1, 1, 0)
153 RESULT_TO_UNSPECIFIC (PQclear)
154
155 DEFINE_PRIMITIVE ("PQ-N-TUPLES", Prim_pq_n_tuples, 1, 1, 0)
156 RESULT_TO_INT (PQntuples)
157
158 DEFINE_PRIMITIVE ("PQ-N-FIELDS", Prim_pq_n_fields, 1, 1, 0)
159 RESULT_TO_INT (PQnfields)
160
161 DEFINE_PRIMITIVE ("PQ-FIELD-NAME", Prim_pq_fname, 2, 2, 0)
162 {
163 PRIMITIVE_HEADER (2);
164 PRIMITIVE_RETURN
165 (char_pointer_to_string (PQfname ((ARG_RESULT (1)),
166 (arg_integer (2)))));
167 }
168
169 DEFINE_PRIMITIVE ("PQ-GET-VALUE", Prim_pq_get_value, 3, 3, 0)
170 {
171 PRIMITIVE_HEADER (3);
172 PRIMITIVE_RETURN
173 (char_pointer_to_string (PQgetvalue ((ARG_RESULT (1)),
174 (arg_integer (2)),
175 (arg_integer (3)))));
176 }
177
178 DEFINE_PRIMITIVE ("PQ-GET-IS-NULL?", Prim_pq_get_is_null, 3, 3, 0)
179 {
180 PRIMITIVE_HEADER (3);
181 PRIMITIVE_RETURN
182 (BOOLEAN_TO_OBJECT (PQgetisnull ((ARG_RESULT (1)),
183 (arg_integer (2)),
184 (arg_integer (3)))));
185 }
186
187 DEFINE_PRIMITIVE ("PQ-CMD-STATUS", Prim_pq_cmd_status, 1, 1, 0)
RESULT_TO_STRING(PQcmdStatus)188 RESULT_TO_STRING (PQcmdStatus)
189
190 DEFINE_PRIMITIVE ("PQ-CMD-TUPLES", Prim_pq_cmd_tuples, 1, 1, 0)
191 RESULT_TO_STRING (PQcmdTuples)
192
193 DEFINE_PRIMITIVE ("PQ-GET-LINE", Prim_pq_get_line, 2, 2, 0)
194 {
195 PRIMITIVE_HEADER (2);
196 CHECK_ARG (2, STRING_P);
197 PRIMITIVE_RETURN
198 (long_to_integer (PQgetline ((ARG_CONN (1)),
199 (STRING_POINTER (ARG_REF (2))),
200 (STRING_LENGTH (ARG_REF (2))))));
201 }
202
203 DEFINE_PRIMITIVE ("PQ-PUT-LINE", Prim_pq_put_line, 2, 2, 0)
204 {
205 PRIMITIVE_HEADER (2);
206 CHECK_ARG (2, STRING_P);
207 PRIMITIVE_RETURN
208 (long_to_integer (PQputnbytes ((ARG_CONN (1)),
209 (STRING_POINTER (ARG_REF (2))),
210 (STRING_LENGTH (ARG_REF (2))))));
211 }
212
213 DEFINE_PRIMITIVE ("PQ-END-COPY", Prim_pq_end_copy, 1, 1, 0)
CONN_TO_INT(PQendcopy)214 CONN_TO_INT (PQendcopy)
215
216 DEFINE_PRIMITIVE ("PQ-ESCAPE-STRING", Prim_pq_escape_string, 2, 2, 0)
217 {
218 PRIMITIVE_HEADER (2);
219 CHECK_ARG (1, STRING_P);
220 PRIMITIVE_RETURN
221 (ulong_to_integer (PQescapeString ((STRING_ARG (2)),
222 (STRING_POINTER (ARG_REF (1))),
223 (STRING_LENGTH (ARG_REF (1))))));
224 }
225
226 DEFINE_PRIMITIVE ("PQ-ESCAPE-BYTEA", Prim_pq_escape_bytea, 1, 1, 0)
227 {
228 PRIMITIVE_HEADER (1);
229 CHECK_ARG (1, STRING_P);
230 {
231 size_t escaped_length;
232 unsigned char * escaped
233 = (PQescapeBytea ((STRING_BYTE_PTR (ARG_REF (1))),
234 (STRING_LENGTH (ARG_REF (1))),
235 (&escaped_length)));
236 SCHEME_OBJECT s = (memory_to_string ((escaped_length - 1), escaped));
237 PQfreemem (escaped);
238 PRIMITIVE_RETURN (s);
239 }
240 }
241
242 DEFINE_PRIMITIVE ("PQ-UNESCAPE-BYTEA", Prim_pq_unescape_bytea, 1, 1, 0)
243 {
244 PRIMITIVE_HEADER (1);
245 {
246 size_t unescaped_length;
247 unsigned char * unescaped
248 = (PQunescapeBytea (((unsigned char *) (STRING_ARG (1))),
249 (&unescaped_length)));
250 if (unescaped == 0)
251 error_bad_range_arg (1);
252 {
253 SCHEME_OBJECT s = (memory_to_string (unescaped_length, unescaped));
254 PQfreemem (unescaped);
255 PRIMITIVE_RETURN (s);
256 }
257 }
258 }
259
260 #ifdef COMPILE_AS_MODULE
261
262 char *
dload_initialize_file(void)263 dload_initialize_file (void)
264 {
265 declare_primitive ("PQ-CONNECT-DB", Prim_pq_connect_db, 2, 2, 0);
266 declare_primitive ("PQ-CONNECT-START", Prim_pq_connect_start, 2, 2, 0);
267 declare_primitive ("PQ-CONNECT-POLL", Prim_pq_connect_poll, 1, 1, 0);
268 declare_primitive ("PQ-STATUS", Prim_pq_status, 1, 1, 0);
269 declare_primitive ("PQ-FINISH", Prim_pq_finish, 1, 1, 0);
270 declare_primitive ("PQ-RESET", Prim_pq_reset, 1, 1, 0);
271 declare_primitive ("PQ-RESET-START", Prim_pq_reset_start, 1, 1, 0);
272 declare_primitive ("PQ-RESET-POLL", Prim_pq_reset_poll, 1, 1, 0);
273 declare_primitive ("PQ-DB", Prim_pq_db, 1, 1, 0);
274 declare_primitive ("PQ-USER", Prim_pq_user, 1, 1, 0);
275 declare_primitive ("PQ-PASS", Prim_pq_pass, 1, 1, 0);
276 declare_primitive ("PQ-HOST", Prim_pq_host, 1, 1, 0);
277 declare_primitive ("PQ-PORT", Prim_pq_port, 1, 1, 0);
278 declare_primitive ("PQ-TTY", Prim_pq_tty, 1, 1, 0);
279 declare_primitive ("PQ-OPTIONS", Prim_pq_options, 1, 1, 0);
280 declare_primitive ("PQ-ERROR-MESSAGE", Prim_pq_error_message, 1, 1, 0);
281 declare_primitive ("PQ-EXEC", Prim_pq_exec, 3, 3, 0);
282 declare_primitive
283 ("PQ-MAKE-EMPTY-PG-RESULT", Prim_pq_make_empty_pg_result, 3, 3, 0);
284 declare_primitive ("PQ-RESULT-STATUS", Prim_pq_result_status, 1, 1, 0);
285 declare_primitive ("PQ-RES-STATUS", Prim_pq_res_status, 1, 1, 0);
286 declare_primitive
287 ("PQ-RESULT-ERROR-MESSAGE", Prim_pq_result_error_message, 1, 1, 0);
288 declare_primitive ("PQ-CLEAR", Prim_pq_clear, 1, 1, 0);
289 declare_primitive ("PQ-N-TUPLES", Prim_pq_n_tuples, 1, 1, 0);
290 declare_primitive ("PQ-N-FIELDS", Prim_pq_n_fields, 1, 1, 0);
291 declare_primitive ("PQ-FIELD-NAME", Prim_pq_fname, 2, 2, 0);
292 declare_primitive ("PQ-GET-VALUE", Prim_pq_get_value, 3, 3, 0);
293 declare_primitive ("PQ-GET-IS-NULL?", Prim_pq_get_is_null, 3, 3, 0);
294 declare_primitive ("PQ-CMD-STATUS", Prim_pq_cmd_status, 1, 1, 0);
295 declare_primitive ("PQ-CMD-TUPLES", Prim_pq_cmd_tuples, 1, 1, 0);
296 declare_primitive ("PQ-GET-LINE", Prim_pq_get_line, 2, 2, 0);
297 declare_primitive ("PQ-PUT-LINE", Prim_pq_put_line, 2, 2, 0);
298 declare_primitive ("PQ-END-COPY", Prim_pq_end_copy, 1, 1, 0);
299 declare_primitive ("PQ-ESCAPE-STRING", Prim_pq_escape_string, 2, 2, 0);
300 declare_primitive ("PQ-ESCAPE-BYTEA", Prim_pq_escape_bytea, 1, 1, 0);
301 declare_primitive ("PQ-UNESCAPE-BYTEA", Prim_pq_unescape_bytea, 1, 1, 0);
302 return ("#prpgsql");
303 }
304
305 #endif /* COMPILE_AS_MODULE */
306