ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/PApp-SQL/SQL.xs
(Generate patch)

Comparing PApp-SQL/SQL.xs (file contents):
Revision 1.6 by root, Sun Apr 22 17:03:28 2001 UTC vs.
Revision 1.22 by root, Sun Jun 21 03:30:00 2009 UTC

1#include "EXTERN.h" 1#include "EXTERN.h"
2#include "perl.h" 2#include "perl.h"
3#include "XSUB.h" 3#include "XSUB.h"
4
5/* import some stuff from DBIXS.h and DBI.xs */
6#define DBIXS_VERSION 93
7#define DBI_MAGIC '~'
8
9#define DBISTATE_PERLNAME "DBI::_dbistate"
10#define DBISTATE_ADDRSV (perl_get_sv(DBISTATE_PERLNAME, 0x05))
11#define DBIS_PUBLISHED_LVALUE (*(INT2PTR(dbistate_t**, &SvIVX(DBISTATE_ADDRSV))))
12
13struct dbistate_st {
14#define DBISTATE_VERSION 94 /* Must change whenever dbistate_t does */
15 /* this must be the first member in structure */
16 void (*check_version) _((const char *name,
17 int dbis_cv, int dbis_cs, int need_dbixs_cv,
18 int drc_s, int dbc_s, int stc_s, int fdc_s));
19
20 /* version and size are used to check for DBI/DBD version mis-match */
21 U16 version; /* version of this structure */
22 U16 size;
23 U16 xs_version; /* version of the overall DBIXS / DBD interface */
24 U16 spare_pad;
25};
26typedef struct dbistate_st dbistate_t;
27
28#define DBIcf_ACTIVE 0x000004 /* needs finish/disconnect before clear */
29
30typedef U32 imp_sth;
31
32/* not strictly part of the API... */
33static imp_sth *
34sth_get_imp (SV *sth)
35{
36 MAGIC *mg = mg_find (SvRV (sth), PERL_MAGIC_tied);
37 sth = mg->mg_obj;
38 mg = mg_find (SvRV (sth), DBI_MAGIC);
39 return (imp_sth *)SvPVX (mg->mg_obj);
40}
41
42#define DBI_STH_ACTIVE(imp) (*(imp) & DBIcf_ACTIVE)
43
44/* end of import section */
4 45
5#if (PERL_VERSION < 5) || ((PERL_VERSION == 5) && (PERL_SUBVERSION <= 6)) 46#if (PERL_VERSION < 5) || ((PERL_VERSION == 5) && (PERL_SUBVERSION <= 6))
6# define get_sv perl_get_sv 47# define get_sv perl_get_sv
7# define call_method perl_call_method 48# define call_method perl_call_method
8# define call_sv perl_call_sv 49# define call_sv perl_call_sv
9#endif 50#endif
10 51
11#if (PERL_VERSION < 5) || ((PERL_VERSION == 5) && (PERL_SUBVERSION <= 5)) 52#if (PERL_VERSION > 5) || ((PERL_VERSION == 5) && (PERL_SUBVERSION >= 6))
12# define CAN_UTF8 1 53# define CAN_UTF8 1
13#endif 54#endif
55
56#define MAX_CACHED_STATEMENT_SIZE 2048
14 57
15static SV * 58static SV *
16sql_upgrade_utf8 (SV *sv) 59sql_upgrade_utf8 (SV *sv)
17{ 60{
18#if CAN_UTF8 61#if CAN_UTF8
… …
21#endif 64#endif
22 return sv; 65 return sv;
23} 66}
24 67
25static SV * 68static SV *
26sql_force_utf8 (SV *sv) 69mortalcopy_and_maybe_force_utf8(int utf8, SV *sv)
27{ 70{
71 sv = sv_mortalcopy (sv);
28#if CAN_UTF8 72#if CAN_UTF8
29 if (SvPOK (sv)) 73 if (utf8 && SvPOK (sv))
30 SvUTF8_on (sv); 74 SvUTF8_on (sv);
31#endif 75#endif
32 return sv; 76 return sv;
33} 77}
34 78
35#define maybe_upgrade_utf8(utf8,sv) ((utf8) ? sql_upgrade_utf8 (sv) : (sv)) 79#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 80
38#define is_dbh(sv) ((sv) && sv_isobject (sv) && sv_derived_from ((sv), "DBI::db")) 81#define is_dbh(sv) ((sv) && sv_isobject (sv) && sv_derived_from ((sv), "DBI::db"))
39 82
40typedef struct lru_node { 83typedef struct lru_node {
41 struct lru_node *next; 84 struct lru_node *next;
42 struct lru_node *prev; 85 struct lru_node *prev;
43 U32 hash; 86 U32 hash; /* bit 31 is used to mark active nodes */
44 SV *dbh; 87 SV *dbh;
45 SV *sql; 88 SV *sql;
46 89
47 SV *sth; 90 SV *sth;
91 imp_sth *sth_imp;
48#if 0 /* method cache */ 92#if 0 /* method cache */
49 GV *execute; 93 GV *execute;
50 GV *bind_columns; 94 GV *bind_columns;
51 GV *fetch; 95 GV *fetch;
52 GV *finish; 96 GV *finish;
… …
55 99
56static lru_node lru_list; 100static lru_node lru_list;
57static int lru_size; 101static int lru_size;
58static int lru_maxsize; 102static int lru_maxsize;
59 103
60#define lru_init lru_list.next = &lru_list; lru_list.prev = &lru_list /* other fields are zero */ 104#define lru_init() lru_list.next = &lru_list; lru_list.prev = &lru_list /* other fields are zero */
61 105
62/* this is primitive, yet effective */ 106/* this is primitive, yet effective */
63/* the returned value must never be zero (or bad things will happen) */ 107/* the returned value must never be zero (or bad things will happen) */
64#define lru_hash do { \ 108#define lru_hash \
109 do { \
65 hash = (((U32)dbh)>>2); \ 110 hash = (((U32)(long)dbh)>>4); \
66 hash += *statement;\ 111 hash += *statement; \
67 hash += len; \ 112 hash += len; \
68} while (0) 113 } while (0)
69 114
70/* fetch and "use" */ 115/* fetch and "use" */
71/* could be done using a single call (we could call prepare!) */ 116/* could be done using a single call (we could call prepare!) */
117static SV *
72static SV *lru_fetch(SV *dbh, SV *sql) 118lru_fetch (SV *dbh, SV *sql)
73{ 119{
74 lru_node *n; 120 lru_node *n;
75 121
76 U32 hash; 122 U32 hash;
77 STRLEN len; 123 STRLEN len;
… …
79 125
80 dbh = SvRV (dbh); 126 dbh = SvRV (dbh);
81 127
82 lru_hash; 128 lru_hash;
83 129
84 /*fprintf (stderr, "F: %08lx %s\n", hash, SvPV_nolen (sql));/*D*/
85
86 n = &lru_list; 130 n = &lru_list;
87 do { 131 do {
88 n = n->next; 132 n = n->next;
133
89 if (!n->hash) 134 if (!n->hash)
90 return 0; 135 return 0;
91 } while (n->hash != hash 136 } while (n->hash != hash
137 || DBI_STH_ACTIVE (n->sth_imp)
92 || !sv_eq (n->sql, sql) 138 || !sv_eq (n->sql, sql)
93 || n->dbh != dbh); 139 || n->dbh != dbh);
94 140
95 /* found, so return to the start of the list */ 141 /* found, so return to the start of the list */
96 n->prev->next = n->next; 142 n->prev->next = n->next;
… …
99 n->next = lru_list.next; 145 n->next = lru_list.next;
100 n->prev = &lru_list; 146 n->prev = &lru_list;
101 lru_list.next->prev = n; 147 lru_list.next->prev = n;
102 lru_list.next = n; 148 lru_list.next = n;
103 149
104 return n->sth; 150 return sv_2mortal (SvREFCNT_inc (n->sth));
105} 151}
106 152
107static void lru_nukeone(void) 153static void
154lru_trim (void)
155{
156 while (lru_size > lru_maxsize)
157 {
158 /* nuke at the end */
159 lru_node *n = lru_list.prev;
160
161 n = lru_list.prev;
162
163 lru_list.prev = n->prev;
164 n->prev->next = &lru_list;
165
166 SvREFCNT_dec (n->dbh);
167 SvREFCNT_dec (n->sql);
168 SvREFCNT_dec (n->sth);
169 Safefree (n);
170
171 lru_size--;
172 }
173}
174
175/* store a not-yet existing entry(!) */
176static void
177lru_store (SV *dbh, SV *sql, SV *sth)
108{ 178{
109 lru_node *n; 179 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 /*fprintf (stderr, "N: %s\n", SvPV_nolen (n->sql));/*D*/
118
119 SvREFCNT_dec (n->dbh);
120 SvREFCNT_dec (n->sql);
121 SvREFCNT_dec (n->sth);
122 Safefree (n);
123
124 lru_size--;
125}
126
127/* store a not-yet existing entry(!) */
128static void lru_store(SV *dbh, SV *sql, SV *sth)
129{
130 lru_node *n;
131
132 U32 hash; 180 U32 hash;
133 STRLEN len; 181 STRLEN len;
182 char *statement;
183
184 if (!lru_maxsize)
185 return;
186
134 char *statement = SvPV (sql, len); 187 statement = SvPV (sql, len);
135
136 dbh = SvRV (dbh); 188 dbh = SvRV (dbh);
137 189
138 lru_hash; 190 lru_hash;
139 191
140 /*fprintf (stderr, "S: %08lx %s\n", hash, SvPV_nolen (sql));/*D*/
141
142 lru_size++; 192 lru_size++;
143 if (lru_size > lru_maxsize) 193 lru_trim ();
144 lru_nukeone ();
145 194
146 New (0, n, 1, lru_node); 195 New (0, n, 1, lru_node);
147 196
148 n->hash = hash; 197 n->hash = hash;
149 n->dbh = dbh; SvREFCNT_inc (dbh); /* note: this is the dbi hash itself, not the reference */ 198 n->dbh = dbh; SvREFCNT_inc (dbh); /* note: this is the dbi hash itself, not the reference */
150 n->sql = newSVsv (sql); 199 n->sql = newSVsv (sql);
151 n->sth = sth; SvREFCNT_inc (sth); 200 n->sth = sth; SvREFCNT_inc (sth);
201 n->sth_imp = sth_get_imp (sth);
152 202
153 n->next = lru_list.next; 203 n->next = lru_list.next;
154 n->prev = &lru_list; 204 n->prev = &lru_list;
155 lru_list.next->prev = n; 205 lru_list.next->prev = n;
156 lru_list.next = n; 206 lru_list.next = n;
157} 207}
158 208
209static void
159static void lru_cachesize (int size) 210lru_cachesize (int size)
160{ 211{
161 if (size >= 0) 212 if (size >= 0)
162 { 213 {
163 lru_maxsize = size; 214 lru_maxsize = size;
164 while (lru_size > lru_maxsize) 215 lru_trim ();
165 lru_nukeone ();
166 } 216 }
167} 217}
168 218
169static GV *sql_exec; 219static GV *sql_exec;
170static GV *DBH; 220static GV *DBH;
… …
178 228
179PROTOTYPES: DISABLE 229PROTOTYPES: DISABLE
180 230
181BOOT: 231BOOT:
182{ 232{
233 struct dbistate_st *dbis = DBIS_PUBLISHED_LVALUE;
234
235 /* this is atcually wrong, we should call the check member, apparently */
236 assert (dbis->version == DBISTATE_VERSION);
237 assert (dbis->xs_version == DBIXS_VERSION);
238
183 sql_exec = gv_fetchpv ("PApp::SQL::sql_exec", TRUE, SVt_PV); 239 sql_exec = gv_fetchpv ("PApp::SQL::sql_exec", TRUE, SVt_PV);
184 DBH = gv_fetchpv ("PApp::SQL::DBH" , TRUE, SVt_PV); 240 DBH = gv_fetchpv ("PApp::SQL::DBH" , TRUE, SVt_PV);
185 241
186 if (!sv_prepare) 242 if (!sv_prepare)
187 { 243 {
… …
195 251
196 /* apache might BOOT: twice :( */ 252 /* apache might BOOT: twice :( */
197 if (lru_size) 253 if (lru_size)
198 lru_cachesize (0); 254 lru_cachesize (0);
199 255
200 lru_init; 256 lru_init ();
201 lru_cachesize (50); 257 lru_cachesize (50);
202} 258}
203 259
204int 260int
205cachesize(size = -1) 261cachesize(size = -1)
… …
231 int count; 287 int count;
232 SV *dbh = ST(0); 288 SV *dbh = ST(0);
233 SV *sth; 289 SV *sth;
234 SV *sql; 290 SV *sql;
235 SV *execute; 291 SV *execute;
236 STRLEN dc; 292 STRLEN dc, dd; /* dummy */
237 293
238 /* save our arguments against destruction through function calls */ 294 /* save our arguments against destruction through function calls */
239 SP += items; 295 SP += items;
240 296
241 /* first check wether we should use an explicit db handle */ 297 /* first check wether we should use an explicit db handle */
242 if (!is_dbh (dbh)) 298 if (!is_dbh (dbh))
243 { 299 {
300 /* the next line doesn't work - check why later maybe */
244 dbh = get_sv ("DBH", FALSE); 301 /* dbh = get_sv ("DBH", FALSE);
245 if (!is_dbh (dbh)) 302 if (!is_dbh (dbh))
246 { 303 {*/
247 dbh = GvSV(DBH); 304 dbh = GvSV (DBH);
248 if (!is_dbh (dbh)) 305 if (!is_dbh (dbh))
306 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::"); 307 /*croak ("sql_exec: no $DBH found in current package or in PApp::SQL::");
250 } 308 }*/
251 } 309 }
252 else 310 else
253 arg++; /* we consumed one argument */ 311 arg++; /* we consumed one argument */
312
313 /* be more Coro-friendly by keeping a copy, so different threads */
314 /* can replace their global handles */
315 dbh = sv_2mortal (newSVsv (dbh));
254 316
255 /* count the remaining references (for bind_columns) */ 317 /* count the remaining references (for bind_columns) */
256 bind_first = arg; 318 bind_first = arg;
257 while (items > arg && SvROK (ST(arg))) 319 while (items > arg && SvROK (ST(arg)))
258 arg++; 320 arg++;
… …
272 { 334 {
273 SV *neu = sv_2mortal (newSVpv ("select count(*) > 0 from ", 0)); 335 SV *neu = sv_2mortal (newSVpv ("select count(*) > 0 from ", 0));
274 sv_catsv (neu, sql); 336 sv_catsv (neu, sql);
275 sv_catpv (neu, " limit 1"); 337 sv_catpv (neu, " limit 1");
276 sql = neu; 338 sql = neu;
277 ix -= 6; /* sql_fetch */ 339 ix -= 4; /* sql_fetch */
278 } 340 }
279 341
280 /* check cache for existing statement handle */ 342 /* check cache for existing statement handle */
281 sth = lru_fetch (dbh, sql); 343 sth = lru_fetch (dbh, sql);
282 if (!sth) 344 if (!sth)
… …
290 SPAGAIN; 352 SPAGAIN;
291 353
292 if (count != 1) 354 if (count != 1)
293 croak ("sql_exec: unable to prepare() statement '%s': %s", 355 croak ("sql_exec: unable to prepare() statement '%s': %s",
294 SvPV (sql, dc), 356 SvPV (sql, dc),
295 SvPV (get_sv ("DBI::errstr", TRUE), dc)); 357 SvPV (get_sv ("DBI::errstr", TRUE), dd));
296 358
297 sth = POPs; 359 sth = POPs;
298 360
361 if (SvLEN (sql) < MAX_CACHED_STATEMENT_SIZE)
299 lru_store (dbh, sql, sth); 362 lru_store (dbh, sql, sth);
300 } 363 }
301 364
302 PUSHMARK (SP); 365 PUSHMARK (SP);
303 EXTEND (SP, items - arg + 1); 366 EXTEND (SP, items - arg + 1);
304 PUSHs (sth); 367 PUSHs (sth);
305 while (items > arg) 368 while (items > arg)
306 { 369 {
370 SV *sv = ST(arg);
371 /* we sv_mortalcopy magical values since DBI seems to have a memory
372 * leak when magical values are passed into execute().
373 */
307 PUSHs (maybe_upgrade_utf8 (ix & 1, ST(arg))); 374 PUSHs (maybe_upgrade_utf8 (ix & 1, SvMAGICAL(sv) ? sv_mortalcopy(sv) : sv));
308 arg++; 375 arg++;
309 } 376 }
310 377
311 PUTBACK; 378 PUTBACK;
312 /* { static GV *execute; 379 /* { static GV *execute;
… …
317 SPAGAIN; 384 SPAGAIN;
318 385
319 if (count != 1) 386 if (count != 1)
320 croak ("sql_exec: execute() didn't return any value ('%s'): %s", 387 croak ("sql_exec: execute() didn't return any value ('%s'): %s",
321 SvPV (sql, dc), 388 SvPV (sql, dc),
322 SvPV (get_sv ("DBI::errstr", TRUE), dc)); 389 SvPV (get_sv ("DBI::errstr", TRUE), dd));
323 390
324 execute = POPs; 391 execute = POPs;
325 392
326 if (!SvTRUE (execute)) 393 if (!SvTRUE (execute))
327 croak ("sql_exec: unable to execute statement '%s' (%s)", 394 croak ("sql_exec: unable to execute statement '%s' (%s)",
328 SvPV (sql, dc), 395 SvPV (sql, dc),
329 SvPV (get_sv ("DBI::errstr", TRUE), dc)); 396 SvPV (get_sv ("DBI::errstr", TRUE), dd));
330 397
331 sv_setsv (GvSV(sql_exec), execute); 398 sv_setsv (GvSV(sql_exec), execute);
332 399
333 if (bind_first != bind_last) 400 if (bind_first != bind_last)
334 { 401 {
335 PUSHMARK (SP); 402 PUSHMARK (SP);
336 EXTEND (SP, bind_last - bind_first + 2); 403 EXTEND (SP, bind_last - bind_first + 2);
337 PUSHs (sth); 404 PUSHs (sth);
338 do { 405 do {
406#if CAN_UTF8
407 if (ix & 1)
408 SvUTF8_on (SvRV(ST(bind_first)));
409#endif
339 PUSHs (ST(bind_first)); 410 PUSHs (ST(bind_first));
340 bind_first++; 411 bind_first++;
341 } while (bind_first != bind_last); 412 } while (bind_first != bind_last);
342 413
343 PUTBACK; 414 PUTBACK;
… …
345 SPAGAIN; 416 SPAGAIN;
346 417
347 if (count != 1) 418 if (count != 1)
348 croak ("sql_exec: bind_columns() didn't return any value ('%s'): %s", 419 croak ("sql_exec: bind_columns() didn't return any value ('%s'): %s",
349 SvPV (sql, dc), 420 SvPV (sql, dc),
350 SvPV (get_sv ("DBI::errstr", TRUE), dc)); 421 SvPV (get_sv ("DBI::errstr", TRUE), dd));
351 422
352 if (!SvOK (POPs)) 423 if (!SvOK (TOPs))
353 croak ("sql_exec: bind_columns() didn't return a true ('%s'): %s", 424 croak ("sql_exec: bind_columns() didn't return a true ('%s'): %s",
354 SvPV (sql, dc), 425 SvPV (sql, dc),
355 SvPV (get_sv ("DBI::errstr", TRUE), dc)); 426 SvPV (get_sv ("DBI::errstr", TRUE), dd));
427
356 } 428 POPs;
429 }
357 430
358 /* free our arguments from the stack */ 431 /* restore our arguments again */
359 SP -= items; 432 SP -= items;
360 433
361 if ((ix & ~1) == 2) 434 if ((ix & ~1) == 2)
362 { /* sql_fetch */ 435 { /* sql_fetch */
363 SV *row; 436 SV *row;
… …
382 case G_VOID: 455 case G_VOID:
383 /* no thing */ 456 /* no thing */
384 break; 457 break;
385 case G_SCALAR: 458 case G_SCALAR:
386 /* the first element */ 459 /* the first element */
387 XPUSHs (maybe_force_utf8 (ix & 1, *av_fetch ((AV *)SvRV (row), 0, 1))); 460 XPUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, *av_fetch ((AV *)SvRV (row), 0, 1)));
388 break; 461 break;
389 case G_ARRAY: 462 case G_ARRAY:
390 av = (AV *)SvRV (row); 463 av = (AV *)SvRV (row);
391 count = AvFILL (av) + 1; 464 count = AvFILL (av) + 1;
392 EXTEND (SP, count); 465 EXTEND (SP, count);
393 for (arg = 0; arg < count; arg++) 466 for (arg = 0; arg < count; arg++)
394 PUSHs (maybe_force_utf8 (ix & 1, AvARRAY (av)[arg])); 467 PUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY (av)[arg]));
395 468
396 break; 469 break;
397 default: 470 default:
398 abort (); 471 abort ();
399 } 472 }
… …
424 int columns = AvFILL ((AV *) SvRV (AvARRAY (av)[0])) + 1; /* columns? */ 497 int columns = AvFILL ((AV *) SvRV (AvARRAY (av)[0])) + 1; /* columns? */
425 498
426 EXTEND (SP, count); 499 EXTEND (SP, count);
427 if (columns == 1) 500 if (columns == 1)
428 for (arg = 0; arg < count; arg++) 501 for (arg = 0; arg < count; arg++)
429 PUSHs (maybe_force_utf8 (ix & 1, AvARRAY ((AV *)SvRV (AvARRAY (av)[arg]))[0])); 502 PUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY ((AV *)SvRV (AvARRAY (av)[arg]))[0]));
430 else 503 else
431 for (arg = 0; arg < count; arg++) 504 for (arg = 0; arg < count; arg++)
432 PUSHs (maybe_force_utf8 (ix & 1, AvARRAY (av)[arg])); 505 PUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY (av)[arg]));
433 } 506 }
434 } 507 }
435 } 508 }
436 else 509 else
437 XPUSHs (sth); 510 XPUSHs (sth);

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines