Added sql-error error type.

Separate condition type is required for catching errors in sql s-expressions.
Useful when an application accepts sql s-expressions from remote source.
---
 postmodern/package.lisp |    1 +
 s-sql/s-sql.lisp        |   47 ++++++++++++++++++++++++++---------------------
 2 files changed, 27 insertions(+), 21 deletions(-)

diff --git a/postmodern/package.lisp b/postmodern/package.lisp
index ec42208..d30a362 100644
--- a/postmodern/package.lisp
+++ b/postmodern/package.lisp
@@ -36,6 +36,7 @@
    #:smallint #:bigint #:numeric #:real #:double-precision
    #:bytea #:text #:varchar
    #:*escape-sql-names-p* #:sql-escape-string #:register-sql-operators
+   #:sql-error
 
    ;; Condition type from cl-postgres
    #:database-error #:database-error-message #:database-error-code
diff --git a/s-sql/s-sql.lisp b/s-sql/s-sql.lisp
index 71ba6f2..3a60e76 100644
--- a/s-sql/s-sql.lisp
+++ b/s-sql/s-sql.lisp
@@ -20,12 +20,17 @@
            #:sql-template
            #:$$
            #:register-sql-operators
-           #:enable-s-sql-syntax))
+           #:enable-s-sql-syntax
+           #:sql-error))
 
 (in-package :s-sql)
 
 ;; Utils
 
