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))))

static SV *sql_varchar, *sql_integer, *sql_double;
static SV *tmp_iv;

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 (SvPOKp (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 && SvPOKp (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 mc_node
{
  struct mc_node *next;
  HV *stash;
  U32 gen;

  /* DBH */
  SV *prepare;

  /* STH */
  SV *execute;
  SV *bind_param;
  SV *bind_columns;
  SV *fetchrow_arrayref;
  SV *fetchall_arrayref;
  SV *finish;
} mc_node;

static mc_node *first;

static mc_node *
mc_find (HV *stash)
{
  mc_node *mc;
  U32 gen = PL_sub_generation;

#ifdef HvMROMETA
  gen += HvMROMETA (stash)->cache_gen;
#endif

  for (mc = first; mc; mc = mc->next)
    if (mc->stash == stash && mc->gen == gen)
      return mc;

  if (!mc)
    {
      Newz (0, mc, 1, mc_node);
      mc->stash = stash;

      mc->next = first;
      first = mc;
    }
  else
    {
      mc->execute           =
      mc->bind_param        =
      mc->bind_columns      =
      mc->fetchrow_arrayref =
      mc->fetchall_arrayref =
      mc->finish            = 0;
    }

  mc->gen = gen;

  return mc;
}

static void
mc_cache (mc_node *mc, SV **method, const char *name)
{
  *method = (SV *)gv_fetchmethod_autoload (mc->stash, name, 0);

  if (!method)
    croak ("%s: method not found in stash, please report.", name);
}

#define mc_cache(mc, method) mc_cache ((mc), &((mc)->method), # method)

typedef struct lru_node
{
  struct lru_node *next;
  struct lru_node *prev;

  U32 hash;
  SV *dbh;
  SV *sql;

  SV *sth;
  imp_sth *sth_imp;

  mc_node *mc;
} 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) */
static U32
lru_hash (SV *dbh, SV *sql)
{
  /* use a variant of fnv1a */
  STRLEN i, l;
  char *b = SvPV (sql, l);
  U32 hash = 2166136261U;

  hash = (hash ^ (U32)dbh) * 16777619U;
  hash = (hash ^        l) * 16777619U;

  /* start hashing at char 7, as this skips the "select " prefix */
  /* also skip more and more octets */
  for (i = 7; i < l; i += i >> 2)
    hash = (hash ^ b [i]) * 16777619U;

  return hash;
}

/* fetch and "use" */
static lru_node *
lru_fetch (SV *dbh, SV *sql)
{
  lru_node *n;
  U32 hash;

  dbh = SvRV (dbh);
  hash = lru_hash (dbh, sql);

  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 n;
}

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_NN (n->dbh);
      SvREFCNT_dec_NN (n->sql);
      SvREFCNT_dec_NN (n->sth);
      Safefree (n);
      
      lru_size--;
    }
}

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

  if (!lru_maxsize)
    return;
  
  dbh = SvRV (dbh);
  hash = lru_hash (dbh, sql);

  lru_size++;
  lru_trim ();

  New (0, n, 1, lru_node);

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

  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;

#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);

   tmp_iv = newSViv (0);

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

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

   lru_init ();
   lru_cachesize (100);
}

