… | |
… | |
6 | # define get_sv perl_get_sv |
6 | # define get_sv perl_get_sv |
7 | # define call_method perl_call_method |
7 | # define call_method perl_call_method |
8 | # define call_sv perl_call_sv |
8 | # define call_sv perl_call_sv |
9 | #endif |
9 | #endif |
10 | |
10 | |
11 | #if (PERL_VERSION < 5) || ((PERL_VERSION == 5) && (PERL_SUBVERSION <= 5)) |
11 | #if (PERL_VERSION > 5) || ((PERL_VERSION == 5) && (PERL_SUBVERSION >= 6)) |
12 | # define CAN_UTF8 1 |
12 | # define CAN_UTF8 1 |
13 | #endif |
13 | #endif |
|
|
14 | |
|
|
15 | #define MAX_CACHED_STATEMENT_SIZE 8192 |
14 | |
16 | |
15 | static SV * |
17 | static SV * |
16 | sql_upgrade_utf8 (SV *sv) |
18 | sql_upgrade_utf8 (SV *sv) |
17 | { |
19 | { |
18 | #if CAN_UTF8 |
20 | #if CAN_UTF8 |
… | |
… | |
21 | #endif |
23 | #endif |
22 | return sv; |
24 | return sv; |
23 | } |
25 | } |
24 | |
26 | |
25 | static SV * |
27 | static SV * |
26 | sql_force_utf8 (SV *sv) |
28 | mortalcopy_and_maybe_force_utf8(int utf8, SV *sv) |
27 | { |
29 | { |
|
|
30 | sv = sv_mortalcopy (sv); |
28 | #if CAN_UTF8 |
31 | #if CAN_UTF8 |
29 | if (SvPOK (sv)) |
32 | if (utf8 && SvPOK (sv)) |
30 | SvUTF8_on (sv); |
33 | SvUTF8_on (sv); |
31 | #endif |
34 | #endif |
32 | return sv; |
35 | return sv; |
33 | } |
36 | } |
34 | |
37 | |
35 | #define maybe_upgrade_utf8(utf8,sv) ((utf8) ? sql_upgrade_utf8 (sv) : (sv)) |
38 | #define maybe_upgrade_utf8(utf8,sv) ((utf8) ? sql_upgrade_utf8 (sv) : (sv)) |
36 | #define maybe_force_utf8(utf8,sv) ((utf8) ? sql_force_utf8 (sv) : (sv)) |
|
|
37 | |
39 | |
38 | #define is_dbh(sv) ((sv) && sv_isobject (sv) && sv_derived_from ((sv), "DBI::db")) |
40 | #define is_dbh(sv) ((sv) && sv_isobject (sv) && sv_derived_from ((sv), "DBI::db")) |
39 | |
41 | |
40 | typedef struct lru_node { |
42 | typedef struct lru_node { |
41 | struct lru_node *next; |
43 | struct lru_node *next; |
… | |
… | |
60 | #define lru_init lru_list.next = &lru_list; lru_list.prev = &lru_list /* other fields are zero */ |
62 | #define lru_init lru_list.next = &lru_list; lru_list.prev = &lru_list /* other fields are zero */ |
61 | |
63 | |
62 | /* this is primitive, yet effective */ |
64 | /* this is primitive, yet effective */ |
63 | /* the returned value must never be zero (or bad things will happen) */ |
65 | /* the returned value must never be zero (or bad things will happen) */ |
64 | #define lru_hash do { \ |
66 | #define lru_hash do { \ |
65 | hash = (((U32)dbh)>>2); \ |
67 | hash = (((U32)(long)dbh)>>2); \ |
66 | hash += *statement;\ |
68 | hash += *statement;\ |
67 | hash += len; \ |
69 | hash += len; \ |
68 | } while (0) |
70 | } while (0) |
69 | |
71 | |
70 | /* fetch and "use" */ |
72 | /* fetch and "use" */ |
… | |
… | |
78 | char *statement = SvPV (sql, len); |
80 | char *statement = SvPV (sql, len); |
79 | |
81 | |
80 | dbh = SvRV (dbh); |
82 | dbh = SvRV (dbh); |
81 | |
83 | |
82 | lru_hash; |
84 | lru_hash; |
83 | |
|
|
84 | /*fprintf (stderr, "F: %08lx %s\n", hash, SvPV_nolen (sql));/*D*/ |
|
|
85 | |
85 | |
86 | n = &lru_list; |
86 | n = &lru_list; |
87 | do { |
87 | do { |
88 | n = n->next; |
88 | n = n->next; |
89 | if (!n->hash) |
89 | if (!n->hash) |
… | |
… | |
112 | n = lru_list.prev; |
112 | n = lru_list.prev; |
113 | |
113 | |
114 | lru_list.prev = n->prev; |
114 | lru_list.prev = n->prev; |
115 | n->prev->next = &lru_list; |
115 | n->prev->next = &lru_list; |
116 | |
116 | |
117 | /*fprintf (stderr, "N: %s\n", SvPV_nolen (n->sql));/*D*/ |
|
|
118 | |
|
|
119 | SvREFCNT_dec (n->dbh); |
117 | SvREFCNT_dec (n->dbh); |
120 | SvREFCNT_dec (n->sql); |
118 | SvREFCNT_dec (n->sql); |
121 | SvREFCNT_dec (n->sth); |
119 | SvREFCNT_dec (n->sth); |
122 | Safefree (n); |
120 | Safefree (n); |
123 | |
121 | |
… | |
… | |
134 | char *statement = SvPV (sql, len); |
132 | char *statement = SvPV (sql, len); |
135 | |
133 | |
136 | dbh = SvRV (dbh); |
134 | dbh = SvRV (dbh); |
137 | |
135 | |
138 | lru_hash; |
136 | lru_hash; |
139 | |
|
|
140 | /*fprintf (stderr, "S: %08lx %s\n", hash, SvPV_nolen (sql));/*D*/ |
|
|
141 | |
137 | |
142 | lru_size++; |
138 | lru_size++; |
143 | if (lru_size > lru_maxsize) |
139 | if (lru_size > lru_maxsize) |
144 | lru_nukeone (); |
140 | lru_nukeone (); |
145 | |
141 | |
… | |
… | |
231 | int count; |
227 | int count; |
232 | SV *dbh = ST(0); |
228 | SV *dbh = ST(0); |
233 | SV *sth; |
229 | SV *sth; |
234 | SV *sql; |
230 | SV *sql; |
235 | SV *execute; |
231 | SV *execute; |
236 | STRLEN dc; |
232 | STRLEN dc, dd; /* dummy */ |
237 | |
233 | |
238 | /* save our arguments against destruction through function calls */ |
234 | /* save our arguments against destruction through function calls */ |
239 | SP += items; |
235 | SP += items; |
240 | |
236 | |
241 | /* first check wether we should use an explicit db handle */ |
237 | /* first check wether we should use an explicit db handle */ |
242 | if (!is_dbh (dbh)) |
238 | if (!is_dbh (dbh)) |
243 | { |
239 | { |
|
|
240 | /* the next line doesn't work - check why later maybe */ |
244 | dbh = get_sv ("DBH", FALSE); |
241 | /* dbh = get_sv ("DBH", FALSE); |
245 | if (!is_dbh (dbh)) |
242 | if (!is_dbh (dbh)) |
246 | { |
243 | {*/ |
247 | dbh = GvSV(DBH); |
244 | dbh = GvSV(DBH); |
248 | if (!is_dbh (dbh)) |
245 | if (!is_dbh (dbh)) |
|
|
246 | croak ("sql_exec: no $DBH argument and no fallback in $PApp::SQL::DBH"); |
249 | croak ("sql_exec: no $DBH found in current package or in PApp::SQL::"); |
247 | /*croak ("sql_exec: no $DBH found in current package or in PApp::SQL::"); |
250 | } |
248 | }*/ |
251 | } |
249 | } |
252 | else |
250 | else |
253 | arg++; /* we consumed one argument */ |
251 | arg++; /* we consumed one argument */ |
254 | |
252 | |
255 | /* count the remaining references (for bind_columns) */ |
253 | /* count the remaining references (for bind_columns) */ |
… | |
… | |
272 | { |
270 | { |
273 | SV *neu = sv_2mortal (newSVpv ("select count(*) > 0 from ", 0)); |
271 | SV *neu = sv_2mortal (newSVpv ("select count(*) > 0 from ", 0)); |
274 | sv_catsv (neu, sql); |
272 | sv_catsv (neu, sql); |
275 | sv_catpv (neu, " limit 1"); |
273 | sv_catpv (neu, " limit 1"); |
276 | sql = neu; |
274 | sql = neu; |
277 | ix -= 6; /* sql_fetch */ |
275 | ix -= 4; /* sql_fetch */ |
278 | } |
276 | } |
279 | |
277 | |
280 | /* check cache for existing statement handle */ |
278 | /* check cache for existing statement handle */ |
281 | sth = lru_fetch (dbh, sql); |
279 | sth = lru_fetch (dbh, sql); |
282 | if (!sth) |
280 | if (!sth) |
… | |
… | |
290 | SPAGAIN; |
288 | SPAGAIN; |
291 | |
289 | |
292 | if (count != 1) |
290 | if (count != 1) |
293 | croak ("sql_exec: unable to prepare() statement '%s': %s", |
291 | croak ("sql_exec: unable to prepare() statement '%s': %s", |
294 | SvPV (sql, dc), |
292 | SvPV (sql, dc), |
295 | SvPV (get_sv ("DBI::errstr", TRUE), dc)); |
293 | SvPV (get_sv ("DBI::errstr", TRUE), dd)); |
296 | |
294 | |
297 | sth = POPs; |
295 | sth = POPs; |
298 | |
296 | |
|
|
297 | if (SvLEN (sql) < MAX_CACHED_STATEMENT_SIZE) |
299 | lru_store (dbh, sql, sth); |
298 | lru_store (dbh, sql, sth); |
300 | } |
299 | } |
301 | |
300 | |
302 | PUSHMARK (SP); |
301 | PUSHMARK (SP); |
303 | EXTEND (SP, items - arg + 1); |
302 | EXTEND (SP, items - arg + 1); |
304 | PUSHs (sth); |
303 | PUSHs (sth); |
305 | while (items > arg) |
304 | while (items > arg) |
306 | { |
305 | { |
|
|
306 | SV *sv = ST(arg); |
|
|
307 | /* we sv_mortalcopy magical values since DBI seems to have a memory |
|
|
308 | * leak when magical values are passed into execute(). |
|
|
309 | */ |
307 | PUSHs (maybe_upgrade_utf8 (ix & 1, ST(arg))); |
310 | PUSHs (maybe_upgrade_utf8 (ix & 1, SvMAGICAL(sv) ? sv_mortalcopy(sv) : sv)); |
308 | arg++; |
311 | arg++; |
309 | } |
312 | } |
310 | |
313 | |
311 | PUTBACK; |
314 | PUTBACK; |
312 | /* { static GV *execute; |
315 | /* { static GV *execute; |
… | |
… | |
317 | SPAGAIN; |
320 | SPAGAIN; |
318 | |
321 | |
319 | if (count != 1) |
322 | if (count != 1) |
320 | croak ("sql_exec: execute() didn't return any value ('%s'): %s", |
323 | croak ("sql_exec: execute() didn't return any value ('%s'): %s", |
321 | SvPV (sql, dc), |
324 | SvPV (sql, dc), |
322 | SvPV (get_sv ("DBI::errstr", TRUE), dc)); |
325 | SvPV (get_sv ("DBI::errstr", TRUE), dd)); |
323 | |
326 | |
324 | execute = POPs; |
327 | execute = POPs; |
325 | |
328 | |
326 | if (!SvTRUE (execute)) |
329 | if (!SvTRUE (execute)) |
327 | croak ("sql_exec: unable to execute statement '%s' (%s)", |
330 | croak ("sql_exec: unable to execute statement '%s' (%s)", |
328 | SvPV (sql, dc), |
331 | SvPV (sql, dc), |
329 | SvPV (get_sv ("DBI::errstr", TRUE), dc)); |
332 | SvPV (get_sv ("DBI::errstr", TRUE), dd)); |
330 | |
333 | |
331 | sv_setsv (GvSV(sql_exec), execute); |
334 | sv_setsv (GvSV(sql_exec), execute); |
332 | |
335 | |
333 | if (bind_first != bind_last) |
336 | if (bind_first != bind_last) |
334 | { |
337 | { |
335 | PUSHMARK (SP); |
338 | PUSHMARK (SP); |
336 | EXTEND (SP, bind_last - bind_first + 2); |
339 | EXTEND (SP, bind_last - bind_first + 2); |
337 | PUSHs (sth); |
340 | PUSHs (sth); |
338 | do { |
341 | do { |
|
|
342 | #if CAN_UTF8 |
|
|
343 | if (ix & 1) |
|
|
344 | SvUTF8_on (SvRV(ST(bind_first))); |
|
|
345 | #endif |
339 | PUSHs (ST(bind_first)); |
346 | PUSHs (ST(bind_first)); |
340 | bind_first++; |
347 | bind_first++; |
341 | } while (bind_first != bind_last); |
348 | } while (bind_first != bind_last); |
342 | |
349 | |
343 | PUTBACK; |
350 | PUTBACK; |
… | |
… | |
345 | SPAGAIN; |
352 | SPAGAIN; |
346 | |
353 | |
347 | if (count != 1) |
354 | if (count != 1) |
348 | croak ("sql_exec: bind_columns() didn't return any value ('%s'): %s", |
355 | croak ("sql_exec: bind_columns() didn't return any value ('%s'): %s", |
349 | SvPV (sql, dc), |
356 | SvPV (sql, dc), |
350 | SvPV (get_sv ("DBI::errstr", TRUE), dc)); |
357 | SvPV (get_sv ("DBI::errstr", TRUE), dd)); |
351 | |
358 | |
352 | if (!SvOK (POPs)) |
359 | if (!SvOK (TOPs)) |
353 | croak ("sql_exec: bind_columns() didn't return a true ('%s'): %s", |
360 | croak ("sql_exec: bind_columns() didn't return a true ('%s'): %s", |
354 | SvPV (sql, dc), |
361 | SvPV (sql, dc), |
355 | SvPV (get_sv ("DBI::errstr", TRUE), dc)); |
362 | SvPV (get_sv ("DBI::errstr", TRUE), dd)); |
|
|
363 | |
356 | } |
364 | POPs; |
|
|
365 | } |
357 | |
366 | |
358 | /* free our arguments from the stack */ |
367 | /* restore our arguments again */ |
359 | SP -= items; |
368 | SP -= items; |
360 | |
369 | |
361 | if ((ix & ~1) == 2) |
370 | if ((ix & ~1) == 2) |
362 | { /* sql_fetch */ |
371 | { /* sql_fetch */ |
363 | SV *row; |
372 | SV *row; |
… | |
… | |
382 | case G_VOID: |
391 | case G_VOID: |
383 | /* no thing */ |
392 | /* no thing */ |
384 | break; |
393 | break; |
385 | case G_SCALAR: |
394 | case G_SCALAR: |
386 | /* the first element */ |
395 | /* the first element */ |
387 | XPUSHs (maybe_force_utf8 (ix & 1, *av_fetch ((AV *)SvRV (row), 0, 1))); |
396 | XPUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, *av_fetch ((AV *)SvRV (row), 0, 1))); |
388 | break; |
397 | break; |
389 | case G_ARRAY: |
398 | case G_ARRAY: |
390 | av = (AV *)SvRV (row); |
399 | av = (AV *)SvRV (row); |
391 | count = AvFILL (av) + 1; |
400 | count = AvFILL (av) + 1; |
392 | EXTEND (SP, count); |
401 | EXTEND (SP, count); |
393 | for (arg = 0; arg < count; arg++) |
402 | for (arg = 0; arg < count; arg++) |
394 | PUSHs (maybe_force_utf8 (ix & 1, AvARRAY (av)[arg])); |
403 | PUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY (av)[arg])); |
395 | |
404 | |
396 | break; |
405 | break; |
397 | default: |
406 | default: |
398 | abort (); |
407 | abort (); |
399 | } |
408 | } |
… | |
… | |
424 | int columns = AvFILL ((AV *) SvRV (AvARRAY (av)[0])) + 1; /* columns? */ |
433 | int columns = AvFILL ((AV *) SvRV (AvARRAY (av)[0])) + 1; /* columns? */ |
425 | |
434 | |
426 | EXTEND (SP, count); |
435 | EXTEND (SP, count); |
427 | if (columns == 1) |
436 | if (columns == 1) |
428 | for (arg = 0; arg < count; arg++) |
437 | for (arg = 0; arg < count; arg++) |
429 | PUSHs (maybe_force_utf8 (ix & 1, AvARRAY ((AV *)SvRV (AvARRAY (av)[arg]))[0])); |
438 | PUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY ((AV *)SvRV (AvARRAY (av)[arg]))[0])); |
430 | else |
439 | else |
431 | for (arg = 0; arg < count; arg++) |
440 | for (arg = 0; arg < count; arg++) |
432 | PUSHs (maybe_force_utf8 (ix & 1, AvARRAY (av)[arg])); |
441 | PUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY (av)[arg])); |
433 | } |
442 | } |
434 | } |
443 | } |
435 | } |
444 | } |
436 | else |
445 | else |
437 | XPUSHs (sth); |
446 | XPUSHs (sth); |