ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/PApp-SQL/SQL.xs
Revision: 1.12
Committed: Thu Apr 11 01:02:10 2002 UTC (22 years, 1 month ago) by root
Branch: MAIN
CVS Tags: klinik-loewenstein-05052002, klinik-loewenstein
Changes since 1.11: +6 -4 lines
Log Message:
*** empty log message ***

File Contents

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