PApp-SQL/SQL.xs

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

/* import some stuff from DBIXS.h and DBI.xs */
#define DBIXS_VERSION 93
#define DBI_MAGIC '~'

#define DBISTATE_PERLNAME "DBI::_dbistate"
#define DBISTATE_ADDRSV   (perl_get_sv(DBISTATE_PERLNAME, 0x05))
#define DBIS_PUBLISHED_LVALUE (*(INT2PTR(dbistate_t**, &SvIVX(DBISTATE_ADDRSV))))

struct dbistate_st {
#define DBISTATE_VERSION  94    /* Must change whenever dbistate_t does */
    /* this must be the first member in structure                       */
    void (*check_version) _((const char *name,
                int dbis_cv, int dbis_cs, int need_dbixs_cv,
                int drc_s, int dbc_s, int stc_s, int fdc_s));

    /* version and size are used to check for DBI/DBD version mis-match */
    U16 version;        /* version of this structure                    */
    U16 size;
    U16 xs_version;     /* version of the overall DBIXS / DBD interface */
    U16 spare_pad;
};
typedef struct dbistate_st dbistate_t;

#define DBIcf_ACTIVE      0x000004      /* needs finish/disconnect before clear */

typedef U32 imp_sth;

/* not strictly part of the API... */
static imp_sth *
sth_get_imp (SV *sth)
{
  MAGIC *mg = mg_find (SvRV (sth), PERL_MAGIC_tied);
  sth = mg->mg_obj;
  mg = mg_find (SvRV (sth), DBI_MAGIC);
  return (imp_sth *)SvPVX (mg->mg_obj);
}

#define DBI_STH_ACTIVE(imp) (*(imp) & DBIcf_ACTIVE)

/* end of import section */

#if (PERL_VERSION < 5) || ((PERL_VERSION == 5) && (PERL_SUBVERSION <= 6))
# define get_sv      perl_get_sv
# define call_method perl_call_method
# define call_sv     perl_call_sv
#endif

#if (PERL_VERSION > 5) || ((PERL_VERSION == 5) && (PERL_SUBVERSION >= 6))
# define CAN_UTF8 1
#endif

#define MAX_CACHED_STATEMENT_SIZE 2048

static SV *
sql_upgrade_utf8 (SV *sv)
{
#if CAN_UTF8
  if (SvPOK (sv))
    sv_utf8_upgrade (sv);
#endif
  return sv;
}

static SV *
mortalcopy_and_maybe_force_utf8(int utf8, SV *sv)
{
  sv = sv_mortalcopy (sv);
#if CAN_UTF8
  if (utf8 && SvPOK (sv))
    SvUTF8_on (sv);
#endif
  return sv;
}

#define maybe_upgrade_utf8(utf8,sv) ((utf8) ? sql_upgrade_utf8 (sv) : (sv))

#define is_dbh(sv) ((sv) && sv_isobject (sv) && sv_derived_from ((sv), "DBI::db"))

typedef struct lru_node {
  struct lru_node *next;
  struct lru_node *prev;
  U32 hash; /* bit 31 is used to mark active nodes */
  SV *dbh;
  SV *sql;

  SV *sth;
  imp_sth *sth_imp;
#if 0 /* method cache */
  GV *execute;
  GV *bind_columns;
  GV *fetch;
  GV *finish;
#endif
} lru_node;

static lru_node lru_list;
static int lru_size;
static int lru_maxsize;

#define lru_init() lru_list.next = &lru_list; lru_list.prev = &lru_list /* other fields are zero */

/* this is primitive, yet effective */
/* the returned value must never be zero (or bad things will happen) */
#define lru_hash                        \
  do {                                  \
    hash = (((U32)(long)dbh)>>4);       \
    hash += *statement;                 \
    hash += len;                        \
  } while (0)

/* fetch and "use" */
/* could be done using a single call (we could call prepare!) */
static SV *
lru_fetch (SV *dbh, SV *sql)
{
  lru_node *n;

  U32 hash;
  STRLEN len;
  char *statement = SvPV (sql, len);

  dbh = SvRV (dbh);

  lru_hash;

  n = &lru_list;
  do {
    n = n->next;

    if (!n->hash)
      return 0;
  } while (n->hash != hash
           || DBI_STH_ACTIVE (n->sth_imp)
           || !sv_eq (n->sql, sql)
           || n->dbh != dbh);

  /* found, so return to the start of the list */
  n->prev->next = n->next;
  n->next->prev = n->prev;

  n->next = lru_list.next;
  n->prev = &lru_list;
  lru_list.next->prev = n;
  lru_list.next = n;

  return sv_2mortal (SvREFCNT_inc (n->sth));
}

static void
lru_trim (void)
{
  while (lru_size > lru_maxsize)
    {
      /* nuke at the end */
      lru_node *n = lru_list.prev;

      n = lru_list.prev;

      lru_list.prev = n->prev;
      n->prev->next = &lru_list;

      SvREFCNT_dec (n->dbh);
      SvREFCNT_dec (n->sql);
      SvREFCNT_dec (n->sth);
      Safefree (n);
      
      lru_size--;
    }
}

