ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/PApp-SQL/SQL.xs
Revision: 1.20
Committed: Sat Jun 20 21:29:29 2009 UTC (14 years, 11 months ago) by root
Branch: MAIN
Changes since 1.19: +5 -1 lines
Log Message:
*** empty log message ***

File Contents

# Content
1 #include "EXTERN.h"
2 #include "perl.h"
3 #include "XSUB.h"
4
5 #if (PERL_VERSION < 5) || ((PERL_VERSION == 5) && (PERL_SUBVERSION <= 6))
6 # define get_sv perl_get_sv
7 # define call_method perl_call_method
8 # define call_sv perl_call_sv
9 #endif
10
11 #if (PERL_VERSION > 5) || ((PERL_VERSION == 5) && (PERL_SUBVERSION >= 6))
12 # define CAN_UTF8 1
13 #endif
14
15 #define MAX_CACHED_STATEMENT_SIZE 8192
16
17 static SV *
18 sql_upgrade_utf8 (SV *sv)
19 {
20 #if CAN_UTF8
21 if (SvPOK (sv))
22 sv_utf8_upgrade (sv);
23 #endif
24 return sv;
25 }
26
27 static SV *
28 mortalcopy_and_maybe_force_utf8(int utf8, SV *sv)
29 {
30 sv = sv_mortalcopy (sv);
31 #if CAN_UTF8
32 if (utf8 && SvPOK (sv))
33 SvUTF8_on (sv);
34 #endif
35 return sv;
36 }
37
38 #define maybe_upgrade_utf8(utf8,sv) ((utf8) ? sql_upgrade_utf8 (sv) : (sv))
39
40 #define is_dbh(sv) ((sv) && sv_isobject (sv) && sv_derived_from ((sv), "DBI::db"))
41
42 typedef struct lru_node {
43 struct lru_node *next;
44 struct lru_node *prev;
45 U32 hash;
46 SV *dbh;
47 SV *sql;
48
49 SV *sth;
50 #if 0 /* method cache */
51 GV *execute;
52 GV *bind_columns;
53 GV *fetch;
54 GV *finish;
55 #endif
56 } lru_node;
57
58 static lru_node lru_list;
59 static int lru_size;
60 static int lru_maxsize;
61
62 #define lru_init lru_list.next = &lru_list; lru_list.prev = &lru_list /* other fields are zero */
63
64 /* this is primitive, yet effective */
65 /* the returned value must never be zero (or bad things will happen) */
66 #define lru_hash do { \
67 hash = (((U32)(long)dbh)>>2); \
68 hash += *statement;\
69 hash += len; \
70 } while (0)
71
72 /* fetch and "use" */
73 /* could be done using a single call (we could call prepare!) */
74 static SV *lru_fetch(SV *dbh, SV *sql)
75 {
76 lru_node *n;
77
78 U32 hash;
79 STRLEN len;
80 char *statement = SvPV (sql, len);
81
82 dbh = SvRV (dbh);
83
84 lru_hash;
85
86 n = &lru_list;
87 do {
88 n = n->next;
89 if (!n->hash)
90 return 0;
91 } while (n->hash != hash
92 || !sv_eq (n->sql, sql)
93 || n->dbh != dbh);
94
95 /* found, so return to the start of the list */
96 n->prev->next = n->next;
97 n->next->prev = n->prev;
98
99 n->next = lru_list.next;
100 n->prev = &lru_list;
101 lru_list.next->prev = n;
102 lru_list.next = n;
103
104 return n->sth;
105 }
106
107 static void lru_nukeone(void)
108 {
109 lru_node *n;
110 /* nuke at the end */
111
112 n = lru_list.prev;
113
114 lru_list.prev = n->prev;
115 n->prev->next = &lru_list;
116
117 SvREFCNT_dec (n->dbh);
118 SvREFCNT_dec (n->sql);
119 SvREFCNT_dec (n->sth);
120 Safefree (n);
121
122 lru_size--;
123 }
124
125 /* store a not-yet existing entry(!) */
126 static void lru_store(SV *dbh, SV *sql, SV *sth)
127 {
128 lru_node *n;
129
130 U32 hash;
131 STRLEN len;
132 char *statement = SvPV (sql, len);
133
134 dbh = SvRV (dbh);
135
136 lru_hash;
137
138 lru_size++;
139 if (lru_size > lru_maxsize)
140 lru_nukeone ();
141
142 New (0, n, 1, lru_node);
143
144 n->hash = hash;
145 n->dbh = dbh; SvREFCNT_inc (dbh); /* note: this is the dbi hash itself, not the reference */
146 n->sql = newSVsv (sql);
147 n->sth = sth; SvREFCNT_inc (sth);
148
149 n->next = lru_list.next;
150 n->prev = &lru_list;
151 lru_list.next->prev = n;
152 lru_list.next = n;
153 }
154
155 static void lru_cachesize (int size)
156 {
157 if (size >= 0)
158 {
159 lru_maxsize = size;
160 while (lru_size > lru_maxsize)
161 lru_nukeone ();
162 }
163 }
164
165 static GV *sql_exec;
166 static GV *DBH;
167 static SV *sv_prepare, *sv_execute, *sv_bind_columns,
168 *sv_fetchrow_arrayref, *sv_fetchall_arrayref,
169 *sv_finish;
170
171 #define newconstpv(str) newSVpvn ((str), sizeof (str))
172
173 MODULE = PApp::SQL PACKAGE = PApp::SQL
174
175 PROTOTYPES: DISABLE
176
177 BOOT:
178 {
179 sql_exec = gv_fetchpv ("PApp::SQL::sql_exec", TRUE, SVt_PV);
180 DBH = gv_fetchpv ("PApp::SQL::DBH" , TRUE, SVt_PV);
181
182 if (!sv_prepare)
183 {
184 sv_prepare = newconstpv ("prepare");
185 sv_execute = newconstpv ("execute");
186 sv_bind_columns = newconstpv ("bind_columns");
187 sv_fetchrow_arrayref = newconstpv ("fetchrow_arrayref");
188 sv_fetchall_arrayref = newconstpv ("fetchall_arrayref");
189 sv_finish = newconstpv ("finish");
190 }
191
192 /* apache might BOOT: twice :( */
193 if (lru_size)
194 lru_cachesize (0);
195
196 lru_init;
197 lru_cachesize (50);
198 }
199
200 int
201 cachesize(size = -1)
202 int size
203 CODE:
204 RETVAL = lru_maxsize;
205 lru_cachesize (size);
206 OUTPUT:
207 RETVAL
208
209 void
210 sql_exec(...)
211 ALIAS:
212 sql_uexec = 1
213 sql_fetch = 2
214 sql_ufetch = 3
215 sql_fetchall = 4
216 sql_ufetchall = 5
217 sql_exists = 6
218 sql_uexists = 7
219 PPCODE:
220 {
221 if (items == 0)
222 croak ("Usage: sql_exec [database-handle,] [bind-var-refs,... ] \"sql-statement\", [arguments, ...]");
223 else
224 {
225 int arg = 0;
226 int bind_first, bind_last;
227 int count;
228 SV *dbh = ST(0);
229 SV *sth;
230 SV *sql;
231 SV *execute;
232 STRLEN dc, dd; /* dummy */
233
234 /* save our arguments against destruction through function calls */
235 SP += items;
236
237 /* first check wether we should use an explicit db handle */
238 if (!is_dbh (dbh))
239 {
240 /* the next line doesn't work - check why later maybe */
241 /* dbh = get_sv ("DBH", FALSE);
242 if (!is_dbh (dbh))
243 {*/
244 dbh = GvSV (DBH);
245 if (!is_dbh (dbh))
246 croak ("sql_exec: no $DBH argument and no fallback in $PApp::SQL::DBH");
247 /*croak ("sql_exec: no $DBH found in current package or in PApp::SQL::");
248 }*/
249 }
250 else
251 arg++; /* we consumed one argument */
252
253 /* be more Coro-friendly by keeping a copy, so different threads */
254 /* can multitask easier */
255 dbh = sv_2mortal (newSVsv (dbh));
256
257 /* count the remaining references (for bind_columns) */
258 bind_first = arg;
259 while (items > arg && SvROK (ST(arg)))
260 arg++;
261
262 bind_last = arg;
263
264 /* consume the sql-statement itself */
265 if (items <= arg)
266 croak ("sql_exec: required argument \"sql-statement\" missing");
267
268 if (!SvPOK (ST(arg)))
269 croak ("sql_exec: sql-statement must be a string");
270
271 sql = ST(arg); arg++;
272
273 if ((ix & ~1) == 6)
274 {
275 SV *neu = sv_2mortal (newSVpv ("select count(*) > 0 from ", 0));
276 sv_catsv (neu, sql);
277 sv_catpv (neu, " limit 1");
278 sql = neu;
279 ix -= 4; /* sql_fetch */
280 }
281
282 /* check cache for existing statement handle */
283 sth = lru_fetch (dbh, sql);
284 if (!sth)
285 {
286 PUSHMARK (SP);
287 EXTEND (SP, 2);
288 PUSHs (dbh);
289 PUSHs (sql);
290 PUTBACK;
291 count = call_sv (sv_prepare, G_METHOD | G_SCALAR);
292 SPAGAIN;
293
294 if (count != 1)
295 croak ("sql_exec: unable to prepare() statement '%s': %s",
296 SvPV (sql, dc),
297 SvPV (get_sv ("DBI::errstr", TRUE), dd));
298
299 sth = POPs;
300
301 if (SvLEN (sql) < MAX_CACHED_STATEMENT_SIZE)
302 lru_store (dbh, sql, sth);
303 }
304
305 PUSHMARK (SP);
306 EXTEND (SP, items - arg + 1);
307 PUSHs (sth);
308 while (items > arg)
309 {
310 SV *sv = ST(arg);
311 /* we sv_mortalcopy magical values since DBI seems to have a memory
312 * leak when magical values are passed into execute().
313 */
314 PUSHs (maybe_upgrade_utf8 (ix & 1, SvMAGICAL(sv) ? sv_mortalcopy(sv) : sv));
315 arg++;
316 }
317
318 PUTBACK;
319 /* { static GV *execute;
320 if (!execute) execute = gv_fetchmethod_autoload(SvSTASH(SvRV(sth)), "execute", 0);
321 count = call_sv(GvCV(execute), G_SCALAR);
322 }*/
323 count = call_sv (sv_execute, G_METHOD | G_SCALAR);
324 SPAGAIN;
325
326 if (count != 1)
327 croak ("sql_exec: execute() didn't return any value ('%s'): %s",
328 SvPV (sql, dc),
329 SvPV (get_sv ("DBI::errstr", TRUE), dd));
330
331 execute = POPs;
332
333 if (!SvTRUE (execute))
334 croak ("sql_exec: unable to execute statement '%s' (%s)",
335 SvPV (sql, dc),
336 SvPV (get_sv ("DBI::errstr", TRUE), dd));
337
338 sv_setsv (GvSV(sql_exec), execute);
339
340 if (bind_first != bind_last)
341 {
342 PUSHMARK (SP);
343 EXTEND (SP, bind_last - bind_first + 2);
344 PUSHs (sth);
345 do {
346 #if CAN_UTF8
347 if (ix & 1)
348 SvUTF8_on (SvRV(ST(bind_first)));
349 #endif
350 PUSHs (ST(bind_first));
351 bind_first++;
352 } while (bind_first != bind_last);
353
354 PUTBACK;
355 count = call_sv (sv_bind_columns, G_METHOD | G_SCALAR);
356 SPAGAIN;
357
358 if (count != 1)
359 croak ("sql_exec: bind_columns() didn't return any value ('%s'): %s",
360 SvPV (sql, dc),
361 SvPV (get_sv ("DBI::errstr", TRUE), dd));
362
363 if (!SvOK (TOPs))
364 croak ("sql_exec: bind_columns() didn't return a true ('%s'): %s",
365 SvPV (sql, dc),
366 SvPV (get_sv ("DBI::errstr", TRUE), dd));
367
368 POPs;
369 }
370
371 /* restore our arguments again */
372 SP -= items;
373
374 if ((ix & ~1) == 2)
375 { /* sql_fetch */
376 SV *row;
377
378 PUSHMARK (SP);
379 XPUSHs (sth);
380 PUTBACK;
381 count = call_sv (sv_fetchrow_arrayref, G_METHOD | G_SCALAR);
382 SPAGAIN;
383
384 if (count != 1)
385 abort ();
386
387 row = POPs;
388
389 if (SvROK (row))
390 {
391 AV *av;
392
393 switch (GIMME_V)
394 {
395 case G_VOID:
396 /* no thing */
397 break;
398 case G_SCALAR:
399 /* the first element */
400 XPUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, *av_fetch ((AV *)SvRV (row), 0, 1)));
401 break;
402 case G_ARRAY:
403 av = (AV *)SvRV (row);
404 count = AvFILL (av) + 1;
405 EXTEND (SP, count);
406 for (arg = 0; arg < count; arg++)
407 PUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY (av)[arg]));
408
409 break;
410 default:
411 abort ();
412 }
413 }
414 }
415 else if ((ix & ~1) == 4)
416 { /* sql_fetchall */
417 SV *rows;
418
419 PUSHMARK (SP);
420 XPUSHs (sth);
421 PUTBACK;
422 count = call_sv (sv_fetchall_arrayref, G_METHOD | G_SCALAR);
423 SPAGAIN;
424
425 if (count != 1)
426 abort ();
427
428 rows = POPs;
429
430 if (SvROK (rows))
431 {
432 AV *av = (AV *)SvRV (rows);
433 count = AvFILL (av) + 1;
434
435 if (count)
436 {
437 int columns = AvFILL ((AV *) SvRV (AvARRAY (av)[0])) + 1; /* columns? */
438
439 EXTEND (SP, count);
440 if (columns == 1)
441 for (arg = 0; arg < count; arg++)
442 PUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY ((AV *)SvRV (AvARRAY (av)[arg]))[0]));
443 else
444 for (arg = 0; arg < count; arg++)
445 PUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY (av)[arg]));
446 }
447 }
448 }
449 else
450 XPUSHs (sth);
451
452 if (ix > 1 || GIMME_V == G_VOID)
453 {
454 PUSHMARK (SP);
455 XPUSHs (sth);
456 PUTBACK;
457 (void) call_sv (sv_finish, G_METHOD | G_DISCARD);
458 SPAGAIN;
459 }
460 }
461 }
462
463
464