Changeset 14620 in project


Ignore:
Timestamp:
05/14/09 00:00:25 (11 years ago)
Author:
sjamaan
Message:

Start work on porting and revitalizing the postgresql egg. This is a WORK IN PROGRESS - it is *not finished*. Do not use it until the (hidden) option is removed from the meta file, because the API *will change*

Location:
release/4/postgresql
Files:
1 added
1 deleted
3 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/postgresql/trunk/postgresql.meta

    r9971 r14620  
    11;;; postgresql.meta -*- Hen -*-
    22
    3 ((date "2004-06-19")
    4  (egg "postgresql.egg")
    5  (synopsis "Some simple bindings for PostgreSQL's C-api")
     3((egg "postgresql.egg")
     4 (synopsis "Bindings for PostgreSQL's C-api")
    65 (category db)
    76 (author "Johannes Groedem")
    8  (needs easyffi syntax-case)
     7 (maintainer "Peter Bex")
    98 (doc-from-wiki)
     9 (hidden) ;; Not ready yet!
    1010 (license "BSD")
    1111 (files "postgresql.setup" "postgresql.html" "postgresql.scm" "ppchar.c"))
  • release/4/postgresql/trunk/postgresql.scm

    r10459 r14620  
     1;;; Bindings to the PostgreSQL C library
     2;;
     3;; Copyright (C) 2008-2009 Peter Bex
    14;; Copyright (C) 2004 Johannes Grødem <johs@copyleft.no>
    25;; Redistribution and use in source and binary forms, with or without
    36;; modification, is permitted.
    4 
     7;;
    58;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
    69;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
     
    1619;; DAMAGE.
    1720
    18 (declare
    19  (export pg:connect pg:reset pg:close pg:query-fold-left pg:query-for-each
    20          pg:query-tuples pg:sql-null-object? pg:connection? pg:escape-string
    21          pg:sql-null-object
    22          pg:named-tuples)
    23  (uses lolevel srfi-1 srfi-13 srfi-18 extras srfi-4))
    24 
    25 (use easyffi)
     21(module postgresql
     22 (pg:connect pg:reset pg:close pg:query-fold-left pg:query-for-each
     23  pg:query-tuples pg:sql-null-object? pg:connection? pg:escape-string
     24  pg:sql-null-object
     25  pg:named-tuples)
     26
     27(import chicken scheme foreign)
     28
     29(require-extension lolevel data-structures extras srfi-1 srfi-4 srfi-13 srfi-18 srfi-69)
    2630
    2731(foreign-declare "#include <libpq-fe.h>")
    28 (foreign-parse
    29 "enum ConnStatusType
    30 {
    31  CONNECTION_OK, CONNECTION_BAD, CONNECTION_STARTED,
    32  CONNECTION_MADE, CONNECTION_AWAITING_RESPONSE,
    33  CONNECTION_AUTH_OK, CONNECTION_SETENV, CONNECTION_SSL_STARTUP,
    34  CONNECTION_NEEDED
    35 };
    36 
    37 enum ExecStatusType
    38 {
    39  PGRES_EMPTY_QUERY = 0, PGRES_COMMAND_OK, PGRES_TUPLES_OK,
    40  PGRES_COPY_OUT, PGRES_COPY_IN, PGRES_BAD_RESPONSE,
    41  PGRES_NONFATAL_ERROR, PGRES_FATAL_ERROR
    42 };
    43 
    44 enum PostgresPollingStatusType
    45 {
    46  PGRES_POLLING_FAILED = 0, PGRES_POLLING_READING, PGRES_POLLING_WRITING,
    47  PGRES_POLLING_OK, PGRES_POLLING_ACTIVE
    48 };
    49 
    50 typedef unsigned int Oid;
    51 
    52 PGconn   *PQconnectStart (const char *conninfo);
    53 enum PostgresPollingStatusType PQconnectPoll (PGconn *conn);
    54 int       PQsocket (const PGconn *conn);
    55 int       PQresetStart (PGconn *conn);
    56 enum PostgresPollingStatusType PQresetPoll (PGconn *conn);
    57 void      PQfinish (PGconn *conn);
    58 enum      ConnStatusType PQstatus (const PGconn *conn);
    59 int       PQsendQuery (PGconn *conn, const char *query);
    60 int PQsendQueryParams(PGconn *conn, const char *command,
    61                       int nParams, const Oid *paramTypes,
    62                       const char **paramValues, const int *paramLengths,
    63                       const int *paramFormats, int resultFormat);
    64 int       PQisBusy (PGconn *conn);
    65 int       PQconsumeInput (PGconn *conn);
    66 PGresult *PQgetResult (PGconn *conn);
    67 enum ExecStatusType PQresultStatus (const PGresult *res);
    68 char     *PQresultErrorMessage (const PGresult *res);
    69 char     *PQerrorMessage(const PGconn *conn);
    70 void      PQclear (PGresult *res);
    71 int       PQntuples (const PGresult *res);
    72 int       PQnfields (const PGresult *res);
    73 char     *PQcmdTuples (PGresult *res);
    74 Oid       PQftype (const PGresult *res, int column_number);
    75 char     *PQfname(const PGresult *res, int field_index);
    76 void     *PQgetvalue (const PGresult *res, int row_number, int column_number);
    77 int       PQgetisnull (const PGresult *res, int row_number, int column_number);
    78 int       PQgetlength (const PGresult *res, int row_number,
    79                              int column_number);
    80 char     *PQresultErrorField(const PGresult *res, int fieldcode);
    81 "
    82 )
    83 
    84 (define-macro (define-foreign-int name)
    85   `(define-foreign-variable ,name int ,(conc "(int) " name)))
     32
     33(define-foreign-type pg-polling-status (enum "PostgresPollingStatusType"))
     34(define-foreign-variable PGRES_POLLING_FAILED pg-polling-status)
     35(define-foreign-variable PGRES_POLLING_READING pg-polling-status)
     36(define-foreign-variable PGRES_POLLING_WRITING pg-polling-status)
     37(define-foreign-variable PGRES_POLLING_OK pg-polling-status)
     38(define-foreign-variable PGRES_POLLING_ACTIVE pg-polling-status)
     39
     40(define-foreign-type pg-exec-status (enum "ExecStatusType"))
     41(define-foreign-variable PGRES_EMPTY_QUERY pg-exec-status)
     42(define-foreign-variable PGRES_COMMAND_OK pg-exec-status)
     43(define-foreign-variable PGRES_TUPLES_OK pg-exec-status)
     44(define-foreign-variable PGRES_COPY_OUT pg-exec-status)
     45(define-foreign-variable PGRES_COPY_IN pg-exec-status)
     46(define-foreign-variable PGRES_BAD_RESPONSE pg-exec-status)
     47(define-foreign-variable PGRES_NONFATAL_ERROR pg-exec-status)
     48(define-foreign-variable PGRES_FATAL_ERROR pg-exec-status)
     49
     50;(define-foreign-type pgconn* (c-pointer "PGconn"))
     51(define-foreign-type pgconn* c-pointer)
     52
     53(define pgsql-connection->fd (foreign-lambda int PQsocket pgconn*))
     54
     55(define PQconnectStart (foreign-lambda pgconn* PQconnectStart (const c-string)))
     56(define PQconnectPoll (foreign-lambda pg-polling-status PQconnectPoll pgconn*))
     57(define PQresetStart (foreign-lambda int PQresetStart pgconn*))
     58(define PQresetPoll (foreign-lambda pg-polling-status PQresetPoll pgconn*))
     59(define PQfinish (foreign-lambda void PQfinish pgconn*))
     60(define PQstatus (foreign-lambda (enum "ConnStatusType") PQstatus (const pgconn*)))
     61(define PQsendQuery (foreign-lambda int PQsendQuery pgconn* (const c-string)))
     62(define PQerrorMessage (foreign-lambda c-string PQerrorMessage (const pgconn*)))
     63
     64(define-foreign-type oid unsigned-int) ;; XXX Should be an opaque type
     65
     66;; TODO: Add define-foreign-type for creating the lists of oids/value strings
     67(define PQsendQueryParams
     68  (foreign-lambda int PQsendQueryParams
     69                  ;; conn  command          nParams
     70                  pgconn*  (const c-string) int
     71                  ;; paramTypes
     72                  (const (nonnull-c-pointer oid))
     73                  ;; paramValues
     74                  (const c-string-list)
     75                  ;; paramLengths
     76                  (const (nonnull-c-pointer int))
     77                  ;; paramFormats
     78                  (const (nonnull-c-pointer int))
     79                  ;; resultFormat
     80                  int))
     81
     82(define PQisBusy (foreign-lambda bool PQisBusy pgconn*))
     83(define PQconsumeInput (foreign-lambda bool PQconsumeInput pgconn*))
     84
     85(define-foreign-type pgresult* (c-pointer "PGresult"))
     86
     87(define PQgetResult (foreign-lambda pgresult* PQgetResult pgconn*))
     88(define PQresultStatus (foreign-lambda pg-exec-status PQresultStatus (const pgresult*)))
     89(define PQresultErrorMessage (foreign-lambda c-string PQresultErrorMessage (const pgresult*)))
     90(define PQresultErrorField (foreign-lambda c-string PQresultErrorField (const pgresult*) int))
     91
     92
     93(define PQclear (foreign-lambda void PQclear pgresult*))
     94(define PQntuples (foreign-lambda int PQntuples (const pgresult*)))
     95(define PQnfields (foreign-lambda int PQntuples (const pgresult*)))
     96(define PQcmdTuples (foreign-lambda nonnull-c-string PQcmdTuples pgresult*))
     97(define PQftype (foreign-lambda oid PQftype (const pgresult*) int))
     98(define PQfname (foreign-lambda c-string PQftype (const pgresult*) int))
     99
     100(define PQgetvalue (foreign-lambda (c-pointer char) PQgetvalue (const pgresult*) int int))
     101(define PQgetisnull (foreign-lambda bool PQgetisnull (const pgresult*) int int))
     102(define PQgetlength (foreign-lambda int PQgetlength (const pgresult*) int int))
     103
     104(define-syntax define-foreign-int
     105  (er-macro-transformer
     106   (lambda (e r c)
     107     ;; cannot rename define-foreign-variable; it's a really special form
     108    `(define-foreign-variable ,(cadr e) int ,(conc "(int) " (cadr e))))))
    86109
    87110(define-foreign-int PG_DIAG_SEVERITY)
     
    138161
    139162(define (pg:poll conn-ptr poll-function)
    140   (let ([conn-fd (PQsocket conn-ptr)])
     163  (let ([conn-fd (pgsql-connection->fd conn-ptr)])
    141164    (let loop ([result (poll-function conn-ptr)])
    142165      (cond [(= result PGRES_POLLING_OK)
     
    164187                      "Unable to allocate a Postgres connection structure."
    165188                      connection-spec)]
    166            [(= CONNECTION_BAD (PQstatus conn-ptr))
     189           [(= (foreign-value "CONNECTION_BAD" int) (PQstatus conn-ptr))
    167190            (let ((error-message (PQerrorMessage conn-ptr)))
    168191             (PQfinish conn-ptr)
     
    227250                  query conn-ptr))
    228251 
    229     (let ([conn-fd (PQsocket conn-ptr)])
     252    (let ([conn-fd (pgsql-connection->fd conn-ptr)])
    230253      (let loop ()
    231         (case (PQconsumeInput conn-ptr)
    232           ((1)
    233            (when (= (PQisBusy conn-ptr) 1)
    234              (block-thread! conn-fd #t)
    235              (loop)))
    236           ((0)
    237            (pg:error 'buffer-available-input!
    238                      (sprintf "PQconsumeInput: ~A"
    239                              (string-trim-right (PQerrorMessage conn-ptr)))
    240                      conn-ptr))))
     254        (if (PQconsumeInput conn-ptr)
     255            (when (PQisBusy conn-ptr)
     256              (block-thread! conn-fd #t)
     257              (loop))
     258            (pg:error 'buffer-available-input!
     259                      (sprintf "PQconsumeInput: ~A"
     260                               (string-trim-right (PQerrorMessage conn-ptr)))
     261                      conn-ptr)))
    241262      (void))))
    242263
     
    342363             
    343364                  (define (get-value row column)
    344                     (if (zero? (PQgetisnull result row column))
     365                    (if (PQgetisnull result row column)
     366                        pg:sql-null-object
    345367                        (let ([value (PQgetvalue result row column)]
    346368                              [value-length
    347369                               (PQgetlength result row column)])
    348370                          ((vector-ref value-parsers column)
    349                            value value-length))
    350                         pg:sql-null-object ))
     371                           value value-length))))
    351372             
    352373                  (let process-row ([row 0]
     
    766787         (pcount (length args))
    767788         (pvalues (map ->string args))
    768          (pvalues (make-ppchar args))
    769789         (plengths (list->s32vector (map string-length args)))
    770790         (pformats (list->s32vector (map (constantly 0) args))) ; 1 for binary, 0 for text.
     
    773793                                    pcount ptypes pvalues plengths pformats
    774794                                    (if (eq? format 'text) 0 1))))
    775     (free-ppchar pvalues)
    776795    result))
    777 
    778 (define make-ppchar (foreign-lambda (pointer (pointer char)) "make_ppchar" scheme-object))
    779 (define free-ppchar (foreign-lambda void "free_ppchar" (pointer (pointer char))))
    780 ;;(define test-ppchar (foreign-lambda void "test_ppchar" (pointer (pointer char))))
     796)
  • release/4/postgresql/trunk/postgresql.setup

    r10583 r14620  
    22;;; postgresql.setup -*- Scheme -*-
    33
    4 #;;;
    5 (run (csc -s -R syntax-case -O2 -d0 postgresql.scm -C -I`pg_config --includedir` -L -L`pg_config --libdir` -lpq))
    6 (run (csc -s -R syntax-case -O2 -d0 postgresql.scm ppchar.c -C -I`pg_config --includedir` -L -L`pg_config --libdir` -lpq))
     4(run (csc -s -O2 -d0 postgresql.scm ppchar.c -j postgresql -C -I`pg_config --includedir` -L -L`pg_config --libdir` -lpq))
     5
     6(run (csc postgresql.import.scm -s -O2 -d0))
    77
    88(install-extension
    99 'postgresql
    10  '("postgresql.so" "postgresql.html")
    11  '((version "2.0.15") (documentation "postgresql.html")))
     10 '("postgresql.so" "postgresql.import.so")
     11 '((version "3.0")
     12   (documentation "postgresql.html")))
    1213
Note: See TracChangeset for help on using the changeset viewer.