Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

adapted to the new extension building process

git-svn-id: svn+ssh://svn.kahua.org/var/local/repos/kahua/Gauche-dbd-pg/trunk@828 4e392e78-dc3f-dc11-8fd5-00188bfc9ac4
  • Loading branch information...
commit d2156adddee4e1439a9f445c9b66bd27fa267a66 1 parent 3ea7c1b
Shiro Kawai shirok authored
30 COPYING
... ... @@ -0,0 +1,30 @@
  1 +
  2 + Copyright (c) 2003 Scheme Arts, L.L.C., All rights reserved.
  3 + Copyright (c) 2003 Time Intermedia Corporation, All rights reserved.
  4 +
  5 + Redistribution and use in source and binary forms, with or without
  6 + modification, are permitted provided that the following conditions
  7 + are met:
  8 +
  9 + 1. Redistributions of source code must retain the above copyright
  10 + notice, this list of conditions and the following disclaimer.
  11 +
  12 + 2. Redistributions in binary form must reproduce the above copyright
  13 + notice, this list of conditions and the following disclaimer in the
  14 + documentation and/or other materials provided with the distribution.
  15 +
  16 + 3. Neither the name of the authors nor the names of its contributors
  17 + may be used to endorse or promote products derived from this
  18 + software without specific prior written permission.
  19 +
  20 + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  21 + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  22 + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  23 + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  24 + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  25 + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
  26 + TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
  27 + PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
  28 + LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  29 + NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  30 + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
43 DIST
... ... @@ -0,0 +1,43 @@
  1 +#!/bin/sh
  2 +#
  3 +# A helper script for developers.
  4 +# ./DIST gen : runs autoconf to generate 'configure' script.
  5 +# ./DIST tgz : creates a tarball.
  6 +# Assumes gnu tar.
  7 +
  8 +MODULE=Gauche-dbd-pg
  9 +
  10 +while [ $# -gt 0 ]; do
  11 + case $1 in
  12 + gen) gen=yes; shift ;;
  13 + tgz) tgz=yes; shift ;;
  14 + *) echo "DIST gen|tgz"; exit 0;;
  15 + esac
  16 +done
  17 +
  18 +if [ "$gen" = "yes" ]; then
  19 + autoconf
  20 +fi
  21 +
  22 +if [ "$tgz" = "yes" ]; then
  23 + if [ -f Makefile ]; then make maintainer-clean; fi
  24 + ./DIST gen
  25 + ./configure
  26 + make distclean
  27 +
  28 + if [ ! -f VERSION ]; then echo "No VERSION; something wrong?"; exit 1; fi
  29 + VERSION=`cat VERSION`
  30 +
  31 + rm -f DIST_EXCLUDE_X
  32 + echo DIST > DIST_EXCLUDE_X
  33 + echo DIST_EXCLUDE_X >> DIST_EXCLUDE_X
  34 + if [ -f DIST_EXCLUDE ]; then cat DIST_EXCLUDE >> DIST_EXCLUDE_X; fi
  35 + find . -name CVS -print -prune >> DIST_EXCLUDE_X
  36 +
  37 + rm -rf ../$MODULE-$VERSION
  38 +
  39 + mkdir ../$MODULE-$VERSION
  40 + tar cvfX - DIST_EXCLUDE_X . | (cd ../$MODULE-$VERSION; tar xf -)
  41 + (cd ..; tar cvf - $MODULE-$VERSION | gzip -9 > $MODULE-$VERSION.tgz)
  42 + (cd ..; rm -rf $MODULE-$VERSION)
  43 +fi
