833 lines
28 KiB
Plaintext
833 lines
28 KiB
Plaintext
;; @module postgres.lsp
|
|
;; @description PostgreSQL interface (tested on PostgreSQL 9.4, should work on all supported versions)
|
|
;; @version 1.02 - feature complete
|
|
;; @version 1.03 - doc formatting
|
|
;; @version 2.00 - replaced <tt>inc</tt> with <tt>++</tt>
|
|
;; @version 2.10 - new <tt>fnumber</tt> and <tt>fetch-value</tt>
|
|
;; @version 2.11 - new <tt>query</tt> with optional parameters
|
|
;; @version 2.12 - add MacPorts path, Fix bugs (error), (affected-rows), (fields ...), test against PostgreSQL 9.4
|
|
;; @version 3.00 - add new postgreSQL imports, use pg_config to find libpq header, improve test coverage
|
|
;; @author Jeremy Cowgar 2006, Ted Walther 2009, Lutz Mueller 2010, Unya 2012, Neil Tiffin 2015
|
|
;;
|
|
;; <h3>Requirements</h3>
|
|
;; At the beginning of the program file include a 'load' statement for the module:
|
|
;; <pre>
|
|
;; (load "/usr/share/newlisp/modules/postgres.lsp")
|
|
;; ; or
|
|
;; (module "postgres.lsp") ; loads from (env "NEWLISPDIR") / modules
|
|
;; </pre>
|
|
;;
|
|
;; A version of 'libpq' for a specific platform is required:
|
|
;;
|
|
;; on LINUX/UNIX: 'libpq.so' <br>
|
|
;; on Mac OS X: 'libpq.dylib' <br>
|
|
;; on Windows: 'libpq.dll'
|
|
;;
|
|
;; This library is installed when using the install
|
|
;; package @link http://www.postgresql.org/download/ .
|
|
;; Unix, Linux, and Mac each have package installers that can be used
|
|
;; to install the PostgreSQL client (libpq) & server.
|
|
;;
|
|
;; Libpq might be in a different location on a particular
|
|
;; installation of PostgreSQL or have a different extension.
|
|
;; This module attempts to find libpq using pg_config. If you can execute
|
|
;; pg_config at the command line and see its results then everything should just
|
|
;; work. If not, then
|
|
;; you may have to edit the manual search code below to find your specific libpq.
|
|
;;
|
|
;; If you are using PostgreSQL from a Linux distribution you will need to install the
|
|
;; development headers for libpq, usually called libpq-dev.
|
|
;;
|
|
;; The PostgreSQL server itself may reside on a different machine
|
|
;; on the network. The library 'libpq' will communicate
|
|
;; with that server. The correct connection is created using
|
|
;; the 'PgSQL:connect' call.
|
|
;;
|
|
;; At the bottom of the module file 'postgres.lsp' a test routine 'test-pgsql'
|
|
;; is included to test for correct installation of PostgreSQL. You call it
|
|
;; with the same arguments you would pass to ':connect'
|
|
;;
|
|
;; <h3>Functions available</h3>
|
|
;; <pre>
|
|
;; Connect
|
|
;; PgSQL:connect ............. connect to a database
|
|
;; PgSQL:close-db ............ close database connection
|
|
;; PgSQL:error-conn .......... get connection error message *
|
|
;;
|
|
;; Query
|
|
;; PgSQL:query ............... execute a SQL statement
|
|
;;
|
|
;; Query Results
|
|
;; PgSQL:affected-rows ....... number of affected rows from operation
|
|
;; PgSQL:data-seek ........... position in result for fetching
|
|
;; PgSQL:error ............... get query error message
|
|
;; PgSQL:fetch-all ........... get all rows from the last query
|
|
;; PgSQL:fetch-row ........... get row from the query result
|
|
;; PgSQL:fetch-value ......... get value from the query result
|
|
;; PgSQL:fnumber ............. column number of query
|
|
;; PgSQL:num-fields .......... columns in result of query
|
|
;; PgSQL:num-rows ............ rows in result of query
|
|
;;
|
|
;; Info
|
|
;; PgSQL:database ............ return all database names
|
|
;; PgSQL:fields .............. return all fields in a table
|
|
;; PgSQL:tables .............. return all tables names
|
|
;;
|
|
;; Misc
|
|
;; PgSQL:escape .............. escapes single quote in input string
|
|
;; PgSQL:escape-literal ...... escapes literal for PostgreSQL *
|
|
;; PgSQL:escape-identifier ... escapes identifier for PostgreSQL *
|
|
;;
|
|
;; * API may be specific to PostgreSQL
|
|
;; </pre>
|
|
;;
|
|
;; <h3>Differences from the MySQL module</h3>
|
|
;;
|
|
;; The function ':inserted-id' isn't supported because PostgreSQL
|
|
;; doesn't support it. Instead, use the 'RETURNING' clause in your 'INSERT'
|
|
;; statement, then use ':fetch-row' or ':fetch-all' to
|
|
;; find the value. 'INSERT RETURNING' is a PostreSQL idiom
|
|
;; documented @link http://www.postgresql.org/docs/9.4/static/sql-insert.html here.
|
|
;;
|
|
;; There is no ':init' function because it isn't needed by the underlying
|
|
;; library. Just call ':connect'.
|
|
;;
|
|
;; <h3>A typical PgSQL session</h3>
|
|
;; The following code piece outlines a typical PgSQL session:
|
|
;;
|
|
;; @example
|
|
;; (module "postgres.lsp") ; load the module file
|
|
;;
|
|
;; (PgSQL:connect "192.168.1.10" "auser" "secret" "mydb") ; logon
|
|
;; (PgSQL:query "select ...;") ; SQL query
|
|
;; (PgSQL:query "insert ...;") ; SQL query
|
|
;; ...
|
|
;; (PgSQL:close-db)
|
|
|
|
;; The database server is listening on IP 192.168.1.10. The program
|
|
;; connects with username '"auser"' password '"secret"' to a database with
|
|
;; the name '"mydb"'. After connecting SQL statements are performed and
|
|
;; finally the program disconnects from the server.
|
|
;;
|
|
;; If the database server is running locally then "localhost" may be used for
|
|
;; the host name.
|
|
;;
|
|
;; <h3>Bugs</h3>
|
|
;;
|
|
;; This module doesn't support connections through a Unix socket.
|
|
;;
|
|
;; <h3>Implementation Notes</h3>
|
|
;; As of 19 March 2015.
|
|
;; On Windows only works with x86 (32bit) PostgreSQL install.
|
|
;; pg_config must be in the path.
|
|
;; Tested on OSX 10.10.2, Linux SMP Debian 3.16.7-ckt7-1, Windows 8.1 [version 6.3.9600]
|
|
|
|
; make this module compatible with version less than 10.1.11
|
|
(when (< (sys-info -2) 10110)
|
|
(constant (global '++) inc))
|
|
|
|
(context 'PgSQL)
|
|
|
|
; get pg_config if available
|
|
(set 'pg_lib_dir (exec "pg_config --libdir"))
|
|
|
|
(if pg_lib_dir
|
|
(set 'files
|
|
(list
|
|
(append (first pg_lib_dir) "/libpq.dylib") ; shared Mac OS X libs
|
|
(append (first pg_lib_dir) "/libpq.so") ; loadable elf libs Posix Unix Linux
|
|
(append (first pg_lib_dir) "/libpq.dll") ; Windows lib
|
|
))
|
|
(set 'files '(
|
|
"/usr/local/lib/libpq.so.5.1" ; OpenBSD 4.6
|
|
"/usr/lib/libpq.so" ; CentOS or other Linux
|
|
"/usr/lib64/libpq.so" ; Linux 64bit
|
|
"/usr/lib/libpq.so.5.1" ; Debian
|
|
"/usr/local/pgsql/lib/libpq.dylib" ; Mac OS X
|
|
"c:/Program Files/PostgreSQL/8.3/bin/libpq.dll" ; Win32
|
|
)))
|
|
|
|
; find the library file
|
|
(set 'library (files (or
|
|
(find true (map file? files))
|
|
(throw-error "Cannot find libpq library!"))))
|
|
|
|
; done with these
|
|
(delete 'pg_config)
|
|
(delete 'pg_lib_dir)
|
|
(delete 'files)
|
|
|
|
; import functions and throw error if not found
|
|
(define (pg_import fun_name)
|
|
(import library fun_name "cdecl"))
|
|
|
|
; import functions and print warning if not found
|
|
(define (pg_import_warn fun_name)
|
|
(unless (catch (import library fun_name "cdecl") 'pg_load_error)
|
|
(println "libpq import WARNING: " pg_load_error)))
|
|
|
|
; import functions available in libpq for 8.4 or earlier
|
|
; These are core functions and will throw an error if not found.
|
|
(map pg_import (list
|
|
"PQcancel"
|
|
"PQclear"
|
|
"PQcmdStatus"
|
|
"PQcmdTuples"
|
|
"PQconnectdb"
|
|
;"PQconnectionNeedsPassword" ; PostgreSQL 8.3
|
|
;"PQconnectionUsedPassword" ; PostgreSQL 8.3
|
|
"PQconsumeInput"
|
|
"PQdb"
|
|
"PQdescribePortal" ; PostgreSQL 8.2
|
|
"PQdescribePrepared" ; PostgreSQL 8.2
|
|
;"PQencryptPassword" ; PostgreSQL 8.2
|
|
"PQerrorMessage"
|
|
"PQexec"
|
|
"PQexecParams"
|
|
"PQexecPrepared" ; PostgreSQL 7.4
|
|
"PQfinish"
|
|
"PQflush"
|
|
"PQfname"
|
|
"PQfnumber"
|
|
"PQfreeCancel"
|
|
"PQfreemem" ; PostgreSQL 7.4
|
|
"PQgetCancel"
|
|
"PQgetisnull"
|
|
"PQgetvalue"
|
|
"PQhost"
|
|
"PQinstanceData" ; PostgreSQL 8.4
|
|
"PQisBusy"
|
|
"PQisnonblocking"
|
|
"PQisthreadsafe" ; PostgreSQL 8.2
|
|
"PQnfields"
|
|
"PQnotifies"
|
|
"PQntuples"
|
|
"PQoptions"
|
|
"PQpass"
|
|
"PQport"
|
|
"PQprepare" ; PostgreSQL 8.0
|
|
"PQprotocolVersion"
|
|
"PQregisterEventProc" ; PostgreSQL 8.4
|
|
"PQresultErrorMessage"
|
|
"PQresultInstanceData" ; PostgreSQL 8.4
|
|
"PQresultSetInstanceData" ; PostgreSQL 8.4
|
|
"PQresultStatus"
|
|
"PQresStatus"
|
|
"PQsendQueryPrepared" ; PostgreSQL 7.4
|
|
"PQserverVersion" ; PostgreSQL 8.0
|
|
"PQsetInstanceData" ; PostgreSQL 8.4
|
|
"PQsetnonblocking"
|
|
"PQsetNoticeProcessor"
|
|
"PQsetNoticeReceiver"
|
|
"PQstatus"
|
|
"PQuser"
|
|
))
|
|
|
|
; Try to import new libpq functions and print warning (do not throw error) if not found.
|
|
; if any of these functions are used then the code in this module should verify
|
|
; that the respective function was actually loaded before use.
|
|
(map pg_import_warn (list
|
|
"PQconninfo" ; PostgreSQL 9.3
|
|
"PQescapeIdentifier" ; PostgreSQL 9.1
|
|
"PQescapeLiteral" ; PostgreSQL 9.1
|
|
"PQlibVersion" ; PostgreSQL 9.0
|
|
"PQping" ; PostgreSQL 9.0
|
|
"PQpingParams" ; PostgreSQL 9.0
|
|
"PQsetSingleRowMode" ; PostgreSQL 9.2
|
|
))
|
|
|
|
(delete 'pg_import_warn)
|
|
(delete 'pg_import)
|
|
|
|
|
|
; On some wierd platforms NULL may equal something else, we'll worry about that when we bump into it.
|
|
(define NULL 0)
|
|
(define (NULL? n) (= 0 n))
|
|
|
|
(setq
|
|
CONNECTION_OK 0
|
|
PGRES_FATAL_ERROR 7)
|
|
|
|
(set 'PQPING_STATUS '(
|
|
"PQPING_OK"
|
|
"PQPING_REJECT"
|
|
"PQPING_NO_RESPONSE"
|
|
"PQPING_NO_ATTEMPT"))
|
|
|
|
; module variables
|
|
(setq PG_CONN nil) ; pg connection structure
|
|
(setq PG_RESULT nil) ; pg query result structure
|
|
(setq PG_ROWX 0) ; current row
|
|
(setq PG_COLX 0) ; current column
|
|
|
|
;; @syntax (PgSQL:connect <str-server> <str-userID> <str-password> <str-db>)
|
|
;; @param <str-server> The host name or IP address or <tt>0</tt> for localhost.
|
|
;; @param <str-userID> The user ID for authentication.
|
|
;; @param <str-password> The password for authentication.
|
|
;; @param <str-db> The name of the database to connect to.
|
|
;; @return 'true' for success or 'nil' for failure.
|
|
;; Connects to a database on server and authenticates a user ID.
|
|
|
|
(define (connect host user passw dbname)
|
|
(connectdb (string
|
|
(if (> (length host) 0) (string "host=" host) "")
|
|
(if (> (length user) 0) (string " user=" user) "")
|
|
(if (> (length passw) 0) (string " password=" passw) "")
|
|
(if (> (length dbname) 0) (string " dbname=" dbname) "")
|
|
)) )
|
|
|
|
;; @syntax (PgSQL:connectdb <str-conninfo>)
|
|
;; @param <str-conninfo> PostgreSQL Connection Parameters, To write an empty value or a value containing spaces, surround it with single quotes, e.g., keyword = 'a value'. keyword is 'host', 'hostaddr, 'port', 'dbname', 'user', 'password', 'connect_timeout', 'client_encoding', 'options', 'application_name', 'fallback_application_name', 'keepalives', 'keepalives_idle', 'keepalives_interval', 'keepalives_count', 'tty', 'sslmode', 'sslcompression', 'sslcert', 'sslkey', 'sslrootcert', 'sslcrl', 'requirepeer', 'krbsrvname', 'gsslib', 'service' in PostgreSQL 9.4.
|
|
;; @return 'true' for success or nil on failure.
|
|
;; Connects to a database on server.
|
|
|
|
(define (connectdb conninfo)
|
|
(close-db)
|
|
(setq PG_CONN (PQconnectdb conninfo))
|
|
(if (NULL? PG_CONN)
|
|
nil
|
|
(if (= (PQstatus PG_CONN) CONNECTION_OK)
|
|
true
|
|
(PQfinish PG_CONN)
|
|
(setq PG_CONN nil))))
|
|
|
|
|
|
;; @syntax (PgSQL:query <str-sql> [<param> ...])
|
|
;; @param <str-sql> A valid SQL query string. If parameters are used, they are referred to in the command string as $1, $2, etc.
|
|
;; @param <param> Specifies the actual values of the parameters.
|
|
;; @return Returns a numeric status code
|
|
;; Sends a SQL query string to the database server for evaluation.
|
|
;; The return value will be an integer representing one of the following enumerated types: PGRES_EMPTY_QUERY,
|
|
;; PGRES_COMMAND_OK, PGRES_TUPLES_OK, PGRES_COPY_OUT, PGRES_COPY_IN,
|
|
;; PGRES_BAD_RESPONSE, PGRES_FATAL_ERROR.
|
|
;;
|
|
;; The numeric status code can be converted to a string using (PgSQL:result-str <status-code>).
|
|
;; The numeric status code should not be used directly.
|
|
;;
|
|
;; From the libpq documentation:
|
|
;; <blockquote>
|
|
;; If the result status is PGRES_TUPLES_OK, then the functions described
|
|
;; below can be used to retrieve the rows returned by the query. Note that
|
|
;; a SELECT command that happens to retrieve zero rows still shows
|
|
;; PGRES_TUPLES_OK. PGRES_COMMAND_OK is for commands that can never return
|
|
;; rows (INSERT, UPDATE, etc.). A response of PGRES_EMPTY_QUERY might
|
|
;; indicate a bug in the client software.
|
|
;; </blockquote>
|
|
;;
|
|
|
|
;; @example
|
|
;;
|
|
;; (PgSQL:query "select $1||$2" "abc" "def")
|
|
;; (PgSQL:fetch-all) ; -> (("abcdef"))
|
|
;;
|
|
;; (PgSQL:query "select $1 + $2" 10 20)
|
|
;; (PgSQL:fetch-all) ; -> (("30"))
|
|
;;
|
|
;; (PgSQL:query "select $1::timestamp + $2::interval" "2012-10-01 00:00:00" "123456 seconds")
|
|
;; (PgSQL:fetch-all) ; -> (("2012-10-02 10:17:36"))
|
|
;;
|
|
;; (PgSQL:query "create table tbl (a integer, b integer)")
|
|
;; (dotimes (i 10) (PgSQL:query "insert into tbl values ($1, $2)" i (* i 2)))
|
|
;; ; a | b
|
|
;; ; ---+----
|
|
;; ; 0 | 0
|
|
;; ; 1 | 2
|
|
;; ; 2 | 4
|
|
;; ; ...
|
|
;; ; 9 | 18
|
|
;;
|
|
;; (PgSQL:query "select * from tbl where a=$1 or a=$2" 2 9)
|
|
;; (PgSQL:fetch-all) ; -> (("2" "4") ("9" "18"))
|
|
|
|
(define (query sql)
|
|
(clear-result)
|
|
(letn ((nParams (length (args)))
|
|
(params (map (lambda (argv) (string argv)) (args)))
|
|
(ptr-fmt (if (= (& (sys-info 9) 256) 0)
|
|
"lu" "Lu"))
|
|
(paramValues (if params
|
|
(pack (dup ptr-fmt nParams) params)
|
|
0)))
|
|
(setq PG_RESULT
|
|
(PQexecParams PG_CONN sql nParams 0 paramValues 0 0 0))
|
|
(if (not (NULL? PG_RESULT))
|
|
(PQresultStatus PG_RESULT)
|
|
PGRES_FATAL_ERROR)) )
|
|
|
|
;; @syntax (PgSQL:num-rows)
|
|
;; @return Number of rows from last query.
|
|
|
|
(define (num-rows)
|
|
(PQntuples PG_RESULT))
|
|
|
|
;; @syntax (PgSQL:num-fields)
|
|
;; @return Number of columns from last query.
|
|
|
|
(define (num-fields)
|
|
(PQnfields PG_RESULT))
|
|
|
|
;; @syntax (PgSQL:fnumber <str-column>)
|
|
;; @param <str-column> The column name.
|
|
;; @return the column number associated with the given column name. return nil when not found column name.
|
|
|
|
(define (fnumber name)
|
|
(let (n (PQfnumber PG_RESULT name))
|
|
(if (< n 0)
|
|
nil
|
|
n)))
|
|
|
|
;; @syntax (PgSQL:fname <int-column>)
|
|
;; @param <int-column> The integer column number.
|
|
;; @return the column name associated with the given column number. return nil when not found column name.
|
|
|
|
(define (fname column)
|
|
(let (s1 (PQfname PG_RESULT (int column)))
|
|
(if (= s1 0)
|
|
nil
|
|
(let (s2 (get-string s1))
|
|
(if (= s2 "")
|
|
nil
|
|
s2)))))
|
|
|
|
;; @syntax (PgSQL:fetch-value <num-row> <col>)
|
|
;; @param <num-row> row number
|
|
;; @param <col> column number or column name string.
|
|
;; @return A single value
|
|
;; Fetches the single value in the row and column specified. Used by the
|
|
;; ':fetch-row' and ':fetch-all' functions. A field containing the 'NULL'
|
|
;; value will return the symbol 'NULL'
|
|
|
|
(define (fetch-value row column)
|
|
(if (string? column)
|
|
(setq column (fnumber column)))
|
|
(when column
|
|
(let (s1 (PQgetvalue PG_RESULT row column))
|
|
(if (NULL? s1)
|
|
nil
|
|
(let (s2 (get-string s1))
|
|
(if (= 1 (PQgetisnull PG_RESULT row column))
|
|
'NULL s2))))) )
|
|
|
|
;; @syntax (PgSQL:fetch-row)
|
|
;; @return A list of field elements.
|
|
;; Fetches a row from a previous SQL 'PgSQL:query' 'select' statement.
|
|
;; Subsequent calls fetch row by row from the result table until the
|
|
;; end of the table is reached.
|
|
|
|
(define (fetch-row)
|
|
(when (and (> (num-rows) 0) (> (num-rows) PG_ROWX))
|
|
(let (row (map (fn (x) (fetch-value PG_ROWX x)) (sequence 0 (- (num-fields) 1))))
|
|
(++ PG_ROWX)
|
|
row)))
|
|
|
|
;; @syntax (PgSQL:fetch-all)
|
|
;; @return All rows/fields from the last query, or 'nil'
|
|
;; The whole result set from the query is returned at once as a list of row lists.
|
|
|
|
(define (fetch-all)
|
|
(when (> (num-rows) 0)
|
|
(data-seek 0)
|
|
(map fetch-row (sequence 0 (- (num-rows) 1)))))
|
|
|
|
;; @syntax (PgSQL:databases)
|
|
;; @return A list of databases.
|
|
;; Performs the query 'SELECT datname FROM pg_database' which shows all the
|
|
;; database schemas hosted by the connected server.
|
|
|
|
(define (databases)
|
|
(when (= "PGRES_TUPLES_OK" (result-status-str (query {SELECT datname FROM pg_database})))
|
|
(map (fn (x) (x 0)) (fetch-all))))
|
|
|
|
;; @syntax (PgSQL:tables)
|
|
;; @return A list of tables in the database, or 'nil'
|
|
;; Performs the query 'SELECT table_name FROM information_schema.tables WHERE table_schema = 'public''
|
|
|
|
(define (tables)
|
|
(when (= "PGRES_TUPLES_OK" (result-status-str (query {SELECT table_name FROM information_schema.tables WHERE table_schema = 'public'})))
|
|
(map (fn (x) (x 0)) (fetch-all))))
|
|
|
|
;; @syntax (PgSQL:fields <str-table>)
|
|
;; @param <str-table> The name of the table.
|
|
;; @return A list of fields in the table, or 'nil'
|
|
;; Unlike the equivalent function in the MySQL module, this function only shows
|
|
;; the names of all the fields in the given table. It does not show the field
|
|
;; specification, which you would need to recreate the table.
|
|
|
|
(define (fields str-table)
|
|
(let (sql (format {SELECT column_name FROM information_schema.columns WHERE table_name = %s} (escape-literal str-table)))
|
|
(when (= "PGRES_TUPLES_OK" (result-status-str (query sql)))
|
|
(map (fn (x) (x 0)) (fetch-all)))))
|
|
|
|
;; @syntax (PgSQL:data-seek <num-offset>)
|
|
;; @param <num-offset> The '0' based offset to position inside the data set.
|
|
;; @return Always 'true'.
|
|
;; Sets a position in the result set which will be used by the next
|
|
;; 'PgSQL:fetch-row' call. If the offset is out of the allowed range for the
|
|
;; result set a subsequent fetch-row will return 'nil'.
|
|
|
|
(define (data-seek n) (setq PG_ROWX n) true)
|
|
|
|
;; @syntax (PgSQL:error)
|
|
;; @return A string containing the query result error message.
|
|
;; If there was no error, this function returns 'nil'.
|
|
|
|
(define (error)
|
|
(if (= PG_RESULT nil)
|
|
(throw-error "Results are not available.")
|
|
(let (s1 (PQresultErrorMessage PG_RESULT))
|
|
(if (NULL? s1)
|
|
nil
|
|
(let (s2 (get-string s1))
|
|
(if (= s2 "")
|
|
nil
|
|
s2))))))
|
|
|
|
;; @syntax (PgSQL:affected-rows)
|
|
;; @return Number of rows affected by the last 'PgSQL:query' operation, or 'nil'
|
|
;; This function will only return a value following the execution of an INSERT,
|
|
;; UPDATE, DELETE, MOVE, FETCH, or COPY statement, or an EXECUTE of a prepared
|
|
;; query that contains an INSERT, UPDATE, or DELETE statement. It will return
|
|
;; 'nil' after all other queries.
|
|
|
|
(define (affected-rows)
|
|
(if (= PG_RESULT nil)
|
|
nil
|
|
(let (s1 (PQcmdTuples PG_RESULT))
|
|
(if (NULL? s1)
|
|
nil
|
|
(let (s2 (get-string s1))
|
|
(if (= s2 "")
|
|
nil
|
|
(int s2)))))))
|
|
|
|
;; @syntax (PgSQL:error-conn)
|
|
;; @return error message string
|
|
;; Returns the error message most recently generated by an operation on the connection.
|
|
|
|
(define (error-conn)
|
|
(if (= PG_CONN nil)
|
|
(throw-error "Connection is not available.")
|
|
(let (s1 (PQerrorMessage PG_CONN))
|
|
(if (NULL? s1)
|
|
nil
|
|
(let (s2 (get-string s1))
|
|
(if (= s2 "")
|
|
nil
|
|
s2))))))
|
|
|
|
;; @syntax (PgSQL:escape <str-sql>)
|
|
;; @return escaped string
|
|
;; This function only escapes the ' character in <str-sql>, as per the SQL standard.
|
|
;; Depending on whether you
|
|
;; are using binary data or have configured Postgres to allow C escapes
|
|
;; you may need more advanced escaping than this function provides.
|
|
|
|
(define (escape)
|
|
(replace {'} (apply string (args)) {''}))
|
|
|
|
;; @syntax (PgSQL:escape-literal <str>)
|
|
;; @param <str> string to be escaped
|
|
;; @return escaped string
|
|
;; This function escapes a string for use within an SQL command. This is
|
|
;; useful when inserting data values as literal constants in SQL commands. Certain
|
|
;; characters (such as quotes and backslashes) must be escaped to prevent them from
|
|
;; being interpreted specially by the SQL parser. escape-literal performs this
|
|
;; operation. This function was added in PostgreSQL 9.1 and will throw an error if
|
|
;; you are using an older libpq.
|
|
|
|
(define (escape-literal x)
|
|
(if (primitive? PQescapeLiteral)
|
|
(if (= PG_CONN nil)
|
|
(throw-error "Must be connected to a database.")
|
|
(let (pg_raw_result (PQescapeLiteral PG_CONN x (length (get-string x))))
|
|
(if (= pg_raw_result nil)
|
|
(throw-error (error-conn))
|
|
(let (pg_result (get-string pg_raw_result))
|
|
(PQfreemem pg_raw_result)
|
|
pg_result))))
|
|
(throw-error "PQescapeLiteral not available.")))
|
|
|
|
;; @syntax (PgSQL:escape-identifier <str>)
|
|
;; @param <str> string to be escaped
|
|
;; @return escaped string
|
|
;; This function escapes a string for use as an SQL identifier, such as a
|
|
;; table, column, or function name. This is useful when a user-supplied identifier
|
|
;; might contain special characters that would otherwise not be interpreted as part
|
|
;; of the identifier by the SQL parser, or when the identifier might contain upper
|
|
;; case characters whose case should be preserved. This function was added in
|
|
;; PostgreSQL 9.1 and will throw an error if you are using an older libpq.
|
|
|
|
(define (escape-identifier x)
|
|
(if (primitive? PQescapeIdentifier)
|
|
(if (= PG_CONN nil)
|
|
(throw-error "Must be connected to a database.")
|
|
(let (pg_raw_result (PQescapeIdentifier PG_CONN x (length (get-string x))))
|
|
(if (= pg_raw_result nil)
|
|
(throw-error (error-conn))
|
|
(let (pg_result (get-string pg_raw_result))
|
|
(PQfreemem pg_raw_result)
|
|
pg_result))))
|
|
(throw-error "PQescapeIdentifier not available.")))
|
|
|
|
(define (clear-result)
|
|
(when (and PG_RESULT (not (NULL? PG_RESULT)))
|
|
(PQclear PG_RESULT))
|
|
(setq PG_RESULT nil PG_ROWX 0 PG_COLX 0))
|
|
|
|
;; @syntax (PgSQL:close-db)
|
|
;; @return Always 'true'.
|
|
;; Closes the database connection and frees associated resources.
|
|
|
|
(define (close-db)
|
|
(clear-result)
|
|
(when (and PG_CONN (not (NULL? PG_CONN)))
|
|
(PQfinish PG_CONN))
|
|
(setq PG_CONN nil)
|
|
true)
|
|
|
|
;; @syntax (PgSQL:host)
|
|
;; @return connected host name string
|
|
(define (host)
|
|
(if (= PG_CONN nil)
|
|
(throw-error "Connection is not established.")
|
|
(let (s1 (PQhost PG_CONN))
|
|
(if (NULL? s1)
|
|
nil
|
|
(let (s2 (get-string s1))
|
|
(if (= s2 "")
|
|
nil
|
|
s2))))))
|
|
|
|
;; @syntax (PgSQL:port)
|
|
;; @return connected port name string
|
|
(define (port)
|
|
(if (= PG_CONN nil)
|
|
(throw-error "Connection is not established.")
|
|
(let (s1 (PQport PG_CONN))
|
|
(if (NULL? s1)
|
|
nil
|
|
(let (s2 (get-string s1))
|
|
(if (= s2 "")
|
|
nil
|
|
s2))))))
|
|
|
|
;; @syntax (PgSQL:db)
|
|
;; @return connected database name string
|
|
(define (db)
|
|
(if (= PG_CONN nil)
|
|
(throw-error "Connection is not established.")
|
|
(let (s1 (PQdb PG_CONN))
|
|
(if (NULL? s1)
|
|
nil
|
|
(let (s2 (get-string s1))
|
|
(if (= s2 "")
|
|
nil
|
|
s2))))))
|
|
|
|
;; @syntax (PgSQL:options)
|
|
;; @return connected options string
|
|
(define (options)
|
|
(if (= PG_CONN nil)
|
|
(throw-error "Connection is not established.")
|
|
(let (s1 (PQoptions PG_CONN))
|
|
(if (NULL? s1)
|
|
nil
|
|
(let (s2 (get-string s1))
|
|
(if (= s2 "")
|
|
nil
|
|
s2))))))
|
|
|
|
;; @syntax (PgSQL:user)
|
|
;; @return connected user name string
|
|
(define (user)
|
|
(if (= PG_CONN nil)
|
|
(throw-error "Connection is not established.")
|
|
(let (s1 (PQuser PG_CONN))
|
|
(if (NULL? s1)
|
|
nil
|
|
(let (s2 (get-string s1))
|
|
(if (= s2 "")
|
|
nil
|
|
s2))))))
|
|
|
|
;; @syntax (PgSQL:result-str <int-status-code>)
|
|
;; @param <int-status-code> An integer query result status code
|
|
;; @return string for the given integer status code
|
|
;; The return value will be one of the following strings "PGRES_EMPTY_QUERY",
|
|
;; "PGRES_COMMAND_OK", "PGRES_TUPLES_OK", "PGRES_COPY_OUT", "PGRES_COPY_IN",
|
|
;; "PGRES_BAD_RESPONSE", "PGRES_FATAL_ERROR".
|
|
|
|
(define (result-status-str status-code)
|
|
(let (s1 (PQresStatus status-code))
|
|
(if (NULL? s1)
|
|
nil
|
|
(let (s2 (get-string s1))
|
|
(if (= s2 "")
|
|
nil
|
|
s2)))))
|
|
|
|
; verify that the constant PGRES_FATAL_ERROR has the correct integer value
|
|
(if (!= "PGRES_FATAL_ERROR" (result-status-str PGRES_FATAL_ERROR) )
|
|
(throw-error
|
|
(append "PGRES_FATAL_ERROR defined as "
|
|
(string PGRES_FATAL_ERROR)
|
|
", but PostgreSQL has that defined as "
|
|
(result-status-str PGRES_FATAL_ERROR) )))
|
|
|
|
;; @syntax (PgSQL:lib-version)
|
|
;; @return libpq version as string (e.g. "9.1.1")
|
|
(define (lib-version)
|
|
(if (= PQlibVersion nil)
|
|
"Not Available - Pre 9.0"
|
|
(begin
|
|
(regex {(\d+?)(\d\d)(\d\d)$} (string (PQlibVersion)))
|
|
(append $1 "." $2 "." $3))))
|
|
|
|
;; @syntax (PgSQL:protocol-version)
|
|
;; @return protocol version "2", or "3" as string, "0" bad connection.
|
|
;; Interrogates the frontend/backend protocol being used.
|
|
(define (protocol-version)
|
|
(if (= PG_CONN nil)
|
|
(throw-error "Connection is not established.")
|
|
(string (PQprotocolVersion PG_CONN))))
|
|
|
|
;; @syntax (PgSQL:server-version)
|
|
;; @return backend server version as string (e.g. "9.1.1")
|
|
(define (server-version)
|
|
(if (= PG_CONN nil)
|
|
(throw-error "Connection is not established.")
|
|
(begin
|
|
(regex {(\d+?)(\d\d)(\d\d)$} (string (PQserverVersion PG_CONN)))
|
|
(append $1 "." $2 "." $3))))
|
|
|
|
(context MAIN)
|
|
|
|
|
|
; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;
|
|
; test data base functions
|
|
;
|
|
; Check PgSQL Test Coverage
|
|
; Function NOT Tested: PgSQL:clear-result
|
|
; Percent PgSQL Coverage: 96.9
|
|
|
|
(define (test-pgsql host user passw dbname)
|
|
(unless (PgSQL:connect host user passw dbname)
|
|
(println "PgSQL: couldn't connect 1st try.")
|
|
(exit 0))
|
|
|
|
; clean up in case the previous test failed
|
|
(PgSQL:query "DROP TABLE fruits")
|
|
|
|
(unless (PgSQL:connectdb (format {host='%s' user='%s' password='%s' dbname='%s'} (PgSQL:escape host) (PgSQL:escape user) (PgSQL:escape passw) (PgSQL:escape dbname)))
|
|
(println "PgSQL: couldn't connect 2nd try.")
|
|
(exit 0))
|
|
|
|
(if (not (PgSQL:NULL? 0))
|
|
(throw-error "NULL not valid."))
|
|
(if (PgSQL:NULL? 5)
|
|
(throw-error "NULL not valid."))
|
|
|
|
(println "\nTest Connection Info Retrieval:")
|
|
(println " database: " (PgSQL:db))
|
|
(println " user: " (PgSQL:user))
|
|
(println " host: " (PgSQL:host))
|
|
(println " port: " (PgSQL:port))
|
|
(println " options: " (PgSQL:options))
|
|
(println " libpq ver: " (PgSQL:lib-version))
|
|
(println " server ver: " (PgSQL:server-version))
|
|
(println "protocol ver: " (PgSQL:protocol-version))
|
|
|
|
(println "\nTest List Databases:")
|
|
(println (join (PgSQL:databases) ", "))
|
|
|
|
(println "\nTest Create Test Data")
|
|
(PgSQL:query "CREATE TABLE fruits (name varchar, qty int, num serial NOT NULL)")
|
|
|
|
(set 'test_data (list (list "apples" 11) (list "oranges" 22) (list "bananas" 33) (list "pears" 44)))
|
|
(println test_data)
|
|
|
|
(dolist (x test_data)
|
|
(println "Insert result: " (PgSQL:result-status-str (PgSQL:query "INSERT INTO fruits VALUES ($1, $2)" (nth 0 x) (nth 1 x))) " - " (nth 0 x) ", " (nth 1 x))
|
|
(let (myCount (PgSQL:affected-rows))
|
|
(if (or (nil? myCount) (zero? myCount))
|
|
(throw-error "Insert did not work."))))
|
|
|
|
(println "\nTest Inserted into fruits:")
|
|
(setq q "SELECT * FROM fruits ORDER BY name;")
|
|
(setq q-status (PgSQL:query q))
|
|
(println " select query: " q)
|
|
|
|
(println " select query result: " (PgSQL:result-status-str q-status))
|
|
(if (!= "PGRES_TUPLES_OK" (PgSQL:result-status-str q-status))
|
|
(throw-error "query result not ok."))
|
|
|
|
(println " rows returned: " (PgSQL:num-rows))
|
|
(if (!= 4 (PgSQL:num-rows))
|
|
(throw-error "Wrong number of rows." ))
|
|
|
|
(println " columns returned: " (PgSQL:num-fields))
|
|
(if (!= 3 (PgSQL:num-fields))
|
|
(throw-error "Wrong number of columns." ))
|
|
|
|
(println " 'qty' column number: " (PgSQL:fnumber "qty"))
|
|
(if (!= 1 (PgSQL:fnumber "qty"))
|
|
(throw-error "column number not correct."))
|
|
|
|
; gather column names from result
|
|
(set 'column_names (let (x -1)
|
|
(collect (PgSQL:fname (inc x)) (PgSQL:num-fields))))
|
|
(println "column names returned: " (join column_names ", "))
|
|
|
|
(dotimes (x (PgSQL:num-rows)) (println " row: " (PgSQL:fetch-row)))
|
|
(println " table column names: " (join (PgSQL:fields "fruits") ", "))
|
|
|
|
|
|
(println "\nTest List Tables:")
|
|
(println (join (PgSQL:tables) ", "))
|
|
|
|
(println "\nTest fetch-row and data-seek to offset 2:")
|
|
(PgSQL:query "SELECT * FROM fruits")
|
|
(PgSQL:data-seek 2)
|
|
(println (PgSQL:fetch-row))
|
|
|
|
(println "\nTest fetch-all:")
|
|
(PgSQL:query "SELECT * FROM fruits")
|
|
(println (PgSQL:fetch-all))
|
|
|
|
(println "\nTest Fetching Out of Range Values:")
|
|
(println "invalid data access (row 5, column 5): " (PgSQL:fetch-value 5 5))
|
|
|
|
; clean up after DB tests
|
|
(PgSQL:query "DROP TABLE fruits")
|
|
|
|
(println "\nTest PG Error Retrieval:")
|
|
(PgSQL:query "SELECT * FROM fruittyyyy")
|
|
(println "Should show result error on next line.\n" (PgSQL:error))
|
|
(println "Should show connection error (same as above) on next line.\n" (PgSQL:error-conn))
|
|
|
|
(println "\nTest Text Escaping:")
|
|
(println " Check escape literal: " (PgSQL:escape-literal "group's"))
|
|
(println "Check escape identifier: " (PgSQL:escape-identifier "group's"))
|
|
|
|
(println "\nTest Query PG Result Conversion to String:")
|
|
(println "result 0: " (PgSQL:result-status-str 0))
|
|
(println "result 1: " (PgSQL:result-status-str 1))
|
|
(println "result 2: " (PgSQL:result-status-str 2))
|
|
(println "result 3: " (PgSQL:result-status-str 3))
|
|
(println "result 4: " (PgSQL:result-status-str 4))
|
|
(println "result 5: " (PgSQL:result-status-str 5))
|
|
(println "result 6: " (PgSQL:result-status-str 6))
|
|
(println "result 7: " (PgSQL:result-status-str 7))
|
|
(println "result 8: " (PgSQL:result-status-str 8))
|
|
(println "result 9: " (PgSQL:result-status-str 9))
|
|
|
|
(PgSQL:close-db)
|
|
|
|
(println)
|
|
(println "Tests Completed.")
|
|
(println)
|
|
)
|
|
|
|
; eof
|