SQLite client WIP, support UPSERT

sql/sql-api.cl

@@ -1,7 +1,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Description    High-level SQL API
 ;;; Author         Michael Kappert 2013
-;;; Last Modified  <michael 2019-12-17 22:53:48>
+;;; Last Modified  <michael 2019-12-25 21:58:25>
 
 (in-package :sql)
 
@@ -20,7 +20,8 @@
         (constraints
           (loop :for constraint :in constraints :collect
              (destructuring-bind (&key primary-key foreign-key unique-key
-                                       columns referenced-table referenced-columns)
+                                       columns referenced-table referenced-columns
+                                       (on-update :restrict) (on-delete :cascade))
                  constraint
                (cond (primary-key
                       `(make-primary-key :name ,primary-key
@@ -31,7 +32,9 @@
                                          :columns ',columns
                                          :referenced-table-schema ,schema
                                          :referenced-table ',referenced-table
-                                         :referenced-columns ',referenced-columns))
+                                         :referenced-columns ',referenced-columns
+                                         :on-update ,on-update
+                                         :on-delete ,on-delete))
                      (unique-key
                       `(make-unique-key :name ,unique-key
                                         :columns ',columns)))))))
@@ -67,46 +70,30 @@
 ;;; create schema
 
 (defun create-schema (schema)
-  ;; At least try to clean up before attempting to create the schema
-  (%drop-schema (schema-name schema) :if-does-not-exist :ignore :if-not-empty :force)
-
-  ;; Create schema initially empty
-  (%create-schema user-name :name (schema-name schema))
-
-  ;; Create tables initially without constraints.
-  (dolist (tabdef (schema-tables schema))
-    (let ((new-tabdef (copy-tabdef tabdef)))
-      (setf (tabdef-constraints new-tabdef) nil)
-      (%create-table new-tabdef)))
-
-  ;; Constraints cannot be altered. Create constraints only for new tables.
-  ;; Create all primary keys
-  (dolist (tabdef (schema-tables schema))
-    (dolist (constraint (tabdef-constraints tabdef))
-      (when (primary-key-p constraint)
-        (%add-primary-key tabdef constraint))))
-
-  ;; Create UNIQUE contraints
-  (dolist (tabdef (schema-tables schema))
-    (dolist (constraint (tabdef-constraints tabdef))
-      (when (unique-key-p constraint)
-        (%add-unique-key tabdef constraint))))
+    ;; At least try to clean up before attempting to create the schema
+
+    ;; not implemented in SQLite
+    ;; (%drop-schema (schema-name schema) :if-does-not-exist :ignore :if-not-empty :force)
+
+    ;; Create schema initially empty
+    (%create-schema (schema-name schema) :if-exists :ignore)
+
+    ;; Create tables
+    (with-transaction ()
 
-  ;; Create all foreign keys (refer to tables and their primary keys)
-  (dolist (tabdef (schema-tables schema))
-    (dolist (constraint (tabdef-constraints tabdef))
-      (when (foreign-key-p constraint)
-        (%add-foreign-key tabdef constraint)))))
+      (dolist (tabdef (schema-tables schema))
+        (%create-table tabdef))))
 
 
 (defun wipe-schema (schema)
   (dolist (tabdef (schema-tables schema))
     (%drop-table tabdef :if-not-empty :force)))
 
 (defun clear-schema (schema)
-  (dolist (tabdef (schema-tables schema))
-    (?delete (tabdef-name tabdef))))
-
+  (with-transaction ()
+    (dolist (tabdef (schema-tables schema))
+      (?delete (tabdef-name tabdef)))))
+
 
 (defun update-schema (schema user-name &key (redeploy nil))
   (with-transaction ()

sql/sql-ddl.cl

@@ -1,7 +1,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Description
 ;;; Author         Michael 2013
-;;; Last Modified <michael 2019-12-15 17:10:35>
+;;; Last Modified <michael 2020-01-09 21:07:40>
 
 (in-package :sql)
 
@@ -58,7 +58,7 @@
   cascade)
 
 
-(defstruct tabdef schema name columns constraints)
+(defstruct tabdef schema name columns constraints %pk_columns)
 
 (defun create-tabdef (&key schema name columns constraints)
   (when (symbolp name)
@@ -72,6 +72,18 @@
                :columns columns
                :constraints constraints))
 
+(defun tabdef-pk-columns (tabdef)
+  (or (tabdef-%pk_columns tabdef)
+      (setf  (tabdef-%pk_columns tabdef)
+             (let ((pk (find-if (lambda (c) (typep c 'primary-key)) (tabdef-constraints tabdef))))
+               (primary-key-columns pk)))))
+
+(defun tabdef-pk-column-p (tabdef column)
+  (member (symbol-name column)
+          (tabdef-pk-columns tabdef)
+          :test #'string-equal))
+
+
 ;;; Column definitions
 (defstruct coldef name datatype default-value collation constraint)
 (defstruct colcon label notnull check default unique references)
@@ -117,12 +129,13 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Schemas
 
-(defstruct schema-create-statement schema authorization tables)
+(defstruct schema-create-statement schema authorization if-exists)
 
-(defun %create-schema (name &key (owner name) (tabdefs)) 
+(defun %create-schema (name &key authorization (if-exists :ignore))
+  (ecase if-exists ((:ignore :error)))
   (sql:sql-exec
    *current-connection*
-   (make-schema-create-statement :schema name :authorization owner :tables tabdefs)))
+   (make-schema-create-statement :schema name :authorization authorization :if-exists if-exists)))
 
 (defmethod sql:sql-exec ((conn t) (statement schema-create-statement))
   (sql:sql-exec conn

sql/sql-dml.cl

@@ -1,7 +1,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Description
 ;;; Author         Michael 2013
-;;; Last Modified <D037165 2018-03-16 10:19:54>
+;;; Last Modified <michael 2020-01-09 22:18:07>
 
 (in-package :sql)
 
@@ -27,10 +27,19 @@
 
 (defstruct (sql-table-statement (:include sql-statement))
   table)
-(defstruct (sql-update (:include sql-table-statement))
-  expression condition)
+
 (defstruct (sql-insert (:include sql-table-statement))
-  columns values)
+  columns
+  values)
+
+(defstruct (sql-update (:include sql-table-statement))
+  expression
+  condition)
+
+(defstruct (sql-upsert (:include sql-insert))
+  key-columns
+  update)
+
 (defstruct (sql-delete (:include sql-table-statement))
   condition)
 
@@ -105,7 +114,6 @@
                     :values values)))
 
 (defgeneric ?insert (values &key into columns))
-
 (defmethod ?insert ((values t) &key into columns)
   (sql:sql-exec
    *current-connection*
@@ -114,8 +122,9 @@
                                  (list columns)
                                  columns)
                     :values values)))
-
-(defun ?update (table &key set to where)
+
+(defgeneric ?update (table &key set to where)) 
+(defmethod ?update (table &key set to where)
   (sql:sql-exec
    *current-connection*
    (make-sql-update :table table
@@ -128,7 +137,7 @@
    (make-sql-delete :table table
                     :condition where)))
 
-(defmacro ?select (select-list &key (into nil) appending from where groupby having (lock-mode :none) (nowait nil))
+(defmacro ?select (select-list &key (into nil) (rows :multi)  appending from where groupby having (lock-mode :none) (nowait nil))
   (declare (ignorable appending))
   `(macrolet ((?select (select-list &key from where groupby having as)
                 `(let* ((select-list ,select-list)
@@ -163,9 +172,12 @@
                                                :having ,having
                                                :lock-mode ,lock-mode
                                                :nowait ,nowait)))
-         (if ,into
-           (fetch ,into (list columns rows))
-           (values columns rows))))))
+         (cond
+           (,into
+            (let ((container (output-container-for-spec ,into :mode ,rows)))
+              (fetch container (list columns rows))))
+           (t
+            (values columns rows)))))))
 
 (defmacro ?alias (column alias)
   `(make-select-item :colspec ,column :alias ,alias))

sql/sql-if.cl

@@ -1,7 +1,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Description  Low-level interface to the backend 
 ;;; Author         Michael 2014
-;;; Last Modified <michael 2019-12-17 22:53:20>
+;;; Last Modified <michael 2020-01-02 20:41:44>
 
 (in-package :sql)
 
@@ -33,13 +33,14 @@
   (:documentation "This function is called to serialize SQL objects into SQL fragments"))
 
 (defgeneric fetch (transient-table result &key field-mapper)
-  ;; Currently not used !
   ;; #ToDo: Think about how to integrate this into ?select/sql-query.
   ;; -> for example, require sql-query to return am object of type sql-result
   ;;    (instead of (values columns rows)) and dispatch on it.
   (:documentation "This function is called by ?select to fetch data rows from the DB"))
 
-(defmethod sql:sql-exec ((conn t) (sql-statement sql-statement))
+(defgeneric output-container-for-spec (spec &key mode))
+
+(defmethod sql-exec ((conn t) (sql-statement sql-statement))
   ;; The default SQL-EXEC method simply serializes the command into a string
   ;; using SERIALIZE-FOR-CONNECTION.
   ;; Backends should specialize SERIALIZE-FOR-CONNECTION and specialize SQL-EXEC

sql/sql-package.cl

@@ -1,7 +1,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Description
 ;;; Author         Michael 2014
-;;; Last Modified <michael 2019-12-17 23:10:15>
+;;; Last Modified <michael 2020-01-09 21:08:33>
 
 (defpackage "SQL"
   (:use "COMMON-LISP"
@@ -58,14 +58,17 @@
 
    ;; Schema
    defschema
+   create-schema
    %create-schema
    get-schema-by-name
    find-db-schema
 
    schema
    schema-create-statement
    schema-create-statement-name
-   schema-create-statement-owner
+   schema-create-statement-authorization
+   schema-create-statement-if-exists
+
    schema-drop-statement
    make-schema
    schema-name
@@ -84,6 +87,8 @@
    tabdef-name
    tabdef-columns
    tabdef-constraints
+   tabdef-pk-columns
+   tabdef-pk-column-p
 
    table-create-statement
    table-drop-statement
@@ -228,9 +233,10 @@
    %copy-table
    %truncate-table
 
-   ?update
    ?insert-into
    ?insert
+   ?upsert
+   ?update
    ?delete
    ?select
    ?inner-join
@@ -287,7 +293,7 @@
    timestamp
    duration
    date
-
+   
    ;; UUIDs
    create-uuid
 

sql/sql-parser.cl

@@ -1,7 +1,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Description
 ;;; Author         Michael Kappert 2019
-;;; Last Modified <D037165 2019-12-18 13:30:20>
+;;; Last Modified <michael 2019-12-19 17:56:59>
 
 (in-package :sql)
 
@@ -37,7 +37,13 @@
         ((string= ctype "UNIQUE")
          (make-unique-key :name name :columns (second spec)))
         ((string= ctype "FOREIGN")
-         (make-foreign-key :name name :columns (third spec)))))))
+          (destructuring-bind (symbol tree)
+              (fourth spec)
+            (make-foreign-key :name name
+                              :columns (third spec)
+                              :referenced-table (token-value (second tree))
+                              :referenced-columns (third tree))))))))
+
 
 (defun _primary (symbol tree level)
   (destructuring-bind (p k columns)