79 Makefile.in
... ... @@ -0,0 +1,79 @@
  1 +#
  2 +# $Id: Makefile.in,v 1.1 2005/07/19 00:45:42 shiro Exp $
  3 +#
  4 +
  5 +# General info
  6 +SHELL = @SHELL@
  7 +prefix = @prefix@
  8 +exec_prefix = @exec_prefix@
  9 +bindir = @bindir@
  10 +libdir = @libdir@
  11 +VPATH = $(srcdir)
  12 +
  13 +# These may be overridden by make invocators
  14 +DESTDIR =
  15 +GOSH = @GOSH@
  16 +GAUCHE_CONFIG = @GAUCHE_CONFIG@
  17 +GAUCHE_PACKAGE = @GAUCHE_PACKAGE@
  18 +INSTALL = @GAUCHE_INSTALL@
  19 +
  20 +# Other parameters
  21 +SOEXT = @SOEXT@
  22 +OBJEXT = @OBJEXT@
  23 +EXEEXT = @EXEEXT@
  24 +
  25 +# Module-specific stuff
  26 +PACKAGE = Gauche-dbd-pg
  27 +
  28 +ARCHFILES = gauche_dbd_pg.$(SOEXT)
  29 +SCMFILES = dbd/pg.scm
  30 +HEADERS =
  31 +
  32 +TARGET = $(ARCHFILES)
  33 +GENERATED =
  34 +CONFIG_GENERATED = Makefile config.cache config.log config.status \
  35 + configure.lineno autom4te*.cache $(PACKAGE).gpd
  36 +
  37 +HEADER_INSTALL_DIR = $(DESTDIR)`$(GAUCHE_CONFIG) --siteincdir`
  38 +SCM_INSTALL_DIR = $(DESTDIR)`$(GAUCHE_CONFIG) --sitelibdir`
  39 +ARCH_INSTALL_DIR = $(DESTDIR)`$(GAUCHE_CONFIG) --sitearchdir`
  40 +
  41 +PG_CFLAGS = @PG_CFLAGS@
  42 +PG_LDFLAGS = @PG_LDFLAGS@
  43 +
  44 +gauche_dbd_pg_SRCS = gauche_dbd_pg.c gauche_dbd_pglib.stub
  45 +
  46 +all : $(TARGET)
  47 +
  48 +gauche_dbd_pg.$(SOEXT): $(gauche_dbd_pg_SRCS)
  49 + $(GAUCHE_PACKAGE) compile \
  50 + --cflags="$(PG_CFLAGS)" \
  51 + --ldflags="$(PG_LDFLAGS)" \
  52 + --verbose gauche_dbd_pg $(gauche_dbd_pg_SRCS)
  53 +
  54 +check : all
  55 + @rm -f test.log
  56 + $(GOSH) -I. test.scm > test.log
  57 +
  58 +install : all
  59 + $(INSTALL) -m 444 -T $(HEADER_INSTALL_DIR) $(HEADERS)
  60 + $(INSTALL) -m 444 -T $(SCM_INSTALL_DIR) $(SCMFILES)
  61 + $(INSTALL) -m 555 -T $(ARCH_INSTALL_DIR) $(ARCHFILES)
  62 + $(INSTALL) -m 444 -T $(SCM_INSTALL_DIR)/.packages $(PACKAGE).gpd
  63 +
  64 +uninstall :
  65 + $(INSTALL) -U $(HEADER_INSTALL_DIR) $(HEADERS)
  66 + $(INSTALL) -U $(SCM_INSTALL_DIR) $(SCMFILES)
  67 + $(INSTALL) -U $(ARCH_INSTALL_DIR) $(ARCHFILES)
  68 + $(INSTALL) -U $(SCM_INSTALL_DIR)/.packages $(PACKAGE).gpd
  69 +
  70 +clean :
  71 + $(GAUCHE_PACKAGE) compile --clean gauche_dbd_pg $(gauche_dbd_pg_SRCS)
  72 + rm -rf core $(TARGET) $(GENERATED) *~ test.log so_locations
  73 +
  74 +distclean : clean
  75 + rm -rf $(CONFIG_GENERATED)
  76 +
  77 +maintainer-clean : clean
  78 + rm -rf $(CONFIG_GENERATED) configure VERSION
  79 +
25 README
... ... @@ -0,0 +1,25 @@
  1 +* Requirements
  2 +
  3 +** pg_config
  4 +
  5 +./configure requires 'pg_config'.
  6 +please set path to 'pg_config', like that:
  7 +
  8 + export PATH=/usr/local/pgsql/bin:$PATH
  9 +
  10 +** your default database
  11 +
  12 +make test requires PostgreSQL's default database.
  13 +
  14 +if it's not exist, you may make it like that:
  15 +
  16 + % sudo -u postgres createuser <your-login-name>
  17 + % sudo -u postgres createdb <your-login-name>
  18 +
  19 +* Build and Install
  20 +
  21 + % ./configure
  22 + % make
  23 + % make check
  24 + % sudo make install
  25 +