+(define-condition sql-error (error)
+  ((message :initarg :message :accessor sql-error-message
+            :documentation "Description of this error.")))
+
 (defun strcat (args)
   "Concatenate a list of strings into a single one."
   (let ((result (make-string (reduce #'+ args :initial-value 0 :key 'length))))
@@ -57,20 +62,20 @@ errors."
                      (cond (found
                             (let ((after-me (nthcdr (1+ found) values)))
                               (unless (or after-me no-args)
-                                (error "Keyword ~A encountered at end of arguments." me))
+                                (error 'sql-error :message "Keyword ~A encountered at end of arguments." me))
                               (let ((next (next-word (cdr words) after-me)))
                                 (cond
-                                  (no-args (unless (zerop next) (error "Keyword ~A does not take any arguments." me)))
-                                  (multi (unless (>= next 1) (error "Not enough arguments to keyword ~A." me)))
-                                  (t (unless (= next 1) (error "Keyword ~A takes exactly one argument." me))))
+                                  (no-args (unless (zerop next) (error 'sql-error :message "Keyword ~A does not take any arguments." me)))
+                                  (multi (unless (>= next 1) (error 'sql-error :message "Not enough arguments to keyword ~A." me)))
+                                  (t (unless (= next 1) (error 'sql-error :message "Keyword ~A takes exactly one argument." me))))
                                 (push (cons (caar words) (if no-args t (subseq after-me 0 next))) result)
                                 found)))
                            (optional
                             (next-word (cdr words) values))
-                           (t (error "Required keyword ~A not found." me))))
+                           (t (error 'sql-error :message "Required keyword ~A not found." me))))
                    (length values))))
       (unless (= (next-word shape list) 0)
-        (error "Arguments do not start with a valid keyword."))
+        (error 'sql-error :message "Arguments do not start with a valid keyword."))
       result)))
 
 (defmacro split-on-keywords (words form &body body)
@@ -219,7 +224,7 @@ name.")
     "SERIAL8")
   (:method ((lisp-type (eql 'db-null)) &rest args)
     (declare (ignore args))
-    (error "Bad use of ~s." 'db-null)))
+    (error 'sql-error :message "Bad use of ~s." 'db-null)))
 
 (defun to-type-name (type)
   "Turn a Lisp type expression into an SQL typename."
@@ -367,7 +372,7 @@ with a given arity."
   (let ((with-spaces (strcat (list " " name " "))))
     (flet ((check-unary (args)
              (when (or (not args) (cdr args))
-               (error "SQL operator ~A is unary." name)))
+               (error 'sql-error :message "SQL operator ~A is unary." name)))
            (expand-n-ary (args)
              `("(" ,@(sql-expand-list args with-spaces) ")")))
       (ecase arity
@@ -383,7 +388,7 @@ with a given arity."
                       (sql-expand (car args)))))
         (:2+-ary (lambda (args)
                    (unless (cdr args)
-                     (error "SQL operator ~A takes at least two arguments." name))
+                     (error 'sql-error :message "SQL operator ~A takes at least two arguments." name))
                    (expand-n-ary args)))
         (:n-or-unary (lambda (args)
                        (if (cdr args)
@@ -498,9 +503,9 @@ with a given arity."
 the proper SQL syntax for joining tables."
   (labels ((is-join (x) (member x '(:left-join :right-join :inner-join :outer-join :cross-join))))
     (when (null args)
-      (error "Empty :from clause in select"))
+      (error 'sql-error :message "Empty :from clause in select"))
     (when (is-join (car args))
-      (error ":from clause starts with a join: ~A" args))
+      (error 'sql-error :message ":from clause starts with a join: ~A" args))
     (let ((rest args))
       (loop :while rest
             :for first = t :then nil
@@ -508,7 +513,7 @@ the proper SQL syntax for joining tables."
                            (destructuring-bind (join name on clause &rest left) rest
                               (setf rest left)
                               (unless (and (eq on :on) clause)
-                                (error "Incorrect join form in select."))
+                                (error 'sql-error :message "Incorrect join form in select."))
                               `(" " ,(ecase join
                                         (:left-join "LEFT") (:right-join "RIGHT")
                                         (:inner-join "INNER") (:outer-join "FULL OUTER")
@@ -555,7 +560,7 @@ to runtime. Used to create stored procedures."
   `("INSERT INTO " ,@(sql-expand table) " "
     ,@(cond ((eq (car method) :set)
              (cond ((oddp (length (cdr method)))
-                    (error "Invalid amount of :set arguments passed to insert-into sql operator"))
+                    (error 'sql-error :message "Invalid amount of :set arguments passed to insert-into sql operator"))
                    ((null (cdr method)) '("DEFAULT VALUES"))
                    (t `("(" ,@(sql-expand-list (loop :for (field value) :on (cdr method) :by #'cddr
                                                      :collect field))
@@ -563,14 +568,14 @@ to runtime. Used to create stored procedures."
                                                               :collect value)) ")"))))
             ((and (not (cdr method)) (consp (car method)) (keywordp (caar method)))
              (sql-expand (car method)))
-            (t (error "No :set arguments or select operator passed to insert-into sql operator")))
+            (t (error 'sql-error :message "No :set arguments or select operator passed to insert-into sql operator")))
     ,@(when returning
         `(" RETURNING " ,@(sql-expand-list returning))))))
 
 (def-sql-op :update (table &rest args)
   (split-on-keywords ((set *) (where ?)) args
     (when (oddp (length set))
-      (error "Invalid amount of :set arguments passed to update sql operator"))
+      (error 'sql-error :message "Invalid amount of :set arguments passed to update sql operator"))
     `("UPDATE " ,@(sql-expand table) " SET "
       ,@(loop :for (field value) :on set :by #'cddr
               :for first = t :then nil
@@ -589,7 +594,7 @@ to runtime. Used to create stored procedures."
                      (if (eq (second type) 'db-null)
                          (values (third type) t)
                          (values (second type) t))
-                     (error "Invalid type: ~a. 'or' types must have two alternatives, one of which is ~s."
+                     (error 'sql-error :message "Invalid type: ~a. 'or' types must have two alternatives, one of which is ~s."
                             type 'db-null))
                  (values type nil)))
            (reference-action (action)
@@ -599,7 +604,7 @@ to runtime. Used to create stored procedures."
                (:set-default "SET DEFAULT")
                (:cascade "CASCADE")
                (:no-action "NO ACTION")
-               (t (error "Unsupported action for foreign key: ~A" action))))
+               (t (error 'sql-error :message "Unsupported action for foreign key: ~A" action))))
            (build-foreign (target on-delete on-update)
              `(" REFERENCES "
                ,@(if (consp target)
@@ -610,7 +615,7 @@ to runtime. Used to create stored procedures."
            (expand-column (column-name args)
              `(,(to-sql-name column-name) " "
                ,@(let ((type (or (getf args :type)
-                                 (error "No type specified for column ~A." column-name))))
+                                 (error 'sql-error :message "No type specified for column ~A." column-name))))
                    (multiple-value-bind (type null) (dissect-type type)
                      `(,(to-type-name type) ,@(when (not null) '(" NOT NULL")))))
                ,@(loop :for (option value) :on args :by #'cddr
@@ -623,7 +628,7 @@ to runtime. Used to create stored procedures."
                                   (destructuring-bind (target &optional (on-delete :restrict) (on-update :restrict)) value
                                     (build-foreign target on-delete on-update)))
                                  (:type ())
-                                 (t (error "Unknown column option: ~A." option))))))
+                                 (t (error 'sql-error :message "Unknown column option: ~A." option))))))
            (expand-option (option args)
              (case option
                (:check `("CHECK " ,@(sql-expand (car args))))
@@ -634,7 +639,7 @@ to runtime. Used to create stored procedures."
                   `("FOREIGN KEY (" ,@(sql-expand-names columns) ")"
                     ,@(build-foreign target on-delete on-update)))))))
     (when (null columns)
-      (error "No columns defined for table ~A." name))
+      (error 'sql-error :message "No columns defined for table ~A." name))
     `("CREATE TABLE " ,(to-sql-name name) " ("
       ,@(loop :for ((column-name . args) . rest) :on columns
               :append (expand-column column-name args)
-- 
1.6.0.5