/* store a not-yet existing entry(!) */
static void
lru_store (SV *dbh, SV *sql, SV *sth)
{
  lru_node *n;
  U32 hash;
  STRLEN len;
  char *statement;

  if (!lru_maxsize)
    return;
  
  statement = SvPV (sql, len);
  dbh = SvRV (dbh);

  lru_hash;

  lru_size++;
  lru_trim ();

  New (0, n, 1, lru_node);

  n->hash    = hash;
  n->dbh     = dbh; SvREFCNT_inc (dbh); /* note: this is the dbi hash itself, not the reference */
  n->sql     = newSVsv (sql);
  n->sth     = sth; SvREFCNT_inc (sth);
  n->sth_imp = sth_get_imp (sth);

  n->next    = lru_list.next;
  n->prev    = &lru_list;
  lru_list.next->prev = n;
  lru_list.next = n;
}

static void
lru_cachesize (int size)
{
  if (size >= 0)
    {
      lru_maxsize = size;
      lru_trim ();
    }
}

static GV *sql_exec;
static GV *DBH;
static SV *sv_prepare, *sv_execute, *sv_bind_columns,
          *sv_fetchrow_arrayref, *sv_fetchall_arrayref,
          *sv_finish;

#define newconstpv(str) newSVpvn ((str), sizeof (str))

MODULE = PApp::SQL              PACKAGE = PApp::SQL

PROTOTYPES: DISABLE

BOOT:
{
   struct dbistate_st *dbis = DBIS_PUBLISHED_LVALUE;

   /* this is actually wrong, we should call the check member, apparently */
   assert (dbis->version == DBISTATE_VERSION);
   assert (dbis->xs_version == DBIXS_VERSION);

   sql_exec = gv_fetchpv ("PApp::SQL::sql_exec", TRUE, SVt_PV);
   DBH      = gv_fetchpv ("PApp::SQL::DBH"     , TRUE, SVt_PV);

   if (!sv_prepare)
     {
       sv_prepare           = newconstpv ("prepare");
       sv_execute           = newconstpv ("execute");
       sv_bind_columns      = newconstpv ("bind_columns");
       sv_fetchrow_arrayref = newconstpv ("fetchrow_arrayref");
       sv_fetchall_arrayref = newconstpv ("fetchall_arrayref");
       sv_finish            = newconstpv ("finish");
     }

   /* apache might BOOT: twice :( */
   if (lru_size)
     lru_cachesize (0);

   lru_init ();
   lru_cachesize (50);
}

int
cachesize(size = -1)
        int     size
        CODE:
        RETVAL = lru_maxsize;
        lru_cachesize (size);
        OUTPUT:
        RETVAL