62 configure.in
... ... @@ -0,0 +1,62 @@
  1 +dnl
  2 +dnl Configuring Gauche-dbd-pg
  3 +dnl process this file with autoconf to generate 'configure'.
  4 +dnl $Id: configure.in,v 1.1 2005/07/19 00:45:42 shiro Exp $
  5 +dnl
  6 +
  7 +AC_PREREQ(2.54)
  8 +AC_INIT(Gauche-dbd-pg, 0.2_pre1, shiro@acm.org)
  9 +dnl If you want to use the system name (OS, architecture, etc) in the
  10 +dnl configure, uncomment the following line. In such a case, you need
  11 +dnl to copy config.guess and config.sub from automake distribution.
  12 +dnl AC_CANONICAL_SYSTEM
  13 +
  14 +dnl Set up gauche related commands. The commands are set by scanning
  15 +dnl PATH. You can override them by "GOSH=/my/gosh ./configure" etc.
  16 +AC_PATH_PROG([GOSH], gosh)
  17 +AC_PATH_PROG([GAUCHE_CONFIG], gauche-config)
  18 +AC_PATH_PROG([GAUCHE_PACKAGE], gauche-package)
  19 +AC_PATH_PROG([GAUCHE_INSTALL], gauche-install)
  20 +AC_PATH_PROG([GAUCHE_CESCONV], gauche-cesconv)
  21 +
  22 +dnl Usually these parameters are set by AC_PROG_CC, but we'd rather use
  23 +dnl the same one as Gauche has been compiled with.
  24 +SOEXT=`$GAUCHE_CONFIG --so-suffix`
  25 +OBJEXT=`$GAUCHE_CONFIG --object-suffix`
  26 +EXEEXT=`$GAUCHE_CONFIG --executable-suffix`
  27 +AC_SUBST(SOEXT)
  28 +AC_SUBST(OBJEXT)
  29 +AC_SUBST(EXEEXT)
  30 +
  31 +dnl Check for headers.
  32 +dnl Add your macro calls to check required headers, if you have any.
  33 +
  34 +dnl Check for other programs.
  35 +dnl Add your macro calls to check existence of programs, if you have any.
  36 +
  37 +dnl Check for libraries
  38 +dnl Add your macro calls to check required libraries, if you have any.
  39 +AC_PATH_PROGS(PG_CONFIG, pg_config)
  40 +AC_MSG_CHECKING(checking postgresql client library)
  41 +if test X${PG_CONFIG} = X; then
  42 + AC_MSG_RESULT(not available)
  43 +else
  44 + AC_DEFINE(HAVE_PG, 1)
  45 + PG_CFLAGS=-I`${PG_CONFIG} --includedir`
  46 + PG_LDFLAGS="-L`${PG_CONFIG} --libdir` -lpq"
  47 + AC_SUBST(PG_CFLAGS)
  48 + AC_SUBST(PG_LDFLAGS)
  49 + AC_MSG_RESULT(ok)
  50 +fi
  51 +
  52 +dnl Creating gpd (gauche package description) file
  53 +GAUCHE_PACKAGE_CONFIGURE_ARGS="`echo ""$ac_configure_args"" | sed 's/[\\""\`\$]/\\\&/g'`"
  54 +AC_MSG_NOTICE([creating ${PACKAGE_NAME}.gpd])
  55 +$GAUCHE_PACKAGE make-gpd "$PACKAGE_NAME" \
  56 + -version "$PACKAGE_VERSION" \
  57 + -configure "./configure $GAUCHE_PACKAGE_CONFIGURE_ARGS"
  58 +
  59 +dnl Output
  60 +echo $PACKAGE_VERSION > VERSION
  61 +AC_OUTPUT(Makefile)
  62 +
