support :on-delete and :on-update args to !foreign
Sat Mar 20 12:15:32 PDT 2010 marijnh@gmail.com
* support :on-delete and :on-update args to !foreign
Warning: CRC errors found. These are probably harmless but should be repaired.
See 'darcs gzcrcs --help' for more information.
diff -rN -u old-postmodern/doc/postmodern.html new-postmodern/doc/postmodern.html
--- old-postmodern/doc/postmodern.html 2014-07-13 02:27:31.000000000 -0700
+++ new-postmodern/doc/postmodern.html 2014-07-13 02:27:31.000000000 -0700
@@ -830,7 +830,7 @@
<p class="def">
<a name="!foreign"></a>
<span>function</span>
- !foreign (target-table columns &amp;optional target-columns)
+ !foreign (target-table columns &amp;optional target-columns &amp;key on-delete on-update)
</p>
<p class="desc">Add a foreign key to the table being defined.
@@ -840,6 +840,14 @@
the table referred to, <code>target-columns</code> should be
another list of names or single name for the target table.</p>
+ <p class="desc">The <code>on-delete</code> and
+ <code>on-update</code> arguments can be used to specify ON DELETE
+ and ON UPDATE actions, as per the keywords allowed in <a
+ href="s-sql.html#create-table"><code>create-table</code></a>. Note
+ that they are not really &amp;key arguments, but rather are picked
+ out of a &amp;rest arg at runtime, so that they can be specified
+ even when <code>target-columns</code> is not given.</p>
+
<h2 id="index">Symbol-index</h2>
<ul class="symbol-index">
diff -rN -u old-postmodern/postmodern/deftable.lisp new-postmodern/postmodern/deftable.lisp
--- old-postmodern/postmodern/deftable.lisp 2014-07-13 02:27:31.000000000 -0700
+++ new-postmodern/postmodern/deftable.lisp 2014-07-13 02:27:31.000000000 -0700
@@ -66,17 +66,21 @@
corresponding DAO class' slots."
(dao-table-definition *table-symbol*))
-(defun \!foreign (target fields &optional target-fields)
+(defun \!foreign (target fields &rest target-fields/on-delete/on-update)
"Used inside a deftable form. Define a foreign key on this table.
Pass a table the index refers to, a list of fields or single field in
*this* table, and, if the fields have different names in the table
referred to, another field or list of fields for the target table."
- (labels ((fkey-name (target fields)
- (to-sql-name (format nil "~a_~a_~{~a~^_~}_foreign" *table-name* target fields))))
- (unless (listp fields) (setf fields (list fields)))
- (unless (listp target-fields) (setf target-fields (list target-fields)))
- (let* ((target-name (to-sql-name target))
- (field-names (mapcar #'to-sql-name fields))
- (target-names (if target-fields (mapcar #'to-sql-name target-fields) field-names)))
- (format nil "ALTER TABLE ~a ADD CONSTRAINT ~a FOREIGN KEY (~{~a~^, ~}) REFERENCES ~a (~{~a~^, ~})"
- *table-name* (fkey-name target fields) field-names target-name target-names))))
+ (let* ((args target-fields/on-delete/on-update)
+ (target-fields (and args (listp (car args)) (pop args))))
+ (labels ((fkey-name (target fields)
+ (to-sql-name (format nil "~a_~a_~{~a~^_~}_foreign" *table-name* target fields))))
+ (unless (listp fields) (setf fields (list fields)))
+ (unless (listp target-fields) (setf target-fields (list target-fields)))
+ (let* ((target-name (to-sql-name target))
+ (field-names (mapcar #'to-sql-name fields))
+ (target-names (if target-fields (mapcar #'to-sql-name target-fields) field-names)))
+ (format nil "ALTER TABLE ~a ADD CONSTRAINT ~a FOREIGN KEY (~{~a~^, ~}) REFERENCES ~a (~{~a~^, ~}) ~@[ON DELETE ~a~] ~@[ON UPDATE ~a~]"
+ *table-name* (fkey-name target fields) field-names target-name target-names
+ (s-sql::expand-foreign-on* (getf args :on-delete))
+ (s-sql::expand-foreign-on* (getf args :on-update)))))))
diff -rN -u old-postmodern/s-sql/s-sql.lisp new-postmodern/s-sql/s-sql.lisp
--- old-postmodern/s-sql/s-sql.lisp 2014-07-13 02:27:31.000000000 -0700
+++ new-postmodern/s-sql/s-sql.lisp 2014-07-13 02:27:31.000000000 -0700
@@ -660,21 +660,22 @@
type 'db-null))
(values type nil)))
+(defun expand-foreign-on* (action)
+ (case action
+ (:restrict "RESTRICT")
+ (:set-null "SET NULL")
+ (:set-default "SET DEFAULT")
+ (:cascade "CASCADE")
+ (:no-action "NO ACTION")
+ (t (sql-error "Unsupported action for foreign key: ~A" action))))
+
(defun %build-foreign-reference (target on-delete on-update)
- (flet ((reference-action (action)
- (case action
- (:restrict "RESTRICT")
- (:set-null "SET NULL")
- (:set-default "SET DEFAULT")
- (:cascade "CASCADE")
- (:no-action "NO ACTION")
- (t (sql-error "Unsupported action for foreign key: ~A" action)))))
- `(" REFERENCES "
- ,@(if (consp target)
- `(,(to-sql-name (car target)) "(" ,@(sql-expand-names (cdr target)) ")")
- `(,(to-sql-name target)))
- " ON DELETE " ,(reference-action on-delete)
- " ON UPDATE " ,(reference-action on-update))))
+ `(" REFERENCES "
+ ,@(if (consp target)
+ `(,(to-sql-name (car target)) "(" ,@(sql-expand-names (cdr target)) ")")
+ `(,(to-sql-name target)))
+ " ON DELETE " ,(expand-foreign-on* on-delete)
+ " ON UPDATE " ,(expand-foreign-on* on-update))))
(defun expand-table-constraint (option args)
(case option