void
sql_exec(...)
        ALIAS:
                sql_uexec     = 1
                sql_fetch     = 2
                sql_ufetch    = 3
                sql_fetchall  = 4
                sql_ufetchall = 5
                sql_exists    = 6
                sql_uexists   = 7
        PPCODE:
{
        if (items == 0)
          croak ("Usage: sql_exec [database-handle,] [bind-var-refs,... ] \"sql-statement\", [arguments, ...]");
        else
          {
            int arg = 0;
            int bind_first, bind_last;
            int count;
            SV *dbh = ST(0);
            SV *sth;
            SV *sql;
            SV *execute;
            STRLEN dc, dd; /* dummy */

            /* save our arguments against destruction through function calls */
            SP += items;
            
            /* first check wether we should use an explicit db handle */
            if (!is_dbh (dbh))
              {
                /* the next line doesn't work - check why later maybe */
                /* dbh = get_sv ("DBH", FALSE);
                if (!is_dbh (dbh))
                  {*/
                    dbh = GvSV (DBH);
                    if (!is_dbh (dbh))
                      croak ("sql_exec: no $DBH argument and no fallback in $PApp::SQL::DBH");
                      /*croak ("sql_exec: no $DBH found in current package or in PApp::SQL::");
                  }*/
              }
            else
              arg++; /* we consumed one argument */

            /* be more Coro-friendly by keeping a copy, so different threads */
            /* can replace their global handles */
            dbh = sv_2mortal (newSVsv (dbh));

            /* count the remaining references (for bind_columns) */
            bind_first = arg;
            while (items > arg && SvROK (ST(arg)))
              arg++;

            bind_last = arg;

            /* consume the sql-statement itself */
            if (items <= arg)
              croak ("sql_exec: required argument \"sql-statement\" missing");

            if (!SvPOK (ST(arg)))
              croak ("sql_exec: sql-statement must be a string");

            sql = ST(arg); arg++;

            if ((ix & ~1) == 6)
              {
                SV *neu = sv_2mortal (newSVpv ("select count(*) > 0 from ", 0));
                sv_catsv (neu, sql);
                sv_catpv (neu, " limit 1");
                sql = neu;
                ix -= 4; /* sql_fetch */
              }

            /* check cache for existing statement handle */
            sth = lru_fetch (dbh, sql);
            if (!sth)
              {
                PUSHMARK (SP);
                EXTEND (SP, 2);
                PUSHs (dbh);
                PUSHs (sql);
                PUTBACK;
                count = call_sv (sv_prepare, G_METHOD | G_SCALAR);
                SPAGAIN;

                if (count != 1)
                  croak ("sql_exec: unable to prepare() statement '%s': %s",
                         SvPV (sql, dc),
                         SvPV (get_sv ("DBI::errstr", TRUE), dd));

                sth = POPs;

                if (SvLEN (sql) < MAX_CACHED_STATEMENT_SIZE)
                  lru_store (dbh, sql, sth);
              }

            PUSHMARK (SP);
            EXTEND (SP, items - arg + 1);
            PUSHs (sth);
            while (items > arg)
              {
                SV *sv = ST(arg);
                /* we sv_mortalcopy magical values since DBI seems to have a memory
                 * leak when magical values are passed into execute().
                 */
                PUSHs (maybe_upgrade_utf8 (ix & 1, SvMAGICAL(sv) ? sv_mortalcopy(sv) : sv));
                arg++;
              }

            PUTBACK;
            /* { static GV *execute;
              if (!execute) execute = gv_fetchmethod_autoload(SvSTASH(SvRV(sth)), "execute", 0);
              count = call_sv(GvCV(execute), G_SCALAR);
             }*/
            count = call_sv (sv_execute, G_METHOD | G_SCALAR);
            SPAGAIN;

            if (count != 1)
              croak ("sql_exec: execute() didn't return any value ('%s'): %s",
                     SvPV (sql, dc),
                     SvPV (get_sv ("DBI::errstr", TRUE), dd));

            execute = POPs;

            if (!SvTRUE (execute))
              croak ("sql_exec: unable to execute statement '%s' (%s)",
                     SvPV (sql, dc),
                     SvPV (get_sv ("DBI::errstr", TRUE), dd));

            sv_setsv (GvSV(sql_exec), execute);

            if (bind_first != bind_last)
              {
                PUSHMARK (SP);
                EXTEND (SP, bind_last - bind_first + 2);
                PUSHs (sth);
                do {
#if CAN_UTF8
                  if (ix & 1)
                     SvUTF8_on (SvRV(ST(bind_first)));
#endif
                  PUSHs (ST(bind_first));
                  bind_first++;
                } while (bind_first != bind_last);

                PUTBACK;
                count = call_sv (sv_bind_columns, G_METHOD | G_SCALAR);
                SPAGAIN;

                if (count != 1)
                  croak ("sql_exec: bind_columns() didn't return any value ('%s'): %s",
                         SvPV (sql, dc),
                         SvPV (get_sv ("DBI::errstr", TRUE), dd));

                if (!SvOK (TOPs))
                  croak ("sql_exec: bind_columns() didn't return a true ('%s'): %s",
                         SvPV (sql, dc),
                         SvPV (get_sv ("DBI::errstr", TRUE), dd));

                POPs;
              }

            /* restore our arguments again */
            SP -= items;

            if ((ix & ~1) == 2)
              { /* sql_fetch */
                SV *row;

                PUSHMARK (SP);
                XPUSHs (sth);
                PUTBACK;
                count = call_sv (sv_fetchrow_arrayref, G_METHOD | G_SCALAR);
                SPAGAIN;

                if (count != 1)
                  abort ();

                row = POPs;

                if (SvROK (row))
                  {
                    AV *av;

                    switch (GIMME_V)
                      {
                        case G_VOID:
                          /* no thing */
                          break;
                        case G_SCALAR:
                          /* the first element */
                          XPUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, *av_fetch ((AV *)SvRV (row), 0, 1)));
                          break;
                        case G_ARRAY:
                          av = (AV *)SvRV (row);
                          count = AvFILL (av) + 1;
                          EXTEND (SP, count);
                          for (arg = 0; arg < count; arg++)
                            PUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY (av)[arg]));

                          break;
                        default:
                          abort ();
                      }
                 }
              }
            else if ((ix & ~1) == 4)
              { /* sql_fetchall */
                SV *rows;

                PUSHMARK (SP);
                XPUSHs (sth);
                PUTBACK;
                count = call_sv (sv_fetchall_arrayref, G_METHOD | G_SCALAR);
                SPAGAIN;

                if (count != 1)
                  abort ();

                rows = POPs;

                if (SvROK (rows))
                  {
                    AV *av = (AV *)SvRV (rows);
                    count = AvFILL (av) + 1;

                    if (count)
                      {
                        int columns = AvFILL ((AV *) SvRV (AvARRAY (av)[0])) + 1; /* columns? */

                        EXTEND (SP, count);
                        if (columns == 1)
                          for (arg = 0; arg < count; arg++)
                            PUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY ((AV *)SvRV (AvARRAY (av)[arg]))[0]));
                        else
                          for (arg = 0; arg < count; arg++)
                            PUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY (av)[arg]));
                      }
                 }
              }
            else
              XPUSHs (sth);

            if (ix > 1 || GIMME_V == G_VOID)
              {
                PUSHMARK (SP);
                XPUSHs (sth);
                PUTBACK;
                (void) call_sv (sv_finish, G_METHOD | G_DISCARD);
                SPAGAIN;
              }
          }
}


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