137 dbd/pg.scm
... ... @@ -0,0 +1,137 @@
  1 +;;; dbd.pg - PostgreSQL driver
  2 +;;;
  3 +;;; Copyright (c) 2003-2005 Scheme Arts, L.L.C., All rights reserved.
  4 +;;; Copyright (c) 2003-2005 Time Intermedia Corporation, All rights reserved.
  5 +;;; See COPYING for terms and conditions of using this software
  6 +;;;
  7 +;;; $Id: pg.scm,v 1.1 2005/07/19 00:45:43 shiro Exp $
  8 +
  9 +(define-module dbd.pg
  10 + (use gauche.collection)
  11 + (use dbi)
  12 + (export <pg-driver>
  13 + <pg-connection>
  14 + <pg-query>
  15 + <pg-result-set>
  16 + <pq-handle> ; pq.so
  17 + <pq-res> ; pq.so
  18 + pq-connectdb ; pq.so
  19 + pq-exec ; pq.so
  20 + pq-result-status ; pq.so
  21 + pq-result-error-message ; pq.so
  22 + pq-ntuples ; pq.so
  23 + pq-nfields ; pq.so
  24 + pq-get-value ; pq.so
  25 + pq-finish ; pq.so
  26 + dbi-make-connection
  27 + dbi-make-query
  28 + dbi-execute-query
  29 + call-with-iterator
  30 + dbi-get-value
  31 + dbi-close))
  32 +(select-module dbd.pg)
  33 +
  34 +;; Loads extension
  35 +(dynamic-load "gauche_dbd_pg")
  36 +
  37 +(define-class <pg-driver> (<dbi-driver>) ())
  38 +
  39 +(define-class <pg-connection> (<dbi-connection>)
  40 + ((%connection :init-keyword :connection :init-value #f)))
  41 +
  42 +(define-class <pg-query> (<dbi-query>)
  43 + ((%connection :init-keyword :connection)
  44 + (%query-string :init-keyword :query-string)))
  45 +
  46 +(define-class <pg-result-set> (<dbi-result-set> <collection>)
  47 + ((%result-set :init-keyword :result-set)
  48 + (%status :init-keyword :status)
  49 + (%error :init-keyword :error)
  50 +;; (%row-id :init-keyword :row-id)
  51 + (%num-rows :init-keyword :num-rows)
  52 + (num-cols :getter dbi-column-count :init-keyword :num-cols)))
  53 +
  54 +(define-method dbi-make-connection ((d <pg-driver>) (user <string>)
  55 + (password <string>) (option <string>))
  56 + (let ((conn
  57 + (make <pg-connection> :driver-name d :open #t
  58 + :connection (pq-connectdb
  59 + (string-append
  60 + (if (> (string-length user) 0) "user=" "")
  61 + user
  62 + (if (> (string-length password) 0) " password=" "")
  63 + password " " option)
  64 + (make <pq-handle>)))))
  65 + (let ((status (pq-status (slot-ref conn '%connection))))
  66 + (if (eq? status CONNECTION_BAD)
  67 + (raise (make <dbi-exception>
  68 + :error-code status
  69 + :message "Connect Error: Bad Connection"))
  70 + conn))))
  71 +
  72 +(define-method dbi-make-query ((c <pg-connection>))
  73 + (if (not (slot-ref c 'open))
  74 + (raise
  75 + (make <dbi-exception> :error-code -1
  76 + :message "connection has already closed.")))
  77 + (make <pg-query> :open #t
  78 + :connection (slot-ref c '%connection)))
  79 +
  80 +(define-method dbi-execute-query ((q <pg-query>) (query-string <string>))
  81 + (if (not (slot-ref q 'open))
  82 + (raise
  83 + (make <dbi-exception> :error-code -2
  84 + :message "query has already closed.")))
  85 + (let ((result (pq-exec query-string (slot-ref q '%connection) (make <pq-res>))))
  86 + (let ((status (pq-result-status result))
  87 + (error (pq-result-error-message result)))
  88 + (case status
  89 + ((PG_NONFATAL_ERROR)
  90 + (raise
  91 + (make <dbi-exception> :error-code status :error-message error)))
  92 + ((PG_FATAL_ERROR)
  93 + (raise
  94 + (make <dbi-exception> :error-code status :error-message error))))
  95 + (make <pg-result-set> :open #t :result-set result
  96 + :status status
  97 + :error error
  98 + :num-rows (pq-ntuples result)
  99 + :num-cols (pq-nfields result)))))
  100 +
  101 +(define-method call-with-iterator ((r <pg-result-set>) proc . option)
  102 + (if (not (slot-ref r 'open))
  103 + (raise (make <dbi-exception> :error-code -4 :message "<pg-result> already closed.")))
  104 + (let ((row-id -1))
  105 + (define (end?) (>= (+ row-id 1) (slot-ref r '%num-rows)))
  106 + (define (next)
  107 + (inc! row-id)
  108 + (let ((proc
  109 + (lambda (n)
  110 + (let ((value (pq-get-value row-id n (slot-ref r '%result-set)))) value)))) proc))
  111 + (proc end? next)))
  112 +
  113 +(define-method dbi-get-value ((proc <procedure>) (n <integer>)) (proc n))
  114 +
  115 +(define-method dbi-close ((result-set <pg-result-set>))
  116 + (if (not (slot-ref result-set 'open))
  117 + (raise
  118 + (make <dbi-exception> :error-code -5 :message "already closed.")))
  119 + (slot-set! result-set 'open #f))
  120 +
  121 +(define-method dbi-close ((query <pg-query>))
  122 + (if (not (slot-ref query 'open))
  123 + (raise
  124 + (make <dbi-exception :error-code -6 :message "already closed.")))
  125 + (slot-set! query 'open #f))
  126 +
  127 +(define-method dbi-close ((connection <pg-connection>))
  128 + (if (not (slot-ref connection 'open))
  129 + (raise
  130 + (make <dbi-exception> :error-code -7 :message "already closed.")))
  131 + (slot-set! connection 'open #f)
  132 + (pq-finish (slot-ref connection '%connection)))
  133 +
  134 +;; Epilogue
  135 +(provide "dbd/pg")
  136 +
  137 +
201 gauche_dbd_pg.c
... ... @@ -0,0 +1,201 @@
  1 +/*
  2 + * gauche_dbd_pg.c
  3 + *
  4 + * Copyright (c) 2003-2005 Scheme Arts, L.L.C., All rights reserved.
  5 + * Copyright (c) 2003-2005 Time Intermedia Corporation, All rights reserved.
  6 + * See COPYING for terms and conditions of using this software
  7 + *
  8 + * $Id: gauche_dbd_pg.c,v 1.1 2005/07/19 00:45:42 shiro Exp $
  9 + */
  10 +
  11 +#include "gauche_dbd_pg.h"
  12 +
  13 +/*
  14 + * static function prototypes
  15 + */
  16 +
  17 +static ScmObj pq_allocate(ScmClass *klass, ScmObj initargs);
  18 +static ScmObj pq_res_allocate(ScmClass *klass, ScmObj initargs);
  19 +
  20 +/*
  21 + * class definitions
  22 + */
  23 +
  24 +SCM_DEFINE_BUILTIN_CLASS(Scm_PqClass,
  25 + NULL, NULL, NULL,
  26 + pq_allocate,
  27 + NULL);
  28 +
  29 +SCM_DEFINE_BUILTIN_CLASS(Scm_PqResClass,
  30 + NULL, NULL, NULL,
  31 + pq_res_allocate,
  32 + NULL);
  33 +
  34 +/*
  35 + * allocators
  36 + */
  37 +static ScmObj pq_allocate(ScmClass *klass, ScmObj initargs) {
  38 + ScmPq *h = SCM_NEW(ScmPq);
  39 + SCM_SET_CLASS(h, SCM_CLASS_PQ);
  40 + memset(&h->handle, 0, sizeof(h->handle));
  41 + return SCM_OBJ(h);
  42 +}
  43 +
  44 +static ScmObj pq_res_allocate(ScmClass *klass, ScmObj initargs) {
  45 + ScmPqRes *r = SCM_NEW(ScmPqRes);
  46 + SCM_SET_CLASS(r, SCM_CLASS_PQ_RES);
  47 + memset(&r->res, 0, sizeof(r->res));
  48 + return SCM_OBJ(r);
  49 +}
  50 +
  51 +/*
  52 + * cprocs
  53 + */
  54 +
  55 +ScmObj Scm_PqConnectdb(ScmString *conninfo,
  56 + ScmObj connection)
  57 +{
  58 + ScmPq *c;
  59 +
  60 + if (SCM_PQ_P(connection)) {
  61 + c = SCM_PQ(connection);
  62 + c->handle = PQconnectdb(Scm_GetString(conninfo));
  63 + if (c->handle == NULL) return SCM_FALSE;
  64 + } else return SCM_FALSE;
  65 +
  66 + return connection;
  67 +}
  68 +
  69 +ScmObj Scm_PqStatus(ScmObj connection)
  70 +{
  71 + ScmPq *c;
  72 + int status;
  73 + ScmObj result = SCM_FALSE;
  74 + if (SCM_PQ_P(connection)) {
  75 + c = SCM_PQ(connection);
  76 + status = PQstatus(c->handle);
  77 + result = SCM_MAKE_INT((int)status);
  78 + } else return SCM_FALSE;
  79 +
  80 + return result;
  81 +}
  82 +
  83 +ScmObj Scm_PqExec(ScmString *query,
  84 + ScmObj connection,
  85 + ScmObj result)
  86 +{
  87 + ScmPq *c;
  88 + ScmPqRes *r;
  89 +
  90 + if (SCM_PQ_P(connection) && SCM_PQ_RES_P(result)) {
  91 + c = SCM_PQ(connection);
  92 + r = SCM_PQ_RES(result);
  93 + r->res = PQexec(c->handle, Scm_GetString(query));
  94 + } else return SCM_FALSE;
  95 +
  96 + return result;
  97 +}
  98 +
  99 +ScmObj Scm_PqResultStatus(ScmObj result) {
  100 + ExecStatusType pq_status;
  101 + ScmObj status = SCM_FALSE;
  102 + ScmPqRes *r;
  103 +
  104 + if (SCM_PQ_RES_P(result)) {
  105 + r = SCM_PQ_RES(result);
  106 + pq_status = PQresultStatus(r->res);
  107 + status = SCM_MAKE_INT((int)pq_status);
  108 + } else return SCM_FALSE;
  109 +
  110 + return status;
  111 +}
  112 +
  113 +ScmObj Scm_PqResultErrorMessage(ScmObj result) {
  114 + char *pq_error_message;
  115 + ScmObj error_message = SCM_FALSE;
  116 + ScmPqRes *r;
  117 +
  118 + if (SCM_PQ_RES_P(result)) {
  119 + r = SCM_PQ_RES(result);
  120 + pq_error_message = PQresultErrorMessage(r->res);
  121 + error_message = SCM_MAKE_STR_COPYING(pq_error_message);
  122 + } else return SCM_FALSE;
  123 +
  124 + return error_message;
  125 +}
  126 +
  127 +ScmObj Scm_PqNtuples(ScmObj result) {
  128 + ScmObj row_count = SCM_FALSE;
  129 + ScmPqRes *r;
  130 + int num_rows;
  131 +
  132 + if (SCM_PQ_RES_P(result)) {
  133 + r = SCM_PQ_RES(result);
  134 + num_rows = PQntuples(r->res);
  135 + row_count = SCM_MAKE_INT(num_rows);
  136 + } else return SCM_FALSE;
  137 +
  138 + return row_count;
  139 +}
  140 +
  141 +ScmObj Scm_PqNfields(ScmObj result) {
  142 + ScmObj column_count = SCM_FALSE;
  143 + ScmPqRes *r;
  144 + int num_cols;
  145 +
  146 + if (SCM_PQ_RES_P(result)) {
  147 + r = SCM_PQ_RES(result);
  148 + num_cols = PQnfields(r->res);
  149 + column_count = SCM_MAKE_INT(num_cols);
  150 + } else return SCM_FALSE;
  151 +
  152 + return column_count;
  153 +}
  154 +
  155 +ScmObj Scm_PqGetValue(int row_id, int col_id, ScmObj result) {
  156 + ScmObj value = SCM_FALSE;
  157 + ScmPqRes *r;
  158 + char *str_value;
  159 +
  160 + if (SCM_PQ_RES_P(result)) {
  161 + r = SCM_PQ_RES(result);
  162 + str_value = PQgetvalue(r->res, row_id, col_id);
  163 + value = SCM_MAKE_STR_COPYING(str_value);
  164 + } else return SCM_FALSE;
  165 +
  166 + return value;
  167 +}
  168 +
  169 +ScmObj Scm_PqFinish(ScmObj connection) {
  170 + ScmPq *c;
  171 +
  172 + if (SCM_PQ_P(connection)) {
  173 + c = SCM_PQ(connection);
  174 + PQfinish(c->handle);
  175 + } else return SCM_FALSE;
  176 +
  177 + return connection;
  178 +}
  179 +
  180 +/*
  181 + * Module initialization function.
  182 + */
  183 +extern void Scm_Init_gauche_dbd_pglib(ScmModule*);
  184 +
  185 +ScmObj Scm_Init_gauche_dbd_pg(void)
  186 +{
  187 + ScmModule *mod;
  188 +
  189 + /* Register this DSO to Gauche */
  190 + SCM_INIT_EXTENSION(gauche_dbd_pg);
  191 +
  192 + /* Create the module if it doesn't exist yet. */
  193 + mod = SCM_MODULE(SCM_FIND_MODULE("dbd.pg", TRUE));
  194 +
  195 + /* Register classes */
  196 + Scm_InitStaticClass(&Scm_PqClass, "<pq-handle>", mod, NULL, 0);
  197 + Scm_InitStaticClass(&Scm_PqResClass, "<pq-res>", mod, NULL, 0);
  198 +
  199 + /* Register stub-generated procedures */
  200 + Scm_Init_gauche_dbd_pglib(mod);
  201 +}
70 gauche_dbd_pg.h
... ... @@ -0,0 +1,70 @@
  1 +/*
  2 + * gauche_dbd_pg.h
  3 + *
  4 + * Copyright (c) 2003-2005 Scheme Arts, L.L.C., All rights reserved.
  5 + * Copyright (c) 2003-2005 Time Intermedia Corporation, All rights reserved.
  6 + * See COPYING for terms and conditions of using this software
  7 + *
  8 + * $Id: gauche_dbd_pg.h,v 1.1 2005/07/19 00:45:42 shiro Exp $
  9 + */
  10 +
  11 +/* Prologue */
  12 +#ifndef GAUCHE_DBD_PG_H
  13 +#define GAUCHE_DBD_PG_H
  14 +
  15 +#include <stdio.h>
  16 +#include <libpq-fe.h>
  17 +#include <gauche.h>
  18 +#include <gauche/extend.h>
  19 +
  20 +SCM_DECL_BEGIN
  21 +
  22 +SCM_CLASS_DECL(Scm_PqClass);
  23 +SCM_CLASS_DECL(Scm_PqResClass);
  24 +
  25 +#define SCM_CLASS_PQ (&Scm_PqClass)
  26 +#define SCM_CLASS_PQ_RES (&Scm_PqResClass)
  27 +
  28 +typedef struct ScmPqRec {
  29 + SCM_HEADER;
  30 + PGconn *handle;
  31 +} ScmPq;
  32 +
  33 +typedef struct ScmPqResRec {
  34 + SCM_HEADER;
  35 + PGresult *res;
  36 +} ScmPqRes;
  37 +
  38 +#define SCM_PQ(obj) ((ScmPq *)(obj))
  39 +#define SCM_PQ_RES(obj) ((ScmPqRes *)(obj))
  40 +
  41 +#define SCM_PQ_P(obj) (SCM_XTYPEP(obj, SCM_CLASS_PQ))
  42 +#define SCM_PQ_RES_P(obj) (SCM_XTYPEP(obj, SCM_CLASS_PQ_RES))
  43 +
  44 +extern void Scm_Init_pqlib(ScmModule *module);
  45 +
  46 +extern ScmObj Scm_PqConnectdb(ScmString *conninfo,
  47 + ScmObj connection);
  48 +
  49 +extern ScmObj Scm_PqStatus(ScmObj connection);
  50 +
  51 +extern ScmObj Scm_PqExec(ScmString *query,
  52 + ScmObj connection,
  53 + ScmObj result);
  54 +
  55 +extern ScmObj Scm_PqResultStatus(ScmObj result);
  56 +
  57 +extern ScmObj Scm_PqResultErrorMessage(ScmObj result);
  58 +
  59 +extern ScmObj Scm_PqNtuples(ScmObj result);
  60 +
  61 +extern ScmObj Scm_PqNfields(ScmObj result);
  62 +
  63 +extern ScmObj Scm_PqGetValue(int row_id, int col_id, ScmObj result);
  64 +
  65 +extern ScmObj Scm_PqFinish(ScmObj connection);
  66 +
  67 +/* Epilogue */
  68 +SCM_DECL_END
  69 +
  70 +#endif /* GAUCHE_DBD_PG_H */
67 gauche_dbd_pglib.stub
... ... @@ -0,0 +1,67 @@
  1 +;;-*-Scheme-*-
  2 +;; pqlib.stub - pq driver stub
  3 +;;
  4 +;; Copyright (c) 2003-2005 Scheme Arts, L.L.C., All rights reserved.
  5 +;; Copyright (c) 2003-2005 Time Intermedia Corporation, All rights reserved.
  6 +;; See COPYING for terms and conditions of using this software
  7 +;;
  8 +;; $Id: gauche_dbd_pglib.stub,v 1.1 2005/07/19 00:45:42 shiro Exp $
  9 +
  10 +"
  11 +#include \"gauche_dbd_pg.h\"
  12 +"
  13 +
  14 +(define-cproc pq-connectdb
  15 + (conninfo::<string> &optional connection)
  16 + "SCM_RETURN(Scm_PqConnectdb(conninfo, connection));")
  17 +
  18 +(define-cproc pq-exec
  19 + (query::<string> &optional connection result)
  20 + "SCM_RETURN(Scm_PqExec(query, connection, result));")
  21 +
  22 +;; ConnStatusType from libpq-fe.h
  23 +(define-enum CONNECTION_OK)
  24 +(define-enum CONNECTION_BAD)
  25 +(define-enum CONNECTION_STARTED)
  26 +(define-enum CONNECTION_MADE)
  27 +(define-enum CONNECTION_AWAITING_RESPONSE)
  28 +(define-enum CONNECTION_AUTH_OK)
  29 +(define-enum CONNECTION_SETENV)
  30 +(define-enum CONNECTION_SSL_STARTUP)
  31 +(define-enum CONNECTION_NEEDED)
  32 +
  33 +;; ExecStatusType from libpq-fe.h
  34 +(define-enum PGRES_EMPTY_QUERY)
  35 +(define-enum PGRES_COMMAND_OK)
  36 +(define-enum PGRES_TUPLES_OK)
  37 +(define-enum PGRES_COPY_OUT)
  38 +(define-enum PGRES_COPY_IN)
  39 +(define-enum PGRES_BAD_RESPONSE)
  40 +(define-enum PGRES_NONFATAL_ERROR)
  41 +(define-enum PGRES_FATAL_ERROR)
  42 +
  43 +(define-cproc pq-status
  44 + (&optional connection)
  45 + "SCM_RETURN(Scm_PqStatus(connection));")
  46 +
  47 +(define-cproc pq-result-status
  48 + (&optional result)
  49 + "SCM_RETURN(Scm_PqResultStatus(result));")
  50 +
  51 +(define-cproc pq-result-error-message
  52 + (&optional result)
  53 + "SCM_RETURN(Scm_PqResultErrorMessage(result));")
  54 +
  55 +(define-cproc pq-ntuples
  56 + (&optional result)
  57 + "SCM_RETURN(Scm_PqNtuples(result));")
  58 +
  59 +(define-cproc pq-nfields
  60 + (&optional result)
  61 + "SCM_RETURN(Scm_PqNfields(result));")
  62 +
  63 +(define-cproc pq-get-value (row_id::<int> col_id::<int> &optional result)
  64 + "SCM_RETURN(Scm_PqGetValue(row_id, col_id, result));")
  65 +
  66 +(define-cproc pq-finish(&optional connection)
  67 + "SCM_RETURN(Scm_PqFinish(connection));")
102 test.scm
... ... @@ -0,0 +1,102 @@
  1 +;;;
  2 +;;; Test dbd.pg
  3 +;;;
  4 +
  5 +(use gauche.test)
  6 +(use gauche.collection)
  7 +(use srfi-1)
  8 +(use srfi-13)
  9 +
  10 +(test-start "dbd.pg")
  11 +(use dbi)
  12 +(use dbd.pg)
  13 +(test-module 'dbd.pg)
  14 +
  15 +;; dbi-make-driver �Υƥ���:
  16 +;; "pg" �ɥ饤�С�����ɤ���
  17 +;; ���饹 <pg-driver> �Υ��󥹥��󥹤�ä�����
  18 +(define pg-driver (dbi-make-driver "pg"))
  19 +(test* "dbi-make-driver pg"
  20 + #t
  21 + (is-a? pg-driver <pg-driver>))
  22 +
  23 +;; dbi-make-connection �Υƥ���:
  24 +;; <pg-driver>���Υ��󥹥��󥹤���ˤ����Ȥ�
  25 +;; dbi-make-connection ������ͤ�
  26 +;; <pg-connection>���Υ��󥹥��󥹤�ä�����
  27 +;; ��: (sys-getenv "USER")�Ǽ���������ߤΥ桼�������ѥ���ɤʤ���
  28 +;; PostgreSQL�Υǥե���ȥǡ����١�������³�Ǥ���ɬ�פ����롣
  29 +(define current-user (sys-getenv "USER"))
  30 +(define pg-connection
  31 + (dbi-make-connection pg-driver current-user "" ""))
  32 +(test* "dbi-make-connection <pg-driver>"
  33 + #t
  34 + (is-a? pg-connection <pg-connection>))
  35 +
  36 +;; dbi-make-query �Υƥ���:
  37 +;; <pg-connection>���Υ��󥹥��󥹤���ˤ����Ȥ�
  38 +;; dbi-make-query������ͤ�
  39 +;; <pg-query>���Υ��󥹥��󥹤�ä�����
  40 +(define pg-query (dbi-make-query pg-connection))
  41 +(test* "dbi-make-query <pg-connection>"
  42 + #t
  43 + (is-a? pg-query <pg-query>))
  44 +
  45 +;;;; test�ơ��֥��drop���Ƥ���
  46 +(with-error-handler
  47 + (lambda (e) #t)
  48 + (lambda () (dbi-execute-query pg-query "drop table test")))
  49 +;;;; test�ơ��֥�������Ƥ���
  50 +(dbi-execute-query pg-query "create table test (id integer, name varchar)")
  51 +;;;; test�ơ��֥�˥ǡ�����insert���Ƥ���
  52 +(dbi-execute-query pg-query
  53 + "insert into test (id, name) values (10, 'yasuyuki')")
  54 +(dbi-execute-query pg-query
  55 + "insert into test (id, name) values (20, 'nyama')")
  56 +
  57 +;; dbi-execute-query �Υƥ���:
  58 +;; <pg-query>���Υ��󥹥��󥹤���ˤ����Ȥ�
  59 +;; dbi-execute-query ������ͤ�
  60 +;; <pg-result-set>���Υ��󥹥��󥹤�ä�����
  61 +(define pg-result-set (dbi-execute-query pg-query "select * from test"))
  62 +(test* "dbi-execute-query <pg-query>"
  63 + #t
  64 + (is-a? pg-result-set <pg-result-set>))
  65 +
  66 +;; dbi-get-value�Υƥ���:
  67 +;; map ����� pg-get-value ��Ȥä� <pg-result-set> ���餹�٤ƤιԤ�������
  68 +;; ���餫���� insert���줿 (("10" "yasuyuki") ("20" "nyama")) ������й��
  69 +(test* "dbi-get-value with map"
  70 + '(("10" "yasuyuki") ("20" "nyama"))
  71 + (map (lambda (row)
  72 + (list (dbi-get-value row 0) (dbi-get-value row 1)))
  73 + pg-result-set))
  74 +
  75 +;; dbi-close <dbi-result-set> �Υƥ���:
  76 +;; <pg-result-set>���Υ��󥹥��󥹤�close���ƺ��٥�����������
  77 +;; <dbi-exception>��ȯ���������
  78 +(dbi-close pg-result-set)
  79 +(test* "dbi-close <pg-result-set>" *test-error*
  80 + (dbi-close pg-result-set))
  81 +
  82 +;; dbi-close <dbi-query> �Υƥ���:
  83 +;; <pg-query>���Υ��󥹥��󥹤�close���ƺ��٥�����������
  84 +;; <dbi-exception>��ȯ���������
  85 +(dbi-close pg-query)
  86 +(test* "dbi-close <pg-query>" *test-error*
  87 + (dbi-close pg-query))
  88 +
  89 +;; dbi-close <dbi-connection> �Υƥ���:
  90 +;; <pg-connection>���Υ��󥹥��󥹤�close���ƺ��٥�����������
  91 +;; <dbi-exception>��ȯ���������
  92 +(dbi-close pg-connection)
  93 +(test* "dbi-close <pg-connection>" *test-error*
  94 + (dbi-close pg-connection))
  95 +
  96 +;; epilogue
  97 +(test-end)
  98 +
  99 +
  100 +
  101 +
  102 +

0 comments on commit d2156ad

Please sign in to comment.
Something went wrong with that request. Please try again.