cl-rdbms showcase

(def test* test/basic/basic-binding ()
  (bind ((unicode-text "éáúóüőű"))
    (unwind-protect
         (with-transaction
           (execute-ddl [create table alma ((name (varchar 50)))])
           (execute [insert alma (name) ((,unicode-text varchar))])
           (is (string= (first* (first* (execute [select * alma]))) unicode-text)))
      (ignore-errors
        (execute-ddl [drop table alma])))))

(def test* test/basic/terminal-action ()
  (unwind-protect
       (progn
         (execute-ddl "CREATE TABLE alma (x integer)")
         (with-transaction
           (execute "INSERT INTO alma VALUES (42)")
           (is (= (first* (first* (execute "SELECT x FROM alma"))) 42))
           (mark-transaction-for-rollback-only))
         (with-transaction
           (is (zerop (first* (first* (execute "SELECT count(*) FROM alma"))))))
         (with-transaction
           (execute "INSERT INTO alma VALUES (42)"))
         (with-transaction
           (is (= 1 (first* (first* (execute "SELECT count(*) FROM alma")))))))
    (ignore-errors
      (execute-ddl "DROP TABLE alma"))))
 

No big surprises here:

(create table (:temporary :drop) alma ((col1 varchar) ("col2" (integer 32))))
=>
Oracle:     CREATE GLOBAL TEMPORARY TABLE "alma" ("col1" VARCHAR2, "col2" NUMBER(10)) ON COMMIT DROP
PostgreSQL: CREATE GLOBAL TEMPORARY TABLE alma (col1 CHARACTER VARYING, col2 INT) ON COMMIT DROP
 

The [] reader macro compiles static parts of the sexp sql fragments into constant strings. It also supports unquoting (using the first level of comma characters by default). If the expression contains parts that are dynamically generated, then it expands into a lambda that when funcall'd generates the whole sql command at runtime, incorporating the dynamic elements (which are SQL AST nodes generated by the forms after commas). This lambda can be fed directly into EXECUTE.

In the simplest case:

[select "bar" table]

;;; It macroexpands to: (lowercased for readability)
(lambda ()
  (unless (typep *database* 'postgresql-postmodern)
    (error "The current value of *database* (~A) is not subtypep of the compile-time value of *database* (~S)." *database* 'postgresql-postmodern))
  (values "SELECT bar FROM table" #() #() #()))
 

When things turn a bit more complex:

;;; A more complex test from the cl-rdbms testsuite:
(def syntax-test test/syntax/expand-sql-ast/unquote/3 postgresql-postmodern (&optional (n 3))
  (bind ((criteria [or ,@(iter (for i :from 1 :to n)
                               (rebind (i)
                                 (collect [= a
                                             (+ b
                                                ,(sql-binding-variable
                                                  :type (sql-integer-type)
                                                  :name (concatenate-symbol (find-package :cl-rdbms-test)
                                                                            "var-" i))
                                                ,i)])))])
         (extra-columns '(c d)))
    (bind (((:values command binding-variables binding-types binding-values)
            (funcall [select (a b ,@extra-columns)
                             table
                             (and (= a 42)
                                  (not (= b ,(sql-literal :type (sql-integer-type)
                                                          :value 43)))
                                  ,criteria)])))
      (is (string= command "SELECT a, b, c, d FROM table WHERE ((a = 42) AND (NOT (b = $1::NUMERIC)) AND ((a = (b + $2::NUMERIC + 1)) OR (a = (b + $3::NUMERIC + 2)) OR (a = (b + $4::NUMERIC + 3))))"))
      (is (null (first* binding-variables)))
      (is (every (rcurry #'typep 'sql-binding-variable) (subseq binding-variables 1)))
      (is (every (rcurry #'typep 'sql-integer-type) binding-types))
      (is (eql (first* binding-values) 43))
      (is (every #'null (subseq binding-values 1))))))

;;; Where the [or ...] expression in the 'criteria' variable macroexpands to:

(lambda ()
  (write-string "(" *sql-stream*)
  (format-separated-list
   (iter (for i :from 1 :to n)
         (rebind (i)
                 (collect
                  (lambda ()
                    (write-string "(a = (b + " *sql-stream*)
                    (format-sql-syntax-node
                     (sql-binding-variable :type (sql-integer-type)
                                           :name (concatenate-symbol (find-package :cl-rdbms-test)
                                                                     "var-"
                                                                     i))
                     *database*)
                    (write-string " + " *sql-stream*)
                    (format-sql-syntax-node i *database*)
                    (write-string "))" *sql-stream*)
                    (values)))))
   "OR" *database* 'format-sql-syntax-node)
  (write-string ")" *sql-stream*)
  (values))

;;; And the [select ...] expression macroexpands to:

(lambda ()
  (unless (typep *database* 'postgresql-postmodern)
    (error "The current value of *database* (~A) is not subtypep of the compile-time value of *database* (~S)." *database* 'postgresql-postmodern))
  (bind ((*print-pretty* nil)
         (*print-circle* nil)
         (*sql-stream* (make-string-output-stream))
         (*binding-variables* (make-array 16 :adjustable t :fill-pointer 0))
         (*binding-types* (make-array 16 :adjustable t :fill-pointer 0))
         (*binding-values* (make-array 16 :adjustable t :fill-pointer 0)))
    (write-string "SELECT a, b, " *sql-stream*)
    (format-separated-list extra-columns #\, *database* 'format-sql-identifier)
    (write-string " FROM table WHERE ((a = 42) AND (NOT (b = " *sql-stream*)
    (format-sql-syntax-node (sql-literal :type (sql-integer-type) :value 43) *database*)
    (write-string ")) AND " *sql-stream*)
    (format-sql-syntax-node criteria *database*)
    (write-string ")" *sql-stream*)
    (values (get-output-stream-string *sql-stream*)
            *binding-variables*
            *binding-types*
            *binding-values*)))