… | |
… | |
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; |
… | |
… | |
233 | SP += items; |
235 | SP += items; |
234 | |
236 | |
235 | /* first check wether we should use an explicit db handle */ |
237 | /* first check wether we should use an explicit db handle */ |
236 | if (!is_dbh (dbh)) |
238 | if (!is_dbh (dbh)) |
237 | { |
239 | { |
|
|
240 | /* the next line doesn't work - check why later maybe */ |
238 | dbh = get_sv ("DBH", FALSE); |
241 | /* dbh = get_sv ("DBH", FALSE); |
239 | if (!is_dbh (dbh)) |
242 | if (!is_dbh (dbh)) |
240 | { |
243 | {*/ |
241 | dbh = GvSV(DBH); |
244 | dbh = GvSV(DBH); |
242 | if (!is_dbh (dbh)) |
245 | if (!is_dbh (dbh)) |
|
|
246 | croak ("sql_exec: no $DBH argument and no fallback in $PApp::SQL::DBH"); |
243 | 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::"); |
244 | } |
248 | }*/ |
245 | } |
249 | } |
246 | else |
250 | else |
247 | arg++; /* we consumed one argument */ |
251 | arg++; /* we consumed one argument */ |
248 | |
252 | |
249 | /* count the remaining references (for bind_columns) */ |
253 | /* count the remaining references (for bind_columns) */ |
… | |
… | |
288 | SvPV (sql, dc), |
292 | SvPV (sql, dc), |
289 | SvPV (get_sv ("DBI::errstr", TRUE), dd)); |
293 | SvPV (get_sv ("DBI::errstr", TRUE), dd)); |
290 | |
294 | |
291 | sth = POPs; |
295 | sth = POPs; |
292 | |
296 | |
|
|
297 | if (SvLEN (sql) < MAX_CACHED_STATEMENT_SIZE) |
293 | lru_store (dbh, sql, sth); |
298 | lru_store (dbh, sql, sth); |
294 | } |
299 | } |
295 | |
300 | |
296 | PUSHMARK (SP); |
301 | PUSHMARK (SP); |
297 | EXTEND (SP, items - arg + 1); |
302 | EXTEND (SP, items - arg + 1); |
298 | PUSHs (sth); |
303 | PUSHs (sth); |
299 | while (items > arg) |
304 | while (items > arg) |
300 | { |
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 | */ |
301 | PUSHs (maybe_upgrade_utf8 (ix & 1, ST(arg))); |
310 | PUSHs (maybe_upgrade_utf8 (ix & 1, SvMAGICAL(sv) ? sv_mortalcopy(sv) : sv)); |
302 | arg++; |
311 | arg++; |
303 | } |
312 | } |
304 | |
313 | |
305 | PUTBACK; |
314 | PUTBACK; |
306 | /* { static GV *execute; |
315 | /* { static GV *execute; |
… | |
… | |
311 | SPAGAIN; |
320 | SPAGAIN; |
312 | |
321 | |
313 | if (count != 1) |
322 | if (count != 1) |
314 | croak ("sql_exec: execute() didn't return any value ('%s'): %s", |
323 | croak ("sql_exec: execute() didn't return any value ('%s'): %s", |
315 | SvPV (sql, dc), |
324 | SvPV (sql, dc), |
316 | SvPV (get_sv ("DBI::errstr", TRUE), dc)); |
325 | SvPV (get_sv ("DBI::errstr", TRUE), dd)); |
317 | |
326 | |
318 | execute = POPs; |
327 | execute = POPs; |
319 | |
328 | |
320 | if (!SvTRUE (execute)) |
329 | if (!SvTRUE (execute)) |
321 | croak ("sql_exec: unable to execute statement '%s' (%s)", |
330 | croak ("sql_exec: unable to execute statement '%s' (%s)", |
322 | SvPV (sql, dc), |
331 | SvPV (sql, dc), |
323 | SvPV (get_sv ("DBI::errstr", TRUE), dc)); |
332 | SvPV (get_sv ("DBI::errstr", TRUE), dd)); |
324 | |
333 | |
325 | sv_setsv (GvSV(sql_exec), execute); |
334 | sv_setsv (GvSV(sql_exec), execute); |
326 | |
335 | |
327 | if (bind_first != bind_last) |
336 | if (bind_first != bind_last) |
328 | { |
337 | { |
… | |
… | |
339 | SPAGAIN; |
348 | SPAGAIN; |
340 | |
349 | |
341 | if (count != 1) |
350 | if (count != 1) |
342 | croak ("sql_exec: bind_columns() didn't return any value ('%s'): %s", |
351 | croak ("sql_exec: bind_columns() didn't return any value ('%s'): %s", |
343 | SvPV (sql, dc), |
352 | SvPV (sql, dc), |
344 | SvPV (get_sv ("DBI::errstr", TRUE), dc)); |
353 | SvPV (get_sv ("DBI::errstr", TRUE), dd)); |
345 | |
354 | |
346 | if (!SvOK (POPs)) |
355 | if (!SvOK (POPs)) |
347 | croak ("sql_exec: bind_columns() didn't return a true ('%s'): %s", |
356 | croak ("sql_exec: bind_columns() didn't return a true ('%s'): %s", |
348 | SvPV (sql, dc), |
357 | SvPV (sql, dc), |
349 | SvPV (get_sv ("DBI::errstr", TRUE), dc)); |
358 | SvPV (get_sv ("DBI::errstr", TRUE), dd)); |
350 | } |
359 | } |
351 | |
360 | |
352 | /* free our arguments from the stack */ |
361 | /* free our arguments from the stack */ |
353 | SP -= items; |
362 | SP -= items; |
354 | |
363 | |
… | |
… | |
376 | case G_VOID: |
385 | case G_VOID: |
377 | /* no thing */ |
386 | /* no thing */ |
378 | break; |
387 | break; |
379 | case G_SCALAR: |
388 | case G_SCALAR: |
380 | /* the first element */ |
389 | /* the first element */ |
381 | XPUSHs (maybe_force_utf8 (ix & 1, *av_fetch ((AV *)SvRV (row), 0, 1))); |
390 | XPUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, *av_fetch ((AV *)SvRV (row), 0, 1))); |
382 | break; |
391 | break; |
383 | case G_ARRAY: |
392 | case G_ARRAY: |
384 | av = (AV *)SvRV (row); |
393 | av = (AV *)SvRV (row); |
385 | count = AvFILL (av) + 1; |
394 | count = AvFILL (av) + 1; |
386 | EXTEND (SP, count); |
395 | EXTEND (SP, count); |
387 | for (arg = 0; arg < count; arg++) |
396 | for (arg = 0; arg < count; arg++) |
388 | PUSHs (maybe_force_utf8 (ix & 1, AvARRAY (av)[arg])); |
397 | PUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY (av)[arg])); |
389 | |
398 | |
390 | break; |
399 | break; |
391 | default: |
400 | default: |
392 | abort (); |
401 | abort (); |
393 | } |
402 | } |
… | |
… | |
418 | int columns = AvFILL ((AV *) SvRV (AvARRAY (av)[0])) + 1; /* columns? */ |
427 | int columns = AvFILL ((AV *) SvRV (AvARRAY (av)[0])) + 1; /* columns? */ |
419 | |
428 | |
420 | EXTEND (SP, count); |
429 | EXTEND (SP, count); |
421 | if (columns == 1) |
430 | if (columns == 1) |
422 | for (arg = 0; arg < count; arg++) |
431 | for (arg = 0; arg < count; arg++) |
423 | PUSHs (maybe_force_utf8 (ix & 1, AvARRAY ((AV *)SvRV (AvARRAY (av)[arg]))[0])); |
432 | PUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY ((AV *)SvRV (AvARRAY (av)[arg]))[0])); |
424 | else |
433 | else |
425 | for (arg = 0; arg < count; arg++) |
434 | for (arg = 0; arg < count; arg++) |
426 | PUSHs (maybe_force_utf8 (ix & 1, AvARRAY (av)[arg])); |
435 | PUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY (av)[arg])); |
427 | } |
436 | } |
428 | } |
437 | } |
429 | } |
438 | } |
430 | else |
439 | else |
431 | XPUSHs (sth); |
440 | XPUSHs (sth); |