void
boot2 (SV *t_str, SV *t_int, SV *t_dbl)
        CODE:
        sql_varchar = newSVsv (t_str);
        sql_integer = newSVsv (t_int);
        sql_double  = newSVsv (t_dbl);

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 i;
            int arg = 0;
            int bind_first, bind_last;
            int count;
            lru_node *lru;
            SV *dbh = ST(0);
            SV *sth;
            SV *sql;
            SV *execute;
            mc_node *mc;
            STRLEN dc, dd; /* dummy */
            I32 orig_stack = SP - PL_stack_base;

            /* 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) /* sql_exists */
              {
                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 */
              }

            /* now prepare all parameters, by unmagicalising them and upgrading them */
            for (i = arg; i < items; ++i)
              {
                SV *sv = ST (i);

                /* we sv_mortalcopy magical values since DBI seems to have a memory
                 * leak when magical values are passed into execute().
                 */
                if (SvMAGICAL (sv))
                  ST (i) = sv = sv_mortalcopy (sv);

                if ((ix & 1) && SvPOKp (sv) && !SvUTF8 (sv))
                  {
                    ST (i) = sv = sv_mortalcopy (sv);
                    sv_utf8_upgrade (sv);
                  }
              }

            /* check cache for existing statement handle */
            lru = SvCUR (sql) <= MAX_CACHED_STATEMENT_SIZE
                  ? lru_fetch (dbh, sql)
                  : 0;
            if (!lru)
              {
                mc = mc_find (SvSTASH (SvRV (dbh)));

                if (!mc->prepare)
                  mc_cache (mc, prepare);

                PUSHMARK (SP);
                EXTEND (SP, 2);
                PUSHs (dbh);
                PUSHs (sql);
                PUTBACK;
                count = call_sv (mc->prepare, 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 (!SvROK (sth))
                  croak ("sql_exec: buggy DBD driver, prepare returned non-reference for '%s': %s",
                         SvPV (sql, dc),
                         SvPV (get_sv ("DBI::errstr", TRUE), dd));

                mc = mc_find (SvSTASH (SvRV (sth)));

                if (!mc->bind_param)
                  {
                    mc_cache (mc, bind_param);
                    mc_cache (mc, execute);
                    mc_cache (mc, finish);
                  }

                if (SvCUR (sql) <= MAX_CACHED_STATEMENT_SIZE)
                  lru_store (dbh, sql, sth, mc);

                /* on first execution we unfortunately need to use bind_param
                 * to mark any numeric parameters as such.
                 */
                SvIV_set (tmp_iv, 0);

                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().
                     */

                    PUSHMARK (SP);
                    EXTEND (SP, 4);
                    PUSHs (sth);
                    SvIVX (tmp_iv)++;
                    SvIOK_only (tmp_iv);
                    PUSHs (tmp_iv);
                    PUSHs (sv);

                    PUSHs (
                       SvPOKp (sv) ? sql_varchar
                     : SvNOKp (sv) ? sql_double
                     : SvIOKp (sv) ? sql_integer
                     :               sql_varchar
                    );

                    PUTBACK;
                    call_sv (mc->bind_param, G_VOID);
                    SPAGAIN;

                    arg++;
                  }

                /* now use execute without any arguments */
                PUSHMARK (SP);
                XPUSHs (sth);
              }
            else
              {
                sth = sv_2mortal (SvREFCNT_inc (lru->sth));
                mc  = lru->mc;

                /* we have previously executed this statement, so we
                 * use the cached types and use execute with arguments.
                 */

                PUSHMARK (SP);
                EXTEND (SP, items - arg + 1);
                PUSHs (sth);
                while (items > arg)
                  {
                    SV *sv = ST (arg);
                    PUSHs (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 (mc->execute, 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;

                if (!mc->bind_columns)
                  mc_cache (mc, bind_columns);

                count = call_sv (mc->bind_columns, 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;
              }

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

                PUSHMARK (SP);
                XPUSHs (sth);
                PUTBACK;

                if (!mc->fetchrow_arrayref)
                  mc_cache (mc, fetchrow_arrayref);

                count = call_sv (mc->fetchrow_arrayref, G_SCALAR);
                SPAGAIN;

                if (count != 1)
                  abort ();

                row = POPs;

                SP = PL_stack_base + orig_stack;

                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, AvARRAY ((AV *)SvRV (row))[0]));
                          count = 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;

                if (!mc->fetchall_arrayref)
                  mc_cache (mc, fetchall_arrayref);

                count = call_sv (mc->fetchall_arrayref, G_SCALAR);
                SPAGAIN;

                if (count != 1)
                  abort ();

                rows = POPs;

                SP = PL_stack_base + orig_stack;

                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
              {
                SP = PL_stack_base + orig_stack;
                XPUSHs (sth);
              }

            if (ix >= 2 || GIMME_V == G_VOID)
              {
                orig_stack = SP - PL_stack_base;

                PUSHMARK (SP);
                XPUSHs (sth);
                PUTBACK;

                if (!mc->finish)
                  mc_cache (mc, finish);

                call_sv (mc->finish, G_DISCARD);
                SPAGAIN;

                SP = PL_stack_base + orig_stack;
              }
          }
}


