1 /*
2 * $Id: perlvdbfunc.c 816 2007-02-13 18:33:22Z bastian $
3 *
4 * Perl virtual database module interface
5 *
6 * Copyright (C) 2007 Collax GmbH
7 * (Bastian Friedrich <bastian.friedrich@collax.com>)
8 *
9 * This file is part of Kamailio, a free SIP server.
10 *
11 * Kamailio is free software; you can redistribute it and/or modify
12 * it under the terms of the GNU General Public License as published by
13 * the Free Software Foundation; either version 2 of the License, or
14 * (at your option) any later version
15 *
16 * Kamailio is distributed in the hope that it will be useful,
17 * but WITHOUT ANY WARRANTY; without even the implied warranty of
18 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 * GNU General Public License for more details.
20 *
21 * You should have received a copy of the GNU General Public License
22 * along with this program; if not, write to the Free Software
23 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
24 *
25 */
26
27 #include <string.h>
28 #include <ctype.h>
29 #include <stdio.h>
30
31 #include "db_perlvdb.h"
32 #include "perlvdbfunc.h"
33 #include "../../core/str.h"
34
35 /*
36 * Simple conversion IV -> int
37 * including decreasing ref cnt
38 */
39
IV2int(SV * in)40 long IV2int(SV *in) {
41 int ret = -1;
42
43 if (SvOK(in)) {
44 if (SvIOK(in)) {
45 ret = SvIV(in);
46 }
47 SvREFCNT_dec(in);
48 }
49
50 return ret;
51 }
52
53 /*
54 * Returns the class part of the URI
55 */
parseurl(const str * url)56 char *parseurl(const str* url) {
57 char *cn;
58
59 cn = strchr(url->s, ':') + 1;
60 if (strlen(cn) > 0)
61 return cn;
62 else
63 return NULL;
64 }
65
66
newvdbobj(const char * cn)67 SV *newvdbobj(const char* cn) {
68 SV* obj;
69 SV *class;
70
71 class = newSVpv(cn, 0);
72
73 obj = perlvdb_perlmethod(class, PERL_CONSTRUCTOR_NAME,
74 NULL, NULL, NULL, NULL);
75
76 return obj;
77 }
78
getobj(const db1_con_t * con)79 SV *getobj(const db1_con_t *con) {
80 return ((SV*)CON_TAIL(con));
81 }
82
83 /*
84 * Checks whether the passed SV is a valid VDB object:
85 * - not null
86 * - not undef
87 * - an object
88 * - derived from Kamailio::VDB
89 */
checkobj(SV * obj)90 int checkobj(SV* obj) {
91 if (obj != NULL) {
92 if (obj != &PL_sv_undef) {
93 if (sv_isobject(obj)) {
94 if (sv_derived_from(obj, PERL_VDB_BASECLASS)) {
95 return 1;
96 }
97 }
98 }
99 }
100
101 return 0;
102 }
103
104 /*
105 * Initialize database module
106 * No function should be called before this
107 */
perlvdb_db_init(const str * url)108 db1_con_t* perlvdb_db_init(const str* url) {
109 db1_con_t* res;
110
111 char *cn;
112 SV *obj = NULL;
113
114 int consize = sizeof(db1_con_t) + sizeof(SV);
115
116 if (!url) {
117 LM_ERR("invalid parameter value\n");
118 return NULL;
119 }
120
121 cn = parseurl(url);
122 if (!cn) {
123 LM_ERR("invalid perl vdb url.\n");
124 return NULL;
125 }
126
127 obj = newvdbobj(cn);
128 if (!checkobj(obj)) {
129 LM_ERR("could not initialize module. Not inheriting from %s?\n",
130 PERL_VDB_BASECLASS);
131 return NULL;
132 }
133
134 res = pkg_malloc(consize);
135 if (!res) {
136 LM_ERR("no pkg memory left\n");
137 return NULL;
138 }
139 memset(res, 0, consize);
140 CON_TAIL(res) = (unsigned int)(unsigned long)obj;
141
142 return res;
143 }
144
145
146 /*
147 * Store name of table that will be used by
148 * subsequent database functions
149 */
perlvdb_use_table(db1_con_t * h,const str * t)150 int perlvdb_use_table(db1_con_t* h, const str* t) {
151 SV *ret;
152
153 if (!h || !t || !t->s) {
154 LM_ERR("invalid parameter value\n");
155 return -1;
156 }
157
158 ret = perlvdb_perlmethod(getobj(h), PERL_VDB_USETABLEMETHOD,
159 sv_2mortal(newSVpv(t->s, t->len)), NULL, NULL, NULL);
160
161 return IV2int(ret);
162 }
163
164
perlvdb_db_close(db1_con_t * h)165 void perlvdb_db_close(db1_con_t* h) {
166 if (!h) {
167 LM_ERR("invalid parameter value\n");
168 return;
169 }
170
171 pkg_free(h);
172 }
173
174
175 /*
176 * Insert a row into specified table
177 * h: structure representing database connection
178 * k: key names
179 * v: values of the keys
180 * n: number of key=value pairs
181 */
perlvdb_db_insertreplace(const db1_con_t * h,const db_key_t * k,const db_val_t * v,const int n,char * insertreplace)182 int perlvdb_db_insertreplace(const db1_con_t* h, const db_key_t* k, const db_val_t* v,
183 const int n, char *insertreplace) {
184 AV *arr;
185 SV *arrref;
186 SV *ret;
187
188 arr = pairs2perlarray(k, v, n);
189 arrref = newRV_noinc((SV*)arr);
190 ret = perlvdb_perlmethod(getobj(h), insertreplace,
191 arrref, NULL, NULL, NULL);
192
193 av_undef(arr);
194
195 return IV2int(ret);
196 }
197
perlvdb_db_insert(const db1_con_t * h,const db_key_t * k,const db_val_t * v,const int n)198 int perlvdb_db_insert(const db1_con_t* h, const db_key_t* k, const db_val_t* v, const int n) {
199 return perlvdb_db_insertreplace(h, k, v, n, PERL_VDB_INSERTMETHOD);
200 }
201
202 /*
203 * Just like insert, but replace the row if it exists
204 */
perlvdb_db_replace(const db1_con_t * h,const db_key_t * k,const db_val_t * v,const int n,const int un,const int m)205 int perlvdb_db_replace(const db1_con_t* h, const db_key_t* k, const db_val_t* v,
206 const int n, const int un, const int m) {
207 return perlvdb_db_insertreplace(h, k, v, n, PERL_VDB_REPLACEMETHOD);
208 }
209
210 /*
211 * Delete a row from the specified table
212 * h: structure representing database connection
213 * k: key names
214 * o: operators
215 * v: values of the keys that must match
216 * n: number of key=value pairs
217 */
perlvdb_db_delete(const db1_con_t * h,const db_key_t * k,const db_op_t * o,const db_val_t * v,const int n)218 int perlvdb_db_delete(const db1_con_t* h, const db_key_t* k, const db_op_t* o,
219 const db_val_t* v, const int n) {
220 AV *arr;
221 SV *arrref;
222 SV *ret;
223
224 arr = conds2perlarray(k, o, v, n);
225 arrref = newRV_noinc((SV*)arr);
226 ret = perlvdb_perlmethod(getobj(h), PERL_VDB_DELETEMETHOD,
227 arrref, NULL, NULL, NULL);
228
229 av_undef(arr);
230
231 return IV2int(ret);
232 }
233
234
235 /*
236 * Update some rows in the specified table
237 * _h: structure representing database connection
238 * _k: key names
239 * _o: operators
240 * _v: values of the keys that must match
241 * _uk: updated columns
242 * _uv: updated values of the columns
243 * _n: number of key=value pairs
244 * _un: number of columns to update
245 */
perlvdb_db_update(const db1_con_t * h,const db_key_t * k,const db_op_t * o,const db_val_t * v,const db_key_t * uk,const db_val_t * uv,const int n,const int un)246 int perlvdb_db_update(const db1_con_t* h, const db_key_t* k, const db_op_t* o,
247 const db_val_t* v, const db_key_t* uk, const db_val_t* uv,
248 const int n, const int un) {
249
250 AV *condarr;
251 AV *updatearr;
252
253 SV *condarrref;
254 SV *updatearrref;
255
256 SV *ret;
257
258 condarr = conds2perlarray(k, o, v, n);
259 updatearr = pairs2perlarray(uk, uv, un);
260
261 condarrref = newRV_noinc((SV*)condarr);
262 updatearrref = newRV_noinc((SV*)updatearr);
263
264 ret = perlvdb_perlmethod(getobj(h), PERL_VDB_UPDATEMETHOD,
265 condarrref, updatearrref, NULL, NULL);
266
267 av_undef(condarr);
268 av_undef(updatearr);
269
270 return IV2int(ret);
271 }
272
273
274 /*
275 * Query table for specified rows
276 * h: structure representing database connection
277 * k: key names
278 * op: operators
279 * v: values of the keys that must match
280 * c: column names to return
281 * n: number of key=values pairs to compare
282 * nc: number of columns to return
283 * o: order by the specified column
284 */
perlvdb_db_query(const db1_con_t * h,const db_key_t * k,const db_op_t * op,const db_val_t * v,const db_key_t * c,const int n,const int nc,const db_key_t o,db1_res_t ** r)285 int perlvdb_db_query(const db1_con_t* h, const db_key_t* k, const db_op_t* op,
286 const db_val_t* v, const db_key_t* c, const int n, const int nc,
287 const db_key_t o, db1_res_t** r) {
288
289
290 AV *condarr;
291 AV *retkeysarr;
292 SV *order;
293
294 SV *condarrref;
295 SV *retkeysref;
296
297 SV *resultset;
298
299 int retval = 0;
300
301 /* Create parameter set */
302 condarr = conds2perlarray(k, op, v, n);
303 retkeysarr = keys2perlarray(c, nc);
304
305 if (o) order = newSVpv(o->s, o->len);
306 else order = &PL_sv_undef;
307
308
309 condarrref = newRV_noinc((SV*)condarr);
310 retkeysref = newRV_noinc((SV*)retkeysarr);
311
312 /* Call perl method */
313 resultset = perlvdb_perlmethod(getobj(h), PERL_VDB_QUERYMETHOD,
314 condarrref, retkeysref, order, NULL);
315
316 av_undef(condarr);
317 av_undef(retkeysarr);
318
319 /* Transform perl result set to Kamailio result set */
320 if (!resultset) {
321 /* No results. */
322 LM_ERR("no perl result set.\n");
323 retval = -1;
324 } else {
325 if (sv_isa(resultset, "Kamailio::VDB::Result")) {
326 retval = perlresult2dbres(resultset, r);
327 /* Nested refs are decreased/deleted inside the routine */
328 SvREFCNT_dec(resultset);
329 } else {
330 LM_ERR("invalid result set retrieved from perl call.\n");
331 retval = -1;
332 }
333 }
334
335 return retval;
336 }
337
338
339 /*
340 * Release a result set from memory
341 */
perlvdb_db_free_result(db1_con_t * _h,db1_res_t * _r)342 int perlvdb_db_free_result(db1_con_t* _h, db1_res_t* _r) {
343 int i;
344
345 if (_r) {
346 for (i = 0; i < _r->n; i++) {
347 if (_r->rows[i].values)
348 pkg_free(_r->rows[i].values);
349 }
350
351 if (_r->col.types)
352 pkg_free(_r->col.types);
353 if (_r->col.names)
354 pkg_free(_r->col.names);
355 if (_r->rows)
356 pkg_free(_r->rows);
357 pkg_free(_r);
358 }
359 return 0;
360 }
361