├── simple-date ├── test-package.lisp ├── package.lisp ├── tests.lisp └── cl-postgres-glue.lisp ├── postmodern ├── tests │ ├── tef-2.sql │ ├── tef-3.sql │ ├── tef-6.sql │ ├── sub1 │ │ ├── tef-7.sql │ │ ├── tef-4.sql │ │ └── tef-5.sql │ ├── test-package.lisp │ ├── tef-1.sql │ ├── test-execute-file-broken.sql │ ├── test-execute-file-broken-transaction.sql │ ├── test-fail-include-execute-file.sql │ ├── test-execute-file.sql │ └── test-postmodern-binary.lisp ├── namespace.lisp ├── package.lisp ├── deftable.lisp └── connect.lisp ├── cl-postgres ├── tests │ ├── test-package.lisp │ ├── test-communicate.lisp │ ├── test-ieee-float.lisp │ ├── test-oids.lisp │ ├── tests-saslprep.lisp │ ├── simple-date-tests.lisp │ ├── test-clp-utf8.lisp │ └── test-data-types.lisp ├── features.lisp ├── strings-utf-8.lisp ├── strings-ascii.lisp ├── config.lisp ├── oid.lisp ├── saslprep.lisp ├── bulk-copy.lisp ├── communicate.lisp ├── ieee-floats.lisp └── data-types.lisp ├── s-sql ├── tests │ └── test-package.lisp ├── package.lisp └── config.lisp ├── .gitignore ├── s-sql.asd ├── simple-date.asd ├── doc ├── s-sql-h.org ├── style.css ├── s-sql-m.org ├── s-sql-b.org ├── s-sql-prepared-statements.org ├── s-sql-f.org ├── s-sql-v.org ├── s-sql-g.org ├── s-sql-n.org ├── s-sql-examples.org ├── s-sql-e.org ├── s-sql-special-characters.org ├── s-sql-r.org ├── s-sql-postgresql-functions.org ├── s-sql-p.org ├── s-sql-s.org ├── simple-date.org ├── s-sql-w.org ├── s-sql-l.org └── s-sql-j.org ├── CONTRIBUTING.md ├── LICENSE ├── postmodern.asd └── cl-postgres.asd /simple-date/test-package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-USER; -*- 2 | 3 | (defpackage :simple-date-tests 4 | (:use :common-lisp :fiveam :simple-date)) 5 | -------------------------------------------------------------------------------- /postmodern/tests/tef-2.sql: -------------------------------------------------------------------------------- 1 | /* test' comment tef-2-1 2 | with multiple lines 3 | --*/ 4 | 5 | insert into company_employees (id,name,age,address,include_file,join_date) values (8, 'Juan', 32, 'Madrid', 'tef-2.sql','2011-04-13'); 6 | -------------------------------------------------------------------------------- /postmodern/tests/tef-3.sql: -------------------------------------------------------------------------------- 1 | /* test' comment tef-3-1 2 | with multiple lines 3 | --*/ 4 | 5 | insert into company_employees (id,name,age,address,include_file,join_date) values (9, 'Julian', 32, 'Athens', 'tef-3.sql','2011-04-13'); 6 | -------------------------------------------------------------------------------- /postmodern/tests/tef-6.sql: -------------------------------------------------------------------------------- 1 | /* test' comment tef-6-1 2 | with multiple lines 3 | --*/ 4 | 5 | insert into company_employees (id,name,age,address,include_file,join_date) values (13, 'Stan', 32, 'Warsaw', 'tef-6.sql','2011-04-13'); 6 | -------------------------------------------------------------------------------- /postmodern/tests/sub1/tef-7.sql: -------------------------------------------------------------------------------- 1 | /* test' comment tef-7-1 2 | with multiple lines 3 | --*/ 4 | 5 | insert into company_employees (id,name,age,address,include_file,join_date) values (155, 'Victor', 32, 'Warsaw', 'tef-7.sql','2011-04-13'); 6 | -------------------------------------------------------------------------------- /postmodern/tests/sub1/tef-4.sql: -------------------------------------------------------------------------------- 1 | /* test' comment tef-4-1 2 | with multiple lines 3 | --*/ 4 | 5 | insert into company_employees (id,name,age,address,include_file,join_date) values (10, 'Catharina', 32, 'Vienna', 'sub1/tef-4.sql','2011-04-13'); 6 | -------------------------------------------------------------------------------- /postmodern/tests/sub1/tef-5.sql: -------------------------------------------------------------------------------- 1 | /* test' comment tef-5-1 2 | with multiple lines 3 | --*/ 4 | 5 | insert into company_employees (id,name,age,address,include_file,join_date) values (11, 'Lisa', 32, 'Frankfurt', 'sub1/tef-5.sql','2011-04-13'); 6 | -------------------------------------------------------------------------------- /postmodern/tests/test-package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-USER; -*- 2 | 3 | (defpackage :postmodern-tests 4 | (:use :common-lisp :fiveam :postmodern :simple-date :cl-postgres-tests) 5 | (:shadow #:with-test-connection)) 6 | -------------------------------------------------------------------------------- /cl-postgres/tests/test-package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-USER; -*- 2 | 3 | (defpackage :cl-postgres-tests 4 | (:use :common-lisp :fiveam :cl-postgres :cl-postgres-error) 5 | (:export #:prompt-connection #:with-test-connection)) 6 | -------------------------------------------------------------------------------- /s-sql/tests/test-package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-USER; -*- 2 | 3 | (defpackage :s-sql-tests 4 | (:use :common-lisp :fiveam :s-sql 5 | :cl-postgres-error :cl-postgres-tests :postmodern) 6 | (:shadow #:with-test-connection)) 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.fas 2 | *.FASL 3 | *.fasl 4 | *.lisp-temp 5 | *.dfsl 6 | *.pfsl 7 | *.d64fsl 8 | *.p64fsl 9 | *.lx64fsl 10 | *.lx32fsl 11 | *.dx64fsl 12 | *.dx32fsl 13 | *.fx64fsl 14 | *.fx32fsl 15 | *.sx64fsl 16 | *.sx32fsl 17 | *.wx64fsl 18 | *.wx32fsl 19 | *.*~ 20 | *.vbin 21 | *.abcl 22 | *~ 23 | -------------------------------------------------------------------------------- /postmodern/tests/tef-1.sql: -------------------------------------------------------------------------------- 1 | /* test' comment tef-1-1 2 | with multiple lines 3 | --*/ 4 | 5 | insert into company_employees (id,name,age,address,include_file,join_date) values (7, 'Robert', 32, 'Paris', 'tef-1.sql','2011-04-13'); 6 | 7 | /* 8 | \i tef-2.sql 9 | */ 10 | 11 | -- \i tef-1.sql 12 | -------------------------------------------------------------------------------- /cl-postgres/features.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES.FEATURES; -*- 2 | (in-package :cl-postgres.features) 3 | 4 | (eval-when (:compile-toplevel :load-toplevel :execute) 5 | (when (find-package 'sb-bsd-sockets) 6 | (pushnew 'sbcl-available *features*) 7 | 8 | (when (find-symbol "INET6-SOCKET" 'sb-bsd-sockets) 9 | (pushnew 'sbcl-ipv6-available *features*)))) 10 | -------------------------------------------------------------------------------- /postmodern/tests/test-execute-file-broken.sql: -------------------------------------------------------------------------------- 1 | create table company_employees( 2 | id bigserial primary key not null, 3 | name text not null, 4 | age int not null, 5 | address char(50), 6 | salary real, 7 | join_date date 8 | ); 9 | insert into company_employees (id,name,age,address,salary,join_date) values (1, 'paul', 32, 'London', 20100.00,'2001-07-13'); 10 | insert into company_employees (id,name,age,address,salary,join_date) values (1, 'paul', 32, 'London', 20100.00,'2001-07-13'); 11 | insert into company_employees (id,name,age,address,salary,join_date) values (2, 'ziad', 32, 'Beirut', 20000.00,'2003-03-13'); 12 | -------------------------------------------------------------------------------- /postmodern/tests/test-execute-file-broken-transaction.sql: -------------------------------------------------------------------------------- 1 | begin transaction; 2 | 3 | create table company_employees( 4 | id bigserial primary key not null, 5 | name text not null, 6 | age int not null, 7 | address char(50), 8 | salary real, 9 | join_date date 10 | ); 11 | insert into company_employees (id,name,age,address,salary,join_date) values (1, 'paul', 32, 'London', 20100.00,'2001-07-13'); 12 | insert into company_employees (id,name,age,address,salary,join_date) values (1, 'paul', 32, 'London', 20100.00,'2001-07-13'); 13 | insert into company_employees (id,name,age,address,salary,join_date) values (2, 'ziad', 32, 'Beirut', 20000.00,'2003-03-13'); 14 | end transaction; 15 | -------------------------------------------------------------------------------- /simple-date/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-USER; -*- 2 | 3 | (defpackage :simple-date 4 | (:use :common-lisp) 5 | (:export #:date #:encode-date #:decode-date #:day-of-week 6 | #:timestamp #:encode-timestamp #:decode-timestamp 7 | #:timestamp-to-universal-time #:universal-time-to-timestamp 8 | #:interval #:encode-interval #:decode-interval 9 | #:time-of-day #:hours #:minutes #:seconds #:microseconds 10 | #:encode-time-of-day #:decode-time-of-day 11 | #:time-add #:time-subtract 12 | #:time= #:time> #:time< #:time<= #:time>=)) 13 | 14 | (defpackage :simple-date-cl-postgres-glue 15 | (:use :common-lisp :simple-date) 16 | (:export *simple-date-sql-readtable* 17 | :simple-date-sql-readtable)) 18 | 19 | -------------------------------------------------------------------------------- /cl-postgres/tests/test-communicate.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES-TESTS; -*- 2 | (in-package :cl-postgres-tests) 3 | 4 | (def-suite :cl-postgres-communicate 5 | :description "Test suite for cl-postgres functions in communicate.lisp" 6 | :in :cl-postgres) 7 | 8 | (in-suite :cl-postgres-communicate) 9 | 10 | (test connection-pid 11 | (is (equal (length (with-test-connection 12 | (cl-postgres::parameter-list-types 13 | (cl-postgres::connection-pid connection)))) 14 | 2))) 15 | 16 | (test postgresql-versions 17 | (with-test-connection 18 | (is (postgresql-version-at-least "9.5.4" connection)) 19 | (is (postgresql-version-at-least 20 | (cl-postgres::get-postgresql-version connection) 21 | connection)) 22 | (is (not (postgresql-version-at-least "11000" connection))))) 23 | -------------------------------------------------------------------------------- /s-sql/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-USER; -*- 2 | 3 | (defpackage :s-sql 4 | (:use :common-lisp) 5 | (:export #:smallint 6 | #:bigint 7 | #:numeric 8 | #:real 9 | #:double-precision 10 | #:double-precision[] 11 | #:bytea 12 | #:text 13 | #:varchar 14 | #:serial 15 | #:serial8 16 | #:timestamp-with-time-zone 17 | #:timestamp-without-time-zone 18 | #:db-null 19 | #:sql-type-name 20 | #:*standard-sql-strings* 21 | #:*downcase-symbols* 22 | #:sql-escape-string 23 | #:sql-escape 24 | #:from-sql-name 25 | #:to-sql-name 26 | #:*escape-sql-names-p* 27 | #:sql 28 | #:sql-compile 29 | #:sql-template 30 | #:$$ 31 | #:register-sql-operators 32 | #:enable-s-sql-syntax 33 | #:sql-error)) 34 | -------------------------------------------------------------------------------- /cl-postgres/strings-utf-8.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES; -*- 2 | (in-package :cl-postgres) 3 | 4 | (defparameter *client-encoding* "UNICODE") 5 | 6 | (declaim (inline enc-byte-length)) 7 | (defun enc-byte-length (sequence) 8 | (cl-postgres-trivial-utf-8:utf-8-byte-length sequence)) 9 | 10 | (declaim (inline enc-write-string)) 11 | (defun enc-write-string (string output &key null-terminate) 12 | (cl-postgres-trivial-utf-8:write-utf-8-bytes string output 13 | :null-terminate null-terminate)) 14 | 15 | (declaim (inline enc-read-string)) 16 | (declaim (ftype (function (t &key (:null-terminated t) 17 | (:byte-length fixnum)) 18 | string) 19 | enc-read-string)) 20 | (defun enc-read-string (input &key null-terminated (byte-length -1)) 21 | (cl-postgres-trivial-utf-8:read-utf-8-string 22 | input :null-terminated null-terminated :stop-at-eof t :byte-length byte-length)) 23 | 24 | (declaim (inline enc-string-bytes)) 25 | (defun enc-string-bytes (string &key null-terminate) 26 | (cl-postgres-trivial-utf-8:string-to-utf-8-bytes 27 | string :null-terminate null-terminate)) 28 | -------------------------------------------------------------------------------- /s-sql.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; -*- 2 | 3 | (defpackage :s-sql-system 4 | (:use :common-lisp :asdf)) 5 | (in-package :s-sql-system) 6 | 7 | (defsystem "s-sql" 8 | :description "Lispy DSL for SQL" 9 | :author "Marijn Haverbeke " 10 | :maintainer "Sabra Crolleton " 11 | :license "zlib" 12 | :version "1.33.11" 13 | :depends-on ("cl-postgres" 14 | "alexandria") 15 | :components 16 | ((:module "s-sql" 17 | :components ((:file "package") 18 | (:file "config" :depends-on ("package")) 19 | (:file "s-sql" :depends-on ("package" "config"))))) 20 | :in-order-to ((test-op (test-op "s-sql/tests")))) 21 | 22 | (defsystem "s-sql/tests" 23 | :depends-on ("postmodern" "s-sql" "cl-postgres/tests" "fiveam") 24 | :components 25 | ((:module "s-sql/tests" 26 | :components ((:file "test-package") 27 | (:file "tests") 28 | (:file "test-arrays" :depends-on ("tests")) 29 | (:file "test-intervals" :depends-on ("tests")) 30 | (:file "test-tables" :depends-on ("tests")) 31 | (:file "test-create-index" :depends-on ("tests"))))) 32 | :perform (test-op (o c) 33 | (uiop:symbol-call :s-sql-tests '#:prompt-connection) 34 | (uiop:symbol-call :fiveam '#:run! :s-sql))) 35 | -------------------------------------------------------------------------------- /simple-date.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; -*- 2 | 3 | (defsystem "simple-date" 4 | :description "Simple date library that can be used with postmodern" 5 | :author "Marijn Haverbeke " 6 | :maintainer "Sabra Crolleton " 7 | :license "zlib" 8 | :version "1.31" 9 | :components 10 | ((:module "simple-date" 11 | :components ((:file "package") 12 | (:file "simple-date")))) 13 | :in-order-to ((test-op (test-op "simple-date/tests")))) 14 | 15 | (defsystem "simple-date/tests" 16 | :depends-on ("fiveam" "simple-date") 17 | :components 18 | ((:module "simple-date" 19 | :components ((:file "test-package") 20 | (:file "tests")))) 21 | :perform (test-op (o c) 22 | (uiop:symbol-call :fiveam '#:run! :simple-date))) 23 | 24 | (defsystem "simple-date/postgres-glue" 25 | :depends-on ("simple-date" "cl-postgres" "s-sql" "cl-postgres/tests") 26 | :components 27 | ((:module "simple-date" 28 | :components 29 | ((:file "cl-postgres-glue"))))) 30 | 31 | #| 32 | ;; The definitions below should work, unlike the bogus method they replace; 33 | ;; but I recommend instead explicit dependency on simple-date/postgres-glue. 34 | (load-system "asdf-system-connections") 35 | (defsystem-connection "simple-date/with-postgres" 36 | :requires ("simple-date" "cl-postgres") 37 | :depends-on ("simple-date/postgres-glue")) 38 | |# 39 | -------------------------------------------------------------------------------- /postmodern/tests/test-fail-include-execute-file.sql: -------------------------------------------------------------------------------- 1 | drop table if exists company_employees; 2 | 3 | create table company_employees( 4 | id bigserial primary key not null, 5 | name text not null, 6 | age int not null, 7 | address char(50), 8 | include_file text , 9 | join_date date 10 | ); 11 | 12 | insert into company_employees (id,name,age,address,include_file,join_date) values (1, 'Paul', 32, 'London', 'first-include-execute-file','2001-07-13'); 13 | 14 | \i ./postmodern/tests/tef-11.sql 15 | 16 | insert into company_employees (id,name,age,address,include_file,join_date) values (3, 'John', 32, 'Toronto', 'first-include-execute-file','2005-07-13'); 17 | 18 | \ir tef-6.sql 19 | 20 | insert into company_employees (id,name,age,address,include_file,join_date) values (6, 'Johanna', 32, 'Berlin', 'first-include-execute-file','2011-03-13'); 21 | 22 | \ir tef-3.sql 23 | 24 | insert into company_employees (id,name,age,address,include_file,join_date) values (4, 'Yasmin', 32, 'Mumbai', 'first-include-execute-file','2007-03-13'); 25 | 26 | \i ./postmodern/tests/sub1/tef-4.sql 27 | 28 | insert into company_employees (id,name,age,address,include_file,join_date) values (5, 'Susan', 32, 'Vancouver', 'first-include-execute-file','2009-07-13'); 29 | 30 | \ir ./sub1/tef-5.sql 31 | 32 | 33 | insert into company_employees (id,name,age,address,include_file,join_date) values (2, 'Ziad', 32, 'Beirut', 'first-include-execute-file','2003-03-13'); 34 | -------------------------------------------------------------------------------- /cl-postgres/tests/test-ieee-float.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES-TESTS; -*- 2 | (in-package :cl-postgres-tests) 3 | 4 | (def-suite :cl-postgres-ieee-float 5 | :description "Test suite for cl-postgres functions in ieee-floats.lisp" 6 | :in :cl-postgres) 7 | 8 | (in-suite :cl-postgres-ieee-float) 9 | 10 | (test ieee-float 11 | (is (equal (cl-postgres-ieee-floats::encode-float64 1234567.89) 12 | 4698053240367874048)) 13 | (is (equal (cl-postgres-ieee-floats::decode-float64 4698053240367874048) 14 | 1234567.875d0)) 15 | (is (equal (cl-postgres-ieee-floats::encode-float64 -4698053240.28) 16 | 13975092309851635712)) 17 | (is (equal (cl-postgres-ieee-floats::decode-float64 13975092309851635712) 18 | -4.69805312d9)) 19 | (is (equal (cl-postgres-ieee-floats::encode-float32 1234567.89) 20 | 1234613311)) 21 | (is (equal (cl-postgres-ieee-floats::decode-float32 1234613311) 22 | 1234567.9)) 23 | (is (equal (cl-postgres-ieee-floats::encode-float32 -4698053240.28) 24 | 3482059597)) 25 | (is (equal (cl-postgres-ieee-floats::decode-float32 3482059597) 26 | -4.698053e9)) 27 | (cl-postgres-ieee-floats::make-float-converters encode-float128 decode-float128 15 112 nil) 28 | (is (equal (encode-float128 1234567.89) 29 | 85170166357702954636935397302398353408)) 30 | (is (equal (decode-float128 85170166357702954636935397302398353408) 31 | 1234567.875d0))) 32 | -------------------------------------------------------------------------------- /doc/s-sql-h.org: -------------------------------------------------------------------------------- 1 | #+TITLE: S-SQL Examples H 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | * [[file:s-sql-examples.org][S-SQL Examples Home Page]] 8 | | [[file:s-sql-a.org][A]]| [[file:s-sql-b.org][B]]| [[file:s-sql-c.org][C]]| [[file:s-sql-d.org][D]]| [[file:s-sql-e.org][E]]| [[file:s-sql-f.org][F]]| [[file:s-sql-g.org][G]]| [[file:s-sql-h.org][H]]| [[file:s-sql-i.org][I]]| [[file:s-sql-j.org][J]]| [[file:s-sql-k.org][K]]| [[file:s-sql-l.org][L]]| [[file:s-sql-m.org][M]]| [[file:s-sql-n.org][N]]| [[file:s-sql-o.org][O]]| [[file:s-sql-p.org][P]]| [[file:s-sql-r.org][R]]| [[file:s-sql-s.org][S]]| [[file:s-sql-t.org][T]]| [[file:s-sql-u.org][U]]| [[file:s-sql-v.org][V]]| [[file:s-sql-w.org][W]]| [[file:s-sql-special-characters.org][Special Characters]] | [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]]| 9 | 10 | * Having 11 | :PROPERTIES: 12 | :CUSTOM_ID: having 13 | :END: 14 | Postgresql documentation [[https://www.postgresql.org/docs/current/queries-table-expressions.html#QUERIES-GROUP][here]] 15 | #+begin_src lisp 16 | (query (:select (:count 'c.id) 'r.name 17 | :from (:as 'countries 'c) 18 | :inner-join (:as 'regions 'r) 19 | :on (:= 'c.region-id 'r.id) 20 | :group-by 'r.name 21 | :having (:< (:count 'c.id) 10))) 22 | 23 | ((5 "Central Asia") (5 "North America") (6 "Central America")) 24 | #+end_src 25 | -------------------------------------------------------------------------------- /doc/style.css: -------------------------------------------------------------------------------- 1 | body { 2 | margin: 0; 3 | font-family: tahoma, arial, sans-serif; 4 | padding: 50px 100px; 5 | color: black; 6 | } 7 | 8 | @media screen and (max-width: 699px) { 9 | body { padding: 20px 5px } 10 | h1.title { text-align: left } 11 | } 12 | 13 | h1 { 14 | font-size: 250%; 15 | border-bottom: 3px solid #449977; 16 | } 17 | 18 | h2 { 19 | font-size: 140%; 20 | border-bottom: 1px solid #449977; 21 | } 22 | 23 | h3 { 24 | font-size: 110%; 25 | } 26 | 27 | code { 28 | font-size: 1.2em; 29 | } 30 | 31 | p.news { 32 | text-indent: -3em; 33 | padding-left: 3em; 34 | } 35 | 36 | pre.code { 37 | margin: 0 16px; 38 | padding: 7px; 39 | border: 1px solid #99CCBB; 40 | } 41 | 42 | p.def { 43 | margin-top: 1.5em; 44 | font-family: courier; 45 | } 46 | 47 | p.def span { 48 | color: #555555; 49 | font-weight: bold; 50 | font-family: tahoma, arial, sans-serif; 51 | font-size: .8em; 52 | } 53 | 54 | .desc { 55 | margin-left: 1em; 56 | } 57 | 58 | thead { 59 | font-weight: bold; 60 | } 61 | 62 | table { 63 | border-collapse: collapse; 64 | } 65 | 66 | tr + tr { 67 | border-top: 1px solid #88BB99; 68 | } 69 | 70 | thead tr { 71 | border-bottom: 2px solid #88BB99; 72 | } 73 | 74 | td + td, th + th { 75 | border-left: 2px solid #88BB99; 76 | } 77 | 78 | th { 79 | text-align: left; 80 | padding: 2px 5px; 81 | } 82 | 83 | td { 84 | padding: 2px 5px; 85 | vertical-align: top; 86 | } 87 | 88 | a:link { 89 | color: #3333AA; 90 | text-decoration: none; 91 | } 92 | 93 | a:visited { 94 | color: #773377; 95 | text-decoration: none; 96 | } 97 | 98 | a:hover { 99 | text-decoration: underline; 100 | } 101 | 102 | ul.symbol-index { 103 | font-family: monospace; 104 | font-size: 1.2em; 105 | } 106 | -------------------------------------------------------------------------------- /cl-postgres/strings-ascii.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES; -*- 2 | (in-package :cl-postgres) 3 | 4 | (defparameter *client-encoding* "SQL_ASCII") 5 | 6 | (declaim (inline enc-byte-length)) 7 | (defun enc-byte-length (sequence) 8 | (length sequence)) 9 | 10 | (declaim (ftype (function (t &key (:null-terminated t) 11 | (:byte-length unsigned-byte)) 12 | string) 13 | enc-read-string)) 14 | (defun enc-read-string (stream &key null-terminated byte-length) 15 | "Read an ascii-string from a byte stream, until either a null byte 16 | is reached or the given amount of bytes have been read." 17 | (declare (type stream stream) 18 | (type (or null fixnum) byte-length) 19 | #.*optimize*) 20 | (let ((bytes-read 0) 21 | (string (make-array 64 :element-type 'character 22 | :adjustable t :fill-pointer 0))) 23 | (loop 24 | (when (and byte-length (>= bytes-read byte-length)) 25 | (return)) 26 | (let ((next-char (read-byte stream))) 27 | (incf bytes-read) 28 | (when (and null-terminated (eq next-char 0)) 29 | (return)) 30 | (vector-push-extend (code-char next-char) string))) 31 | string)) 32 | 33 | (declaim (ftype (function (string) (simple-array (unsigned-byte 8) (*))) 34 | enc-string-bytes)) 35 | (defun enc-string-bytes (string) 36 | "Convert an ascii string to an array of octets." 37 | (map '(simple-array (unsigned-byte 8) (*)) 'char-code string)) 38 | 39 | (defun enc-write-string (string stream) 40 | "Write an ascii string to a stream." 41 | (declare (type stream stream) 42 | (type string string) 43 | #.*optimize*) 44 | (loop :for char :of-type character :across string 45 | :do (write-byte (char-code char) stream))) 46 | -------------------------------------------------------------------------------- /cl-postgres/config.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES; -*- 2 | (in-package :cl-postgres) 3 | 4 | (defparameter *silently-truncate-ratios* t "Given a ratio, a stream and a 5 | digital-length-limit, if *silently-truncate-ratios* is true, 6 | will return a potentially truncated ratio. If false and the digital-length-limit 7 | is reached, it will throw an error noting the loss of precision and offering to 8 | continue or reset *silently-truncate-ratios* to true. Code contributed by 9 | Attila Lendvai.") 10 | 11 | (defparameter *query-log* nil "When debugging, it can be helpful to inspect the 12 | queries that are being sent to the database. Set this variable to an output 13 | stream value (*standard-output*, for example) to have CL-postgres log every 14 | query it makes.") 15 | (defparameter *query-callback* 'log-query "When profiling or debugging, the 16 | *query-log* may not give enough information, or reparsing its output may not be 17 | feasible. This variable may be set to a designator of function taking two 18 | arguments. This function will be then called after every query, and receive 19 | query string and internal time units (as in (CL:GET-INTERNAL-REAL-TIME)) spent 20 | in query as its arguments. 21 | 22 | Default value of this variable is 'LOG-QUERY, which takes care of *QUERY-LOG* 23 | processing. If you provide custom query callback and wish to keep *QUERY-LOG* 24 | functionality, you will have to call LOG-QUERY from your callback function") 25 | 26 | (defvar *retry-connect-times* 5 27 | "How many times do we try to connect again. Borrowed from pgloader") 28 | 29 | (defvar *retry-connect-delay* 0.5 30 | "How many seconds to wait before trying to connect again. Borrowed from 31 | pgloader") 32 | 33 | (defparameter *on-evidence-of-man-in-the-middle-attack* :error 34 | "If Postmodern sees evidence of an attempted man-in-the-middle attack, 35 | what should Postmodern do? Acceptable values are :error, :warn or :ignore") 36 | -------------------------------------------------------------------------------- /postmodern/tests/test-execute-file.sql: -------------------------------------------------------------------------------- 1 | drop table if exists company_employees; 2 | 3 | create table company_employees( 4 | id bigserial primary key not null, 5 | name text not null, 6 | age int not null, 7 | address char(50), 8 | include_file text, 9 | join_date date 10 | ); 11 | -- ;Test comment 1;; 12 | insert into company_employees (id,name,age,address,include_file,join_date) values (1, 'Paul', 32, 'London', 'test-execute-file','2001-07-13'); 13 | insert into company_employees (id,name,age,address,include_file,join_date) values (2, 'Ziad', 32, 'Beirut', 'test-execute-file','2003-03-13'); 14 | /* test' comment 2 15 | with multiple lines 16 | --*/ 17 | /* 18 | /* 19 | 20 | */ 21 | ***/ 22 | --\i ./postmodern/tests/tef-11.sql 23 | \i tef-1.sql -- an included file, will need to use fallback to find it 24 | \ir tef-6.sql -- an included file using file location relative to this file 25 | \ir tef-3.sql 26 | \i sub1/tef-4.sql 27 | \ir ./sub1/tef-5.sql 28 | 29 | insert into company_employees (id,name,age,address,include_file,join_date) values (3, 'John', 32, 'Toronto', 'test-execute-file','2005-07-13'); 30 | -- Yet another comments 31 | insert into company_employees (id,name,age,address,include_file,join_date) values (4, 'Yasmin', 32, 'Mumbai', 'test-execute-file','2007-03-13'); 32 | /* ;test comment 3 (asterisk in /second/ line of multiline comment) 33 | * with multiple lines;; 34 | */ 35 | insert into company_employees (id,name,age,address,include_file,join_date) values (5, 'Susan', 32, 'Vancouver', 'test-execute-file','2009-07-13'); 36 | /* ;test comment 4 (asterisk in second line of multiline comment) 37 | *** with multiple lines;; 38 | /* test' comment 4-1 39 | with multiple lines 40 | /***/ 41 | */ 42 | * did I say something wrong? 43 | --*/ 44 | insert into company_employees (id,name,age,address,include_file,join_date) values (6, 'Johanna', 32, 'Berlin', 'test-execute-file','2011-03-13'); 45 | -------------------------------------------------------------------------------- /doc/s-sql-m.org: -------------------------------------------------------------------------------- 1 | #+TITLE: S-SQL Examples M 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | * [[file:s-sql-examples.org][S-SQL Examples Home Page]] 8 | | [[file:s-sql-a.org][A]]| [[file:s-sql-b.org][B]]| [[file:s-sql-c.org][C]]| [[file:s-sql-d.org][D]]| [[file:s-sql-e.org][E]]| [[file:s-sql-f.org][F]]| [[file:s-sql-g.org][G]]| [[file:s-sql-h.org][H]]| [[file:s-sql-i.org][I]]| [[file:s-sql-j.org][J]]| [[file:s-sql-k.org][K]]| [[file:s-sql-l.org][L]]| [[file:s-sql-m.org][M]]| [[file:s-sql-n.org][N]]| [[file:s-sql-o.org][O]]| [[file:s-sql-p.org][P]]| [[file:s-sql-r.org][R]]| [[file:s-sql-s.org][S]]| [[file:s-sql-t.org][T]]| [[file:s-sql-u.org][U]]| [[file:s-sql-v.org][V]]| [[file:s-sql-w.org][W]]| [[file:s-sql-special-characters.org][Special Characters]] | [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]]| 9 | 10 | * Many to Many Calls 11 | :PROPERTIES: 12 | :CUSTOM_ID: many-to-many 13 | :END: 14 | Many database records are linked in a many to many relationship with other tables or records. Consider the following query: 15 | #+begin_src lisp 16 | (query "select countries.id, countries.name, events.name as event 17 | from countries,events,countries_events 18 | where country_id=countries.id 19 | and events.id=event_id 20 | and events.id=$1" 21 | 29) 22 | #+end_src 23 | 24 | This can be rephrased in s-sql as: 25 | #+begin_src lisp 26 | (query (:select 'countries.id 'countries.name 27 | (:as 'events.name 'event) 28 | :from 'countries 'events 'countries_events 29 | :where (:and (:= 'country_id 'countries.id) 30 | (:= 'events.id 'event_id) 31 | (:= 'events.id '$1))) 32 | 29) 33 | #+end_src 34 | -------------------------------------------------------------------------------- /doc/s-sql-b.org: -------------------------------------------------------------------------------- 1 | #+TITLE: S-SQL Examples B 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | * [[file:s-sql-examples.org][S-SQL Examples Home Page]] 8 | | [[file:s-sql-a.org][A]]| [[file:s-sql-b.org][B]]| [[file:s-sql-c.org][C]]| [[file:s-sql-d.org][D]]| [[file:s-sql-e.org][E]]| [[file:s-sql-f.org][F]]| [[file:s-sql-g.org][G]]| [[file:s-sql-h.org][H]]| [[file:s-sql-i.org][I]]| [[file:s-sql-j.org][J]]| [[file:s-sql-k.org][K]]| [[file:s-sql-l.org][L]]| [[file:s-sql-m.org][M]]| [[file:s-sql-n.org][N]]| [[file:s-sql-o.org][O]]| [[file:s-sql-p.org][P]]| [[file:s-sql-r.org][R]]| [[file:s-sql-s.org][S]]| [[file:s-sql-t.org][T]]| [[file:s-sql-u.org][U]]| [[file:s-sql-v.org][V]]| [[file:s-sql-w.org][W]]| [[file:s-sql-special-characters.org][Special Characters]] | [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]]| 9 | 10 | 11 | * Between 12 | :PROPERTIES: 13 | :CUSTOM_ID: between 14 | :END: 15 | #+begin_src lisp 16 | (query (:select 'name 17 | :from 'countries 18 | :where (:between 'latitude -10 10)) 19 | :column) 20 | 21 | ("Solomon Islands" "Benin" "Brazil" "Brunei" "Cameroon" "Congo" "Costa Rica" "Ecuador" "Ethiopia" "Gabon" "Ghana" "Guyana" "Indonesia" "Ivory Coast" "Kenya" "Kiribati" "Liberia" "Malaysia" "Maldives" "Marshall Islands" "Micronesia" "Nauru" "Nigeria" "Palau" "Panama" "Papua New Guinea" "Peru" "Rwanda" "Seychelles" "Sierra Leone" "Singapore" "None" "Sri Lanka" "Suriname" "Tanzania" "East Timor" "Togo" "Tuvalu" "Uganda" "Venezuela" "Colombia") 22 | #+end_src 23 | 24 | * Boolean Operators (:is-true, :is-false, :is-null) 25 | :PROPERTIES: 26 | :CUSTOM_ID: boolean 27 | :END: 28 | ** :Is-True 29 | #+begin_src lisp 30 | (query (:select '* :from 'boolean-test :where (:is-true 'a))) 31 | #+end_src 32 | ** :Is-False 33 | #+begin_src lisp 34 | (sql (:select '* :from 'table1 :where (:is-false 'col))) 35 | #+end_src 36 | *** :Is-NULL 37 | #+begin_src lisp 38 | (:select '* :from 'table1 :where (:is-false 'col)) 39 | #+end_src 40 | -------------------------------------------------------------------------------- /doc/s-sql-prepared-statements.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Prepared Statements 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | * [[file:s-sql-examples.org][S-SQL Examples Home Page]] 8 | | [[file:s-sql-a.org][A]]| [[file:s-sql-b.org][B]]| [[file:s-sql-c.org][C]]| [[file:s-sql-d.org][D]]| [[file:s-sql-e.org][E]]| [[file:s-sql-f.org][F]]| [[file:s-sql-g.org][G]]| [[file:s-sql-h.org][H]]| [[file:s-sql-i.org][I]]| [[file:s-sql-j.org][J]]| [[file:s-sql-k.org][K]]| [[file:s-sql-l.org][L]]| [[file:s-sql-m.org][M]]| [[file:s-sql-n.org][N]]| [[file:s-sql-o.org][O]]| [[file:s-sql-p.org][P]]| [[file:s-sql-r.org][R]]| [[file:s-sql-s.org][S]]| [[file:s-sql-t.org][T]]| [[file:s-sql-u.org][U]]| [[file:s-sql-v.org][V]]| [[file:s-sql-w.org][W]]| [[file:s-sql-special-characters.org][Special Characters]] | [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]]| 9 | 10 | * Prepared Statements 11 | :PROPERTIES: 12 | :CUSTOM_ID: prepared-statements 13 | :END: 14 | The general rule of thumb on deciding whether to use prepared statements, is to use them unless you have sufficient reason not to. Prepared Statements are compiled before execution therefore lending to better performance, and increased security against SQL injection as the database server takes care of the encoding of special characters. 15 | 16 | Preventing SQL injection attacks. This basically means automated sanitizing of inputs from external sources (web browser is external!) which are going to be saved to the database. 17 | Batch processing. If you have a lot of data to enter into/modify in/remove from database at once, prepared statements can be used for that. In this case, prepared statements optimize away most of the overhead of such operations and allows you to write fast database batch code. 18 | #+begin_src lisp 19 | (defprepared sovereign-of 20 | (:select 'sovereign :from 'country :where (:= 'name '$1)) 21 | :single!) 22 | 23 | (sovereign-of "The Netherlands");; => "Beatrix" 24 | 25 | #+end_src 26 | The bang at the end of the :single! keyword indicates throw an error if it returns more than one. 27 | -------------------------------------------------------------------------------- /doc/s-sql-f.org: -------------------------------------------------------------------------------- 1 | #+TITLE: S-SQL Examples F 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | * [[file:s-sql-examples.org][S-SQL Examples Home Page]] 8 | | [[file:s-sql-a.org][A]]| [[file:s-sql-b.org][B]]| [[file:s-sql-c.org][C]]| [[file:s-sql-d.org][D]]| [[file:s-sql-e.org][E]]| [[file:s-sql-f.org][F]]| [[file:s-sql-g.org][G]]| [[file:s-sql-h.org][H]]| [[file:s-sql-i.org][I]]| [[file:s-sql-j.org][J]]| [[file:s-sql-k.org][K]]| [[file:s-sql-l.org][L]]| [[file:s-sql-m.org][M]]| [[file:s-sql-n.org][N]]| [[file:s-sql-o.org][O]]| [[file:s-sql-p.org][P]]| [[file:s-sql-r.org][R]]| [[file:s-sql-s.org][S]]| [[file:s-sql-t.org][T]]| [[file:s-sql-u.org][U]]| [[file:s-sql-v.org][V]]| [[file:s-sql-w.org][W]]| [[file:s-sql-special-characters.org][Special Characters]] | [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]]| 9 | 10 | * Fetch 11 | :PROPERTIES: 12 | :CUSTOM_ID: fetch 13 | :END: 14 | Fetch is a more efficient way to do pagination instead of using limit and 15 | offset. Fetch allows you to retrieve a limited set of rows, optionally offset 16 | by a specified number of rows. In order to ensure this works correctly, you 17 | should use the order-by clause. If the amount is not provided, it assumes 18 | you only want to return 1 row. 19 | https://www.postgresql.org/docs/current/sql-select.html 20 | 21 | Examples: 22 | #+BEGIN_SRC lisp 23 | (query (:fetch (:order-by (:select 'id :from 'historical-events) 'id) 5)) 24 | 25 | ((1) (2) (3) (4) (5)) 26 | 27 | (query (:fetch (:order-by (:select 'id :from 'historical-events) 'id) 5 10)) 28 | 29 | ((11) (12) (13) (14) (15)) 30 | #+END_SRC 31 | 32 | * Filter 33 | :PROPERTIES: 34 | :CUSTOM_ID: filter 35 | :END: 36 | #+BEGIN_SRC lisp 37 | (query (:select (:as (:count '* :distinct) 'unfiltered) 38 | (:as (:count '* :filter (:= 1 'bid)) 39 | 'filtered) 40 | :from 'testtable)) 41 | #+END_SRC 42 | Note that, if used, the filter must be last in the count args. If distinct 43 | is used, it must come before filter. Unlike standard sql, the word 'where' 44 | is not used inside the filter clause. E.g. 45 | #+BEGIN_SRC lisp 46 | (query (:select (:count '*) 47 | (:count '* :filter (:= 1 'bid)) 48 | 'id 49 | :from 'pbbench-history)) 50 | #+END_SRC 51 | -------------------------------------------------------------------------------- /cl-postgres/tests/test-oids.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES-TESTS; -*- 2 | (in-package :cl-postgres-tests) 3 | 4 | (def-suite :cl-postgres-oid 5 | :description "Test suite for cl-postgres" 6 | :in :cl-postgres) 7 | 8 | (in-suite :cl-postgres-oid) 9 | 10 | (test int2 11 | (is (typep 2 'cl-postgres::int2)) 12 | (is (not (typep 327682 'cl-postgres::int2)))) 13 | 14 | (test int4 15 | (is (typep 2 'cl-postgres::int4)) 16 | (is (typep 327682 'cl-postgres::int4)) 17 | (is (not (typep -2147483650 'cl-postgres::int4)))) 18 | 19 | (test int8 20 | (is (typep 2 'cl-postgres::int8)) 21 | (is (typep 327682 'cl-postgres::int8)) 22 | (is (typep -9223372036854775808 'cl-postgres::int8)) 23 | (is (not (typep -9223372036854775821 'cl-postgres::int8)))) 24 | 25 | (test uuid 26 | (is (cl-postgres::uuip-p "c73bcdcc-2669-4bf6-81d3-e4ae73fb11fd")) 27 | (is (not (cl-postgres::uuip-p "c73bcdcc-2669-4bf6-81d3-e4an73fb11fd"))) 28 | (is (cl-postgres::uuip-p "123e4567-e89b-12d3-a456-426655440000")) 29 | (is (cl-postgres::uuip-p "C73BCDCC-2669-4Bf6-81d3-E4AE73FB11FD")) 30 | (is (cl-postgres::uuip-p "c73bcdcc-2669-4bf6-81d3-e4ae73fb11fD")) 31 | (is (typep "c73bcdcc-2669-4bf6-81d3-e4ae73fb11fD" 'cl-postgres::uuid-string))) 32 | 33 | (test int64-to-vector 34 | (is (equalp (cl-postgres::int64-to-vector 92233720368547758) 35 | #(1 71 174 20 122 225 71 174))) 36 | (is (equalp (cl-postgres::int64-to-vector -9223372036854758) 37 | #(255 223 59 100 90 28 172 26)))) 38 | 39 | (test int32-to-vector 40 | (is (equalp (cl-postgres::int32-to-vector -327681) 41 | #(255 250 255 255))) 42 | (is (equalp (cl-postgres::int32-to-vector 327682) 43 | #(0 5 0 2))) 44 | (is (not (cl-postgres::int32-to-vector 21474836481)))) 45 | 46 | (test int16-to-vector 47 | (is (equalp (cl-postgres::int16-to-vector -34) 48 | #(255 222))) 49 | (is (equalp (cl-postgres::int16-to-vector 32767) 50 | #(127 255))) 51 | (is (equalp (cl-postgres::int16-to-vector -32767) 52 | #(128 1)))) 53 | 54 | (test param-to-oid 55 | (is (equal (cl-postgres:param-to-oid 32) 56 | 21)) 57 | (is (equal (cl-postgres:param-to-oid 144220) 58 | 23)) 59 | (is (equal (cl-postgres:param-to-oid "abba") 60 | 0)) 61 | (is (equal (cl-postgres:param-to-oid :NULL) 62 | 0)) 63 | (is (equal (cl-postgres:param-to-oid nil) 64 | 16))) 65 | -------------------------------------------------------------------------------- /doc/s-sql-v.org: -------------------------------------------------------------------------------- 1 | #+TITLE: S-SQL Examples V 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | * [[file:s-sql-examples.org][S-SQL Examples Home Page]] 8 | | [[file:s-sql-a.org][A]]| [[file:s-sql-b.org][B]]| [[file:s-sql-c.org][C]]| [[file:s-sql-d.org][D]]| [[file:s-sql-e.org][E]]| [[file:s-sql-f.org][F]]| [[file:s-sql-g.org][G]]| [[file:s-sql-h.org][H]]| [[file:s-sql-i.org][I]]| [[file:s-sql-j.org][J]]| [[file:s-sql-k.org][K]]| [[file:s-sql-l.org][L]]| [[file:s-sql-m.org][M]]| [[file:s-sql-n.org][N]]| [[file:s-sql-o.org][O]]| [[file:s-sql-p.org][P]]| [[file:s-sql-r.org][R]]| [[file:s-sql-s.org][S]]| [[file:s-sql-t.org][T]]| [[file:s-sql-u.org][U]]| [[file:s-sql-v.org][V]]| [[file:s-sql-w.org][W]]| [[file:s-sql-special-characters.org][Special Characters]] | [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]]| 9 | 10 | * Variable Parameters 11 | :PROPERTIES: 12 | :CUSTOM_ID: variable-parameters 13 | :END: 14 | You can use variables in s-sql statements. For example: 15 | #+begin_src lisp 16 | (let ((column 'latitude) (table 'countries)) 17 | (query (:select column :from table))) 18 | 19 | (let ((select 'countries.name)) 20 | (query (:select select 21 | :from 'countries 'regions 22 | :where (:and 23 | (:or (:= 'regions.name '$1) 24 | (:= 'regions.name '$2)) 25 | (:= 'regions.id 'countries.region-id))))) 26 | #+end_src 27 | Notice that the variable values were quoted. If you used strings, the string would be escaped and Postgresql would give you a syntax error. 28 | 29 | * View (:create-view) 30 | :PROPERTIES: 31 | :CUSTOM_ID: create-view 32 | :END: 33 | Create-view will accept quoted values, strings or keywords for the name of the view you are creating. Hyphens will be automatically be converted to underscores. 34 | #+begin_src lisp 35 | (query (:create-view 'quagmire (:select 'id 'name :from 'employee))) 36 | 37 | (query (:create-view :quagmire (:select 'id 'name :from 'employee))) 38 | 39 | (query (:create-view "quagmire" (:select 'id 'name :from 'employee))) 40 | 41 | (query (:create-view 'quagmire-hollow (:select 'id 'name :from 'employee))) 42 | 43 | (query (:create-view "quagmire-hollow" (:select 'id 'name :from 'employee))) 44 | 45 | #+end_src 46 | -------------------------------------------------------------------------------- /doc/s-sql-g.org: -------------------------------------------------------------------------------- 1 | #+TITLE: S-SQL Examples G 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | * [[file:s-sql-examples.org][S-SQL Examples Home Page]] 8 | | [[file:s-sql-a.org][A]]| [[file:s-sql-b.org][B]]| [[file:s-sql-c.org][C]]| [[file:s-sql-d.org][D]]| [[file:s-sql-e.org][E]]| [[file:s-sql-f.org][F]]| [[file:s-sql-g.org][G]]| [[file:s-sql-h.org][H]]| [[file:s-sql-i.org][I]]| [[file:s-sql-j.org][J]]| [[file:s-sql-k.org][K]]| [[file:s-sql-l.org][L]]| [[file:s-sql-m.org][M]]| [[file:s-sql-n.org][N]]| [[file:s-sql-o.org][O]]| [[file:s-sql-p.org][P]]| [[file:s-sql-r.org][R]]| [[file:s-sql-s.org][S]]| [[file:s-sql-t.org][T]]| [[file:s-sql-u.org][U]]| [[file:s-sql-v.org][V]]| [[file:s-sql-w.org][W]]| [[file:s-sql-special-characters.org][Special Characters]] | [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]]| 9 | 10 | * Generate-Series 11 | :PROPERTIES: 12 | :CUSTOM_ID: generate-series 13 | :END: 14 | #+begin_src lisp 15 | (query (:select 'x (:generate-series 0 'x) 16 | :from (:as (:values (:set 0) (:set 1) (:set 2)) 17 | (:t 'x)))) 18 | 19 | '((0 0) (1 0) (1 1) (2 0) (2 1) (2 2)) 20 | #+end_src 21 | * Group-By 22 | :PROPERTIES: 23 | :CUSTOM_ID: group-by 24 | :END: 25 | The following two examples use group-by. The first determines the number of countries in my table in each region and returns the list in region name order. The second determines the country with the maximum latitude for each region. 26 | 27 | #+begin_src lisp 28 | (query (:order-by 29 | (:select 'regions.name 30 | (:count 'regions.name) 31 | :from 'countries 'regions 32 | :where (:= 'regions.id 'countries.region-id) 33 | :group-by 'regions.name) 34 | 'regions.name)) 35 | 36 | (("Africa" 38) ("Asia" 27) ("Caribbean" 15) ("Central America" 6)("Central Asia" 5) ("Eastern Europe" 11) 37 | ("Middle East" 13) ("North America" 5)("Pacific" 24) ("South America" 14) 38 | ("Western Europe" 39)) 39 | 40 | (query (:select 'regions.name (:max 'latitude) 41 | :from 'countries 'regions 42 | :where (:= 'regions.id 'region-id) 43 | :group-by 'regions.name)) 44 | 45 | (("Pacific" 378/25) ("Western Europe" 65) ("Asia" 46) ("Central Asia" 48)("Caribbean" 483/20) ("Eastern Europe" 60) 46 | ("North America" 72) ("Middle East" 39)("Central America" 343/20) ("Africa" 34) ("South America" 15)) 47 | #+end_src 48 | -------------------------------------------------------------------------------- /cl-postgres/tests/tests-saslprep.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES-TESTS; -*- 2 | (in-package :cl-postgres-tests) 3 | 4 | (def-suite :cl-postgres-saslprep 5 | :description "Saslpre Test suite for cl-postgres" 6 | :in :cl-postgres) 7 | 8 | (in-suite :cl-postgres-saslprep) 9 | 10 | (test bad-char-error) 11 | 12 | (test char-prinable-ascii-p 13 | (is (cl-postgres::char-printable-ascii-p (code-char 45))) 14 | (is (not (cl-postgres::char-printable-ascii-p (code-char 16)))) 15 | (is (not (cl-postgres::char-printable-ascii-p (code-char 163))))) 16 | 17 | (test string-printable-ascii-p 18 | (is (not (string-printable-ascii-p "eleveÖn"))) 19 | (is (string-printable-ascii-p "eleven"))) 20 | 21 | (test code-point-printable-ascii-p 22 | (is (cl-postgres::code-point-printable-ascii-p 45)) 23 | (is (not (cl-postgres::code-point-printable-ascii-p 16))) 24 | (is (not (cl-postgres::code-point-printable-ascii-p 163)))) 25 | 26 | (test char-mapped-to-nothing-p 27 | (is (not (cl-postgres::char-mapped-to-nothing-p (code-char 214)))) 28 | (is (cl-postgres::char-mapped-to-nothing-p (code-char 8203)))) 29 | 30 | (test char-mapped-to-space-p 31 | (is (not (cl-postgres::char-mapped-to-space-p (code-char 214)))) 32 | (is (cl-postgres::char-mapped-to-space-p (code-char 8203))) 33 | (is (cl-postgres::char-mapped-to-space-p (code-char 5760)))) 34 | 35 | (test string-mapped-to-nothing-p 36 | (is (equal (coerce (vector #\a (code-char 65025) #\c #\d) 'string) 37 | "a︁cd")) 38 | (is (equal (cl-postgres::string-mapped-to-nothing 39 | (coerce (vector #\a (code-char 65025) #\c #\d) 'string)) 40 | "acd"))) 41 | 42 | (test string-mapped-to-space-p 43 | (is (equal (cl-postgres::string-mapped-to-nothing 44 | (coerce (vector #\a (code-char 8193) #\c #\d) 'string)) 45 | "a cd")) 46 | (is (equal (cl-postgres::string-mapped-to-space 47 | (coerce (vector #\a (code-char 8193) #\c #\d) 'string)) 48 | "a cd")) 49 | (is (not (equal (cl-postgres::string-mapped-to-nothing 50 | (coerce (vector #\a (code-char 8193) #\c #\d) 'string)) 51 | (cl-postgres::string-mapped-to-space 52 | (coerce (vector #\a (code-char 8193) #\c #\d) 'string))))) 53 | (is (not (equal (coerce (vector #\a (code-char 8193) #\c #\d) 'string) 54 | (cl-postgres::string-mapped-to-space 55 | (coerce (vector #\a (code-char 8193) #\c #\d) 'string)))))) 56 | 57 | (test saslprep-normalize 58 | (is (equal (cl-postgres::saslprep-normalize 59 | (coerce (vector #\a (code-char 214) 60 | (code-char 8193) #\c (code-char 8203) 61 | (code-char 65025) 62 | (code-char 1214) #\d) 63 | 'string)) 64 | "aÖ cҾd"))) 65 | -------------------------------------------------------------------------------- /cl-postgres/tests/simple-date-tests.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES-SIMPLE-DATE-TESTS; -*- 2 | (defpackage :cl-postgres-simple-date-tests 3 | (:use :common-lisp :fiveam :cl-postgres :cl-postgres-error :simple-date) 4 | (:import-from #:cl-postgres-tests 5 | #:prompt-connection)) 6 | 7 | (in-package :cl-postgres-simple-date-tests) 8 | 9 | (defmacro with-simple-date-readtable (&body body) 10 | `(let ((*sql-readtable* (simple-date-cl-postgres-glue:simple-date-sql-readtable))) 11 | ,@body)) 12 | 13 | (defmacro with-test-connection (&body body) 14 | `(let ((connection (apply 'open-database (prompt-connection)))) 15 | (with-simple-date-readtable 16 | (unwind-protect (progn ,@body) 17 | (close-database connection))))) 18 | 19 | (def-suite :cl-postgres-simple-date) 20 | (in-suite :cl-postgres-simple-date) 21 | 22 | (test row-timestamp-without-time-zone-binary 23 | (with-test-connection 24 | (with-binary-row-values 25 | (is (time= (caaar (exec-query connection "select row('2010-04-05 14:42:21.500'::timestamp without time zone)" 26 | 'list-row-reader)) 27 | (encode-timestamp 2010 4 5 14 42 21 500)))))) 28 | 29 | (test row-timestamp-with-time-zone-binary 30 | (with-test-connection 31 | (exec-query connection "set time zone 'GMT'") 32 | (with-binary-row-values 33 | (destructuring-bind (gmt pdt) 34 | (caar 35 | (exec-query 36 | connection 37 | (concatenate 'string 38 | "select row('2010-04-05 14:42:21.500'::timestamp with time zone at time zone 'GMT', " 39 | " '2010-04-05 14:42:21.500'::timestamp with time zone at time zone 'PST')") 40 | 'list-row-reader)) 41 | (is (time= gmt (encode-timestamp 2010 4 5 14 42 21 500))) 42 | (is (time= pdt (encode-timestamp 2010 4 5 6 42 21 500))))))) 43 | 44 | (test row-timestamp-without-time-zone-array-binary 45 | (with-test-connection 46 | (with-binary-row-values 47 | (is (time= (elt (caaar (exec-query connection "select row(ARRAY['2010-04-05 14:42:21.500'::timestamp without time zone])" 48 | 'list-row-reader)) 0) 49 | (encode-timestamp 2010 4 5 14 42 21 500)))))) 50 | 51 | (test row-time-binary 52 | (with-test-connection 53 | (with-binary-row-values 54 | (is (time= (caaar (exec-query connection "select row('05:00'::time)" 55 | 'list-row-reader)) 56 | (encode-time-of-day 5 0)))))) 57 | 58 | (test row-timestamp-binary 59 | (with-test-connection 60 | (with-binary-row-values 61 | (is (time= (caaar (exec-query connection "select row('2010-04-05 14:42:21.500'::timestamp)" 62 | 'list-row-reader)) 63 | (encode-timestamp 2010 4 5 14 42 21 500)))))) 64 | -------------------------------------------------------------------------------- /doc/s-sql-n.org: -------------------------------------------------------------------------------- 1 | #+TITLE: S-SQL Examples N 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | * [[file:s-sql-examples.org][S-SQL Examples Home Page]] 8 | | [[file:s-sql-a.org][A]]| [[file:s-sql-b.org][B]]| [[file:s-sql-c.org][C]]| [[file:s-sql-d.org][D]]| [[file:s-sql-e.org][E]]| [[file:s-sql-f.org][F]]| [[file:s-sql-g.org][G]]| [[file:s-sql-h.org][H]]| [[file:s-sql-i.org][I]]| [[file:s-sql-j.org][J]]| [[file:s-sql-k.org][K]]| [[file:s-sql-l.org][L]]| [[file:s-sql-m.org][M]]| [[file:s-sql-n.org][N]]| [[file:s-sql-o.org][O]]| [[file:s-sql-p.org][P]]| [[file:s-sql-r.org][R]]| [[file:s-sql-s.org][S]]| [[file:s-sql-t.org][T]]| [[file:s-sql-u.org][U]]| [[file:s-sql-v.org][V]]| [[file:s-sql-w.org][W]]| [[file:s-sql-special-characters.org][Special Characters]] | [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]]| 9 | 10 | * Null 11 | :PROPERTIES: 12 | :CUSTOM_ID: null 13 | :END: 14 | I have a few "groups of countries" in a countries table that should not have a latitude such as the EU. As a result so I would expect to be able to find them by looking for records with null in the latitude field. The second example is similar, looking for any countries with either a null latitude or null longitude. In my particular database, the only "country" matching that is the EU. 15 | #+begin_src lisp 16 | (query (:select 'id 'name 17 | :from 'countries 18 | :where (:is-null 'latitude))) 19 | 20 | ((6 "EU")) 21 | 22 | (query (:select 'name :from 'countries 23 | :where (:or (:is-null 'latitude) 24 | (:is-null 'longitude)))) 25 | 26 | (("EU")) 27 | #+end_src 28 | 29 | 30 | The next gives the number of records (without using the sql count operator) from countries where the currency field was both not null and did not consist of just a blank string. 31 | #+begin_src lisp 32 | (length 33 | (query (:select 'id 34 | :from 'countries 35 | :where (:and (:not (:= "" 'countries.currency)) 36 | (:not (:is-null 'countries.currency)))))) 37 | #+end_src 38 | 39 | * Not-Null 40 | :PROPERTIES: 41 | :CUSTOM_ID: not-null 42 | :END: 43 | Similarly, you can use :not-null 44 | #+begin_src lisp 45 | (query (:select 'ta :from 'a :where (:not-null 'ta))) 46 | #+end_src 47 | 48 | * Nullif 49 | :PROPERTIES: 50 | :CUSTOM_ID: nullif 51 | :END: 52 | Suppose you want to perform division, but do not know if the divisor could be zero. The following will handle that and return 0 in that case. 53 | #+begin_src lisp 54 | (let ((divisor 3)) 55 | (query (:select (:coalesce (:/ 12 (:nullif divisor 0 )) 0)) 56 | :single)) 57 | 58 | (let ((divisor 0)) 59 | (query (:select (:coalesce (:/ 12 (:nullif divisor 0 )) 0)) 60 | :single)) 61 | #+end_src 62 | -------------------------------------------------------------------------------- /postmodern/tests/test-postmodern-binary.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: POSTMODERN-TESTS; -*- 2 | (in-package :postmodern-tests) 3 | 4 | (def-suite :postmodern-binary 5 | :description "Dao suite for postmodern" 6 | :in :postmodern) 7 | 8 | (in-suite :postmodern-binary) 9 | 10 | (test binary-parameters 11 | (with-binary-test-connection 12 | (query "create table countries (id serial not null, iso2 text not null, 13 | latitude numeric(9, 6) not null, 14 | longitude numeric(9, 6) not null, 15 | name text not null, 16 | population integer not null)" 17 | 'list-row-reader) 18 | (query "insert into countries (iso2, latitude, longitude, name, population) 19 | values ('AD', 42.546245, 1.601554, 'Andorra', 77142), 20 | ('AE', 23.424076, 53.847818, 'UAE', 9770529), 21 | ('AF', 33.93911, 67.709953, 'Afghanistan', 38041754), 22 | ('AG', 17.060816, -61.796428, 'Antigua and Barbuda', 97118), 23 | ('AI', 18.220554, -63.068615, 'Anguilla', 13869), 24 | ('AL', 41.153332, 20.168331, 'Albania', 2880917), 25 | ('AM', 40.069099, 45.038189, 'Armenia', 2957731), 26 | ('AW', 12.52111, -69.968338, 'Aruba', 106314), 27 | ('AO', -11.202692, 17.873887, 'Angola', 31825295), 28 | ('AR', -38.416097, -63.616672, 'Argentina', 44780677), 29 | ('AS', -14.270972, -170.132217, 'American Samoa', 55312), 30 | ('AT', 47.516231, 14.550072, 'Austria', 8955102), 31 | ('AU', -25.274398, 133.775136, 'Australia', 25203198)" 32 | 'list-row-reader) 33 | (is (equal (query "select $1" 132 :single) 34 | 132)) 35 | (is (equal (query "select $1, $2" "10" 20) 36 | '(("10" 20)))) 37 | (is (equal (query "select name from countries where population = $1" 97118 :single) 38 | "Antigua and Barbuda")) 39 | (is (equal (query 40 | "select name from countries where population < $1 and population > $2" 41 | 3000000 100000) 42 | '(("Albania") ("Armenia") ("Aruba")))) 43 | (is (equal (query 44 | "select name from countries where latitude < $1 and latitude > $2" 45 | 30 10) 46 | '(("UAE") ("Antigua and Barbuda") ("Anguilla") ("Aruba")))) 47 | (is (equal (query "select $1, $2" "10" (/ 1 3.0)) 48 | '(("10" 0.33333334)))) 49 | (is (equal (query "select $1, $2" "10" (/ 1 3.0d0)) 50 | '(("10" 0.3333333333333333d0)))) 51 | (is (equal (query "select $1, $2" "10" t) 52 | '(("10" T)))) 53 | (is (equal (query "select $1, $2" "10" nil) 54 | '(("10" NIL)))) 55 | (drop-table 'countries))) 56 | -------------------------------------------------------------------------------- /s-sql/config.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: S-SQL; -*- 2 | (in-package :s-sql) 3 | 4 | ;; Converting between symbols and SQL strings. 5 | 6 | (defparameter *postgres-reserved-words* 7 | (let ((words (make-hash-table :test 'equal))) 8 | (dolist (word '("all" "analyse" "analyze" "and" "any" "array" "as" "asc" 9 | "asymmetric" "authorization" "between" "binary" "both" 10 | "case" "cast" "check" "collate" "column" "concurrently" 11 | "constraint" "create" "cross" "current-catalog" 12 | "current-date" "current-role" "current-schema" 13 | "current-time" "current-timestamp" "current-user" "default" 14 | "deferrable" "desc" "distinct" "do" "else" "end" "except" 15 | "false" "fetch" "filter" "for" "foreign" "freeze" "from" 16 | "full" "grant" "group" "having" "ilike" "in" "initially" 17 | "inner" "intersect" "into" "is" "isnull" "join" "lateral" 18 | "leading" "left" "like" "limit" "localtime" "localtimestamp" 19 | "natural" "new" "not" "notnull" "nowait" "null" "off" 20 | "offset" "old" "on" "only" "or" "order" "outer" "overlaps" 21 | "placing" "primary" "references" "returning" "right" 22 | "select" "session-user" "Share" "similar" "some" "symmetric" 23 | "table" "then" "to" "trailing" "true" "union" "unique" 24 | "user" "using" "variadic" "verbose" "when" "where" "window" 25 | "with")) 26 | (setf (gethash word words) t)) 27 | words) 28 | "A set of all PostgreSQL's reserved words, for automatic escaping. Probably 29 | not a good idea to use these words as identifiers anyway.") 30 | 31 | (defparameter *escape-sql-names-p* :auto 32 | "Determines whether double quotes are added around column, table, and ** 33 | function names in queries. Valid values: 34 | 35 | - T, in which case every name is escaped, 36 | - NIL, in which case no name is escaped, 37 | - :auto, which causes only reserved words to be escaped, or. 38 | - :literal which is the same as :auto except it has added consequence in 39 | to-sql-name (see below). 40 | 41 | The default value is :auto. 42 | 43 | Be careful when binding this with let and such ― since a lot of SQL compilation 44 | tends to happen at compile-time, the result might not be what you expect. Mixed 45 | case sensitivity is not currently well supported. Postgresql itself will 46 | downcase unquoted identifiers. This will be revisited in the future if 47 | requested.") 48 | 49 | (defvar *downcase-symbols* t 50 | "When converting symbols to strings, whether to downcase the symbols is set 51 | here. The default is to downcase symbols.") 52 | 53 | (defparameter *standard-sql-strings* nil 54 | "Indicate whether S-SQL will use standard SQL strings (just use '' 55 | for #\'), or backslash-style escaping. Setting this to NIL is always 56 | safe, but when the server is configured to allow standard 57 | strings (parameter 'standard_conforming_strings' is 'on'), the noise 58 | in queries can be reduced by setting this to T.") 59 | -------------------------------------------------------------------------------- /doc/s-sql-examples.org: -------------------------------------------------------------------------------- 1 | #+TITLE: S-SQL Examples 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | * S-SQL examples 8 | :PROPERTIES: 9 | :CUSTOM_ID: s-sql-examples 10 | :END: 11 | | [[file:s-sql-a.org][A]]| [[file:s-sql-b.org][B]]| [[file:s-sql-c.org][C]]| [[file:s-sql-d.org][D]]| [[file:s-sql-e.org][E]]| [[file:s-sql-f.org][F]]| [[file:s-sql-g.org][G]]| [[file:s-sql-h.org][H]]| [[file:s-sql-i.org][I]]| [[file:s-sql-j.org][J]]| [[file:s-sql-k.org][K]]| [[file:s-sql-l.org][L]]| [[file:s-sql-m.org][M]]| [[file:s-sql-n.org][N]]| [[file:s-sql-o.org][O]]| [[file:s-sql-p.org][P]]| [[file:s-sql-r.org][R]]| [[file:s-sql-s.org][S]]| [[file:s-sql-t.org][T]]| [[file:s-sql-u.org][U]]| [[file:s-sql-v.org][V]]| [[file:s-sql-w.org][W]]| [[file:s-sql-special-characters.org][Special Characters]] | [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]]| 12 | 13 | - [[file:intro-to-s-sql.org][Intro to S-SQL]] 14 | - [[file:s-sql-a.org][a (alter-table, and, analyze, any and any*, as or alias, avg)]] 15 | - [[file:s-sql-b.org][b (Between, Boolean Operators)]] 16 | - [[file:s-sql-c.org][c (call, case, cast, coalesce, constraints, count, create-composite-types create-index, create-table)]] 17 | - [[file:s-sql-d.org][d (data types (numbers and timestamps), delete, desc, distinct, distinct-on, doquery)]] 18 | - [[file:s-sql-e.org][e (enum, except, exists, extract)]] 19 | - [[file:s-sql-f.org][f (fetch, filter)]] 20 | - [[file:s-sql-g.org][g (generate-series, group-by)]] 21 | - [[file:s-sql-h.org][h (having)]] 22 | - [[file:s-sql-i.org][i (insert, insert-into, intersect)]] 23 | - [[file:s-sql-j.org][j (Joins)]] 24 | - [[file:s-sql-l.org][l (lateral, like, ilike, limit)]] 25 | - [[file:s-sql-m.org][m (many-to-many)]] 26 | - [[file:s-sql-n.org][n (null, not-null, nullif)]] 27 | - [[file:s-sql-o.org][o (on, on-conflict, or, order-by, order-by with limit and offset, over)]] 28 | - [[file:s-sql-p.org][p (parameterized, partition-by)]] 29 | - [[file:s-sql-r.org][r (random, raw, returning primary key, rollup)]] 30 | - [[file:s-sql-s.org][s (Set, sql-type-name, string_agg, sum)]] 31 | - [[file:s-sql-t.org][t (threads, time functions, to-tsquery, to-tsvector, truncate)]] 32 | - [[file:s-sql-u.org][u (union, union-all, unique, update, upsert, using)]] 33 | - [[file:s-sql-v.org][v (create-view, variable parameters)]] 34 | - [[file:s-sql-w.org][w (when, window, with, with-recursive)]] 35 | 36 | - [[file:array-notes.html][Array-Notes]] 37 | - [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]] 38 | - [[file:dao-classes.html][Database Access Object (Dao) Classes]] 39 | - [[file:interval-notes.html][Interval Notes]] 40 | - [[file:isolation-notes.html][Isolation Notes]] 41 | - [[file:s-sql-postgresql-functions.org][S-SQL and Postgresql Functions]] 42 | - [[file:s-sql-prepared-statements.org][S-SQL and Prepared Statements]] 43 | - [[file:s-sql-special-characters.org][Special Characters]] 44 | 45 | * References 46 | :PROPERTIES: 47 | :CUSTOM_ID: references 48 | :END: 49 | - [[file:index.org][Documentation Index]] 50 | - [[file:s-sql.org][S-SQL Reference]] 51 | - [[file:postmodern.org][Postmodern Reference]] 52 | - [[file:cl-postgres.org][Cl-Postgres Reference]] 53 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to Postmodern 2 | Thank you for potentially contributing to Postmodern. We have tried to set out a few guidelines below to help both you and the maintainers. 3 | 4 | # Bugs and Enhancements 5 | We welcome new issue submissions identifying bugs and requested enhancements. We also welcome bug fixes and proposed code for enhancements. If you have found a security bug, please email the current maintainer shown in the asd files directly rather than creating new issue on github. 6 | 7 | Please clearly describe the issue and test cases are very much appreciated. Proposed code changes and additions should, at a minimum, have a doc string for any new function or appropriate modification of existing doc string. We prefer that documentation also be added to the appropriate doc org file and tests using fiveam be added to the appropriate testing file (each major sub-package - see below - has its own testing directory). You do not need to modify the html doc files because those will be automatically updated from the org files. Note that the docs in the repository are current, the docs at http://marijnhaverbeke.nl/postmodern are not necessarily up to date. 8 | 9 | We also would appreciate it if you note which common lisp implementations and operating system you have used to test and ensure that your bugfix or enhancement actually works. 10 | 11 | As a reminder - because we have done this ourselves - test that the new version can be compiled from a clean start (e.g. no debugging statements remain from a logging library). 12 | 13 | We are always open to more tests, regardless of whether you have found a bug or need an enhancement. 14 | 15 | # Code of Conduct 16 | We have not had any historical issues with conduct related to postmodern, its users or contributors. That being said, we expect that people will behave with respect towards users or contributors. This is all volunteer work by everyone and while the range of experience and expertise varies widely, harrassment or insults do not add value to the code or the community and will not be tolerated. 17 | 18 | # Licensing 19 | All code is under the license provided in the LICENSE file found in the root directory. If you want to contribute existing code which has another license, you need to get permission from that licensor to have the code released under the same rules as the rest of postmodern or work with the maintainer(s) for appropriate licensing. 20 | 21 | # Questions 22 | Feel free to email the current maintainer as shown in the asd files if you want to address something off line. 23 | 24 | # The structure of Postmodern 25 | Postmodern has four main packages - cl-postgres, s-sql, postmodern and simple-date. There are a few things to keep in mind here: 26 | 27 | ## cl-postgres 28 | cl-postgres establishes the network connections with postgresql and is used by other libraries besides postmodern. Any changes to cl-postgres functionality or api needs to be thoroughly tested and documented. 29 | 30 | ## postmodern 31 | The postmodern package adds the querying structures and utility functions to the networking connections provided by cl-postgres 32 | 33 | ## s-sql 34 | s-sql is a lispy wrapper around the sql language. You do not need to use s-sql to use postmodern. 35 | 36 | ## simple-date 37 | simple-date is an add-on date library. simple-date is not loaded automatically and many people use local-time instead. Do not assume that simple-date will be loaded by any user. 38 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) Marijn Haverbeke, marijnh@gmail.com 2 | 3 | This software is provided 'as-is', without any express or implied 4 | warranty. In no event will the authors be held liable for any 5 | damages arising from the use of this software. 6 | 7 | Permission is granted to anyone to use this software for any 8 | purpose, including commercial applications, and to alter it and 9 | redistribute it freely, subject to the following restrictions: 10 | 11 | 1. The origin of this software must not be misrepresented; you must 12 | not claim that you wrote the original software. If you use this 13 | software in a product, an acknowledgment in the product 14 | documentation would be appreciated but is not required. 15 | 16 | 2. Altered source versions must be plainly marked as such, and must 17 | not be misrepresented as being the original software. 18 | 19 | 3. This notice may not be removed or altered from any source 20 | distribution. 21 | 22 | ----------------------------------- 23 | 24 | This software contains code from the pgloader project in the following files: 25 | /postmodern/execute-file.lisp 26 | 27 | It is available under the below license. 28 | 29 | ----------------------------------- 30 | 31 | Copyright (c) 2005-2017, The PostgreSQL Global Development Group 32 | 33 | Permission to use, copy, modify, and distribute this software and its 34 | documentation for any purpose, without fee, and without a written agreement is 35 | hereby granted, provided that the above copyright notice and this paragraph and 36 | the following two paragraphs appear in all copies. 37 | 38 | IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR 39 | DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, INCLUDING LOST 40 | PROFITS, ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF 41 | THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 42 | 43 | THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, 44 | BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 45 | PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS" BASIS, AND 46 | THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATIONS TO PROVIDE MAINTENANCE, SUPPORT, 47 | UPDATES, ENHANCEMENTS, OR MODIFICATIONS. 48 | 49 | __________________________________________________________________________ 50 | This software contains code from the cl-json project in the following file: 51 | /postmodern/json-encoder.lisp 52 | 53 | which was made available under the MIT license quoted below: 54 | 55 | (This is the MIT / X Consortium license as taken from 56 | http://www.opensource.org/licenses/mit-license.html) 57 | 58 | Copyright (c) 2006-20012 Henrik Hjelte 59 | Copyright (c) 2008 Hans Hübner (code from the program YASON) 60 | 61 | Permission is hereby granted, free of charge, to any person obtaining 62 | a copy of this software and associated documentation files (the 63 | "Software"), to deal in the Software without restriction, including 64 | without limitation the rights to use, copy, modify, merge, publish, 65 | distribute, sublicense, and/or sell copies of the Software, and to 66 | permit persons to whom the Software is furnished to do so, subject to 67 | the following conditions: 68 | 69 | The above copyright notice and this permission notice shall be 70 | included in all copies or substantial portions of the Software. 71 | 72 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 73 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 74 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 75 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 76 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 77 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 78 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 79 | -------------------------------------------------------------------------------- /cl-postgres/oid.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES-OID; -*- 2 | 3 | (in-package :cl-postgres-oid) 4 | 5 | (defconstant +bool+ 16) 6 | (defconstant +bytea+ 17) 7 | (defconstant +char+ 18) 8 | (defconstant +name+ 19) 9 | (defconstant +int8+ 20) 10 | (defconstant +int2+ 21) 11 | (defconstant +int2vector+ 22) 12 | (defconstant +int4+ 23) 13 | (defconstant +regproc+ 24) 14 | (defconstant +text+ 25) 15 | (defconstant +oid+ 26) 16 | (defconstant +tid+ 27) 17 | (defconstant +xid+ 28) 18 | (defconstant +cid+ 29) 19 | (defconstant +oid-vector+ 30) 20 | (defconstant +json+ 114) 21 | (defconstant +xml+ 142) 22 | (defconstant +pgnodetree+ 194) 23 | (defconstant +pgddlcommand+ 32) 24 | (defconstant +point+ 600) 25 | (defconstant +lseg+ 601) 26 | (defconstant +path+ 602) 27 | (defconstant +box+ 603) 28 | (defconstant +polygon+ 604) 29 | (defconstant +line+ 628) 30 | (defconstant +float4+ 700) 31 | (defconstant +float8+ 701) 32 | (defconstant +abstime+ 702) 33 | (defconstant +reltime+ 703) 34 | (defconstant +tinterval+ 704) 35 | (defconstant +unknown+ 705) 36 | (defconstant +circle+ 718) 37 | (defconstant +cash+ 790) 38 | (defconstant +macaddr+ 829) 39 | (defconstant +inet+ 869) 40 | (defconstant +cidr+ 650) 41 | (defconstant +bool-array+ 1000) 42 | (defconstant +bytea-array+ 1001) 43 | (defconstant +char-array+ 1002) 44 | (defconstant +name-array+ 1003) 45 | (defconstant +int2-array+ 1005) 46 | (defconstant +int4-array+ 1007) 47 | (defconstant +text-array+ 1009) 48 | (defconstant +bpchar-array+ 1014) 49 | (defconstant +varchar-array+ 1015) 50 | (defconstant +int8-array+ 1016) 51 | (defconstant +point-array+ 1017) 52 | (defconstant +lseg-array+ 1018) 53 | (defconstant +box-array+ 1020) 54 | (defconstant +float4-array+ 1021) 55 | (defconstant +float8-array+ 1022) 56 | (defconstant +oid-array+ 1028) 57 | (defconstant +aclitem+ 1033) 58 | (defconstant +cstring-array+ 1263) 59 | (defconstant +bpchar+ 1042) 60 | (defconstant +varchar+ 1043) 61 | (defconstant +date+ 1082) 62 | (defconstant +time+ 1083) 63 | (defconstant +timestamp+ 1114) 64 | (defconstant +timestamp-array+ 1115) 65 | (defconstant +date-array+ 1182) 66 | (defconstant +time-array+ 1183) 67 | (defconstant +timestamptz+ 1184) 68 | (defconstant +timestamptz-array+ 1185) 69 | (defconstant +interval+ 1186) 70 | (defconstant +interval-array+ 1187) 71 | (defconstant +timetz+ 1266) 72 | (defconstant +bit+ 1560) 73 | (defconstant +bit-array+ 1561) 74 | (defconstant +varbit+ 1562) 75 | (defconstant +varbit-array+ 1563) 76 | (defconstant +numeric+ 1700) 77 | (defconstant +numeric-array+ 1231) 78 | (defconstant +refcursor+ 1790) 79 | (defconstant +regprocedure+ 2202) 80 | (defconstant +regoper+ 2203) 81 | (defconstant +regoperator+ 2204) 82 | (defconstant +regclass+ 2205) 83 | (defconstant +regtype+ 2206) 84 | (defconstant +regrole+ 4096) 85 | (defconstant +regnamespace+ 4089) 86 | (defconstant +regtype-array+ 2211) 87 | (defconstant +uuid+ 2950) 88 | (defconstant +lsn+ 3220) 89 | (defconstant +tsvector+ 3614) 90 | (defconstant +gtsvector+ 3642) 91 | (defconstant +tsquery+ 3615) 92 | (defconstant +regconfig+ 3734) 93 | (defconstant +regdictionary+ 3769) 94 | (defconstant +jsonb+ 3802) 95 | (defconstant +int4range+ 3904) 96 | (defconstant +record+ 2249) 97 | (defconstant +record-array+ 2287) 98 | (defconstant +cstring+ 2275) 99 | (defconstant +any+ 2276) 100 | (defconstant +any-array+ 2277) 101 | (defconstant +v-oid+ 2278) 102 | (defconstant +trigger+ 2279) 103 | (defconstant +evttrigger+ 3838) 104 | (defconstant +language-handler+ 2280) 105 | (defconstant +internal+ 2281) 106 | (defconstant +opaque+ 2282) 107 | (defconstant +anyelement+ 2283) 108 | (defconstant +anynon-array+ 2776) 109 | (defconstant +anyenum+ 3500) 110 | (defconstant +fdw-handler+ 3115) 111 | (defconstant +index-am-handler+ 325) 112 | (defconstant +tsm-handler+ 3310) 113 | (defconstant +anyrange+ 3831) 114 | -------------------------------------------------------------------------------- /postmodern.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; -*- 2 | 3 | (defpackage :postmodern-system 4 | (:use :common-lisp :asdf) 5 | (:export :*threads*)) 6 | (in-package :postmodern-system) 7 | 8 | ;; Change this to manually turn threading support on or off. 9 | (eval-when (:compile-toplevel :load-toplevel :execute) 10 | #+(or allegro armedbear clasp cmu corman (and digitool ccl-5.1) 11 | ecl lispworks openmcl sbcl genera) 12 | (pushnew :postmodern-thread-safe *features*) 13 | 14 | #+(or allegro clasp clisp ecl lispworks mcl openmcl cmu sbcl armedbear) 15 | (pushnew :postmodern-use-mop *features*)) 16 | 17 | (defsystem "postmodern" 18 | :description "PostgreSQL programming API" 19 | :author "Marijn Haverbeke " 20 | :maintainer "Sabra Crolleton " 21 | :homepage "https://github.com/marijnh/Postmodern" 22 | :license "zlib" 23 | :version "1.33.11" 24 | :depends-on ("alexandria" 25 | "cl-postgres" 26 | "s-sql" 27 | "global-vars" 28 | "split-sequence" 29 | "uiop" 30 | (:feature :postmodern-use-mop "closer-mop") 31 | (:feature :postmodern-thread-safe "bordeaux-threads")) 32 | :components 33 | ((:module "postmodern" 34 | :components ((:file "package") 35 | (:file "config") 36 | (:file "connect" :depends-on ("package" "config")) 37 | (:file "json-encoder" :depends-on ("package" "config")) 38 | (:file "query" :depends-on ("connect" "json-encoder" "config")) 39 | (:file "prepare" :depends-on ("query" "config")) 40 | (:file "roles" :depends-on ("query" "config")) 41 | (:file "util" :depends-on ("query" "roles" "config")) 42 | (:file "transaction" :depends-on ("query" "config")) 43 | (:file "namespace" :depends-on ("query" "config")) 44 | (:file "execute-file" :depends-on ("query" "config")) 45 | (:file "table" :depends-on ("util" "transaction" "query" "config") 46 | :if-feature :postmodern-use-mop) 47 | (:file "deftable" :depends-on 48 | ("query" (:feature :postmodern-use-mop "table" "config")))))) 49 | :in-order-to ((test-op (test-op "postmodern/tests")))) 50 | 51 | (defsystem "postmodern/tests" 52 | :depends-on ("postmodern" "fiveam" "simple-date" "simple-date/postgres-glue" 53 | "cl-postgres/tests" "s-sql/tests" "local-time" 54 | "cl-postgres+local-time") 55 | :components 56 | ((:module "postmodern/tests" 57 | :components ((:file "test-package") 58 | (:file "tests") 59 | (:file "test-prepared-statements" :depends-on ("test-package" "tests") 60 | :if-feature :postmodern-use-mop) 61 | (:file "test-binary-prepared-statements" :depends-on ("test-package" "tests") 62 | :if-feature :postmodern-use-mop) 63 | (:file "test-binary-parameters" :depends-on ("test-package" "tests") 64 | :if-feature :postmodern-use-mop) 65 | (:file "test-return-types" :depends-on ("tests" "test-package")) 66 | (:file "test-table-info" :depends-on ("test-package" "tests")) 67 | (:file "test-return-types-timestamps" :depends-on ("test-package" "tests")) 68 | (:file "test-transactions" :depends-on ("test-package" "tests")) 69 | (:file "test-roles" :depends-on ("test-package" "tests")) 70 | #-abcl (:file "test-dao" :depends-on ("test-package" "tests")) 71 | #+abcl (:file "abcl-test-dao" :depends-on ("test-package" "tests")) 72 | (:file "test-execute-file" :depends-on ("test-package" "tests"))))) 73 | 74 | :perform (test-op (o c) 75 | (uiop:symbol-call :cl-postgres-tests '#:prompt-connection) 76 | (uiop:symbol-call :fiveam '#:run! :postmodern))) 77 | -------------------------------------------------------------------------------- /doc/s-sql-e.org: -------------------------------------------------------------------------------- 1 | #+TITLE: S-SQL Examples E 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | * [[file:s-sql-examples.org][S-SQL Examples Home Page]] 8 | | [[file:s-sql-a.org][A]]| [[file:s-sql-b.org][B]]| [[file:s-sql-c.org][C]]| [[file:s-sql-d.org][D]]| [[file:s-sql-e.org][E]]| [[file:s-sql-f.org][F]]| [[file:s-sql-g.org][G]]| [[file:s-sql-h.org][H]]| [[file:s-sql-i.org][I]]| [[file:s-sql-j.org][J]]| [[file:s-sql-k.org][K]]| [[file:s-sql-l.org][L]]| [[file:s-sql-m.org][M]]| [[file:s-sql-n.org][N]]| [[file:s-sql-o.org][O]]| [[file:s-sql-p.org][P]]| [[file:s-sql-r.org][R]]| [[file:s-sql-s.org][S]]| [[file:s-sql-t.org][T]]| [[file:s-sql-u.org][U]]| [[file:s-sql-v.org][V]]| [[file:s-sql-w.org][W]]| [[file:s-sql-special-characters.org][Special Characters]] | [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]]| 9 | 10 | 11 | * Enum 12 | :PROPERTIES: 13 | :CUSTOM_ID: enum 14 | :END: 15 | Per the postgresql documentation, Enumerated (enum) types are data types that comprise a static, ordered set of values. They are equivalent to the enum types supported in a number of programming languages. An example of an enum type might be the days of the week, or a set of status values for a piece of data. In this example, we are going to create an enumerated type "rainbow" with specific allowed colors. 16 | #+begin_src lisp 17 | (query (:create-enum 'rainbow 18 | (list "red" "orange" "yellow" "green" "blue" "purple"))) 19 | 20 | (query (:create-table test26 21 | ((name :type text) 22 | (color :type rainbow)))) 23 | 24 | (query (:insert-into 'test26 :set 'name "Moe" 'current-color "yellow")) 25 | #+end_src 26 | 27 | Now if we try to insert an invalid type, we will trigger an error: 28 | #+begin_src lisp 29 | (query (:insert-into 'test26 :set 'name "Moe" 'current-color "chartreuse")) 30 | 31 | Database error 22P02: invalid input value for enum rainbow: "chartreuse" Query: insert into test26 values ('Moe', 'chartreuse') 32 | 33 | [Condition of type CL-POSTGRES-ERROR:DATA-EXCEPTION] 34 | #+end_src 35 | 36 | * Except 37 | :PROPERTIES: 38 | :CUSTOM_ID: except 39 | :END: 40 | The sql except operator returns rows that are in the first selection but not in the second selection. Following on with our like example, assume we want all countries with "New" in their name, but not countries with "Zealand" in their names. 41 | #+begin_src lisp 42 | (query (:except (:select 'id 'name 43 | :from 'countries 44 | :where (:like 'name "%New%")) 45 | (:select 'id 'name 46 | :from 'countries 47 | :where (:like 'name "%Zealand%")))) 48 | 49 | ((108 "Papua New Guinea") (103 "New Caledonia")) 50 | 51 | #+end_src 52 | 53 | * Exists 54 | :PROPERTIES: 55 | :CUSTOM_ID: exists 56 | :END: 57 | Exists is used to run one subquery when a second subquery returns at least one row. For example: 58 | #+begin_src lisp 59 | (query (:select 'id 'name 60 | :from 'regions 61 | :where (:exists 62 | (:select 'region-id 63 | :from 'countries 64 | :where (:and 65 | (:= 'countries.name "Costa Rica") 66 | (:= 'regions.id 'countries.region-id)))))) 67 | 68 | ((3 "Central America")) 69 | 70 | #+end_src 71 | 72 | * Extract 73 | :PROPERTIES: 74 | :CUSTOM_ID: extract 75 | :END: 76 | #+begin_src lisp 77 | (query (:order-by (:select 'facid 78 | (:as (:extract 'month 'starttime) 'month) 79 | (:as (:sum 'slots) 'total-slots) 80 | :from 'cd.bookings 81 | :where (:and (:>= 'starttime "2012-01-01") 82 | (:< 'starttime "2013-01-01")) 83 | :group-by 'facid 'month) 84 | 'facid 'month)) 85 | #+end_src 86 | -------------------------------------------------------------------------------- /doc/s-sql-special-characters.org: -------------------------------------------------------------------------------- 1 | #+TITLE: S-SQL Special Characters 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | * [[file:s-sql-examples.org][S-SQL Examples Home Page]] 8 | | [[file:s-sql-a.org][A]]| [[file:s-sql-b.org][B]]| [[file:s-sql-c.org][C]]| [[file:s-sql-d.org][D]]| [[file:s-sql-e.org][E]]| [[file:s-sql-f.org][F]]| [[file:s-sql-g.org][G]]| [[file:s-sql-h.org][H]]| [[file:s-sql-i.org][I]]| [[file:s-sql-j.org][J]]| [[file:s-sql-k.org][K]]| [[file:s-sql-l.org][L]]| [[file:s-sql-m.org][M]]| [[file:s-sql-n.org][N]]| [[file:s-sql-o.org][O]]| [[file:s-sql-p.org][P]]| [[file:s-sql-r.org][R]]| [[file:s-sql-s.org][S]]| [[file:s-sql-t.org][T]]| [[file:s-sql-u.org][U]]| [[file:s-sql-v.org][V]]| [[file:s-sql-w.org][W]]| [[file:s-sql-special-characters.org][Special Characters]] | [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]]| 9 | 10 | You can generally assume that most Postgresql operators will act similarly to the following: 11 | * := The Equal operator 12 | :PROPERTIES: 13 | :CUSTOM_ID: equal 14 | :END: 15 | #+begin_src lisp 16 | (query (:select 'id 'name :from 'regions :where (:= 'name "South America"))) 17 | 18 | ((7 "South America")) 19 | #+end_src 20 | 21 | * :+ The Plus operator 22 | :PROPERTIES: 23 | :CUSTOM_ID: plus 24 | :END: 25 | #+begin_src lisp 26 | (query (:select (:+ 'id 12) 'name 27 | :from 'regions 28 | :where (:= 'name "South America"))) 29 | ((19 "South America")) 30 | #+end_src 31 | 32 | * :<> The Not Equals or Greater or Lesser than operators 33 | :PROPERTIES: 34 | :CUSTOM_ID: not-equal 35 | :END: 36 | The not equals operator 37 | #+begin_src lisp 38 | (query (:select 'id 'name 39 | :from 'regions 40 | :where (:<> 'name "Africa"))) 41 | 42 | ((3 "Central America") (5 "Middle East") (6 "North America") (7 "SouthAmerica") (8 "Central Asia") (9 "Pacific") (10 "Caribbean") (11 "Eastern Europe") (4 "Western Europe") (2 "Asia")) 43 | 44 | #+end_src 45 | 46 | * :| Concatenating Columns 47 | :PROPERTIES: 48 | :CUSTOM_ID: concate 49 | :END: 50 | The concatenation operator combines two or more columns into a single column return. First, consider the query on a raw sql string: 51 | #+begin_src lisp 52 | (query "(SELECT countries.id, (countries.name | '-' | regions.name) 53 | FROM countries, regions 54 | WHERE ((regions.id = countries.region_id) 55 | and (countries.name = 'US')))") 56 | 57 | ((21 "US-North America")) 58 | 59 | #+end_src 60 | 61 | Now consider the result using s-sql. 62 | #+begin_src lisp 63 | (query (:select 'countries.id (:| 'countries.name "-" 'regions.name) 64 | :from 'countries 'regions 65 | :where (:and (:= 'regions.id 'countries.region-id) 66 | (:= 'countries.name "US")))) 67 | 68 | ((21 "US-North America")) 69 | 70 | #+end_src 71 | 72 | * :~, :!~, :~* Regex Match 73 | :PROPERTIES: 74 | :CUSTOM_ID: regex 75 | :END: 76 | Regular expression matching operators. The exclamation mark means 'does not match', 77 | the asterisk makes the match case-insensitive. 78 | #+BEGIN_SRC lisp 79 | (query (:select (:regexp_match "foobarbequebaz" "bar.*que")) :single) 80 | 81 | #("barbeque") 82 | 83 | (query (:select (:regexp_match "foobarbequebaz" "bar.~que")) :single) 84 | 85 | :NULL 86 | 87 | (query (:select (:~ "foobarbequebaz" "bar.*que") ) :single) 88 | 89 | t 90 | 91 | (query (:select (:!~ "foobarbequebaz" "bar.*que") ) :single) 92 | 93 | nil 94 | 95 | (query (:select (:~ "foobarbequebaz" "barque") ) :single) 96 | 97 | nil 98 | 99 | (query (:select (:~ "foobarbequebaz" "barbeque") ) :single) 100 | 101 | t 102 | 103 | (query (:select (:~ "foobarBequebaz" "barbeque") ) :single) 104 | 105 | nil 106 | 107 | (query (:select (:~* "foobarBequebaz" "barbeque") ) :single) 108 | 109 | t 110 | 111 | (query (:select 'id 'text :from 'text-search :where (:~ 'text "sushi"))) 112 | 113 | #+END_SRC 114 | -------------------------------------------------------------------------------- /cl-postgres/tests/test-clp-utf8.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES-TESTS; -*- 2 | (in-package :cl-postgres-tests) 3 | 4 | (def-suite :cl-postgres-clp-utf8 5 | :description "Test suite for cl-postgres functions in trivial-utf-8.lisp" 6 | :in :cl-postgres) 7 | 8 | (in-suite :cl-postgres-clp-utf8) 9 | 10 | ;; The following parameters encode "ÄÖÜÈäes8" as utf-8 octets and utf-16 octets 11 | ;; respectively 12 | (defparameter *test-8-octets* 13 | (make-array 13 14 | :element-type '(unsigned-byte 8) 15 | :initial-contents #(195 132 195 150 195 156 195 136 195 164 101 115 56))) 16 | (defparameter *test-16-octets* 17 | (make-array 16 18 | :element-type '(unsigned-byte 8) 19 | :initial-contents #(196 0 214 0 220 0 200 0 228 0 101 0 115 0 56 0))) 20 | (defparameter *test-latin1-octets* 21 | (make-array 9 22 | :element-type '(unsigned-byte 8) 23 | :initial-contents #(196 214 220 200 228 101 115 56 10))) 24 | 25 | (test octet-test-1 26 | (is (equalp 27 | (clp-utf8::read-utf-8-string 28 | (trivial-octet-streams:make-octet-input-stream 29 | *test-8-octets*) 30 | :stop-at-eof t) 31 | "ÄÖÜÈäes8")) 32 | (signals error 33 | (clp-utf8::read-utf-8-string 34 | (trivial-octet-streams:make-octet-input-stream 35 | *test-16-octets*) 36 | :stop-at-eof t)) 37 | (signals error 38 | (clp-utf8::read-utf-8-string 39 | (trivial-octet-streams:make-octet-input-stream 40 | *test-latin1-octets*) 41 | :stop-at-eof t))) 42 | 43 | (test clp1 44 | (is (equalp (clp-utf8::string-to-utf-8-bytes "twelve") 45 | #(116 119 101 108 118 101))) 46 | (is (equalp (cl-postgres::enc-string-bytes "twelve") 47 | #(116 119 101 108 118 101))) 48 | (is (eql (cl-postgres::enc-byte-length "twelve") 49 | 6)) 50 | (is (equalp (clp-utf8::string-to-utf-8-bytes "twelve" :null-terminate t) 51 | #(116 119 101 108 118 101 0))) 52 | (with-open-file (out "/tmp/data" :direction :output :if-exists :supersede 53 | :element-type '(signed-byte 16)) 54 | (clp-utf8::write-utf-8-bytes "twelve" out)) 55 | (is (equal (with-open-file (in "/tmp/data" :element-type '(signed-byte 16)) 56 | (clp-utf8::read-utf-8-string in :stop-at-eof t)) 57 | "twelve")) 58 | (is (equal (with-open-file (in "/tmp/data" :element-type '(signed-byte 16)) 59 | (clp-utf8::read-utf-8-string in :stop-at-eof t)) 60 | "twelve")) 61 | (is (equal (with-open-file (in "/tmp/data" :element-type '(signed-byte 16)) 62 | (cl-postgres::enc-read-string in )) 63 | "twelve")) 64 | (with-open-file (out "/tmp/data" :direction :output :if-exists :supersede 65 | :element-type '(signed-byte 16)) 66 | (cl-postgres::enc-write-string "twelve" out :null-terminate t)) 67 | (is (equal (with-open-file (in "/tmp/data" :element-type '(signed-byte 16)) 68 | (cl-postgres::enc-read-string in :null-terminated t)) 69 | "twelve")) 70 | (is (equal (with-open-file (in "/tmp/data" :element-type '(signed-byte 16)) 71 | (cl-postgres::enc-read-string in)) 72 | "twelve"))) 73 | 74 | (test clp-utf8-tests 75 | (is (equal (clp-utf8::utf-8-bytes-to-string (clp-utf8::string-to-utf-8-bytes "пример")) 76 | "пример")) 77 | (is (equalp (clp-utf8::string-to-utf-8-bytes "пример") 78 | #(208 191 209 128 208 184 208 188 208 181 209 128))) 79 | (is (equal (clp-utf8::utf-8-string-length (clp-utf8::string-to-utf-8-bytes "twelve")) 80 | 6)) 81 | (is (equal (clp-utf8::utf-8-bytes-to-string #(116 119 101 108 118 101)) 82 | "twelve")) 83 | (is (equalp (clp-utf8::string-to-utf-8-bytes "tönkösti") 84 | #(116 195 182 110 107 195 182 115 116 105))) 85 | (is (equal 86 | (clp-utf8::utf-8-bytes-to-string (clp-utf8::string-to-utf-8-bytes "tönkösti")) 87 | "tönkösti")) 88 | (is (equalp (clp-utf8::string-to-utf-8-bytes "Вас ждет шрифты") 89 | #(208 146 208 176 209 129 32 208 182 208 180 208 181 209 130 32 209 136 209 128 90 | 208 184 209 132 209 130 209 139))) 91 | 92 | (is (equal (clp-utf8::utf-8-string-length 93 | (clp-utf8::string-to-utf-8-bytes "пример")) 94 | 6))) 95 | -------------------------------------------------------------------------------- /cl-postgres/tests/test-data-types.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES-TESTS; -*- 2 | (in-package :cl-postgres-tests) 3 | 4 | (def-suite :cl-postgres-data-types 5 | :description "Test suite for cl-postgres functions in data-types.lisp" 6 | :in :cl-postgres) 7 | 8 | (in-suite :cl-postgres-data-types) 9 | 10 | 11 | (test data-types-integers 12 | (is (eq (cl-postgres::get-int-size 12) 13 | 'cl-postgres::INT2)) 14 | (is (eq (cl-postgres::get-int-size 123456789) 15 | 'cl-postgres::INT4)) 16 | (is (eq (cl-postgres::get-int-size 123456789123456) 17 | 'cl-postgres::INT8)) 18 | (is (eq (cl-postgres::get-int-size 123456789123456789123456) 19 | nil)) 20 | (is (cl-postgres::int2p 12)) 21 | (is (cl-postgres::int4p -123456789)) 22 | (is (cl-postgres::int8p -123456789123456))) 23 | 24 | (test data-types-uuid-to-byte-array 25 | (is (equalp (cl-postgres::uuid-to-byte-array "2ef91ac6-aa47-4486-9531-362a72615c1f") 26 | #(46 249 26 198 170 71 68 134 149 49 54 42 114 97 92 31))) 27 | (is (equalp (cl-postgres::uuid-to-byte-array "2EF91AC6-AA47-4486-9531-362A72615C1F") 28 | #(46 249 26 198 170 71 68 134 149 49 54 42 114 97 92 31)))) 29 | 30 | (test data-types-text-array-p 31 | (is (cl-postgres::text-array-p (vector "A" "b" "d"))) 32 | (is (not (cl-postgres::text-array-p (vector "A" "b" 1)))) 33 | (is (typep (vector "a" "b" "c") 'cl-postgres::text-array)) 34 | (is (typep (vector "a" "b" "c") '(cl-postgres::text-array 3))) 35 | (is (not (typep (vector "a" "b" "c") '(cl-postgres::text-array 2))))) 36 | 37 | 38 | (test data-types-int2-array-p 39 | (is (typep (vector 1 2 3) '(cl-postgres::int2-array 3))) 40 | (is (not (typep (vector 1 2 3) '(cl-postgres::int2-array 4)))) 41 | (is (typep (vector 1 2 3 4) '(cl-postgres::int2-array))) 42 | (is (cl-postgres::int2-array-p (vector 1 2 3 4)))) 43 | 44 | (test data-types-int4-array-p 45 | (is (typep (vector 1 4 3) '(cl-postgres::int4-array 3))) 46 | (is (not (typep (vector 1 4 3) '(cl-postgres::int4-array 4)))) 47 | (is (typep (vector 1 4 3 4) '(cl-postgres::int4-array))) 48 | (is (cl-postgres::int4-array-p (vector 1 4 3 4)))) 49 | 50 | (test data-types-int8-array-p 51 | (is (typep (vector 1 -8 3) '(cl-postgres::int8-array 3))) 52 | (is (not (typep (vector 1 8 3) '(cl-postgres::int8-array 8)))) 53 | (is (typep (vector 1 8 3 8) '(cl-postgres::int8-array))) 54 | (is (cl-postgres::int8-array-p (vector 1 8 3 8))) 55 | (is (typep (vector 1 -123456789123456789 3) '(cl-postgres::int8-array 3))) 56 | (is (not (typep (vector 1 -123456789123456789123456 3) '(cl-postgres::int8-array 3))))) 57 | 58 | (test types-match 59 | (is (cl-postgres::types-match-p "a" "c")) 60 | (is (cl-postgres::oid-types-match-p "a" "c"))) 61 | 62 | (test parameter-list-types 63 | (is (equal (cl-postgres::parameter-list-types '("a" 1 123456789 123456789123456 64 | 123456789123456987654 'b #\d 12.2 65 | nil t)) 66 | '(0 21 23 20 0 0 0 700 16 16))) 67 | #-clisp (is (equal (cl-postgres::parameter-list-types '(12413212.98324d0)) 68 | '(701))) 69 | #+clisp (is (equal (cl-postgres::parameter-list-types '(12413212.98324d0)) 70 | '(700)))) 71 | 72 | (test parameter-lists-match-oid-types 73 | (is (cl-postgres::parameter-lists-match-oid-types-p '(12413212.98324d0) '(124212.98324d0))) 74 | (is (not (cl-postgres::parameter-lists-match-oid-types-p '(12413212.98324d0 "a") 75 | '(124212.98324d0)))) 76 | (is (not (cl-postgres::parameter-lists-match-oid-types-p '("a") 77 | '(3))))) 78 | 79 | (test param-to-oid 80 | #-clisp (is (equal (loop for x in '(integer int2 int4 int8 boolean t nil float 81 | double-float "jeff" 2 2000 12345678909 1.0 2.7d0 "12a") 82 | collect (list x (param-to-oid x))) 83 | '((INTEGER 0) (INT2 0) (INT4 0) (INT8 0) (BOOLEAN 0) (T 16) (NIL 16) (FLOAT 0) 84 | (DOUBLE-FLOAT 0) ("jeff" 0) (2 21) (2000 21) (12345678909 20) (1.0 700) 85 | (2.7d0 701) ("12a" 0)))) 86 | #+clisp (is (equal (loop for x in '(integer int2 int4 int8 boolean t nil float 87 | double-float "jeff" 2 2000 12345678909 1.0 2.7d0 "12a") 88 | collect (list x (param-to-oid x))) 89 | '((INTEGER 0) (INT2 0) (INT4 0) (INT8 0) (BOOLEAN 0) (T 16) (NIL 16) (FLOAT 0) 90 | (DOUBLE-FLOAT 0) ("jeff" 0) (2 21) (2000 21) (12345678909 20) (1.0 700) 91 | (2.7d0 700) ("12a" 0))))) 92 | -------------------------------------------------------------------------------- /doc/s-sql-r.org: -------------------------------------------------------------------------------- 1 | #+TITLE: S-SQL Examples R 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | * [[file:s-sql-examples.org][S-SQL Examples Home Page]] 8 | | [[file:s-sql-a.org][A]]| [[file:s-sql-b.org][B]]| [[file:s-sql-c.org][C]]| [[file:s-sql-d.org][D]]| [[file:s-sql-e.org][E]]| [[file:s-sql-f.org][F]]| [[file:s-sql-g.org][G]]| [[file:s-sql-h.org][H]]| [[file:s-sql-i.org][I]]| [[file:s-sql-j.org][J]]| [[file:s-sql-k.org][K]]| [[file:s-sql-l.org][L]]| [[file:s-sql-m.org][M]]| [[file:s-sql-n.org][N]]| [[file:s-sql-o.org][O]]| [[file:s-sql-p.org][P]]| [[file:s-sql-r.org][R]]| [[file:s-sql-s.org][S]]| [[file:s-sql-t.org][T]]| [[file:s-sql-u.org][U]]| [[file:s-sql-v.org][V]]| [[file:s-sql-w.org][W]]| [[file:s-sql-special-characters.org][Special Characters]] | [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]]| 9 | 10 | * Random 11 | :PROPERTIES: 12 | :CUSTOM_ID: random 13 | :END: 14 | #+begin_src lisp 15 | (query (:limit 16 | (:order-by 17 | (:select 'id 'name 18 | :from 'countries) 19 | (:random)) 20 | 5)) 21 | 22 | ((54 "Israel") (62 "South Africa") (195 "Aruba") (79 "Costa Rica")(31 "OECD")) 23 | 24 | #+end_src 25 | 26 | * Raw SQL Statements 27 | :PROPERTIES: 28 | :CUSTOM_ID: raw-sql 29 | :END: 30 | We've already seen that the postmodern:query function can take a raw sql string and that the postmodern:sql function can output an sql string. You can combine them if you need to go beyond what postmodern can already provide. Consider the following toy example which uses a part of the eventual query in the let and inserts it into the body. 31 | #+begin_src lisp 32 | (let ((param-constraints (sql (:= 'name "Austria")))) 33 | (query (:select 'id 'name 34 | :from 'countries 35 | :where (:raw param-constraints)))) 36 | #+end_src 37 | 38 | Now consider this function where you have a conditional query based on the variables test1 and test2 passed into the function. In this toy example, if test1 is true then look for countries whose name is a fuzzy match for param1, if test2 is true, look for countries whose name is a fuzzy match for param2. If both are true, then the names need to be fuzzy matches for both param1 and param2. If neither test1 or test2 are true, then return all rows in the countries table. 39 | #+begin_src lisp 40 | (defun test3 (test1 test2 param1 param2) 41 | (query (:select '* :from 'countries 42 | :where (:and 43 | (:raw (if test1 44 | (sql 45 | (:like 'name 46 | (concatenate 'string "%" param1 47 | "%"))) 48 | "'t'")) 49 | (:raw (if test2 50 | (sql (:like 'name 51 | (concatenate 'string "%" 52 | param2 53 | "%"))) 54 | "'t'")))))) 55 | 56 | (test3 nil t "New" "gary") 57 | 58 | ((10 "Hungary" 11 47 20 "GU" 1 "2005-09-11 00:15:40-07" "Forint" "HUF" 348)) 59 | 60 | #+end_src 61 | 62 | * Returning the Primary Key 63 | :PROPERTIES: 64 | :CUSTOM_ID: returning-primary 65 | :END: 66 | Suppose your table has a serial or identity key of id and you want the insert function to return the newly generated id for that new record. 67 | #+begin_src lisp 68 | (query 69 | (:insert-into 'categories :set 'name "test-cat3" 70 | :returning 'id) 71 | :single) 72 | #+end_src 73 | The next example shows the same example using parameterized variables. 74 | #+begin_src lisp 75 | (let ((name "test-cat4")) 76 | (query 77 | (:insert-into 'categories :set 'name '$1 78 | :returning 'id) 79 | name :single)) 80 | #+end_src 81 | 82 | * Rollup 83 | :PROPERTIES: 84 | :CUSTOM_ID: rollup 85 | :END: 86 | Rollup was added to postgresql in version 9.5. See https://www.postgresql.org/docs/devel/static/queries-table-expressions.html#QUERIES-GROUPING-SETS Sample usage: 87 | #+begin_src lisp 88 | (query (:order-by 89 | (:select 'facid 90 | (:as (:extract 'month 'starttime) 'month) 91 | (:as (:sum 'slots) 'slots) 92 | :from 'cd.bookings 93 | :where (:and (:>= 'starttime "2012-01-01") 94 | (:< 'starttime "2013-01-01")) 95 | :group-by (:rollup 'facid 'month)) 96 | 'facid 'month)) 97 | #+end_src 98 | -------------------------------------------------------------------------------- /doc/s-sql-postgresql-functions.org: -------------------------------------------------------------------------------- 1 | #+TITLE: S-SQL and Postgresql Functions 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | * [[file:s-sql-examples.org][S-SQL Examples Home Page]] 8 | | [[file:s-sql-a.org][A]]| [[file:s-sql-b.org][B]]| [[file:s-sql-c.org][C]]| [[file:s-sql-d.org][D]]| [[file:s-sql-e.org][E]]| [[file:s-sql-f.org][F]]| [[file:s-sql-g.org][G]]| [[file:s-sql-h.org][H]]| [[file:s-sql-i.org][I]]| [[file:s-sql-j.org][J]]| [[file:s-sql-k.org][K]]| [[file:s-sql-l.org][L]]| [[file:s-sql-m.org][M]]| [[file:s-sql-n.org][N]]| [[file:s-sql-o.org][O]]| [[file:s-sql-p.org][P]]| [[file:s-sql-r.org][R]]| [[file:s-sql-s.org][S]]| [[file:s-sql-t.org][T]]| [[file:s-sql-u.org][U]]| [[file:s-sql-v.org][V]]| [[file:s-sql-w.org][W]]| [[file:s-sql-special-characters.org][Special Characters]] | [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]]| 9 | 10 | * Postgresql Functions 11 | :PROPERTIES: 12 | :CUSTOM_ID: postgresql-functions 13 | :END: 14 | Postgresql functions are typically inserted into s-sql in their own form prefaced with : and their parameters are generally single quoted. Here are a few simple examples. 15 | 16 | ** :avg 17 | :PROPERTIES: 18 | :CUSTOM_ID: avg 19 | :END: 20 | #+begin_src lisp 21 | (froundn (query (:select (:avg 'latitude) :from 'countries) :single) 4) 22 | 23 | 18.4209 24 | #+end_src 25 | 26 | ** :generate-series 27 | :PROPERTIES: 28 | :CUSTOM_ID: generate-series 29 | :END: 30 | Generate-series returns a list of of lists of numbers with a starting point of x, and ending point of y and an interval of z (defaulting to 1). Thus: 31 | #+begin_src lisp 32 | (query (:select '* :from (:generate-series 1 10))) 33 | 34 | ((1) (2) (3) (4) (5) (6) (7) (8) (9) (10)) 35 | 36 | (query (:select '* :from (:generate-series 1 30 5))) 37 | 38 | ((1) (6) (11) (16) (21) (26)) 39 | 40 | (query (:select '* :from (:generate-series 3 30 5))) 41 | 42 | ((3) (8) (13) (18) (23) (28)) 43 | 44 | #+end_src 45 | 46 | ** :max 47 | :PROPERTIES: 48 | :CUSTOM_ID: max 49 | :END: 50 | #+begin_src lisp 51 | (query (:select (:max 'latitude) :from 'countries) 52 | :single) 53 | 54 | 72 55 | #+end_src 56 | 57 | ** :min 58 | :PROPERTIES: 59 | :CUSTOM_ID: min 60 | :END: 61 | #+begin_src lisp 62 | (query (:select (:min 'latitude) :from 'countries) 63 | :single) 64 | 65 | -1029/20 66 | 67 | #+end_src 68 | 69 | ** :random 70 | :PROPERTIES: 71 | :CUSTOM_ID: random 72 | :END: 73 | #+begin_src lisp 74 | (query (:limit 75 | (:order-by 76 | (:select 'id 'name :from 'countries) 77 | (:random)) 78 | 5)) 79 | 80 | ((54 "Israel") (62 "South Africa") (195 "Aruba") (79 "Costa Rica") (31 "OECD")) 81 | 82 | #+end_src 83 | 84 | ** :string_agg 85 | :PROPERTIES: 86 | :CUSTOM_ID: string-agg 87 | :END: 88 | String_agg returns a string containging the values returned, separated by a delimiter. In the following example, we are searching for the name of all the regions in the regions table and we want it all returned as a single string with a delimiting comma. 89 | #+begin_src lisp 90 | (query (:select (:string_agg 'name ",") 91 | :from 'regions)) 92 | 93 | (("Central America,Middle East,North America,South America,Central Asia,Pacific,Caribbean,Eastern Europe,Western Europe,EMEA,APAC,LATAM,Emerging,US,Canada,Africa,All,Asia,Eastern Africa,Middle Africa,Northern Africa,Southern Africa,Western Africa,Oceania,Northern Europe,Southern Europe,Eastern Asia,South Central Asia,South East Asia")) 94 | 95 | #+end_src 96 | 97 | ** :version 98 | :PROPERTIES: 99 | :CUSTOM_ID: version 100 | :END: 101 | #+begin_src lisp 102 | (query (:select (:version))) 103 | 104 | (("PostgreSQL 9.2 on x86_64-pc-linux-gnu, compiled by GCC x86_64")) 105 | 106 | #+end_src 107 | #+begin_src lisp 108 | (defun table-size (table-name) 109 | "Return the size of a postgresql table in k or m. Table-name can be either astring or quoted." 110 | (when (symbolp table-name) 111 | (setf table-name (string-downcase (write-to-string table-name)))) 112 | (query (:select (:pg_size_pretty (:pg_total_relation_size '$1))) 113 | :single 114 | table-name)) 115 | 116 | (table-size 'countries) 117 | 118 | "88 kB" 119 | 120 | #+end_src 121 | 122 | ** Combining Postgresql Functions 123 | :PROPERTIES: 124 | :CUSTOM_ID: combining 125 | :END: 126 | #+begin_src lisp 127 | (defun current-database-size-pretty () 128 | "Returns the current database size as a string in MB" 129 | (query (:select (:pg_size_pretty 130 | (:pg_database_size (:current_database)))) 131 | :single)) 132 | #+end_src 133 | -------------------------------------------------------------------------------- /postmodern/namespace.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: POSTMODERN; -*- 2 | (in-package :postmodern) 3 | 4 | (defmacro with-schema ((schema &key (strict t) (if-not-exist :create) 5 | (drop-after nil)) 6 | &body form) 7 | "A macro to set the schema search path (namespace) of the postgresql database 8 | to include as first entry a specified schema and then executes the body. 9 | Before executing body the PostgreSQL's session variable search_path is set to 10 | the given namespace. After executing body the search_path variable is restored 11 | to the original value. 12 | 13 | Calling with :strict 't only the specified schema is set as current search 14 | path. All other schema are then not searched any more. If strict is nil, the 15 | namespace is just first schema on the search path upon the the body execution. 16 | 17 | Calling with :if-not-exist set to :create the schema is created if this 18 | schema did not exist. 19 | Calling with :if-not-exist set to nil, an error is signaled. 20 | 21 | calling with drop-after set to 't the schema is removed after the execution 22 | of the body form. 23 | 24 | example : 25 | 26 | (with-schema (:schema-name :strict nil :drop-after nil :if-not-exist :error) 27 | (foo 1) 28 | (foo 2)) 29 | 30 | example : 31 | 32 | (with-schema ('uniq :if-not-exist :create) ;; changing the search path 33 | (schema-exists-p 'uniq))" 34 | 35 | `(do-with-schema ,schema (lambda () ,@form) 36 | :strict ,strict :if-not-exist ,if-not-exist :drop-after ,drop-after)) 37 | 38 | (defun do-with-schema (schema thunk &key strict if-not-exist drop-after) 39 | (let ((old-search-path (get-search-path))) 40 | (unwind-protect 41 | (progn 42 | (unless (schema-exists-p schema) 43 | (if (eq if-not-exist :create) 44 | (create-schema schema) 45 | (error 'database-error :message 46 | (format nil "Schema '~a' does not exist." schema)))) 47 | (set-search-path (if strict (to-sql-name schema t) 48 | (concatenate 'string (to-sql-name schema t) 49 | "," 50 | old-search-path))) 51 | (setf *schema-path* (get-search-path)) 52 | (funcall thunk)) 53 | (set-search-path old-search-path) 54 | (setf *schema-path* old-search-path) 55 | (when drop-after (drop-schema schema :cascade 't))))) 56 | 57 | (defun get-search-path () 58 | "Returns the default schema search path for the current session." 59 | (query "SHOW search_path" :single)) 60 | 61 | (defun set-search-path (path) 62 | "This changes the postgresql runtime parameter controlling what order schemas 63 | are searched. You can always use fully qualified names [schema.table]. By 64 | default, this function only changes the search path for the current 65 | session. This function is used by with-schema." 66 | (execute (format nil "SET search_path TO ~a" path))) 67 | 68 | (defun list-schemas () 69 | "List schemas in the current database, excluding the pg_* system schemas. 70 | Should have the same result as list-schemata even though it uses different 71 | system tables." 72 | (alexandria:flatten 73 | (query (:order-by 74 | (:select 'nspname 75 | :from 'pg_namespace 76 | :where (:!~* 'nspname "^pg_.*|information_schema")) 77 | 'nspname)))) 78 | 79 | (defun schema-exists-p (name) 80 | "Tests for the existence of a given schema. Returns T if the schema exists or 81 | nil otherwise. The name provided can be either a string or quoted symbol." 82 | (query (:select (:exists (:select 'schema_name 83 | :from 'information_schema.schemata 84 | :where (:= 'schema_name '$1)))) 85 | (to-sql-name name) 86 | :single)) 87 | 88 | (defun create-schema (schema &optional authorization) 89 | "Create a new schema. Raises an error if the schema already exists. If the 90 | optional authorization parameter is provided, the schema will be owned by that 91 | role." 92 | (if authorization 93 | (execute (format nil "create schema ~a authorization ~a" 94 | (to-sql-name schema t) authorization)) 95 | (execute (format nil "create schema ~a" (to-sql-name schema t))))) 96 | 97 | (defun drop-schema (schema &key (if-exists nil) (cascade nil)) 98 | "Drops an existing database schema 'schema' Accepts :if-exists and/or :cascade 99 | arguments like :drop-table. A notice instead of an error is raised with the 100 | is-exists parameter." 101 | (execute (format nil "DROP SCHEMA ~:[~;IF EXISTS~] ~a ~:[~;CASCADE~]" 102 | if-exists (to-sql-name schema t) cascade))) 103 | -------------------------------------------------------------------------------- /cl-postgres.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; -*- 2 | 3 | (defpackage :cl-postgres-system 4 | (:use :common-lisp :asdf)) 5 | (in-package :cl-postgres-system) 6 | 7 | ;; Change this to enable/disable unicode manually (mind that it won't 8 | ;; work unless your implementation supports it). 9 | (defparameter *unicode* 10 | #+(or sb-unicode unicode ics openmcl-unicode-strings abcl) t 11 | #-(or sb-unicode unicode ics openmcl-unicode-strings abcl) nil) 12 | (defparameter *string-file* (if *unicode* "strings-utf-8" "strings-ascii")) 13 | 14 | (defsystem "cl-postgres" 15 | :description "Low-level client library for PostgreSQL" 16 | :author "Marijn Haverbeke " 17 | :maintainer "Sabra Crolleton " 18 | :license "zlib" 19 | :version "1.33.11" 20 | :depends-on ("md5" "split-sequence" "ironclad" "cl-base64" "uax-15" 21 | (:feature (:or :allegro :ccl :clisp :genera 22 | :armedbear :cmucl :lispworks :ecl) 23 | "usocket") 24 | (:feature :sbcl (:require :sb-bsd-sockets))) 25 | :components 26 | ((:module "cl-postgres" 27 | :components ((:file "package") 28 | (:file "features") 29 | (:file "config") 30 | (:file "oid" :depends-on ("package" "config")) 31 | (:file "errors" :depends-on ("package")) 32 | (:file "data-types" :depends-on ("package" "config")) 33 | (:file "sql-string" :depends-on ("package" "config" "data-types")) 34 | (:file "trivial-utf-8" :depends-on ("package" "config")) 35 | (:file #.*string-file* 36 | :depends-on ("package" "trivial-utf-8" "config")) 37 | (:file "communicate" 38 | :depends-on (#.*string-file* "sql-string" "config")) 39 | (:file "messages" :depends-on ("communicate" "config")) 40 | (:file "ieee-floats" :depends-on ("config")) 41 | (:file "interpret" 42 | :depends-on ("oid" "communicate" "ieee-floats" "config")) 43 | (:file "saslprep" :depends-on ("package" "config")) 44 | (:file "scram" 45 | :depends-on ("package" "messages" "errors" "saslprep" 46 | "trivial-utf-8" "config")) 47 | (:file "protocol" 48 | :depends-on ("package" "interpret" "messages" "errors" "scram" 49 | "saslprep" "trivial-utf-8" "config")) 50 | (:file "public" :depends-on ("package" "protocol" "features" "config")) 51 | (:file "bulk-copy" 52 | :depends-on ("package" "public" "trivial-utf-8"))))) 53 | :in-order-to ((test-op (test-op "cl-postgres/tests") 54 | (test-op "cl-postgres/simple-date-tests")))) 55 | 56 | (defsystem "cl-postgres/tests" 57 | :depends-on ("cl-postgres" "fiveam" "uiop" "trivial-octet-streams") 58 | :components 59 | ((:module "cl-postgres/tests" 60 | :components ((:file "test-package") 61 | (:file "tests" :depends-on ("test-package")) 62 | (:file "test-binary-parameters" :depends-on ("test-package" "tests")) 63 | (:file "test-oids" :depends-on ("test-package" "tests")) 64 | (:file "test-ieee-float" :depends-on ("test-package" "tests")) 65 | (:file "test-clp-utf8" :depends-on ("test-package" "tests")) 66 | (:file "test-data-types" :depends-on ("test-package" "tests")) 67 | (:file "test-communicate" :depends-on ("test-package" "tests")) 68 | (:file "tests-scram" :depends-on ("test-package" "tests")) 69 | (:file "tests-saslprep" :depends-on ("test-package"))))) 70 | 71 | :perform (test-op (o c) 72 | (uiop:symbol-call :cl-postgres-tests '#:prompt-connection) 73 | (uiop:symbol-call :fiveam '#:run! :cl-postgres))) 74 | 75 | (defsystem "cl-postgres/simple-date-tests" 76 | :depends-on ("cl-postgres" "cl-postgres/tests" "fiveam" "simple-date" 77 | "simple-date/postgres-glue") 78 | :components 79 | ((:module "cl-postgres/tests" 80 | :components ((:file "test-package") 81 | (:file "simple-date-tests")))) 82 | :perform (test-op (o c) 83 | (uiop:symbol-call :cl-postgres-simple-date-tests 84 | '#:prompt-connection) 85 | (uiop:symbol-call :fiveam '#:run! :cl-postgres-simple-date))) 86 | 87 | #| 88 | ;; The definitions below should work, unlike the bogus method they replace; 89 | ;; but I recommend instead explicit dependency on simple-date/postgres-glue. 90 | (load-system "asdf-system-connections") 91 | (defsystem-connection "postgres/with-simple-date" 92 | :requires ("simple-date" "cl-postgres") 93 | :depends-on ("simple-date/postgres-glue")) 94 | |# 95 | -------------------------------------------------------------------------------- /simple-date/tests.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: SIMPLE-DATE-TESTS; -*- 2 | (in-package :simple-date-tests) 3 | 4 | ;; After loading the file, run the tests with (fiveam:run! :simple-date) 5 | 6 | (def-suite :simple-date) 7 | (in-suite :simple-date) 8 | 9 | (test days-in-month 10 | ;; Note: internal date numbers, so 0 is March 11 | (is (= 31 (simple-date::days-in-month 0 2000))) 12 | (is (= 30 (simple-date::days-in-month 1 2000))) 13 | (is (= 31 (simple-date::days-in-month 2 2000))) 14 | (is (= 30 (simple-date::days-in-month 3 2000))) 15 | (is (= 31 (simple-date::days-in-month 4 2000))) 16 | (is (= 31 (simple-date::days-in-month 5 2000))) 17 | (is (= 30 (simple-date::days-in-month 6 2000))) 18 | (is (= 31 (simple-date::days-in-month 7 2000))) 19 | (is (= 30 (simple-date::days-in-month 8 2000))) 20 | (is (= 31 (simple-date::days-in-month 9 2000))) 21 | (is (= 31 (simple-date::days-in-month 10 2000))) 22 | (is (= 28 (simple-date::days-in-month 11 2001)))) 23 | 24 | (defmacro with-random-dates (amount &body body) 25 | (let ((i (gensym))) 26 | `(dotimes (,i ,amount) 27 | (let ((year (+ 1900 (random 300))) 28 | (month (1+ (random 12))) 29 | (day (1+ (random 28))) 30 | (hour (random 24)) 31 | (min (random 60)) 32 | (sec (random 60)) 33 | (millisec (random 1000))) 34 | ,@body)))) 35 | 36 | (test encode-date 37 | (with-random-dates 100 38 | (declare (ignore hour min sec millisec)) 39 | (multiple-value-bind (year* month* day*) (decode-date (encode-date year month day)) 40 | (is (and (= year* year) 41 | (= month* month) 42 | (= day* day)))))) 43 | 44 | (test leap-year 45 | (flet ((test-date (y m d) 46 | (multiple-value-bind (y2 m2 d2) (decode-date (encode-date y m d)) 47 | (and (= y y2) (= m m2) (= d d2))))) 48 | (is (test-date 2000 2 29)) 49 | (is (test-date 2004 2 29)) 50 | (is (test-date 2108 2 29)) 51 | (is (test-date 1992 2 29)))) 52 | 53 | (test encode-timestamp 54 | (with-random-dates 100 55 | (multiple-value-bind (year* month* day* hour* min* sec* millisec*) 56 | (decode-timestamp (encode-timestamp year month day hour min sec millisec)) 57 | (is (and (= year* year) 58 | (= month* month) 59 | (= day* day) 60 | (= hour* hour) 61 | (= min* min) 62 | (= sec* sec) 63 | (= millisec* millisec)))))) 64 | 65 | (test timestamp-universal-times 66 | (with-random-dates 100 67 | (declare (ignore millisec)) 68 | (let ((stamp (encode-timestamp year month day hour min sec 0)) 69 | (utime (encode-universal-time sec min hour day month year 0))) 70 | (is (= (timestamp-to-universal-time stamp) utime)) 71 | (is (time= (universal-time-to-timestamp utime) stamp))))) 72 | 73 | (test add-month 74 | (with-random-dates 100 75 | (multiple-value-bind (year* month* day* hour* min* sec* millisec*) 76 | (decode-timestamp (time-add (encode-timestamp year month day hour min sec millisec) 77 | (encode-interval :month 1))) 78 | (is (and (or (and (= year* year) (= month* (1+ month))) 79 | (and (= year* (1+ year)) (= month* 1))) 80 | (= day* day) 81 | (= hour* hour) 82 | (= min* min) 83 | (= sec* sec) 84 | (= millisec* millisec)))))) 85 | 86 | (test subtract-month 87 | (with-random-dates 100 88 | (multiple-value-bind (year* month* day* hour* min* sec* millisec*) 89 | (decode-timestamp (time-add (encode-timestamp year month day hour min sec millisec) 90 | (encode-interval :month -1))) 91 | (is (and (or (and (= year* year) (= month* (1- month))) 92 | (and (= year* (1- year)) (= month* 12))) 93 | (= day* day) 94 | (= hour* hour) 95 | (= min* min) 96 | (= sec* sec) 97 | (= millisec* millisec)))))) 98 | 99 | (test add-hour 100 | (with-random-dates 100 101 | (declare (ignore millisec)) 102 | (is (= (- (timestamp-to-universal-time (time-add (encode-timestamp year month day hour min sec 0) 103 | (encode-interval :hour 1))) 104 | (encode-universal-time sec min hour day month year 0)) 105 | 3600)))) 106 | 107 | (test time< 108 | (with-random-dates 100 109 | (is (time< (encode-date year month day) 110 | (encode-date (1+ year) month day))) 111 | (is (time< (encode-timestamp year month day hour min sec millisec) 112 | (encode-timestamp year month day hour min (1+ sec) millisec))) 113 | (is (time< (encode-interval :month month :hour hour) 114 | (encode-interval :month month :hour hour :minute 30))))) 115 | -------------------------------------------------------------------------------- /doc/s-sql-p.org: -------------------------------------------------------------------------------- 1 | #+TITLE: S-SQL Examples P 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | * [[file:s-sql-examples.org][S-SQL Examples Home Page]] 8 | | [[file:s-sql-a.org][A]]| [[file:s-sql-b.org][B]]| [[file:s-sql-c.org][C]]| [[file:s-sql-d.org][D]]| [[file:s-sql-e.org][E]]| [[file:s-sql-f.org][F]]| [[file:s-sql-g.org][G]]| [[file:s-sql-h.org][H]]| [[file:s-sql-i.org][I]]| [[file:s-sql-j.org][J]]| [[file:s-sql-k.org][K]]| [[file:s-sql-l.org][L]]| [[file:s-sql-m.org][M]]| [[file:s-sql-n.org][N]]| [[file:s-sql-o.org][O]]| [[file:s-sql-p.org][P]]| [[file:s-sql-r.org][R]]| [[file:s-sql-s.org][S]]| [[file:s-sql-t.org][T]]| [[file:s-sql-u.org][U]]| [[file:s-sql-v.org][V]]| [[file:s-sql-w.org][W]]| [[file:s-sql-special-characters.org][Special Characters]] | [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]]| 9 | 10 | * Parameterized Statements 11 | :PROPERTIES: 12 | :CUSTOM_ID: parameterized 13 | :END: 14 | Parameterized statements help protect against sql injection and some of the examples above have used parameterized statement forms. You can't parameterize table names, column names or sql keywords. So if you are getting those from the user, you definitely need to sanitize the input. Parameterized statements also don't protect against other things like cross-script attacks, so you still need to sanitize input. 15 | 16 | The following is a simple parameterized query and a prepared statement using parameters. First, the pure sql version 17 | #+begin_src lisp 18 | (query "select name from countries where name=$1" 19 | "France" :single) 20 | #+end_src 21 | 22 | Now the s-sql version: 23 | #+begin_src lisp 24 | (query (:select 'id :from 'countries :where (:= 'name '$1)) 25 | "France" :single) 26 | #+end_src 27 | 28 | Now the simple prepared statement version in standard sql and s-sql: 29 | #+begin_src lisp 30 | (defprepared test21 "select name from countries where id=$1") 31 | 32 | (test21 5) 33 | 34 | ("Denmark") 35 | #+end_src 36 | Now the s-sql version 37 | #+begin_src lisp 38 | (defprepared test22 39 | (:select 'name 40 | :from 'countries 41 | :where (:= 'id '$1))) 42 | 43 | (test22 5) 44 | 45 | ("Denmark") 46 | #+end_src 47 | Now let's change the simple version to one where you want to give it a list. We are going to use the :column parameter to indicate we just want a single list of all the country names found with the select statement. 48 | #+begin_src lisp 49 | (defprepared test23 "select name from countries where id=any($1)" 50 | :column) 51 | 52 | (test23 '(21 6 5)) 53 | 54 | ("EU" "Denmark" "US") 55 | #+end_src 56 | You also get the same result if you pass a vector instead of a list. 57 | #+begin_src lisp 58 | (test23 59 | (vector 21 6 5)) 60 | 61 | ("EU" "Denmark" "US") 62 | #+end_src 63 | 64 | You cannot use a list or vector with the sql keyword "in". E.g. 65 | #+begin_src lisp 66 | (query "select name from countries where id in $1" '(21 20)) 67 | 68 | Evaluation aborted on #. 69 | 70 | #+end_src 71 | 72 | You can, however, use a list or a vector with the keyword any. E.g. 73 | #+begin_src lisp 74 | (query "select name from countries where id = any($1)" 75 | (coerce '(21 20) 'vector) 76 | :column) 77 | 78 | ("UK" "US") 79 | 80 | (query "select name from countries where id = any($1)" 81 | '(21 20) ) 82 | 83 | ("UK" "US") 84 | #+end_src 85 | 86 | Now the s-sql version. Note the change for any to any* 87 | #+begin_src lisp 88 | (query (:select 'name 89 | :from 'countries 90 | :where (:= 'id (:any* '$1))) 91 | '(21 20) :column) 92 | 93 | ("UK" "US") 94 | 95 | (query (:select 'name 96 | :from 'countries 97 | :where (:= 'id (:any* '$1))) 98 | (vector 21 20) :column) 99 | 100 | ("UK" "US") 101 | #+end_src 102 | 103 | * Partition-by 104 | :PROPERTIES: 105 | :CUSTOM_ID: partition-by 106 | :END: 107 | Partition-by is not table partitioning. Rather it is a clause that allows you to set the range of records that will be used for each group within an over clause. Consider it a windowing function. Partition-by is available in Postmodern as of the Oct 29, 2013 git version. 108 | 109 | Important: Note use of :order-by without being the function call at the beginning of a form. 110 | #+begin_src lisp 111 | (query (:select 'depname 'empno 'salary 112 | (:over (:avg 'salary) 113 | (:partition-by 'depname)) 114 | :from 'empsalary)) 115 | 116 | (query (:select 'depname 'empno 'salary 117 | (:over (:rank) 118 | (:partition-by 'depname :order-by (:desc 'salary))) 119 | :from 'empsalary)) 120 | #+end_src 121 | -------------------------------------------------------------------------------- /simple-date/cl-postgres-glue.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: SIMPLE-DATE-CL-POSTGRES-GLUE; -*- 2 | (in-package :simple-date-cl-postgres-glue) 3 | 4 | (defparameter *simple-date-sql-readtable* 5 | (cl-postgres:copy-sql-readtable)) 6 | 7 | ;; PostgreSQL days are measured from 01-01-2000, whereas simple-date 8 | ;; uses 01-03-2000. 9 | 10 | (defconstant +postgres-day-offset+ -60) 11 | (defconstant +usecs-in-one-day+ (* 1000 1000 3600 24)) 12 | 13 | (flet ((interpret-timestamp (usecs) 14 | (multiple-value-bind (days usecs) (floor usecs +usecs-in-one-day+) 15 | (make-instance 'timestamp :days (+ days +postgres-day-offset+) 16 | :ms (floor usecs 1000))))) 17 | (cl-postgres:set-sql-datetime-readers 18 | :date (lambda (days) 19 | (make-instance 'date :days (+ days +postgres-day-offset+))) 20 | :timestamp #'interpret-timestamp 21 | :timestamp-with-timezone #'interpret-timestamp 22 | :interval (lambda (months days usecs) 23 | (make-instance 'interval :months months 24 | :ms (floor (+ (* days +usecs-in-one-day+) usecs) 1000))) 25 | :time (lambda (usecs) 26 | (multiple-value-bind (seconds usecs) 27 | (floor usecs 1000000) 28 | (multiple-value-bind (minutes seconds) 29 | (floor seconds 60) 30 | (multiple-value-bind (hours minutes) 31 | (floor minutes 60) 32 | (make-instance 'time-of-day 33 | :hours hours 34 | :minutes minutes 35 | :seconds seconds 36 | :microseconds usecs))))) 37 | :table *simple-date-sql-readtable*)) 38 | 39 | (defmethod cl-postgres:to-sql-string ((arg date)) 40 | (multiple-value-bind (year month day) (decode-date arg) 41 | (values (format nil "~4,'0d-~2,'0d-~2,'0d" year month day) "date"))) 42 | 43 | (defmethod cl-postgres:to-sql-string ((arg timestamp)) 44 | (multiple-value-bind (year month day hour min sec ms) (decode-timestamp arg) 45 | (values 46 | (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d~@[.~3,'0d~]" 47 | year month day hour min sec (if (zerop ms) nil ms)) 48 | "timestamp"))) 49 | 50 | (defmethod cl-postgres:to-sql-string ((arg interval)) 51 | (multiple-value-bind (year month day hour min sec ms) (decode-interval arg) 52 | (if (= year month day hour min sec ms 0) 53 | (values "0 milliseconds" "interval") 54 | (flet ((not-zero (x) (if (zerop x) nil x))) 55 | (values 56 | (format nil "~@[~d years ~]~@[~d months ~]~@[~d days ~]~@[~d hours ~]~@[~d minutes ~]~@[~d seconds ~]~@[~d milliseconds~]" 57 | (not-zero year) (not-zero month) (not-zero day) 58 | (not-zero hour) (not-zero min) (not-zero sec) (not-zero ms)) 59 | "interval"))))) 60 | 61 | (defmethod cl-postgres:to-sql-string ((arg time-of-day)) 62 | (with-accessors ((hours hours) 63 | (minutes minutes) 64 | (seconds seconds) 65 | (microseconds microseconds)) 66 | arg 67 | (format nil "~2,'0d:~2,'0d:~2,'0d~@[.~6,'0d~]" 68 | hours minutes seconds (if (zerop microseconds) nil microseconds)))) 69 | 70 | (defmethod s-sql::to-s-sql-string ((arg date)) 71 | (multiple-value-bind (year month day) (decode-date arg) 72 | (values (format nil "~4,'0d-~2,'0d-~2,'0d" year month day) "date"))) 73 | 74 | (defmethod s-sql::to-s-sql-string ((arg timestamp)) 75 | (multiple-value-bind (year month day hour min sec ms) (decode-timestamp arg) 76 | (values 77 | (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d~@[.~3,'0d~]" 78 | year month day hour min sec (if (zerop ms) nil ms)) 79 | "timestamp"))) 80 | 81 | (defmethod s-sql::to-s-sql-string ((arg interval)) 82 | (multiple-value-bind (year month day hour min sec ms) (decode-interval arg) 83 | (if (= year month day hour min sec ms 0) 84 | (values "0 milliseconds" "interval") 85 | (flet ((not-zero (x) (if (zerop x) nil x))) 86 | (values 87 | (format nil "~@[~d years ~]~@[~d months ~]~@[~d days ~]~@[~d hours ~]~@[~d minutes ~]~@[~d seconds ~]~@[~d milliseconds~]" 88 | (not-zero year) (not-zero month) (not-zero day) 89 | (not-zero hour) (not-zero min) (not-zero sec) (not-zero ms)) 90 | "interval"))))) 91 | 92 | (defmethod s-sql::to-s-sql-string ((arg time-of-day)) 93 | (with-accessors ((hours hours) 94 | (minutes minutes) 95 | (seconds seconds) 96 | (microseconds microseconds)) 97 | arg 98 | (format nil "~2,'0d:~2,'0d:~2,'0d~@[.~6,'0d~]" 99 | hours minutes seconds (if (zerop microseconds) nil microseconds)))) 100 | 101 | ;; 102 | ;; install a copy of the readtable we just modified, leaving our 103 | ;; readtable safe from further modification, for better or worse. 104 | (setf cl-postgres:*sql-readtable* 105 | (cl-postgres:copy-sql-readtable *simple-date-sql-readtable*)) 106 | 107 | (defun simple-date-sql-readtable () 108 | "An sql-readtable that has the simple-date-cl-postgres-glue reader 109 | functions installed." 110 | *simple-date-sql-readtable*) 111 | -------------------------------------------------------------------------------- /cl-postgres/saslprep.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES; -*- 2 | (in-package :cl-postgres) 3 | 4 | (defvar *printable-ascii-chars* '(#\ #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* 5 | #\+ #\, #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5 6 | #\6 #\7 #\8 #\9 #\: #\; #\< #\= #\> #\? #\@ 7 | #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K 8 | #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V 9 | #\W #\X #\Y #\Z #\[ #\\ #\] #\^ #\_ #\` #\a 10 | #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l 11 | #\m #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w 12 | #\x #\y #\z #\{ #\| #\} #\~)) 13 | 14 | (define-condition bad-char-error (error) 15 | ((message 16 | :initarg :message 17 | :accessor bad-char-error-message 18 | :initform nil 19 | :documentation "Text message indicating what went wrong with the validation.") 20 | (value 21 | :initarg :value 22 | :accessor bad-char-error-value 23 | :initform nil 24 | :documentation "The value of the field for which the error is signalled.") 25 | (normalization-form 26 | :initarg :normalization-form 27 | :accessor bad-char-error-normalization-form 28 | :initform nil 29 | :documentation "The normalization form for the error was signalled."))) 30 | 31 | (defmethod print-object ((object bad-char-error) stream) 32 | (print-unreadable-object (object stream :type t :identity t) 33 | (format stream "~@[L~A ~]~S~@[: ~S~]" 34 | (bad-char-error-normalization-form object) 35 | (bad-char-error-message object) 36 | (bad-char-error-value object)))) 37 | 38 | (defun bad-char-error (message &key value normalization-form) 39 | (error 'bad-char-error 40 | :message message 41 | :value value 42 | :normalization-form normalization-form)) 43 | 44 | (defun char-printable-ascii-p (ch) 45 | "Returns t if the char is printable ascii." 46 | (member ch *printable-ascii-chars*)) 47 | 48 | (defun string-printable-ascii-p (str) 49 | "Returns t if every character in the string is printable ascii." 50 | (every #'char-printable-ascii-p str)) 51 | 52 | (defun code-point-printable-ascii-p (int) 53 | "Returns t if the int is a printable ascii code-point." 54 | (and (>= int 32) 55 | (<= int 126))) 56 | 57 | (defun char-mapped-to-nothing-p (chr) 58 | "Returns t if the character should be mapped to nothing per RFC 3454 59 | Table B.1 and RFC 4013" 60 | (when (not (or (characterp chr) (integerp chr))) 61 | (bad-char-error "Passing unknown type data to char-mapped-to-nothing-p" 62 | :value chr)) 63 | (let ((chr-code-point (if (integerp chr) (coerce chr 'fixnum) 64 | (char-code chr)))) 65 | (declare (optimize speed) 66 | (integer chr-code-point)) 67 | (or (member chr-code-point '(#x00AD #x1806 #x200B #x2060 #xFEFF #x034F 68 | #x180B #x180C #x180D #x200C #x200D)) 69 | (and (>= chr-code-point #xFE00) (<= chr-code-point #xFE0F))))) 70 | 71 | (defun char-mapped-to-space-p (chr) 72 | "If character is mapped to space per RFC 3454 Table C.1.2 and RFC 4013, then 73 | return t, else nil" 74 | (when (not (or (characterp chr) (integerp chr))) 75 | (bad-char-error "Passing unknown type data to char-mapped-to-space-p" 76 | :value chr)) 77 | (let ((chr-code-point (if (integerp chr) (coerce chr 'fixnum) 78 | (char-code chr)))) 79 | (declare (optimize speed) 80 | (integer chr-code-point)) 81 | (or (member chr-code-point '(#x00A0 #x1680 #x202F #x205F #x3000)) 82 | (and (>= chr-code-point #x2000) (<= chr-code-point #x200B))))) 83 | 84 | (defun string-mapped-to-nothing (str) 85 | "Reads a string and removes any character that should be mapped to nothing per 86 | RFC 3454 and RFC 4013." 87 | (let ((s1 (coerce str 'simple-vector)) 88 | (lst nil)) 89 | (loop for x across s1 counting x into y do 90 | (cond ((char-mapped-to-nothing-p x)) 91 | ((characterp x) 92 | (push x lst)) 93 | (t (return-from string-mapped-to-nothing)))) 94 | (setf lst (nreverse lst)) 95 | (format nil "~{~A~}" lst))) 96 | 97 | (defun string-mapped-to-space (str) 98 | "Reads a string and converts any character which should be mapped to a space 99 | pre RFC 3454 and RFC 4013 to a space." 100 | (let ((s1 (coerce str 'simple-vector))) 101 | (loop for x across s1 for y from 0 do 102 | (when (char-mapped-to-space-p x) 103 | (setf (aref s1 y) #\Space))) 104 | (coerce s1 'string))) 105 | 106 | (defun saslprep-normalize (str &optional (form :nfkc)) 107 | "Scans string. If any character should be mapped to nothing, it eliminates 108 | that character. If any character is not printable ascii, it returns nil. If 109 | every character remaining after eliminations is printable ascii, it returns the 110 | printable-ascii string. It then calls (uax-15:normalize str form) to normalize 111 | the string based on the provided unicode form, defaulting to :nfkc." 112 | (when (string-printable-ascii-p str) 113 | (return-from saslprep-normalize str)) 114 | (setf str (string-mapped-to-nothing str)) 115 | (setf str (string-mapped-to-space str)) 116 | (setf str (uax-15:normalize str form))) 117 | -------------------------------------------------------------------------------- /doc/s-sql-s.org: -------------------------------------------------------------------------------- 1 | #+TITLE: S-SQL Examples S 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | * [[file:s-sql-examples.org][S-SQL Examples Home Page]] 8 | | [[file:s-sql-a.org][A]]| [[file:s-sql-b.org][B]]| [[file:s-sql-c.org][C]]| [[file:s-sql-d.org][D]]| [[file:s-sql-e.org][E]]| [[file:s-sql-f.org][F]]| [[file:s-sql-g.org][G]]| [[file:s-sql-h.org][H]]| [[file:s-sql-i.org][I]]| [[file:s-sql-j.org][J]]| [[file:s-sql-k.org][K]]| [[file:s-sql-l.org][L]]| [[file:s-sql-m.org][M]]| [[file:s-sql-n.org][N]]| [[file:s-sql-o.org][O]]| [[file:s-sql-p.org][P]]| [[file:s-sql-r.org][R]]| [[file:s-sql-s.org][S]]| [[file:s-sql-t.org][T]]| [[file:s-sql-u.org][U]]| [[file:s-sql-v.org][V]]| [[file:s-sql-w.org][W]]| [[file:s-sql-special-characters.org][Special Characters]] | [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]]| 9 | 10 | * Set 11 | :PROPERTIES: 12 | :CUSTOM_ID: set 13 | :END: 14 | Often I need to get a list of results where a query is in a particular set. The following would be the syntax in postmodern sql where the set is a list. If you want to use a vector, then you need to use Any: 15 | 16 | The following are equivalent 17 | #+begin_src lisp 18 | (query (:select 'name 19 | :from 'countries 20 | :where (:in 'id 21 | (:set 20 21 23)))) 22 | 23 | (let ((x (list 20 21 23))) 24 | (query (:select 'name 25 | :from 'countries 26 | :where (:in 'id 27 | (:set x))))) 28 | 29 | (query (:select 'name 30 | :from 'countries 31 | :where (:in 'id (:set (list 20 21 23))))) 32 | #+end_src 33 | ** Quoted lists 34 | Replacing (list 20 21 23) with '(20 21 23) within the query will not work. Postgresql will throw a syntax error. (We have not worked out all the bugs). 35 | #+begin_src lisp 36 | (query (:select 'name 37 | :from 'countries 38 | :where (:in 'id 39 | (:set '(20 21 23))))) 40 | 41 | ERROR 42 | #+end_src 43 | Solution: Pass it in as a variable. 44 | #+begin_src lisp 45 | (let ((ids '(20 21 23))) 46 | (query (:select 'name 47 | :from 'countries 48 | :where (:in 'id 49 | (:set ids))))) 50 | #+end_src 51 | Now with selecting a dao 52 | #+begin_src lisp 53 | (select-dao 'countries 54 | (:in 'id 55 | (:set (list 20 21 23)))) 56 | 57 | (# # #) 58 | #+end_src 59 | 60 | Now with selecting from a vector. Note both the use of any* and := instead of :in. 61 | #+begin_srcbbbb lisp 62 | (let ((x (vector 20 21 23))) 63 | (query (:select 'name 64 | :from 'countries 65 | :where (:= 'id (:any* x))))) 66 | 67 | (("Greece") ("US") ("UK")) 68 | #+end_src 69 | 70 | Note that the responses are still coming back in a list of lists 71 | 72 | * SQL-type-name 73 | :PROPERTIES: 74 | :CUSTOM_ID: sql-type-name 75 | :END: 76 | sql-type-name is an exported generic method that allows you to define how some lisp type gets declared in sql terms that Postgresql can understand. Some examples for the built-in methods already provided will convert: 77 | 78 | | Lisp sample | SQL Conversion | 79 | | 'float | "REAL" | 80 | | '(string "5") | "(CHAR(5)" | 81 | | '(string 5) | "(CHAR(5)" | 82 | | 'double-float | "DOUBLE PRECISION" | 83 | | '(numeric 3 2) | "NUMERIC(3, 2)" | 84 | | 'some-symbol | "SOME_SYMBOL" | 85 | | 'timestamp-with-time-zone | "TIMESTAMP WITH TIME ZONE" | 86 | | 'timestamp-without-time-zone | "TIMESTAMP WITHOUT TIME ZONE" | 87 | 88 | This function gets called by other operators such :create-table and :alter-table. If you need to create a conversion for e.g. some custom type for a Postgresql extension, then your method might look something like this: 89 | #+begin_src lisp 90 | (defmethod s-sql:sql-type-name ((lisp-type (eql 'pgvector)) &rest args) 91 | (cond (args (format nil "VECTOR(~{~A~^, ~})" args))) 92 | (t "VECTOR(1)"))) 93 | #+end_src 94 | and then be called like this in a :create-table statement. We will use the sql function to show what the generated sql would look like: 95 | #+begin_src lisp 96 | (pomo:sql (:create-table 'items ((id :type bigserial :primary-key t) 97 | (embedding :type (pgvector 3))))) 98 | "CREATE TABLE items (id BIGSERIAL NOT NULL PRIMARY KEY , embedding VECTOR(3) NOT NULL)" 99 | #+end_src 100 | * String_agg 101 | :PROPERTIES: 102 | :CUSTOM_ID: string-agg 103 | :END: 104 | String_agg returns a string containging the values returned, separated by a delimiter. In the following example, we are searching for the name of all the regions in the regions table and we want it all returned as a single string with a delimiting comma. 105 | #+begin_src lisp 106 | (query (:select (:string_agg 'name ",") :from 'regions)) 107 | 108 | (("Central America,Middle East,North America,South America,Central Asia,Pacific,Caribbean,Eastern Europe,Western Europe,EMEA,APAC,LATAM,Emerging,US,Canada,Africa,All,Asia,Eastern Africa,Middle Africa,Northern Africa,Southern Africa,Western Africa,Oceania,Northern Europe,Southern Europe,Eastern Asia,South Central Asia,South East Asia")) 109 | 110 | #+end_src 111 | 112 | * Sum 113 | :PROPERTIES: 114 | :CUSTOM_ID: sum 115 | :END: 116 | Simple example for a sum: 117 | #+begin_src lisp 118 | (query (:select (:sum 'population) :from 'countries) 119 | :single) 120 | 121 | 14427958899 122 | #+end_src 123 | -------------------------------------------------------------------------------- /cl-postgres/bulk-copy.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES; -*- 2 | (in-package :cl-postgres) 3 | 4 | (defclass bulk-copier () 5 | ((own-connection :initarg :own-connection :reader bulk-copier-own-connection) 6 | (database :initarg :database :reader copier-database) 7 | (table :initarg :table :reader copier-table) 8 | (columns :initarg :columns :reader copier-columns) 9 | (count :initform 0 :accessor copier-count))) 10 | 11 | (defmethod print-object ((self bulk-copier) stream) 12 | (print-unreadable-object (self stream :type t :identity t) 13 | (format stream "~a ~a" (copier-table self) 14 | (copier-columns self)))) 15 | 16 | 17 | (defun open-db-writer (db-spec table columns) 18 | "Opens a table stream into which rows can be written one at a time using 19 | db-write-row. db is either a connection object or a list of arguments that 20 | could be passed to open-database. table is the name of an existing table 21 | into which this writer will write rows. If you don't have data for all 22 | columns, use columns to indicate those that you do." 23 | (let* ((own-connection (listp db-spec)) 24 | (copier (make-instance 'bulk-copier 25 | :own-connection own-connection 26 | :database (if own-connection 27 | (apply 'open-database db-spec) 28 | db-spec) 29 | :table table 30 | :columns columns))) 31 | (initialize-copier copier) 32 | copier)) 33 | 34 | (defun close-db-writer (self &key (abort nil)) 35 | "Closes a bulk writer opened by open-db-writer. Will close the associated 36 | database connection when it was created for this copier, or abort is true." 37 | (unwind-protect 38 | (let* ((connection (copier-database self)) 39 | (socket (connection-socket connection))) 40 | (with-reconnect-restart connection 41 | (using-connection connection 42 | (send-copy-done socket)))) 43 | (when (or abort (bulk-copier-own-connection self)) 44 | (close-database (copier-database self)))) 45 | (copier-count self)) 46 | 47 | (defun db-write-row (self row &optional (data (prepare-row self row))) 48 | "Writes row-data into the table and columns referenced by the writer. 49 | row-data is a list of Lisp objects, one for each column included when 50 | opening the writer. Arrays (the elements of which must all be the same type) 51 | will be serialized into their PostgreSQL representation before being written 52 | into the DB." 53 | (let* ((connection (copier-database self)) 54 | (socket (connection-socket connection))) 55 | (with-reconnect-restart connection 56 | (using-connection connection 57 | (with-syncing 58 | (copy-data-message socket data))))) 59 | (incf (copier-count self))) 60 | 61 | (defun copy-query (self) 62 | (format nil "~%copy ~a ~@[(~{~a~^,~})~] ~a ~a" 63 | (copier-table self) 64 | (copier-columns self) 65 | "FROM" 66 | "STDIN")) 67 | 68 | (defun send-copy-start (socket query) 69 | (with-syncing 70 | (query-message socket query) 71 | (flush-message socket) 72 | (force-output socket) 73 | (message-case socket 74 | ;; Ignore the field formats because we're only supporting plain 75 | ;; text for now 76 | (#\G (read-uint1 socket) 77 | (skip-bytes socket (* 2 (read-uint2 socket))))))) 78 | 79 | (defun initialize-copier (self) 80 | (let* ((query (copy-query self)) 81 | (connection (copier-database self)) 82 | (socket (connection-socket connection))) 83 | (with-reconnect-restart connection 84 | (using-connection connection 85 | (send-copy-start socket query))))) 86 | 87 | (defun copier-write-value (s val) 88 | (typecase val 89 | (string 90 | (let ((pg-string 91 | (with-output-to-string (str) 92 | (loop for byte across (cl-postgres-trivial-utf-8:string-to-utf-8-bytes val) do 93 | (case (code-char byte) 94 | (#\Space (princ " " str)) 95 | ((#\Newline #\Tab) (format str "\\~a" (code-char byte))) 96 | (#\\ (progn (princ #\\ str) (princ #\\ str))) 97 | (otherwise (if (and (< 32 byte) 98 | (> 127 byte)) 99 | (write-char (code-char byte) str) 100 | (princ (format nil "\\~o" byte) str)))))))) 101 | #+nil(print `(:loading ,pg-string)) 102 | (princ pg-string s))) 103 | (number (princ val s)) 104 | (null (princ "false" s)) 105 | (symbol 106 | (case val 107 | (:null (princ "\\N" s)) 108 | ((t) (princ "true" s)) 109 | (otherwise 110 | (error "copier-write-val: Symbols shouldn't be getting this far ~a" val)))))) 111 | 112 | (defun copier-write-sequence (s vector) 113 | (write-char #\{ s) 114 | (loop for (item . more-p) on (coerce vector 'list) 115 | do (cond 116 | ((null item) (copier-write-value s :null)) 117 | ((atom item) (copier-write-value s item)) 118 | (t (copier-write-sequence s item))) 119 | when more-p 120 | do (write-char #\, s)) 121 | (write-char #\} s)) 122 | 123 | (defmethod prepare-row (self row) 124 | (declare (ignore self)) 125 | (with-output-to-string (s) 126 | (loop for (val . more-p) on row 127 | do (progn 128 | (if (typep val '(or string 129 | (not vector))) 130 | (copier-write-value s val) 131 | (copier-write-sequence s val))) 132 | if more-p do (write-char #\Tab s) 133 | finally 134 | (write-char #\Newline s)))) 135 | 136 | (defun send-copy-done (socket) 137 | (with-syncing 138 | (setf sync-sent t) 139 | (copy-done-message socket) 140 | (force-output socket) 141 | (message-case socket 142 | (#\C (let* ((command-tag (read-str socket)) 143 | (space (position #\Space command-tag :from-end t))) 144 | (when space 145 | (parse-integer command-tag :junk-allowed t :start (1+ space)))))) 146 | (block find-ready 147 | (loop (message-case socket 148 | (#\Z (read-uint1 socket) 149 | (return-from find-ready)) 150 | (t :skip)))))) 151 | -------------------------------------------------------------------------------- /postmodern/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-USER; -*- 2 | (defpackage :postmodern 3 | (:use #-postmodern-use-mop :common-lisp 4 | #+postmodern-use-mop :closer-common-lisp 5 | :s-sql :cl-postgres) 6 | (:nicknames :pomo) 7 | 8 | #+postmodern-use-mop 9 | (:export 10 | #:dao-class #:dao-exists-p #:dao-keys #:query-dao #:select-dao #:get-dao 11 | #:define-dao-class 12 | #:fetch-defaults 13 | #:do-query-dao #:do-select-dao 14 | #:with-column-writers 15 | #:insert-dao #:update-dao #:save-dao #:save-dao/transaction #:upsert-dao 16 | #:delete-dao #:make-dao 17 | #:define-dao-finalization 18 | #:dao-table-name #:dao-table-definition 19 | #:\!dao-def #:*ignore-unknown-columns* 20 | #:class-finalized-p 21 | #:finalize-inheritance 22 | #:find-dao-column-slot 23 | #:col-type-text-p 24 | #:find-col-type) 25 | 26 | (:export 27 | #:connect 28 | #:disconnect 29 | #:reconnect 30 | #:call-with-connection 31 | #:with-connection 32 | #:*database* 33 | #:connected-p 34 | #:database-connection 35 | #:connect-toplevel 36 | #:disconnect-toplevel 37 | #:change-toplevel-database 38 | #:clear-connection-pool 39 | #:*max-pool-size* 40 | #:*default-use-ssl* 41 | #:list-connections 42 | #:connection-use-binary 43 | #:use-binary-parameters 44 | #:query 45 | #:execute 46 | #:doquery 47 | #:parse-queries 48 | #:read-queries 49 | #:execute-file 50 | #:prepare 51 | #:defprepared 52 | #:defprepared-with-names 53 | #:*current-logical-transaction* 54 | #:*isolation-level* 55 | #:with-transaction 56 | #:begin-transaction 57 | #:commit-transaction 58 | #:commit-logical-transaction 59 | #:abort-transaction 60 | #:rollback-transaction 61 | #:abort-logical-transaction 62 | #:with-savepoint 63 | #:rollback-savepoint 64 | #:release-savepoint 65 | #:with-logical-transaction 66 | #:ensure-transaction 67 | #:ensure-transaction-with-isolation-level 68 | #:abort-hooks 69 | #:commit-hooks 70 | #:retry-transaction 71 | #:deftable 72 | #:*table-name* 73 | #:*table-symbol* 74 | #:create-table 75 | #:create-all-tables 76 | #:create-package-tables 77 | #:\!index 78 | #:\!unique-index 79 | #:\!foreign 80 | #:\!unique 81 | #:set-search-path 82 | #:get-search-path 83 | #:get-database-comment 84 | #:encode-json-to-string 85 | #:load-extension 86 | #:load-uuid-extension 87 | 88 | ;; Prepared Statement Functions 89 | #:*allow-overwriting-prepared-statements* 90 | #:*enforce-parameter-types* 91 | #:prepared-statement-exists-p 92 | #:list-prepared-statements 93 | #:drop-prepared-statement 94 | #:list-postmodern-prepared-statements 95 | #:find-postmodern-prepared-statement 96 | #:find-postgresql-prepared-statement 97 | #:reset-prepared-statement 98 | #:get-pid 99 | #:cancel-backend 100 | #:terminate-backend 101 | #:get-pid-from-postmodern 102 | 103 | ;; Reduced S-SQL interface 104 | #:sql #:sql-compile 105 | #:smallint #:bigint #:numeric #:real #:double-precision 106 | #:timestamp-with-time-zone 107 | #:timestamp-without-time-zone 108 | #:serial #:serial8 109 | #:bytea #:text #:varchar 110 | #:*escape-sql-names-p* 111 | #:sql-escape-string 112 | #:sql-escape 113 | #:register-sql-operators 114 | #:sql-error 115 | #:from-sql-name 116 | #:to-sql-name 117 | #:db-null 118 | 119 | ;; Condition type from cl-postgres 120 | #:database-error 121 | #:database-error-message 122 | #:database-error-code 123 | #:database-error-detail 124 | #:database-error-query 125 | #:database-error-cause 126 | #:database-connection-error 127 | #:database-error-constraint-name 128 | #:database-error-extract-name 129 | 130 | ;; Utility Functions 131 | ;; columns 132 | #:list-columns 133 | #:list-columns-with-types 134 | #:column-exists-p 135 | #:rename-column 136 | ;; constraints 137 | #:list-all-constraints 138 | #:describe-constraint 139 | #:describe-foreign-key-constraints 140 | ;; database-management 141 | #:create-database 142 | #:database-version 143 | #:postgresql-version 144 | #:current-database 145 | #:num-records-in-database 146 | #:database-exists-p 147 | #:database-size 148 | #:drop-database 149 | #:list-databases 150 | #:list-templates 151 | #:list-available-collations 152 | #:list-database-access-rights 153 | #:find-comments 154 | 155 | ;; extensions 156 | #:list-available-extensions 157 | #:list-installed-extensions 158 | ;; functions 159 | #:list-database-functions 160 | ;; indices 161 | #:list-indices 162 | #:index-exists-p 163 | #:create-index 164 | #:drop-index 165 | #:list-table-indices 166 | #:list-indexed-column-and-attributes 167 | #:list-index-definitions 168 | ;; keys 169 | #:list-foreign-keys 170 | #:list-unique-or-primary-constraints 171 | #:find-primary-key-info 172 | #:find-primary-key-column 173 | ;; roles 174 | #:list-roles 175 | #:list-role-permissions 176 | #:role-exists-p 177 | #:create-role 178 | #:drop-role 179 | #:alter-role-search-path 180 | #:change-password 181 | #:grant-role-permissions 182 | #:grant-readonly-permissions 183 | #:grant-editor-permissions 184 | #:grant-admin-permissions 185 | #:revoke-all-on-table 186 | #:list-role-accessible-databases 187 | 188 | #:list-database-users ;deprecated 189 | 190 | ;; schemas 191 | #:list-schemata ; 192 | #:list-schemas 193 | #:create-schema 194 | #:drop-schema 195 | #:with-schema 196 | #:schema-exists-p 197 | #:get-schema-comment 198 | ;; sequences 199 | #:sequence-next 200 | #:list-sequences 201 | #:sequence-exists-p 202 | #:create-sequence 203 | #:drop-sequence 204 | ;; tables 205 | #:list-tables 206 | #:list-all-tables 207 | #:table-exists-p 208 | #:table-description 209 | #:table-description-plus 210 | #:table-description-menu 211 | #:table-schema-names 212 | #:list-table-sizes 213 | #:table-size 214 | #:list-tables-in-schema 215 | #:drop-table 216 | #:get-table-oid 217 | #:get-table-comment 218 | #:get-column-comments 219 | #:get-column-comment 220 | #:get-all-table-comments 221 | #:rename-table 222 | #:list-check-constraints 223 | ;; tablespaces 224 | #:list-tablespaces 225 | ;; triggers 226 | #:describe-triggers 227 | #:list-triggers 228 | #:list-detailed-triggers 229 | ;; util 230 | #:add-comment 231 | #:find-comments 232 | #:list-available-types 233 | #:cache-hit-ratio 234 | #:bloat-measurement 235 | #:unused-indexes 236 | #:check-query-performance 237 | #:coalesce 238 | #:split-fully-qualified-tablename 239 | #:postgres-array-string-to-list 240 | #:postgres-array-string-to-array 241 | #:valid-sql-identifier-p 242 | ;; views 243 | #:list-views #:view-exists-p 244 | #:describe-views)) 245 | 246 | (in-package :postmodern) 247 | -------------------------------------------------------------------------------- /cl-postgres/communicate.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES; -*- 2 | (in-package :cl-postgres) 3 | 4 | ;; These are used to synthesize reader and writer names for integer 5 | ;; reading/writing functions when the amount of bytes and the 6 | ;; signedness is known. Both the macro that creates the functions and 7 | ;; some macros that use them create names this way. 8 | (eval-when (:compile-toplevel :load-toplevel :execute) 9 | (defun integer-reader-name (bytes signed) 10 | (intern (with-standard-io-syntax 11 | (format nil "~a~a~a~a" '#:read- (if signed "" '#:u) 12 | '#:int bytes)))) 13 | (defun integer-writer-name (bytes signed) 14 | (intern (with-standard-io-syntax 15 | (format nil "~a~a~a~a" '#:write- (if signed "" '#:u) 16 | '#:int bytes))))) 17 | 18 | (defmacro integer-reader (bytes) 19 | "Create a function to read integers from a binary stream." 20 | (let ((bits (* bytes 8))) 21 | (labels ((return-form (signed) 22 | (if signed 23 | `(if (logbitp ,(1- bits) result) 24 | (dpb result (byte ,(1- bits) 0) -1) 25 | result) 26 | `result)) 27 | (generate-reader (signed) 28 | `(defun ,(integer-reader-name bytes signed) (socket) 29 | (declare (type stream socket) 30 | #.*optimize*) 31 | ,(if (= bytes 1) 32 | `(let ((result (the (unsigned-byte 8) (read-byte socket)))) 33 | (declare (type (unsigned-byte 8) result)) 34 | ,(return-form signed)) 35 | `(let ((result 0)) 36 | (declare (type (unsigned-byte ,bits) result)) 37 | ,@(loop :for byte :from (1- bytes) :downto 0 38 | :collect `(setf (ldb (byte 8 ,(* 8 byte)) 39 | result) 40 | (the (unsigned-byte 8) 41 | (read-byte socket)))) 42 | ,(return-form signed)))))) 43 | `(progn 44 | ;; This causes weird errors on SBCL in some circumstances. Disabled for now. 45 | ;; (declaim (inline ,(integer-reader-name bytes t) 46 | ;; ,(integer-reader-name bytes nil))) 47 | (declaim (ftype (function (t) (signed-byte ,bits)) 48 | ,(integer-reader-name bytes t))) 49 | ,(generate-reader t) 50 | (declaim (ftype (function (t) (unsigned-byte ,bits)) 51 | ,(integer-reader-name bytes nil))) 52 | ,(generate-reader nil))))) 53 | 54 | (defmacro integer-writer (bytes) 55 | "Create a function to write integers to a binary stream." 56 | (let ((bits (* 8 bytes))) 57 | `(progn 58 | (declaim (inline ,(integer-writer-name bytes t) 59 | ,(integer-writer-name bytes nil))) 60 | (defun ,(integer-writer-name bytes nil) (socket value) 61 | (declare (type stream socket) 62 | (type (unsigned-byte ,bits) value) 63 | #.*optimize*) 64 | ,@(if (= bytes 1) 65 | `((write-byte value socket)) 66 | (loop :for byte :from (1- bytes) :downto 0 67 | :collect `(write-byte (ldb (byte 8 ,(* byte 8)) value) 68 | socket))) 69 | (values)) 70 | (defun ,(integer-writer-name bytes t) (socket value) 71 | (declare (type stream socket) 72 | (type (signed-byte ,bits) value) 73 | #.*optimize*) 74 | ,@(if (= bytes 1) 75 | `((write-byte (ldb (byte 8 0) value) socket)) 76 | (loop :for byte :from (1- bytes) :downto 0 77 | :collect `(write-byte (ldb (byte 8 ,(* byte 8)) value) 78 | socket))) 79 | (values))))) 80 | 81 | ;; All the instances of the above that we need. 82 | 83 | (integer-reader 1) 84 | (integer-reader 2) 85 | (integer-reader 4) 86 | (integer-reader 8) 87 | 88 | (integer-writer 1) 89 | (integer-writer 2) 90 | (integer-writer 4) 91 | (integer-writer 8) 92 | 93 | (defun write-bytes (socket bytes) 94 | "Write a byte-array to a stream." 95 | (declare (type stream socket) 96 | (type (simple-array (unsigned-byte 8)) bytes) 97 | #.*optimize*) 98 | (write-sequence bytes socket)) 99 | 100 | (defun write-str (socket string) 101 | "Write a null-terminated string to a stream \(encoding it when UTF-8 102 | support is enabled.)." 103 | (declare (type stream socket) 104 | (type string string) 105 | #.*optimize*) 106 | (enc-write-string string socket) 107 | (write-uint1 socket 0)) 108 | 109 | (declaim (ftype (function (t unsigned-byte) 110 | (simple-array (unsigned-byte 8) (*))) 111 | read-bytes)) 112 | (defun read-bytes (socket length) 113 | "Read a byte array of the given length from a stream." 114 | (declare (type stream socket) 115 | (type fixnum length) 116 | #.*optimize*) 117 | (let ((result (make-array length 118 | :element-type '(unsigned-byte 8) 119 | :initial-element 0))) 120 | (read-sequence result socket) 121 | result)) 122 | 123 | (declaim (ftype (function (t) string) read-str)) 124 | (defun read-str (socket) 125 | "Read a null-terminated string from a stream. Takes care of encoding 126 | when UTF-8 support is enabled." 127 | (declare (type stream socket) 128 | #.*optimize*) 129 | (enc-read-string socket :null-terminated t)) 130 | 131 | (declaim (ftype (function (t) string) read-simple-str)) 132 | (defun read-simple-str (socket) 133 | "Read a null-terminated string from a stream. Interprets it as ASCII." 134 | (declare (type stream socket) 135 | #.*optimize*) 136 | (with-output-to-string (out) 137 | (loop :for b := (read-byte socket nil 0) :do 138 | (cond ((eq b 0) (return)) 139 | ((< b 128) (write-char (code-char b) out)))))) 140 | 141 | (defun skip-bytes (socket length) 142 | "Skip a given number of bytes in a binary stream." 143 | (declare (type stream socket) 144 | (type (unsigned-byte 32) length) 145 | #.*optimize*) 146 | (dotimes (i length) 147 | (read-byte socket))) 148 | 149 | (defun skip-str (socket) 150 | "Skip a null-terminated string." 151 | (declare (type stream socket) 152 | #.*optimize*) 153 | (loop :for char :of-type fixnum = (read-byte socket) 154 | :until (zerop char))) 155 | 156 | (defun ensure-socket-is-closed (socket &key abort) 157 | (when (open-stream-p socket) 158 | (handler-case 159 | (close socket :abort abort) 160 | (error (error) 161 | (warn "Ignoring the error which happened while trying to close 162 | PostgreSQL socket: ~A" error))))) 163 | -------------------------------------------------------------------------------- /postmodern/deftable.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: POSTMODERN; -*- 2 | (in-package :postmodern) 3 | 4 | (defvar *table-name*) 5 | (setf (documentation '*table-name* 'variable) 6 | "Used inside deftable to find the name of the table being defined.") 7 | (defvar *table-symbol*) 8 | (setf (documentation '*table-symbol* 'variable) 9 | "Used inside deftable to find the symbol naming the table being defined.") 10 | 11 | (defvar *tables* () 12 | "Unexported ordered list containing the known table definitions.") 13 | 14 | (defun add-table-definition (symbol func) 15 | (let (last-cons) 16 | (loop :for cons :on *tables* :do 17 | (when (eq (caar cons) symbol) 18 | (setf (cdar cons) func) 19 | (return-from add-table-definition (values))) 20 | (setf last-cons cons)) 21 | (if last-cons 22 | (setf (cdr last-cons) (list (cons symbol func))) 23 | (setf *tables* (list (cons symbol func))))) 24 | (values)) 25 | 26 | (defmacro deftable (name &body definitions) 27 | "Define a table. name can be either a symbol or a (symbol string) list. In the 28 | first case, the table name is derived from the symbol by S-SQL's rules, in the 29 | second case, the name is given explicitly. The body of definitions can contain 30 | anything that evaluates to a string, as well as S-SQL expressions. In this body, 31 | the variables *table-name* and *table-symbol* are bound to the relevant values. 32 | Note that the evaluation of the definition is ordered, so you will generally 33 | want to create your table first and then define indices on it." 34 | (multiple-value-bind (symbol name) 35 | (if (consp name) (values-list name) (values name (to-sql-name name nil))) 36 | (flet ((check-s-sql (form) 37 | (if (and (consp form) (keywordp (car form))) (list 'sql form) form))) 38 | `(add-table-definition 39 | ',symbol 40 | (lambda () 41 | (let ((*table-name* ,name) (*table-symbol* ',symbol)) 42 | (dolist (stat (list ,@(mapcar #'check-s-sql definitions))) 43 | (execute stat)))))))) 44 | 45 | (defun create-table (name) 46 | "Takes the name of a dao-class and creates the table identified by symbol by 47 | executing all forms in its definition as found in the *tables* list." 48 | (with-transaction () 49 | (funcall (or (cdr (assoc name *tables*)) 50 | (error "No table '~a' defined." name))) 51 | (values))) 52 | 53 | (defun create-all-tables () 54 | "Create all defined tables." 55 | (loop :for (nil . def) :in *tables* :do (funcall def))) 56 | 57 | (defun create-package-tables (package) 58 | "Create all tables whose identifying symbol is interned in the given 59 | package." 60 | (let ((package (find-package package))) 61 | (loop :for (sym . def) :in *tables* :do 62 | (when (eq (symbol-package sym) package) (funcall def))))) 63 | 64 | (defun flat-table-name (&optional (table *table-name*)) 65 | (when (symbolp table) 66 | (setf table (string-downcase (string table)))) 67 | (let ((dotpos (position #\. table))) 68 | (if dotpos 69 | (subseq table (1+ dotpos)) 70 | table))) 71 | 72 | (labels ((index-name (fields) 73 | (make-symbol (format nil "~a-~{~a~^-~}-index" (flat-table-name) 74 | fields))) 75 | (make-index (type fields) 76 | (sql-compile `(,type ,(index-name fields) :on ,*table-name* 77 | :fields ,@fields)))) 78 | (defun \!index (&rest fields) 79 | "Used inside a deftable form. Define an index on the table being 80 | defined. The columns can be given as symbols or strings." 81 | (make-index :create-index fields)) 82 | (defun \!unique-index (&rest fields) 83 | "Used inside a deftable form. Define a unique index on the defined table." 84 | (make-index :create-unique-index fields))) 85 | 86 | #+postmodern-use-mop 87 | (defun \!dao-def () 88 | "Should only be used inside a deftable form. Define this table using the 89 | corresponding DAO class' slots. Adds the result of calling dao-table-definition 90 | on *table-symbol* to the definition." 91 | (dao-table-definition *table-symbol*)) 92 | 93 | (defun \!foreign (target fields &rest target-fields/on-delete/on-update/deferrable/initially-deferred) 94 | "Used inside a deftable form. Define a foreign key on this table. Pass a table 95 | the index refers to, a list of fields or single field in *this* table, and, if 96 | the fields have different names in the table referred to, another field or list 97 | of fields for the target table, or :primary-key to indicate that the other 98 | table's primary key should be referenced." 99 | (let* ((args target-fields/on-delete/on-update/deferrable/initially-deferred) 100 | (target-fields (and args (or (not (keywordp (car args))) 101 | (eq (car args) :primary-key)) 102 | (pop args)))) 103 | (labels ((fkey-name (target fields) 104 | (to-sql-name (format nil "~a_~a_~{~a~^_~}_foreign" (flat-table-name) 105 | (flat-table-name target) 106 | fields)))) 107 | (unless (listp fields) (setf fields (list fields))) 108 | (unless (listp target-fields) (setf target-fields (list target-fields))) 109 | (let* ((target-name (to-sql-name target)) 110 | (field-names (mapcar #'to-sql-name fields)) 111 | (target-names (cond 112 | ((equal target-fields '(:primary-key)) nil) 113 | ((null target-fields) field-names) 114 | (t (mapcar #'to-sql-name target-fields))))) 115 | (format nil "ALTER TABLE ~a ADD CONSTRAINT ~a FOREIGN KEY (~{~a~^, ~}) 116 | REFERENCES ~a~@[ (~{~a~^, ~})~] ~@[ON DELETE ~a~] 117 | ~@[ON UPDATE ~a~] ~:[NOT DEFERRABLE~;DEFERRABLE INITIALLY 118 | ~:[IMMEDIATE~;DEFERRED~]~]" 119 | (to-sql-name *table-name*) 120 | (fkey-name target fields) 121 | field-names 122 | target-name target-names 123 | (s-sql::expand-foreign-on* (getf args :on-delete :restrict)) 124 | (s-sql::expand-foreign-on* (getf args :on-update :restrict)) 125 | (getf args :deferrable nil) 126 | (getf args :initially-deferred nil)))))) 127 | 128 | (defun \!unique (target-fields &key deferrable initially-deferred) 129 | "Constrains one or more columns to only contain unique (combinations of) 130 | values, with deferrable and initially-deferred defined as in !foreign" 131 | (unless (listp target-fields) (setf target-fields (list target-fields))) 132 | (format nil "ALTER TABLE ~A ADD CONSTRAINT ~A UNIQUE (~{~A~^, ~}) 133 | ~:[NOT DEFERRABLE~;DEFERRABLE INITIALLY ~:[IMMEDIATE~;DEFERRED~]~]" 134 | (to-sql-name *table-name*) 135 | (to-sql-name (format nil "~A_~{~A~^_~}_unique" *table-name* 136 | target-fields)) 137 | (mapcar #'pomo::to-sql-name target-fields) 138 | deferrable 139 | initially-deferred)) 140 | -------------------------------------------------------------------------------- /cl-postgres/ieee-floats.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES-IEEE-FLOATS; -*- 2 | (in-package :cl-postgres-ieee-floats) 3 | 4 | ;;; Functions for converting floating point numbers represented in 5 | ;;; IEEE 754 style to lisp numbers. 6 | ;;; 7 | ;;; See http://common-lisp.net/project/ieee-floats/ 8 | 9 | ;; The following macro may look a bit overcomplicated to the casual 10 | ;; reader. The main culprit is the fact that NaN and infinity can be 11 | ;; optionally included, which adds a bunch of conditional parts. 12 | ;; 13 | ;; Assuming you already know more or less how floating point numbers 14 | ;; are typically represented, I'll try to elaborate a bit on the more 15 | ;; confusing parts, as marked by letters: 16 | ;; 17 | ;; (A) Exponents in IEEE floats are offset by half their range, for 18 | ;; example with 8 exponent bits a number with exponent 2 has 129 19 | ;; stored in its exponent field. 20 | ;; 21 | ;; (B) The maximum possible exponent is reserved for special cases 22 | ;; (NaN, infinity). 23 | ;; 24 | ;; (C) If the exponent fits in the exponent-bits, we have to adjust 25 | ;; the significand for the hidden bit. Because decode-float will 26 | ;; return a significand between 0 and 1, and we want one between 1 27 | ;; and 2 to be able to hide the hidden bit, we double it and then 28 | ;; subtract one (the hidden bit) before converting it to integer 29 | ;; representation (to adjust for this, 1 is subtracted from the 30 | ;; exponent earlier). When the exponent is too small, we set it to 31 | ;; zero (meaning no hidden bit, exponent of 1), and adjust the 32 | ;; significand downward to compensate for this. 33 | ;; 34 | ;; (D) Here the hidden bit is added. When the exponent is 0, there is 35 | ;; no hidden bit, and the exponent is interpreted as 1. 36 | ;; 37 | ;; (E) Here the exponent offset is subtracted, but also an extra 38 | ;; factor to account for the fact that the bits stored in the 39 | ;; significand are supposed to come after the 'decimal dot'. 40 | 41 | (defmacro make-float-converters (encoder-name 42 | decoder-name 43 | exponent-bits 44 | significand-bits 45 | support-nan-and-infinity-p) 46 | "Writes an encoder and decoder function for floating point 47 | numbers with the given amount of exponent and significand 48 | bits (plus an extra sign bit). If support-nan-and-infinity-p is 49 | true, the decoders will also understand these special cases. NaN 50 | is represented as :not-a-number, and the infinities as 51 | :positive-infinity and :negative-infinity. Note that this means 52 | that the in- or output of these functions is not just floating 53 | point numbers anymore, but also keywords." 54 | (let* ((total-bits (+ 1 exponent-bits significand-bits)) 55 | (exponent-offset (1- (expt 2 (1- exponent-bits)))) ; (A) 56 | (sign-part `(ldb (byte 1 ,(1- total-bits)) bits)) 57 | (exponent-part `(ldb (byte ,exponent-bits ,significand-bits) bits)) 58 | (significand-part `(ldb (byte ,significand-bits 0) bits)) 59 | (nan support-nan-and-infinity-p) 60 | (max-exponent (1- (expt 2 exponent-bits)))) ; (B) 61 | `(progn 62 | (defun ,encoder-name (float) 63 | ,@(unless nan `((declare (type float float)))) 64 | (multiple-value-bind (sign significand exponent) 65 | (cond ,@(when nan `(((eq float :not-a-number) 66 | (values 0 1 ,max-exponent)) 67 | ((eq float :positive-infinity) 68 | (values 0 0 ,max-exponent)) 69 | ((eq float :negative-infinity) 70 | (values 1 0 ,max-exponent)))) 71 | ((zerop float) 72 | (values 0 0 0)) 73 | (t 74 | (multiple-value-bind (significand exponent sign) 75 | (decode-float float) 76 | (let ((exponent (+ (1- exponent) ,exponent-offset)) 77 | (sign (if (= sign 1.0) 0 1))) 78 | (unless (< exponent ,(expt 2 exponent-bits)) 79 | (error "Floating point overflow when encoding ~A." 80 | float)) 81 | (if (< exponent 0) ; (C) 82 | (values sign (ash (round (* ,(expt 2 significand-bits) 83 | significand)) 84 | exponent) 85 | 0) 86 | (values sign (round (* ,(expt 2 significand-bits) 87 | (1- (* significand 2)))) 88 | exponent)))))) 89 | (let ((bits 0)) 90 | (declare (type (unsigned-byte ,total-bits) bits)) 91 | (setf ,sign-part sign 92 | ,exponent-part exponent 93 | ,significand-part significand) 94 | bits))) 95 | 96 | (defun ,decoder-name (bits) 97 | (declare (type (unsigned-byte ,total-bits) bits)) 98 | (let* ((sign ,sign-part) 99 | (exponent ,exponent-part) 100 | (significand ,significand-part)) 101 | ,@(when nan `((when (= exponent ,max-exponent) 102 | (return-from ,decoder-name 103 | (cond ((not (zerop significand)) :not-a-number) 104 | ((zerop sign) :positive-infinity) 105 | (t :negative-infinity)))))) 106 | (if (zerop exponent) ; (D) 107 | (setf exponent 1) 108 | (setf (ldb (byte 1 ,significand-bits) significand) 1)) 109 | (unless (zerop sign) 110 | (setf significand (- significand))) 111 | (scale-float (float significand ,(if (> total-bits 32) 1.0d0 1.0)) 112 | (- exponent ,(+ exponent-offset significand-bits)))))))) ; (E) 113 | 114 | ;; And instances of the above for the common forms of floats. 115 | (make-float-converters encode-float32 decode-float32 8 23 nil) 116 | (make-float-converters encode-float64 decode-float64 11 52 nil) 117 | 118 | ;;; Copyright (c) 2006 Marijn Haverbeke 119 | ;;; 120 | ;;; This software is provided 'as-is', without any express or implied 121 | ;;; warranty. In no event will the authors be held liable for any 122 | ;;; damages arising from the use of this software. 123 | ;;; 124 | ;;; Permission is granted to anyone to use this software for any 125 | ;;; purpose, including commercial applications, and to alter it and 126 | ;;; redistribute it freely, subject to the following restrictions: 127 | ;;; 128 | ;;; 1. The origin of this software must not be misrepresented; you must 129 | ;;; not claim that you wrote the original software. If you use this 130 | ;;; software in a product, an acknowledgment in the product 131 | ;;; documentation would be appreciated but is not required. 132 | ;;; 133 | ;;; 2. Altered source versions must be plainly marked as such, and must 134 | ;;; not be misrepresented as being the original software. 135 | ;;; 136 | ;;; 3. This notice may not be removed or altered from any source 137 | ;;; distribution. 138 | -------------------------------------------------------------------------------- /postmodern/connect.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: POSTMODERN; -*- 2 | (in-package :postmodern) 3 | 4 | (defvar *connection-pools* (make-hash-table :test 'equal) 5 | "Maps pool specifiers to lists of pooled connections.") 6 | 7 | (defparameter *database* nil 8 | "Special holding the current database. Most functions and macros operating 9 | on a database assume this contains a connected database.") 10 | 11 | (defclass pooled-database-connection (database-connection) 12 | ((pool-type :initarg :pool-type :accessor connection-pool-type)) 13 | (:documentation "Type for database connections that are pooled. 14 | Stores the arguments used to create it, so different pools can be 15 | distinguished.")) 16 | 17 | (defun connect (database-name user-name password host &key (port 5432) pooled-p 18 | (use-ssl *default-use-ssl*) 19 | (use-binary nil) 20 | (service "postgres") 21 | (application-name "")) 22 | "Create a new database connection for the given user and the database. Port 23 | will default to 5432, which is where most PostgreSQL servers are running. If 24 | pooled-p is T, a connection will be taken from a pool of connections of this 25 | type, if one is available there, and when the connection is disconnected it 26 | will be put back into this pool instead. use-ssl can be :no, :yes, or :try, 27 | as in open-database, and defaults to the value of *default-use-ssl*." 28 | (cond (pooled-p 29 | (let ((type (list database-name user-name password host port use-ssl 30 | application-name use-binary))) 31 | (or (get-from-pool type) 32 | (let ((connection (cl-postgres:open-database database-name user-name 33 | password host port 34 | use-ssl 35 | service application-name 36 | use-binary))) 37 | #-genera (change-class connection 'pooled-database-connection 38 | :pool-type type) 39 | #+genera (progn 40 | (change-class connection 'pooled-database-connection) 41 | (setf (slot-value connection 'pool-type) type)) 42 | connection)))) 43 | (t (cl-postgres:open-database database-name user-name password host port 44 | use-ssl service application-name 45 | use-binary)))) 46 | 47 | (defun connected-p (database) 48 | "Returns a boolean indicating whether the given connection is still connected 49 | to the server." 50 | (cl-postgres:database-open-p database)) 51 | 52 | (defun connect-toplevel (database-name user-name password host 53 | &key (port 5432) (use-ssl *default-use-ssl*) (application-name "") 54 | use-binary) 55 | "Bind the *database* to a new connection. Use this if you only need one 56 | connection, or if you want a connection for debugging from the REPL." 57 | (when (and *database* (connected-p *database*)) 58 | (restart-case (error "Top-level database already connected.") 59 | (replace () :report "Replace it with a new connection." 60 | (disconnect-toplevel)) 61 | (leave () :report "Leave it." (return-from connect-toplevel nil)))) 62 | (setf *database* (connect database-name user-name password host 63 | :port port :use-ssl use-ssl :application-name application-name 64 | :use-binary use-binary)) 65 | (values)) 66 | 67 | (defgeneric disconnect (database) 68 | (:method ((connection database-connection)) 69 | (close-database connection)) 70 | (:documentation "Disconnects a normal database connection, or moves a pooled 71 | connection into the pool.")) 72 | 73 | (defgeneric reconnect (database) 74 | (:method ((database database-connection)) 75 | (reopen-database database) 76 | (when *schema-path* 77 | (let ((path *schema-path*)) 78 | (set-search-path path)))) 79 | (:method ((connection pooled-database-connection)) 80 | (error "Can not reconnect a pooled database.")) 81 | (:documentation "Reconnect a disconnected database connection. This is not 82 | allowed for pooled connections ― after they are disconnected they might be in 83 | use by some other process, and should no longer be used.")) 84 | 85 | (defun disconnect-toplevel () 86 | "Disconnect *database*." 87 | (when (and *database* (connected-p *database*)) 88 | (disconnect *database*)) 89 | (setf *database* nil)) 90 | 91 | (defun call-with-connection (spec thunk) 92 | "The functional backend to with-connection. Binds *database* to a new connection 93 | as specified by spec, which should be a list that connect can be applied to, and 94 | runs the zero-argument function given as second argument in the new environment. 95 | When the function returns or throws, the new connection is disconnected." 96 | (let ((*database* (apply #'connect spec))) 97 | (unwind-protect (funcall thunk) 98 | (disconnect *database*)))) 99 | 100 | (defmacro with-connection (spec &body body) 101 | "Evaluates the body with *database* bound to a connection as specified by spec, 102 | which should be list that connect can be applied to." 103 | `(let ((*database* (apply #'connect ,spec))) 104 | (unwind-protect (progn ,@body) 105 | (disconnect *database*)))) 106 | 107 | #+postmodern-thread-safe 108 | (defvar *pool-lock* 109 | (bordeaux-threads:make-lock "connection-pool-lock") 110 | "A lock to prevent multiple threads from messing with the connection 111 | pool at the same time.") 112 | 113 | (defmacro with-pool-lock (&body body) 114 | "Aquire a lock for the pool when evaluating body \(if thread support 115 | is present)." 116 | #+postmodern-thread-safe 117 | `(bordeaux-threads:with-lock-held (*pool-lock*) ,@body) 118 | #-postmodern-thread-safe 119 | `(progn ,@body)) 120 | 121 | (defun get-from-pool (type) 122 | "Get a database connection from the specified pool, returns nil if 123 | no connection was available." 124 | (with-pool-lock 125 | (pop (gethash type *connection-pools*)))) 126 | 127 | (defmethod disconnect ((connection pooled-database-connection)) 128 | "Add the connection to the corresponding pool, or drop it when the 129 | pool is full." 130 | (macrolet ((the-pool () 131 | '(gethash (connection-pool-type connection) *connection-pools* ()))) 132 | (when (database-open-p connection) 133 | (with-pool-lock 134 | (if (or (not *max-pool-size*) (< (length (the-pool)) *max-pool-size*)) 135 | (push connection (the-pool)) 136 | (call-next-method)))) 137 | (values))) 138 | 139 | (defun clear-connection-pool () 140 | "Disconnect and remove all connections in the connection pools." 141 | (with-pool-lock 142 | (maphash 143 | (lambda (type connections) 144 | (declare (ignore type)) 145 | (dolist (conn connections) 146 | (close-database conn))) 147 | *connection-pools*) 148 | (setf *connection-pools* (make-hash-table :test 'equal)) 149 | (values))) 150 | -------------------------------------------------------------------------------- /doc/simple-date.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Simple-Date 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | Simple-date provides types (CLOS classes) for dates, timestamps, and intervals 8 | similar to the ones SQL databases use, in order to be able to store and read 9 | these to and from a database in a straighforward way. A few obvious operations 10 | are defined on these types. 11 | 12 | To use this library with cl-postgres or postmodern and get the simple-date reader 13 | to be loaded, you need to load simple-date/postgres-glue 14 | and then set the readtable. This will register suitable SQL 15 | readers and writers for the associated database types. 16 | 17 | #+BEGIN_SRC lisp 18 | (ql:quickload :simple-date/postgres-glue) 19 | 20 | (setf cl-postgres:*sql-readtable* 21 | (cl-postgres:copy-sql-readtable 22 | simple-date-cl-postgres-glue:*simple-date-sql-readtable*)) 23 | #+END_SRC 24 | 25 | The most glaring defect of this library is its ignorance of time zones. It 26 | pretends the whole world lives in UTC. Use with care. 27 | 28 | To get back to the default cl-postgres reader: 29 | #+BEGIN_SRC lisp 30 | (setf cl-postgres:*sql-readtable* 31 | (cl-postgres:copy-sql-readtable 32 | cl-postgres::*default-sql-readtable*)) 33 | #+END_SRC 34 | 35 | To use the simple-date reader when cl-postgres is using the default: 36 | #+BEGIN_SRC lisp 37 | (setf cl-postgres:*sql-readtable* 38 | (cl-postgres:copy-sql-readtable 39 | simple-date-cl-postgres-glue:*simple-date-sql-readtable*)) 40 | #+END_SRC 41 | 42 | As a reminder for those who want to use local-time, to enable the local-time 43 | reader: 44 | #+BEGIN_SRC lisp 45 | (local-time:set-local-time-cl-postgres-readers) 46 | #+END_SRC 47 | 48 | 49 | * Date type 50 | :PROPERTIES: 51 | :ID: 6cefa703-d55b-464d-bad9-7c7ceae0c90d 52 | :END: 53 | ** class date 54 | :PROPERTIES: 55 | :ID: 203d5d98-5ce7-4bcb-81d9-1aeb4fe2796d 56 | :END: 57 | 58 | Represents a date, with no time-of-day information. 59 | 60 | ** function encode-date (year month day) 61 | :PROPERTIES: 62 | :ID: dbf2a874-80e1-4a43-86be-7febb1573b8d 63 | :END: 64 | → date 65 | 66 | Creates a date object. 67 | 68 | ** function decode-date (date) 69 | :PROPERTIES: 70 | :ID: 35da4a62-ea64-4053-aa30-4496d56a0f95 71 | :END: 72 | → (values year month day) 73 | 74 | Extract the elements from a date object. 75 | 76 | ** function day-of-week (date) 77 | :PROPERTIES: 78 | :ID: b1590639-fd02-458d-86e4-6e1bd3c1c003 79 | :END: 80 | → integer 81 | 82 | Determine the day of the week that the given date falls on. Value ranges from 83 | 0 to 6, with 0 being Sunday and 6 being Saturday. 84 | 85 | ** Timestamp type 86 | :PROPERTIES: 87 | :ID: 6efdaace-0c1c-45ba-8376-9b91e18a0b38 88 | :END: 89 | class timestamp 90 | 91 | Represents an absolute timestamp, with a millisecond precision. 92 | 93 | ** function encode-timestamp (year month day &optional (hour 0) (minute 0) (second 0) (millisecond 0)) 94 | :PROPERTIES: 95 | :ID: f6817a2a-92e2-44aa-9060-d9ab459f6207 96 | :END: 97 | → timestamp 98 | 99 | Create a timestamp. No negative values or values outside of an arguments normal 100 | range (i.e. 60 for minutes, 1000 for milliseconds) should be passed. 101 | 102 | ** function decode-timestamp (timestamp) 103 | :PROPERTIES: 104 | :ID: 5cb5f677-4fc4-4ab3-b2af-65579e660baf 105 | :END: 106 | → (values year month day hour minute second millisecond) 107 | 108 | Decode a timestamp into its components. 109 | 110 | ** function timestamp-to-universal-time (timestamp) 111 | :PROPERTIES: 112 | :ID: 477dd9e6-3e72-4eaa-b1fd-cf5d06bdfd1b 113 | :END: 114 | → universal-time 115 | 116 | Convert a timestamp to the corresponding universal-time, rounding to seconds. 117 | Note that this will treat the timestamp as if it were in UTC. 118 | 119 | ** function universal-time-to-timestamp (universal-time) 120 | :PROPERTIES: 121 | :ID: ba44156f-a860-4601-a5fe-6465d6ad8353 122 | :END: 123 | → timestamp 124 | 125 | Create a timestamp from a universal time. Again, the resulting timestamp should 126 | be treated as if it were in UTC. 127 | 128 | ** Interval type 129 | :PROPERTIES: 130 | :ID: 316f3287-fd76-46ce-8c2b-c07ad381fc38 131 | :END: 132 | class interval 133 | 134 | An interval represents a period of time. It contains both an absolute part in 135 | milliseconds (days, weeks, minutes, etc are always the same length), and a 136 | relative part for months and years ― the amount of time that a month or year 137 | represents is not always the same. 138 | 139 | ** function encode-interval (&key (year 0) (month 0) (week 0) (day 0) (hour 0) (minute 0) (second 0) (millisecond 0)) 140 | :PROPERTIES: 141 | :ID: 77212a01-b23f-40c7-aeec-fc93d4834f53 142 | :END: 143 | → interval 144 | 145 | Create an interval. Arguments may be negative and of any size. 146 | 147 | ** function decode-interval (interval) 148 | :PROPERTIES: 149 | :ID: cfd906be-cc00-437e-b250-b7d294131aa0 150 | :END: 151 | → (values year month day hour minute second millisecond) 152 | 153 | Decompose an interval into parts. Note that these may be different from the 154 | parameters that created it ― an interval of 3600 seconds is the same as one 155 | of 1 hour. 156 | 157 | * Operations 158 | :PROPERTIES: 159 | :ID: d2616cd8-622b-464f-994e-e1f9d6309706 160 | :END: 161 | To prevent a proliferation of different function names, generic functions 162 | are used for operations on time values. The semantics of these differ for 163 | the type of the operands. 164 | 165 | ** method time-add (a b) 166 | :PROPERTIES: 167 | :ID: 6846ba8b-a59f-475e-bc25-0c18e4fa5548 168 | :END: 169 | → value 170 | 171 | Adds two time-related objects. Adding an interval to a date or timestamp 172 | will return a new date or timestamp, increased by the value of the interval. 173 | Adding two intervals returns a new interval with the sum of the two 174 | arguments. Integers can be used in place of intervals, and will be 175 | interpreted as an amount of milliseconds. 176 | 177 | ** method time-subtract (a b) 178 | :PROPERTIES: 179 | :ID: 98dee89f-7178-4487-8d85-3036149f2def 180 | :END: 181 | → value 182 | 183 | Subtracts time-related objects from each other. Subtracting two dates or 184 | timestamps results in an interval that represents the difference between 185 | them. Similarly, subtracting two intervals also gives their difference. 186 | 187 | ** method time= (a b) 188 | :PROPERTIES: 189 | :ID: 74acb8a0-5438-4a56-8d08-3316a7792108 190 | :END: 191 | → boolean 192 | 193 | Compare two time-related values, returns a boolean indicating whether 194 | they denote the same time or period. 195 | 196 | ** method time< (a b) 197 | :PROPERTIES: 198 | :ID: 02b06b96-bbd7-482a-aa3c-f9080f97c3fa 199 | :END: 200 | → boolean 201 | 202 | Compare two time-related values, returns a boolean indicating whether the 203 | first is less than the second. 204 | 205 | ** method time> (a b) 206 | :PROPERTIES: 207 | :ID: 6901c062-4b1c-4cb1-a9f6-6935141d5fdd 208 | :END: 209 | → boolean 210 | 211 | Compare two time-related values, returns a boolean indicating whether the 212 | first is greater than the second. 213 | 214 | ** function time<= (a b) 215 | :PROPERTIES: 216 | :ID: 450e4d9e-2f31-4278-817a-bb42eaf0ea04 217 | :END: 218 | → boolean 219 | 220 | The inverse of time>. 221 | 222 | ** function time>= (a b) 223 | :PROPERTIES: 224 | :ID: d77174da-9511-41c6-bc46-95d62842435c 225 | :END: 226 | → boolean 227 | 228 | The inverse of time<. 229 | -------------------------------------------------------------------------------- /doc/s-sql-w.org: -------------------------------------------------------------------------------- 1 | #+TITLE: S-SQL Examples W 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | * [[file:s-sql-examples.org][S-SQL Examples Home Page]] 8 | | [[file:s-sql-a.org][A]]| [[file:s-sql-b.org][B]]| [[file:s-sql-c.org][C]]| [[file:s-sql-d.org][D]]| [[file:s-sql-e.org][E]]| [[file:s-sql-f.org][F]]| [[file:s-sql-g.org][G]]| [[file:s-sql-h.org][H]]| [[file:s-sql-i.org][I]]| [[file:s-sql-j.org][J]]| [[file:s-sql-k.org][K]]| [[file:s-sql-l.org][L]]| [[file:s-sql-m.org][M]]| [[file:s-sql-n.org][N]]| [[file:s-sql-o.org][O]]| [[file:s-sql-p.org][P]]| [[file:s-sql-r.org][R]]| [[file:s-sql-s.org][S]]| [[file:s-sql-t.org][T]]| [[file:s-sql-u.org][U]]| [[file:s-sql-v.org][V]]| [[file:s-sql-w.org][W]]| [[file:s-sql-special-characters.org][Special Characters]] | [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]]| 9 | 10 | * When 11 | :PROPERTIES: 12 | :CUSTOM_ID: when 13 | :END: 14 | #+begin_src lisp 15 | (let ((param-latitude nil) (param-longitude t)) 16 | (query (:select 'id 'name 17 | (when param-latitude '0) 18 | (when param-longitude 'longitude) 19 | :from 'countries 20 | :where (:= 'id 20)))) 21 | 22 | ((20 "UK" NIL -2)) 23 | #+end_src 24 | 25 | * Window 26 | :PROPERTIES: 27 | :CUSTOM_ID: window 28 | :END: 29 | As stated in the postgresql documentation: "When a query involves multiple window functions, it is possible to write out each one with a separate OVER clause, but this is duplicative and error-prone if the same windowing behavior is wanted for several functions. Instead, each windowing behavior can be named in a WINDOW clause and then referenced in OVER". http://www.postgresql.org/docs/9.1/static/tutorial-window.html. They are available in postmodern as of the 29 October 2013 additions to the git repository. 30 | #+begin_src lisp 31 | (query (:select (:over (:sum 'salary) 'w) 32 | (:over (:avg 'salary) 'w) 33 | :from 'empsalary :window 34 | (:as 'w (:partition-by 'depname :order-by (:desc 'salary))))) 35 | #+end_src 36 | 37 | * With 38 | :PROPERTIES: 39 | :CUSTOM_ID: with 40 | :END: 41 | With queries are often referred to as Common Table Expressions. They are used as ways to write auxiliary statements for use in a larger query. The Postgresql documentation covers them at http://www.postgresql.org/docs/current/queries-with.html 42 | #+begin_src lisp 43 | (query 44 | (:with 45 | (:as 'upd 46 | (:parens 47 | (:update 'employees 48 | :set 'sales-count (:= 'sales-count 1) 49 | :where (:= 'id 50 | (:select 'sales-person 51 | :from 'accounts 52 | :where (:= 'name "Acme Corporation"))) 53 | :returning '*))) 54 | (:insert-into 'employees-log 55 | (:select '* 'current-timestamp 56 | :from 57 | 'upd)))) 58 | #+end_src 59 | 60 | * With-recursive 61 | :PROPERTIES: 62 | :CUSTOM_ID: with-recursive 63 | :END: 64 | With-recursive allows the with auxiliary statement to refer to itself. These queries match the following template: 65 | #+begin_src text 66 | WITH RECURSIVE [temp table] [column list] 67 | AS ( [seed statement] 68 | UNION ALL [recursive statement - effectively looping through the table] ) 69 | 70 | [outer query which specifies the fields to be kept in the final result and throws away the intermediate results] 71 | 72 | #+end_src 73 | Testing with recursive. When working with recursive queries it is important to be sure that the recursive part of the query will eventually return no tuples, or else the query will loop indefinitely. Sometimes, using UNION instead of UNION ALL can accomplish this by discarding rows that duplicate previous output rows. However, often a cycle does not involve output rows that are completely duplicate: it may be necessary to check just one or a few fields to see if the same point has been reached before. The standard method for handling such situations is to compute an array of the already-visited values. 74 | 75 | A few postmodern samples follow which match up with the [[https://www.postgresql.org/docs/current/queries-with.html][postgresql documentation examples:]] 76 | #+begin_src lisp 77 | (query 78 | (:with-recursive 79 | (:as (:t1 'n) 80 | (:union-all (:values (:set 1)) 81 | (:select (:+ 'n 1) 82 | :from 't1 83 | :where (:< 'n 100)))) 84 | (:select (:sum 'n) :from 't1)) 85 | :single)) 86 | 87 | (query 88 | (:with-recursive 89 | (:as (:included-parts 'sub-part 'part 'quantity) 90 | (:union-all 91 | (:select 'sub-part 'part 'quantity 92 | :from 'parts 93 | :where (:= 'part "our-product")) 94 | (:select 'p.sub-part 'p.part 'p.quantity 95 | :from (:as 'included-parts 'pr) 96 | (:as 'parts 'p) 97 | :where (:= 'p.part 'pr.sub-part)))) 98 | (:select 'sub-part (:as (:sum 'quantity) 'total-quantity) 99 | :from 'included-parts 100 | :group-by 'sub-part))) 101 | 102 | 103 | (query 104 | (:with-recursive 105 | (:as (:search-graph 'id 'link 'data 'depth) 106 | (:union-all 107 | (:select 'g.id 'g.link 'g.data 1 108 | :from (:as 'graph 'g)) 109 | (:select 'g.id 'g.link 'g.data (:= 'sg.depth 1) 110 | :from (:as 'graph 'g) (:as 'search-graph 'sg) 111 | :where (:= 'g.id 'sg.link)))) 112 | (:select '* :from 'search-graph))) 113 | 114 | (query 115 | (:with-recursive 116 | (:as (:search-graph 'id 'link 'data'depth 'path 'cycle) 117 | (:union-all 118 | (:select 'g.id 'g.link 'g.data 1 119 | (:[] 'g.f1 'g.f2) nil 120 | :from (:as 'graph 'g)) 121 | (:select 'g.id 'g.link 'g.data (:= 'sg.depth 1) 122 | (:|| 'path (:row 'g.f1 'g.f2)) 123 | (:= (:row 'g.f1 'g.f2) 124 | (:any* 'path)) 125 | :from (:as 'graph 'g) 126 | (:as 'search-graph 'sg) 127 | :where (:and (:= 'g.id 'sg.link) 128 | (:not 'cycle))))) 129 | (:select '* :from 'search-graph))) 130 | 131 | #+end_src 132 | 133 | As a different example, consider a quicklisp dependency table where the fields are 'depends_on' and 'depended_on'. In other words library staple depends-on alexandria. So one record has "staple" in the depends_on column and "alexandria" in the depended_on column. 134 | 135 | A function to return a list of all the dependencies of a quicklisp library (assuming the data is in a table called "dependencies") could look like this: 136 | #+begin_src lisp 137 | (defun list-dependencies (lib-name) 138 | "Returns a list of the names of the direct and indirect libraries depended-on by lib-name." 139 | (sort (alexandria:flatten 140 | (postmodern:query 141 | (:with-recursive 142 | (:as 'children 143 | (:union 144 | (:select 'depended-on 145 | :from 'dependencies 146 | :where (:= 'depends-on '$1)) 147 | (:select 'a.depended-on 148 | :from (:as 'dependencies 'a) 149 | :inner-join (:as 'children 'b) 150 | :on (:= 'a.depends-on 'b.depended-on)))) 151 | (:select '* :from 'children)) 152 | lib-name)) 153 | #'string<))) 154 | #+end_src 155 | -------------------------------------------------------------------------------- /doc/s-sql-l.org: -------------------------------------------------------------------------------- 1 | #+TITLE: S-SQL Examples L 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | * [[file:s-sql-examples.org][S-SQL Examples Home Page]] 8 | | [[file:s-sql-a.org][A]]| [[file:s-sql-b.org][B]]| [[file:s-sql-c.org][C]]| [[file:s-sql-d.org][D]]| [[file:s-sql-e.org][E]]| [[file:s-sql-f.org][F]]| [[file:s-sql-g.org][G]]| [[file:s-sql-h.org][H]]| [[file:s-sql-i.org][I]]| [[file:s-sql-j.org][J]]| [[file:s-sql-k.org][K]]| [[file:s-sql-l.org][L]]| [[file:s-sql-m.org][M]]| [[file:s-sql-n.org][N]]| [[file:s-sql-o.org][O]]| [[file:s-sql-p.org][P]]| [[file:s-sql-r.org][R]]| [[file:s-sql-s.org][S]]| [[file:s-sql-t.org][T]]| [[file:s-sql-u.org][U]]| [[file:s-sql-v.org][V]]| [[file:s-sql-w.org][W]]| [[file:s-sql-special-characters.org][Special Characters]] | [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]]| 9 | 10 | * Lateral 11 | :PROPERTIES: 12 | :CUSTOM_ID: lateral 13 | :END: 14 | Basically, the lateral keyword allows access to columns after the from statement and use them earlier in the query. Here is a sample vanilla sql query using lateral, borrowed from [[https://popsql.com/learn-sql/postgresql/how-to-use-lateral-joins-in-postgresql#data-set][https://popsql.com/learn-sql/postgresql/how-to-use-lateral-joins-in-postgresql#data-set]] 15 | #+begin_src lisp 16 | (query 17 | "select 18 | pledged_usd, 19 | avg_pledge_usd, 20 | amt_from_goal, 21 | duration, 22 | (usd_from_goal / duration) as usd_needed_daily 23 | from kickstarter_data, 24 | lateral (select pledged / fx_rate as pledged_usd) pu 25 | lateral (select pledged_usd / backers_count as avg_pledge_usd) apu 26 | lateral (select goal / fx_rate as goal_usd) gu 27 | lateral (select goal_usd - pledged_usd as usd_from_goal) ufg 28 | lateral (select (deadline - launched_at)/86400.00 as duration) dr;") 29 | #+end_src 30 | And now how it would be written in s-sql 31 | #+begin_src lisp 32 | (query 33 | (:select 'pledged-usd 'avg-pledge-usd 'amt-from-goal 'duration 34 | (:as (:/ 'usd-from-goal 'duration) 'usd-needed-daily) 35 | :from 'kickstarter-data 36 | :lateral (:as (:select (:as (:/ 'pledged 'fx-rate) 37 | 'pledged-usd)) 38 | 'pu) 39 | :lateral (:as (:select (:as (:/ 'pledged-usd 'backers-count) 40 | 'avg-pledge-usd)) 41 | 'apu) 42 | :lateral (:as (:select (:as (:/ 'goal 'fx-rate) 43 | 'goal-usd)) 44 | 'gu) 45 | :lateral (:as (:select (:as (:- 'goal-usd 'pledged-usd) 46 | 'usd-from-goal)) 47 | 'ufg) 48 | :lateral (:as (:select (:as (:/ (:- 'deadline 'launched-at) 86400.00) 49 | 'duration)) 50 | 'dr))) 51 | #+end_src 52 | Here is an example with :join-lateral 53 | #+begin_src lisp 54 | (query 55 | (:select '* 56 | :from (:as 'tags 't1) 57 | :join-lateral (:as 58 | (:fetch 59 | (:order-by 60 | (:select 'm.* 61 | :from (:as 'movies 'm) 62 | :where (:= 'm.tag-id 't1.id)) 63 | (:desc 'm.created-at)) 64 | 2) 65 | 'e1) 66 | :on (:= 1 1))) 67 | #+end_src 68 | This one has an :inner-join-lateral 69 | #+begin_src lisp 70 | (query 71 | (:select '* 72 | :from (:as 'tags 't1) 73 | :inner-join-lateral (:as 74 | (:fetch 75 | (:order-by 76 | (:select 'm.* 77 | :from (:as 'movies 'm) 78 | :where (:= 'm.tag-id 't1.id)) 79 | (:desc 'm.created-at)) 80 | 2) 81 | 'e1) 82 | :on 't)) 83 | #+end_src 84 | A :cross-join-lateral 85 | #+begin_src lisp 86 | (query 87 | (:select '* 88 | :from (:as 'tags 't1) 89 | :cross-join-lateral (:as 90 | (:fetch 91 | (:order-by 92 | (:select 'm.* 93 | :from (:as 'movies 'm) 94 | :where (:= 'm.tag-id 't1.id)) 95 | (:desc 'm.created-at)) 96 | 2) 97 | 'e1))) 98 | 99 | (query 100 | (:select 'geo.zipcode 'geo.state 'movie.name 101 | :from 'geo 102 | :cross-join-lateral 103 | (:as 104 | (:limit 105 | (:order-by 106 | (:select 'movie-name 107 | :from 'streams 108 | :where (:= 'geo.zipcode 'streams.zipcode)) 109 | (:desc 'streams.country)) 110 | 5) 111 | (:movie 'name)))) 112 | #+end_src 113 | And a :left-join-lateral 114 | #+begin_src lisp 115 | (query 116 | (:select 'p.* (:as 'dads.id 'dad-id) (:as 'moms.id 'mom-id) 117 | :from (:as 'people 'p) 118 | :left-join-lateral (:as (:select '* 119 | :from 'people 120 | :where (:and (:= 'gender "m") 121 | (:= 'surname-1 'p.surname-1) 122 | (:<> 'pack-id 'p.pack-id))) 123 | 'dads) 124 | :on 't 125 | :left-join-lateral (:as (:select '* 126 | :from 'people 127 | :where (:and (:= 'gender "f") 128 | (:= 'surname-1 'p.surname-2) 129 | (:<> 'pack-id 'p.pack-id) 130 | (:<> 'pack-id 'dads.pack-id))) 131 | 'moms) 132 | :on 't)) 133 | #+end_src 134 | * Like, ilike Example 135 | :PROPERTIES: 136 | :CUSTOM_ID: like 137 | :END: 138 | The sql like operator provides a little bit of fuzzy string matching in a search. The following is a simple example using the sql like operator in s-sql. 139 | #+begin_src lisp 140 | (query (:select 'id 'name 141 | :from 'countries 142 | :where (:like 'name "%New%"))) 143 | 144 | ((103 "New Caledonia") (58 "New Zealand") (108 "Papua New Guinea")) 145 | 146 | #+end_src 147 | 148 | The sql ilike operator provides the same thing, but on a case insensitive basis. The following is a simple example using the sql ilike operator in s-sql. 149 | #+begin_src lisp 150 | (query (:select 'id 'name 151 | :from 'countries 152 | :where (:like 'name "%NEW%"))) 153 | 154 | ((103 "New Caledonia") (58 "New Zealand") (108 "Papua New Guinea")) 155 | 156 | #+end_src 157 | 158 | * Limit and offset 159 | :PROPERTIES: 160 | :CUSTOM_ID: limit 161 | :END: 162 | Note that :limit has 2 possible parameters, the limit and the offset. Note that the :order-by and :limit forms are wrapped around the :select form. The only difference between the two queries is the offset parameter. 163 | #+begin_src lisp 164 | (let ((list-limit 2) 165 | (offset 0)) 166 | (query 167 | (:limit 168 | (:order-by 169 | (:select 'countries.id 'countries.name 170 | :from 'countries) 171 | 'name) 172 | '$1 '$2) 173 | list-limit offset)) 174 | 175 | ((82 "Afghanistan") (130 "Albania")) 176 | 177 | (let ((list-limit 2) (offset 2)) 178 | (query 179 | (:limit 180 | (:order-by 181 | (:select 'countries.id 'countries.name 182 | :from 'countries) 183 | 'name) 184 | '$1 '$2) 185 | list-limit offset)) 186 | 187 | ((140 "Algeria") (34 "All")) 188 | #+end_src 189 | -------------------------------------------------------------------------------- /doc/s-sql-j.org: -------------------------------------------------------------------------------- 1 | #+TITLE: S-SQL Examples J 2 | #+OPTIONS: num:nil 3 | #+HTML_HEAD: 4 | #+HTML_HEAD: 5 | #+OPTIONS: ^:nil 6 | 7 | * [[file:s-sql-examples.org][S-SQL Examples Home Page]] 8 | | [[file:s-sql-a.org][A]]| [[file:s-sql-b.org][B]]| [[file:s-sql-c.org][C]]| [[file:s-sql-d.org][D]]| [[file:s-sql-e.org][E]]| [[file:s-sql-f.org][F]]| [[file:s-sql-g.org][G]]| [[file:s-sql-h.org][H]]| [[file:s-sql-i.org][I]]| [[file:s-sql-j.org][J]]| [[file:s-sql-k.org][K]]| [[file:s-sql-l.org][L]]| [[file:s-sql-m.org][M]]| [[file:s-sql-n.org][N]]| [[file:s-sql-o.org][O]]| [[file:s-sql-p.org][P]]| [[file:s-sql-r.org][R]]| [[file:s-sql-s.org][S]]| [[file:s-sql-t.org][T]]| [[file:s-sql-u.org][U]]| [[file:s-sql-v.org][V]]| [[file:s-sql-w.org][W]]| [[file:s-sql-special-characters.org][Special Characters]] | [[file:calling-postgresql-stored-functions.org][Calling Postgresql Stored Functions and Procedures]]| 9 | 10 | 11 | * Joins 12 | :PROPERTIES: 13 | :CUSTOM_ID: joins 14 | :END: 15 | A long discussion of joins can be found here: http://www.gplivna.eu/papers/sql_join_types.htm (Oracle centric, but still useful). The postgresql documentation pages can be found here: http://www.postgresql.org/docs/9.3/static/sql-select.html#SQL-FROM 16 | 17 | ** Cross Join 18 | :PROPERTIES: 19 | :CUSTOM_ID: cross-join 20 | :END: 21 | From the postgresql documentation: "For every possible combination of rows from T1 and T2 (i.e., a Cartesian product), the joined table will contain a row consisting of all columns in T1 followed by all columns in T2. If the tables have N and M rows respectively, the joined table will have N * M rows." 22 | #+begin_src lisp 23 | (query (:select '* from 'employee 24 | :cross-join 'compensation)) 25 | #+end_src 26 | 27 | ** Inner Join 28 | :PROPERTIES: 29 | :CUSTOM_ID: inner-join 30 | :END: 31 | An inner join looks at two tables and creates a new result consisting of the selected elements in the rows from the two tables that match the specified conditions. You can simplistically think of it as the intersection of the two sets. In reality, it is creating a new set consisting of certain elements of the intersecting rows. An inner join is the default and need not be specified. 32 | 33 | A sample of standard sql on an inner join could look like this: 34 | #+begin_src sql 35 | (SELECT foo, bar, baz 36 | FROM (SELECT foo FROM x WHERE some-condition-here) AS tmp1 37 | INNER JOIN 38 | (SELECT bar FROM x WHERE some-condition-here) AS tmp2 39 | ON (tmp1.id = tmp2.id) 40 | INNER JOIN 41 | (SELECT baz FROM x WHERE some-condition-here) AS tmp3 42 | ON (tmp2.id = tmp3.id)) 43 | #+end_src 44 | 45 | The same query could be expressed in s-sql as: 46 | #+begin_src lisp 47 | (query (:select 'foo 'bar 'baz 48 | :from (:as 49 | (:select 'foo 50 | :from 'x 51 | :where 'x) 52 | 'tmp1) 53 | :inner-join (:as 54 | (:select 'bar 55 | :from 'x 56 | :where 'x) 57 | 'tmp2) 58 | :on (:= 'tmp1.id 'tmp2.id) 59 | :inner-join (:as 60 | (:select 'baz 61 | :from 'x 62 | :where 'x) 63 | 'tmp3) 64 | :on (:= 'tmp2.id 'tmp3.id))) 65 | 66 | #+end_src 67 | 68 | The normal pre-ansi shorthand example, using our countries and regions tables would look like this: 69 | #+begin_src lisp 70 | (query (:select 'countries.name 71 | :from 'countries 'regions 72 | :where (:and (:= 'countries.region-id 'regions.id) 73 | (:= 'regions.name "North America")))) 74 | 75 | (("US") ("Canada") ("Mexico") ("Bermuda")) 76 | 77 | #+end_src 78 | 79 | The full portable ansi version, using inner join would look like this. 80 | #+begin_src lisp 81 | (query (:select 'tmp1.name 82 | :from (:as (:select 'name 'region-id 83 | :from 'countries) 84 | 'tmp1) 85 | :inner-join (:as (:select 'id 86 | :from 'regions 87 | :where (:= 'name "North America")) 88 | 'tmp2) 89 | :on (:= 'tmp1.region-id 'tmp2.id))) 90 | 91 | (("US") ("Canada") ("Mexico") ("Bermuda")) 92 | 93 | #+end_src 94 | 95 | Some people argue that specifying the inner join allows separation of join criteria and, therefore is more readable. I leave that to you and your coding style. 96 | 97 | ** Outer Join 98 | :PROPERTIES: 99 | :CUSTOM_ID: outer-join 100 | :END: 101 | An outer join not only generates an inner join, it also joins the rows from one table that matches the conditions and adds null values for the joined columns from the second table (which obviously did not match the condition.) Under Postgresql, a "left join", "right join" or "full join" all imply an outer join. 102 | 103 | A left join (or left outer join) looks at two tables, keeps the matched rows from both and the unmatched rows from the left table and drops the unmatched rows from the right table. A right outer join keeps the matched rows, the unmatched rows from the right table and drops the unmatched rows from the left table. A full outer join includes the rows that match from each table individually, with null values for the missing matching columns. 104 | 105 | ** Left Join 106 | :PROPERTIES: 107 | :CUSTOM_ID: left-join 108 | :END: 109 | Example: Here we assume two tables. A countries table and a many-to-many linking table named countries-topics. (There is an implicit third table named topics.) We are looking for records from the countries table which do not have a match in the countries-topics table. In other words, where do we have a note, but not matched it to a topic? 110 | #+begin_src lisp 111 | (defun notes-with-no-topics () 112 | (query (:order-by 113 | (:select 'countries.id 'countries.name 114 | :distinct 115 | :from 'countries 116 | :left-join 'countries-topics 117 | :on (:= 'countries.id 'countries-topics.country-id) 118 | :where (:is-null 'countries-topics.country-id)) 119 | 'countries.id))) 120 | 121 | #+end_src 122 | 123 | Here is a somewhat contrived example using our countries and regions table. We want to get the names of all the regions and also return the country names in one specified region. Assume that we only want the names of the countries in Central America, which happens to have a region-id of 3. 124 | #+begin_src lisp 125 | (query (:select 'tmp2.name 'tmp1.name 126 | :from (:as (:select 'id 'name 127 | :from 'regions) 128 | 'tmp2) 129 | :left-join (:as (:select 'name 'region-id 130 | :from 'countries 131 | :where (:= 'region-id 3)) 132 | 'tmp1) 133 | :on (:= 'tmp1.region-id 'tmp2.id))) 134 | 135 | (("Central America" "Panama") ("Central America" "Costa Rica") ("Central America" "Guatemala") 136 | ("Central America" "Nicaragua") ("Central America" "Belize") ("Central America" "El Salvador") 137 | ("Western Africa" :NULL) ("Eastern Europe" :NULL) ("APAC" :NULL) ("Southern Europe" :NULL) 138 | ("Caribbean" :NULL) ("LATAM" :NULL) ("Northern Africa" :NULL) ("Eastern Africa" :NULL) 139 | ("Asia" :NULL) ("US" :NULL) ("Middle East" :NULL) ("South East Asia" :NULL) 140 | ("Oceania" :NULL) ("Northern Europe" :NULL) ("Emerging" :NULL) ("All" :NULL) 141 | ("Central Asia" :NULL) ("Eastern Asia" :NULL) ("North America" :NULL) ("EMEA" :NULL) 142 | ("Middle Africa" :NULL) ("Western Europe" :NULL) ("Africa" :NULL) ("South Central Asia" :NULL) 143 | ("Southern Africa" :NULL) ("Canada" :NULL) ("Pacific" :NULL) ("South America" :NULL)) 144 | #+end_src 145 | -------------------------------------------------------------------------------- /cl-postgres/data-types.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: LISP; Syntax: Ansi-Common-Lisp; Base: 10; Package: CL-POSTGRES; -*- 2 | (in-package :cl-postgres) 3 | 4 | (defun int64-to-vector (int) 5 | "Takes a 64 byte integer and returns a vector of unsigned bytes with a length of 8" 6 | (when (and (integerp int) (< int 18446744073709551615)) 7 | (let ((intv (make-array '(8) 8 | :element-type '(unsigned-byte 8) 9 | :initial-element 0))) 10 | (setf (aref intv 0) (ldb (byte 8 56) int)) 11 | (setf (aref intv 1) (ldb (byte 8 48) int)) 12 | (setf (aref intv 2) (ldb (byte 8 40) int)) 13 | (setf (aref intv 3) (ldb (byte 8 32) int)) 14 | (setf (aref intv 4) (ldb (byte 8 24) int)) 15 | (setf (aref intv 5) (ldb (byte 8 16) int)) 16 | (setf (aref intv 6) (ldb (byte 8 8) int)) 17 | (setf (aref intv 7) (ldb (byte 8 0) int)) 18 | intv))) 19 | 20 | (defun int32-to-vector (int) 21 | "Takes a 32 byte integer and returns a vector of unsigned bytes with a length of 4" 22 | (when (and (integerp int) (< int 4294967296)) 23 | (let ((intv (make-array '(4) 24 | :element-type '(unsigned-byte 8) 25 | :initial-element 0))) 26 | (setf (aref intv 0) (ldb (byte 8 24) int)) 27 | (setf (aref intv 1) (ldb (byte 8 16) int)) 28 | (setf (aref intv 2) (ldb (byte 8 8) int)) 29 | (setf (aref intv 3) (ldb (byte 8 0) int)) 30 | intv))) 31 | 32 | (defun int16-to-vector (int) 33 | "Takes a 16 byte integer and returns a vector of unsigned bytes 34 | with a length of 2." 35 | (when (and (integerp int) (< int 65536)) 36 | (let ((intv (make-array '(2) 37 | :element-type '(unsigned-byte 8) 38 | :initial-element 0))) 39 | (setf (aref intv 0) (ldb (byte 8 8) int)) 40 | (setf (aref intv 1) (ldb (byte 8 0) int)) 41 | intv))) 42 | 43 | (defun int8-to-vector (int) 44 | "Takes a 8 byte positive integer and returns a vector of unsigned bytes 45 | with a length of 1 byte." 46 | (let ((intv (make-array '(1) 47 | :element-type '(unsigned-byte 8) 48 | :initial-element 0))) 49 | (setf (aref intv 0) (ldb (byte 8 0) int)) 50 | intv)) 51 | 52 | (defun int-to-vector (int) 53 | "Takes a signed integer and returns a vector of unsigned bytes." 54 | (if (integerp int) 55 | (case (get-int-size int) 56 | (int2 (int16-to-vector int)) 57 | (int4 (int32-to-vector int)) 58 | (int8 (int64-to-vector int))) 59 | nil)) 60 | 61 | (defun get-int-size (int) 62 | "Takes an integer and returns the size of the integer for postgresql 63 | purposes (int2, int4, int8)" 64 | (declare (integer int)) 65 | (cond ((and (> int -32769) 66 | (< int 32768)) 67 | 'int2) 68 | ((and (> int -2147483649) 69 | (< int 2147483648)) 70 | 'int4) 71 | ((and (> int -9223372036854775809) 72 | (< int 9223372036854775808)) 73 | 'int8) 74 | (t nil))) 75 | 76 | (defun int2p (item) 77 | "Checking whether the item is an int2" 78 | (and (integerp item) 79 | (and (> item -32769) 80 | (< item 32768)))) 81 | 82 | (defun int4p (item) 83 | "Checking whether the item is an int4" 84 | (and (integerp item) 85 | (and (> item -2147483649) 86 | (< item 2147483648)))) 87 | 88 | (defun int8p (item) 89 | "Checking whether the item is an int8" 90 | (and (integerp item) 91 | (and (> item -9223372036854775809) 92 | (< item 9223372036854775808)))) 93 | 94 | (deftype int2 () 95 | '(integer -32769 32768)) 96 | 97 | (deftype int4 () 98 | '(integer -2147483648 2147483647)) 99 | 100 | (deftype int8 () 101 | '(integer -9223372036854775808 9223372036854775808)) 102 | 103 | (defun uuid-to-byte-array (uuid) 104 | "Takes a uuid string and creates a vector of unsigned bytes" 105 | (let ((array (make-array 16 106 | :element-type '(unsigned-byte 8) 107 | :initial-element 0)) 108 | (sec1 (parse-integer uuid :start 0 :end 8 :radix 16)) 109 | (sec2 (parse-integer uuid :start 9 :end 13 :radix 16)) 110 | (sec3 (parse-integer uuid :start 14 :end 18 :radix 16)) 111 | (sec4 (parse-integer uuid :start 19 :end 23 :radix 16)) 112 | (sec5 (parse-integer uuid :start 24 :end 36 :radix 16))) 113 | (loop for i from 3 downto 0 114 | do (setf (aref array (- 3 i)) (ldb (byte 8 (* 8 i)) sec1))) 115 | (loop for i from 5 downto 4 116 | do (setf (aref array i) (ldb (byte 8 (* 8 (- 5 i))) sec2))) 117 | (loop for i from 7 downto 6 118 | do (setf (aref array i) (ldb (byte 8 (* 8 (- 7 i))) sec3))) 119 | (loop for i from 9 downto 8 120 | do (setf (aref array i) (ldb (byte 8 (* 8 (- 9 i))) sec4))) 121 | (loop for i from 15 downto 10 122 | do (setf (aref array i) (ldb (byte 8 (* 8 (- 15 i))) sec5))) 123 | array)) 124 | 125 | 126 | (defun uuip-p (item) 127 | "Checking whether a string is a uuid. It does require the uuid string to be in hyphenated form. Like Postgresql, it will accept both upper and lower case, so looser than the specification which requires lower case only." 128 | (and (stringp item) 129 | (cl-ppcre:scan "\\b[0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}-[0-9a-fA-F]{4}-[0-9a-fA-F]{4}-\\b[0-9a-fA-F]{12}\\b" 130 | item))) 131 | 132 | (deftype uuid-string () 133 | `(and (string) 134 | (satisfies uuip-p))) 135 | 136 | (defun text-array-p (item) 137 | "Checking whether every item in an array is text" 138 | (and (arrayp item) 139 | (every #'stringp item))) 140 | 141 | (defun int2-array-p (item) 142 | "Checking whether every item in an array is an int4" 143 | (and (arrayp item) 144 | (every #'int2p item))) 145 | 146 | (defun int4-array-p (item) 147 | "Checking whether every item in an array is an int4" 148 | (and (arrayp item) 149 | (every #'int4p item))) 150 | 151 | (defun int8-array-p (item) 152 | "Checking whether every item in an array is an int4" 153 | (and (arrayp item) 154 | (every #'int8p item))) 155 | 156 | (deftype text-array (&optional size) 157 | "Text-array is an array of strings" 158 | `(and (array string (,size)) 159 | (satisfies text-array-p))) 160 | 161 | (deftype int2-array (&optional size) 162 | "Int4-array is an array of integers of size 2" 163 | `(and (array integer (,size)) 164 | (satisfies int2-array-p))) 165 | 166 | (deftype int4-array (&optional size) 167 | "Int4-array is an array of integers of size 4" 168 | `(and (array integer (,size)) 169 | (satisfies int4-array-p))) 170 | 171 | (deftype int8-array (&optional size) 172 | "Int8-array is an array of integers of size 8" 173 | `(and (array int8 (,size)) 174 | (satisfies int8-array-p))) 175 | 176 | (defun param-to-oid (param) 177 | "Returns the postgresql oid for parameters which are going to be passed 178 | from postmodern to postgresql in binary. Currently that only includes integers, 179 | single-floats, double-floats and boolean. Everything else will be passed as 180 | text for postgresql to interpret. We do not do arrays because passing them in Postgresql's 181 | binary format is actually more overhead than sending the string literal version. See 182 | https://www.codesynthesis.com/pipermail/odb-users/2012-August/000688.html. 183 | 184 | If you are wondering why text is not included in this function, many Postgresql 185 | data types have no common lisp equivalent and therefore must be 186 | passed as string literals. Specifying that something was text 187 | when it is not will result in Postgresql throwing type mismatch errors." 188 | (typecase param 189 | (int2 cl-postgres-oid:+int2+) 190 | (int4 cl-postgres-oid:+int4+) 191 | (int8 cl-postgres-oid:+int8+) 192 | #-clisp (single-float cl-postgres-oid:+float4+) 193 | #+clisp (float cl-postgres-oid:+float4+) 194 | (double-float cl-postgres-oid:+float8+) 195 | (boolean cl-postgres-oid:+bool+) 196 | (t 0))) 197 | 198 | (defun types-match-p (x y) 199 | (equal (type-of x) (type-of y))) 200 | 201 | (defun oid-types-match-p (x y) 202 | "Returns t if the two parameters have matching types" 203 | (eq (param-to-oid x) (param-to-oid y))) 204 | 205 | (defun parameter-list-types (lst) 206 | "Takes a list of parameters and returns the matching postgresql oid types" 207 | (mapcar #'param-to-oid lst)) 208 | 209 | (defun parameter-lists-match-oid-types-p (x y) 210 | "Takes two lists and validates that the lists have matching postgresql oid types." 211 | (let ((lst1 (mapcar #'param-to-oid x)) 212 | (lst2 (mapcar #'param-to-oid y))) 213 | (equal lst1 lst2))) 214 | --------------------------------------------------------------------------------