Revision:	1.32
Committed:	Wed Nov 10 11:23:39 2021 UTC (2 years, 6 months ago) by root
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.31:	+12 -13 lines
Log Message:	* empty log message *
#	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	root	1.24	#define DBISTATE_ADDRSV (perl_get_sv (DBISTATE_PERLNAME, 0x05))
11	root	1.22	#define DBIS_PUBLISHED_LVALUE ((INT2PTR(dbistate_t*, &SvIVX(DBISTATE_ADDRSV))))
12
13	root	1.24	static SV sql_varchar, sql_integer, *sql_double;
14			static SV *tmp_iv;
15
16	root	1.22	struct dbistate_st {
17			#define DBISTATE_VERSION 94 /* Must change whenever dbistate_t does */
18			/* this must be the first member in structure */
19			void (check_version) _((const char name,
20			int dbis_cv, int dbis_cs, int need_dbixs_cv,
21			int drc_s, int dbc_s, int stc_s, int fdc_s));
22
23			/* version and size are used to check for DBI/DBD version mis-match */
24			U16 version; /* version of this structure */
25			U16 size;
26			U16 xs_version; /* version of the overall DBIXS / DBD interface */
27			U16 spare_pad;
28			};
29			typedef struct dbistate_st dbistate_t;
30
31			#define DBIcf_ACTIVE 0x000004 /* needs finish/disconnect before clear */
32
33			typedef U32 imp_sth;
34
35			/* not strictly part of the API... */
36			static imp_sth *
37			sth_get_imp (SV *sth)
38			{
39			MAGIC *mg = mg_find (SvRV (sth), PERL_MAGIC_tied);
40			sth = mg->mg_obj;
41			mg = mg_find (SvRV (sth), DBI_MAGIC);
42			return (imp_sth *)SvPVX (mg->mg_obj);
43			}
44
45			#define DBI_STH_ACTIVE(imp) (*(imp) & DBIcf_ACTIVE)
46
47			/* end of import section */
48
49	root	1.3	#if (PERL_VERSION < 5) \|\| ((PERL_VERSION == 5) && (PERL_SUBVERSION <= 6))
50	root	1.5	# define get_sv perl_get_sv
51	root	1.3	# define call_method perl_call_method
52	root	1.5	# define call_sv perl_call_sv
53	root	1.3	#endif
54
55	root	1.11	#if (PERL_VERSION > 5) \|\| ((PERL_VERSION == 5) && (PERL_SUBVERSION >= 6))
56	root	1.5	# define CAN_UTF8 1
57			#endif
58
59	root	1.22	#define MAX_CACHED_STATEMENT_SIZE 2048
60	root	1.14
61	root	1.5	static SV *
62			sql_upgrade_utf8 (SV *sv)
63			{
64			#if CAN_UTF8
65	root	1.24	if (SvPOKp (sv))
66	root	1.5	sv_utf8_upgrade (sv);
67			#endif
68			return sv;
69			}
70
71			static SV *
72	root	1.13	mortalcopy_and_maybe_force_utf8(int utf8, SV *sv)
73	root	1.5	{
74	root	1.13	sv = sv_mortalcopy (sv);
75	root	1.5	#if CAN_UTF8
76	root	1.24	if (utf8 && SvPOKp (sv))
77	root	1.5	SvUTF8_on (sv);
78			#endif
79			return sv;
80			}
81
82			#define maybe_upgrade_utf8(utf8,sv) ((utf8) ? sql_upgrade_utf8 (sv) : (sv))
83
84	root	1.2	#define is_dbh(sv) ((sv) && sv_isobject (sv) && sv_derived_from ((sv), "DBI::db"))
85	root	1.1
86	root	1.24	typedef struct mc_node
87			{
88			struct mc_node *next;
89			HV *stash;
90			U32 gen;
91
92			/* DBH */
93			SV *prepare;
94
95			/* STH */
96			SV *execute;
97			SV *bind_param;
98			SV *bind_columns;
99			SV *fetchrow_arrayref;
100			SV *fetchall_arrayref;
101			SV *finish;
102			} mc_node;
103
104			static mc_node *first;
105
106			static mc_node *
107			mc_find (HV *stash)
108			{
109			mc_node *mc;
110			U32 gen = PL_sub_generation;
111
112			#ifdef HvMROMETA
113			gen += HvMROMETA (stash)->cache_gen;
114			#endif
115
116			for (mc = first; mc; mc = mc->next)
117			if (mc->stash == stash && mc->gen == gen)
118			return mc;
119
120			if (!mc)
121			{
122			Newz (0, mc, 1, mc_node);
123			mc->stash = stash;
124
125			mc->next = first;
126			first = mc;
127			}
128			else
129			{
130			mc->execute =
131			mc->bind_param =
132			mc->bind_columns =
133			mc->fetchrow_arrayref =
134			mc->fetchall_arrayref =
135			mc->finish = 0;
136			}
137
138			mc->gen = gen;
139
140			return mc;
141			}
142
143			static void
144			mc_cache (mc_node mc, SV method, const char name)
145			{
146			method = (SV )gv_fetchmethod_autoload (mc->stash, name, 0);
147
148			if (!method)
149	root	1.28	croak ("%s: method not found in stash, please report.", name);
150	root	1.24	}
151
152			#define mc_cache(mc, method) mc_cache ((mc), &((mc)->method), # method)
153
154			typedef struct lru_node
155			{
156	root	1.1	struct lru_node *next;
157			struct lru_node *prev;
158	root	1.24
159			U32 hash;
160	root	1.1	SV *dbh;
161			SV *sql;
162
163			SV *sth;
164	root	1.22	imp_sth *sth_imp;
165	root	1.24
166			mc_node *mc;
167	root	1.1	} lru_node;
168
169			static lru_node lru_list;
170			static int lru_size;
171			static int lru_maxsize;
172
173	root	1.22	#define lru_init() lru_list.next = &lru_list; lru_list.prev = &lru_list /* other fields are zero */
174	root	1.1
175			/* this is primitive, yet effective */
176			/* the returned value must never be zero (or bad things will happen) */
177	root	1.24	static U32
178			lru_hash (SV dbh, SV sql)
179			{
180	root	1.31	/* use a variant of fnv1a */
181	root	1.24	STRLEN i, l;
182			char *b = SvPV (sql, l);
183	root	1.26	U32 hash = 2166136261U;
184	root	1.24
185			hash = (hash ^ (U32)dbh) * 16777619U;
186			hash = (hash ^ l) * 16777619U;
187
188	root	1.31	/* start hashing at char 7, as this skips the "select " prefix */
189			/* also skip more and more octets */
190	root	1.24	for (i = 7; i < l; i += i >> 2)
191	root	1.31	hash = (hash ^ b [i]) * 16777619U;
192	root	1.24
193			return hash;
194			}
195	root	1.1
196			/* fetch and "use" */
197	root	1.24	static lru_node *
198	root	1.22	lru_fetch (SV dbh, SV sql)
199	root	1.1	{
200			lru_node *n;
201			U32 hash;
202
203			dbh = SvRV (dbh);
204	root	1.24	hash = lru_hash (dbh, sql);
205	root	1.1
206			n = &lru_list;
207			do {
208			n = n->next;
209	root	1.22
210	root	1.1	if (!n->hash)
211			return 0;
212			} while (n->hash != hash
213	root	1.22	\|\| DBI_STH_ACTIVE (n->sth_imp)
214	root	1.1	\|\| !sv_eq (n->sql, sql)
215			\|\| n->dbh != dbh);
216
217			/* found, so return to the start of the list */
218			n->prev->next = n->next;
219			n->next->prev = n->prev;
220
221			n->next = lru_list.next;
222			n->prev = &lru_list;
223			lru_list.next->prev = n;
224			lru_list.next = n;
225
226	root	1.24	return n;
227	root	1.1	}
228
229	root	1.22	static void
230			lru_trim (void)
231	root	1.1	{
232	root	1.22	while (lru_size > lru_maxsize)
233			{
234			/* nuke at the end */
235			lru_node *n = lru_list.prev;
236	root	1.1
237	root	1.22	n = lru_list.prev;
238	root	1.1
239	root	1.22	lru_list.prev = n->prev;
240			n->prev->next = &lru_list;
241	root	1.1
242	root	1.32	SvREFCNT_dec_NN (n->dbh);
243			SvREFCNT_dec_NN (n->sql);
244			SvREFCNT_dec_NN (n->sth);
245	root	1.22	Safefree (n);
246
247			lru_size--;
248			}
249	root	1.1	}
250
251			/* store a not-yet existing entry(!) */
252	root	1.22	static void
253	root	1.24	lru_store (SV dbh, SV sql, SV sth, mc_node mc)
254	root	1.1	{
255			lru_node *n;
256			U32 hash;
257
258	root	1.22	if (!lru_maxsize)
259			return;
260
261	root	1.1	dbh = SvRV (dbh);
262	root	1.24	hash = lru_hash (dbh, sql);
263	root	1.1
264			lru_size++;
265	root	1.22	lru_trim ();
266	root	1.1
267			New (0, n, 1, lru_node);
268
269	root	1.22	n->hash = hash;
270	root	1.32	n->dbh = SvREFCNT_inc_NN (dbh); /* note: this is the dbi hash itself, not the reference */
271	root	1.22	n->sql = newSVsv (sql);
272	root	1.32	n->sth = SvREFCNT_inc_NN (sth);
273	root	1.22	n->sth_imp = sth_get_imp (sth);
274	root	1.24	n->mc = mc;
275	root	1.1
276	root	1.22	n->next = lru_list.next;
277			n->prev = &lru_list;
278	root	1.1	lru_list.next->prev = n;
279			lru_list.next = n;
280			}
281
282	root	1.22	static void
283			lru_cachesize (int size)
284	root	1.1	{
285			if (size >= 0)
286			{
287			lru_maxsize = size;
288	root	1.22	lru_trim ();
289	root	1.1	}
290			}
291
292			static GV *sql_exec;
293			static GV *DBH;
294	root	1.5
295			#define newconstpv(str) newSVpvn ((str), sizeof (str))
296	root	1.1
297			MODULE = PApp::SQL PACKAGE = PApp::SQL
298
299			PROTOTYPES: DISABLE
300
301			BOOT:
302			{
303	root	1.22	struct dbistate_st *dbis = DBIS_PUBLISHED_LVALUE;
304
305	root	1.23	/* this is actually wrong, we should call the check member, apparently */
306	root	1.22	assert (dbis->version == DBISTATE_VERSION);
307			assert (dbis->xs_version == DBIXS_VERSION);
308
309	root	1.24	tmp_iv = newSViv (0);
310
311	root	1.1	sql_exec = gv_fetchpv ("PApp::SQL::sql_exec", TRUE, SVt_PV);
312			DBH = gv_fetchpv ("PApp::SQL::DBH" , TRUE, SVt_PV);
313
314			/* apache might BOOT: twice :( */
315			if (lru_size)
316			lru_cachesize (0);
317
318	root	1.22	lru_init ();
319	root	1.24	lru_cachesize (100);
320	root	1.1	}
321
322	root	1.24	void
323			boot2 (SV t_str, SV t_int, SV *t_dbl)
324			CODE:
325			sql_varchar = newSVsv (t_str);
326			sql_integer = newSVsv (t_int);
327			sql_double = newSVsv (t_dbl);
328
329	root	1.1	int
330			cachesize(size = -1)
331			int size
332			CODE:
333			RETVAL = lru_maxsize;
334			lru_cachesize (size);
335			OUTPUT:
336			RETVAL
337
338			void
339			sql_exec(...)
340			ALIAS:
341	root	1.5	sql_uexec = 1
342	root	1.27	sql_fetch = 2
343	root	1.5	sql_ufetch = 3
344			sql_fetchall = 4
345			sql_ufetchall = 5
346			sql_exists = 6
347			sql_uexists = 7
348	root	1.1	PPCODE:
349			{
350			if (items == 0)
351			croak ("Usage: sql_exec [database-handle,] [bind-var-refs,... ] \"sql-statement\", [arguments, ...]");
352			else
353			{
354	root	1.24	int i;
355	root	1.1	int arg = 0;
356			int bind_first, bind_last;
357			int count;
358	root	1.24	lru_node *lru;
359	root	1.1	SV *dbh = ST(0);
360			SV *sth;
361			SV *sql;
362			SV *execute;
363	root	1.24	mc_node *mc;
364	root	1.9	STRLEN dc, dd; /* dummy */
365	root	1.24	I32 orig_stack = SP - PL_stack_base;
366	root	1.1
367			/* save our arguments against destruction through function calls */
368			SP += items;
369
370			/* first check wether we should use an explicit db handle */
371			if (!is_dbh (dbh))
372			{
373	root	1.12	/* the next line doesn't work - check why later maybe */
374			/* dbh = get_sv ("DBH", FALSE);
375	root	1.1	if (!is_dbh (dbh))
376	root	1.12	{*/
377	root	1.20	dbh = GvSV (DBH);
378	root	1.1	if (!is_dbh (dbh))
379	root	1.12	croak ("sql_exec: no $DBH argument and no fallback in $PApp::SQL::DBH");
380			/*croak ("sql_exec: no $DBH found in current package or in PApp::SQL::");
381			}*/
382	root	1.1	}
383			else
384			arg++; /* we consumed one argument */
385
386	root	1.20	/* be more Coro-friendly by keeping a copy, so different threads */
387	root	1.21	/* can replace their global handles */
388	root	1.20	dbh = sv_2mortal (newSVsv (dbh));
389
390	root	1.1	/* count the remaining references (for bind_columns) */
391			bind_first = arg;
392			while (items > arg && SvROK (ST(arg)))
393			arg++;
394
395			bind_last = arg;
396
397			/* consume the sql-statement itself */
398			if (items <= arg)
399			croak ("sql_exec: required argument \"sql-statement\" missing");
400
401			if (!SvPOK (ST(arg)))
402			croak ("sql_exec: sql-statement must be a string");
403
404			sql = ST(arg); arg++;
405
406	root	1.32	if ((ix & ~1) == 6) /* sql_exists */
407	root	1.1	{
408			SV neu = sv_2mortal (newSVpv ("select count() > 0 from ", 0));
409			sv_catsv (neu, sql);
410			sv_catpv (neu, " limit 1");
411			sql = neu;
412	root	1.7	ix -= 4; /* sql_fetch */
413	root	1.1	}
414
415	root	1.24	/* now prepare all parameters, by unmagicalising them and upgrading them */
416			for (i = arg; i < items; ++i)
417			{
418			SV *sv = ST (i);
419
420			/* we sv_mortalcopy magical values since DBI seems to have a memory
421			* leak when magical values are passed into execute().
422			*/
423			if (SvMAGICAL (sv))
424			ST (i) = sv = sv_mortalcopy (sv);
425
426			if ((ix & 1) && SvPOKp (sv) && !SvUTF8 (sv))
427			{
428			ST (i) = sv = sv_mortalcopy (sv);
429			sv_utf8_upgrade (sv);
430			}
431			}
432
433	root	1.4	/* check cache for existing statement handle */
434	root	1.24	lru = SvCUR (sql) <= MAX_CACHED_STATEMENT_SIZE
435			? lru_fetch (dbh, sql)
436			: 0;
437			if (!lru)
438	root	1.1	{
439	root	1.24	mc = mc_find (SvSTASH (SvRV (dbh)));
440
441			if (!mc->prepare)
442			mc_cache (mc, prepare);
443
444	root	1.1	PUSHMARK (SP);
445			EXTEND (SP, 2);
446			PUSHs (dbh);
447			PUSHs (sql);
448			PUTBACK;
449	root	1.24	count = call_sv (mc->prepare, G_SCALAR);
450	root	1.1	SPAGAIN;
451
452			if (count != 1)
453			croak ("sql_exec: unable to prepare() statement '%s': %s",
454	root	1.3	SvPV (sql, dc),
455	root	1.9	SvPV (get_sv ("DBI::errstr", TRUE), dd));
456	root	1.1
457			sth = POPs;
458
459	root	1.25	if (!SvROK (sth))
460			croak ("sql_exec: buggy DBD driver, prepare returned non-reference for '%s': %s",
461			SvPV (sql, dc),
462			SvPV (get_sv ("DBI::errstr", TRUE), dd));
463
464	root	1.24	mc = mc_find (SvSTASH (SvRV (sth)));
465
466			if (!mc->bind_param)
467			{
468			mc_cache (mc, bind_param);
469			mc_cache (mc, execute);
470			mc_cache (mc, finish);
471			}
472
473			if (SvCUR (sql) <= MAX_CACHED_STATEMENT_SIZE)
474			lru_store (dbh, sql, sth, mc);
475
476			/* on first execution we unfortunately need to use bind_param
477			* to mark any numeric parameters as such.
478			*/
479			SvIV_set (tmp_iv, 0);
480
481			while (items > arg)
482			{
483			SV *sv = ST (arg);
484			/* we sv_mortalcopy magical values since DBI seems to have a memory
485			* leak when magical values are passed into execute().
486			*/
487
488			PUSHMARK (SP);
489			EXTEND (SP, 4);
490			PUSHs (sth);
491			SvIVX (tmp_iv)++;
492	root	1.29	SvIOK_only (tmp_iv);
493	root	1.24	PUSHs (tmp_iv);
494			PUSHs (sv);
495
496			PUSHs (
497			SvPOKp (sv) ? sql_varchar
498			: SvNOKp (sv) ? sql_double
499			: SvIOKp (sv) ? sql_integer
500			: sql_varchar
501			);
502
503			PUTBACK;
504			call_sv (mc->bind_param, G_VOID);
505			SPAGAIN;
506
507			arg++;
508			}
509
510			/* now use execute without any arguments */
511			PUSHMARK (SP);
512	root	1.32	XPUSHs (sth);
513	root	1.1	}
514	root	1.24	else
515			{
516			sth = sv_2mortal (SvREFCNT_inc (lru->sth));
517			mc = lru->mc;
518	root	1.1
519	root	1.24	/* we have previously executed this statement, so we
520			* use the cached types and use execute with arguments.
521	root	1.15	*/
522	root	1.24
523			PUSHMARK (SP);
524			EXTEND (SP, items - arg + 1);
525			PUSHs (sth);
526			while (items > arg)
527			{
528			SV *sv = ST (arg);
529	root	1.27	PUSHs (sv);
530	root	1.24	arg++;
531			}
532	root	1.1	}
533
534			PUTBACK;
535			/* { static GV *execute;
536			if (!execute) execute = gv_fetchmethod_autoload(SvSTASH(SvRV(sth)), "execute", 0);
537			count = call_sv(GvCV(execute), G_SCALAR);
538			}*/
539	root	1.24	count = call_sv (mc->execute, G_SCALAR);
540	root	1.1	SPAGAIN;
541
542			if (count != 1)
543			croak ("sql_exec: execute() didn't return any value ('%s'): %s",
544	root	1.3	SvPV (sql, dc),
545	root	1.10	SvPV (get_sv ("DBI::errstr", TRUE), dd));
546	root	1.1
547			execute = POPs;
548
549			if (!SvTRUE (execute))
550			croak ("sql_exec: unable to execute statement '%s' (%s)",
551	root	1.3	SvPV (sql, dc),
552	root	1.10	SvPV (get_sv ("DBI::errstr", TRUE), dd));
553	root	1.1
554	root	1.24	sv_setsv (GvSV (sql_exec), execute);
555	root	1.1
556			if (bind_first != bind_last)
557			{
558			PUSHMARK (SP);
559			EXTEND (SP, bind_last - bind_first + 2);
560			PUSHs (sth);
561			do {
562	stefan	1.16	#if CAN_UTF8
563	root	1.17	if (ix & 1)
564			SvUTF8_on (SvRV(ST(bind_first)));
565	stefan	1.16	#endif
566	root	1.1	PUSHs (ST(bind_first));
567			bind_first++;
568			} while (bind_first != bind_last);
569
570			PUTBACK;
571	root	1.24
572			if (!mc->bind_columns)
573			mc_cache (mc, bind_columns);
574
575			count = call_sv (mc->bind_columns, G_SCALAR);
576
577	root	1.1	SPAGAIN;
578
579			if (count != 1)
580			croak ("sql_exec: bind_columns() didn't return any value ('%s'): %s",
581	root	1.3	SvPV (sql, dc),
582	root	1.10	SvPV (get_sv ("DBI::errstr", TRUE), dd));
583	root	1.1
584	root	1.19	if (!SvOK (TOPs))
585	root	1.1	croak ("sql_exec: bind_columns() didn't return a true ('%s'): %s",
586	root	1.3	SvPV (sql, dc),
587	root	1.10	SvPV (get_sv ("DBI::errstr", TRUE), dd));
588	root	1.19
589			POPs;
590	root	1.1	}
591
592	root	1.32	if ((ix & ~1) == 2) /* sql_fetch */
593			{
594	root	1.1	SV *row;
595
596			PUSHMARK (SP);
597			XPUSHs (sth);
598			PUTBACK;
599	root	1.24
600			if (!mc->fetchrow_arrayref)
601			mc_cache (mc, fetchrow_arrayref);
602
603			count = call_sv (mc->fetchrow_arrayref, G_SCALAR);
604	root	1.1	SPAGAIN;
605
606			if (count != 1)
607			abort ();
608
609			row = POPs;
610
611	root	1.24	SP = PL_stack_base + orig_stack;
612
613	root	1.1	if (SvROK (row))
614			{
615			AV *av;
616
617			switch (GIMME_V)
618			{
619			case G_VOID:
620			/* no thing */
621			break;
622			case G_SCALAR:
623			/* the first element */
624	root	1.29	XPUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY ((AV *)SvRV (row))[0]));
625	root	1.24	count = 1;
626	root	1.1	break;
627			case G_ARRAY:
628			av = (AV *)SvRV (row);
629			count = AvFILL (av) + 1;
630			EXTEND (SP, count);
631			for (arg = 0; arg < count; arg++)
632	root	1.13	PUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY (av)[arg]));
633	root	1.1
634			break;
635			default:
636			abort ();
637			}
638			}
639			}
640	root	1.32	else if ((ix & ~1) == 4) /* sql_fetchall */
641			{
642	root	1.1	SV *rows;
643
644			PUSHMARK (SP);
645			XPUSHs (sth);
646			PUTBACK;
647	root	1.24
648			if (!mc->fetchall_arrayref)
649			mc_cache (mc, fetchall_arrayref);
650
651			count = call_sv (mc->fetchall_arrayref, G_SCALAR);
652	root	1.1	SPAGAIN;
653
654			if (count != 1)
655			abort ();
656
657			rows = POPs;
658
659	root	1.24	SP = PL_stack_base + orig_stack;
660
661	root	1.1	if (SvROK (rows))
662			{
663			AV av = (AV )SvRV (rows);
664			count = AvFILL (av) + 1;
665
666			if (count)
667			{
668	root	1.6	int columns = AvFILL ((AV ) SvRV (AvARRAY (av)[0])) + 1; / columns? */
669	root	1.1
670			EXTEND (SP, count);
671			if (columns == 1)
672			for (arg = 0; arg < count; arg++)
673	root	1.13	PUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY ((AV *)SvRV (AvARRAY (av)[arg]))[0]));
674	root	1.1	else
675			for (arg = 0; arg < count; arg++)
676	root	1.13	PUSHs (mortalcopy_and_maybe_force_utf8 (ix & 1, AvARRAY (av)[arg]));
677	root	1.1	}
678			}
679			}
680			else
681	root	1.24	{
682			SP = PL_stack_base + orig_stack;
683			XPUSHs (sth);
684			}
685	root	1.1
686	root	1.32	if (ix >= 2 \|\| GIMME_V == G_VOID)
687	root	1.1	{
688	root	1.24	orig_stack = SP - PL_stack_base;
689
690	root	1.1	PUSHMARK (SP);
691			XPUSHs (sth);
692			PUTBACK;
693	root	1.24
694			if (!mc->finish)
695			mc_cache (mc, finish);
696
697			call_sv (mc->finish, G_DISCARD);
698	root	1.1	SPAGAIN;
699	root	1.24
700			SP = PL_stack_base + orig_stack;
701	root	1.1	}
702			}
703			}
704
705
706