Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
submarine
submarine
Commits
8ac773bd
Commit
8ac773bd
authored
Aug 30, 2007
by
ryszard.szopa
Browse files
add-constraint and apply-foreign-key-constraints
darcs-hash:4aa4d55b0d989e3006469cb17a2e51595fc5cc54
parent
06338d08
Changes
1
Hide whitespace changes
Inline
Side-by-side
db.lisp
View file @
8ac773bd
...
...
@@ -82,6 +82,42 @@ be reverted.)"
(
let
((
class
(
find-class
name
)))
(
create-table
class
)))
(
defgeneric
add-constraint
(
slot
constraint
)
(
:documentation
"Add a constraint to this slot's class' table."
))
(
defmethod
add-constraint
:around
((
slot
db-class-slot-definition
)
constraint
)
(
let
((
class
(
slot-value
slot
'sb-pcl::allocation-class
)))
(
with-class-connection
(
class
)
(
postmodern:execute
(
format
nil
"ALTER TABLE ~A ADD ~A;"
(
class-name
class
)
(
call-next-method
))))))
(
defmethod
add-constraint
((
slot
db-class-slot-definition
)
(
constraint
(
eql
:foreign-key
)))
(
format
nil
"FOREIGN KEY (~A) REFERENCES ~A ON DELETE ~A"
(
sql-ize
(
slot-definition-name
slot
))
(
sql-ize
(
slot-definition-type
slot
))
(
case
(
on-delete
slot
)
(
:set-null
"SET NULL"
)
(
:set-default
"SET DEFAULT"
)
(
otherwise
(
on-delete
slot
)))))
(
defmethod
add-constraint
((
slot
db-class-slot-definition
)
(
constraint
(
eql
:unique
)))
(
format
nil
"UNIQUE ~A"
(
sql-ize
(
slot-definition-name
slot
))))
(
defmethod
apply-foreign-key-constraints
((
class
db-class
))
(
iter
(
for
slot
in
(
db-class-foreign-keys
class
))
(
let
((
closure
(
lambda
()
(
add-constraint
slot
:foreign-key
))))
;todo: in case of errors store the closure
(
handler-case
(
funcall
closure
)
(
database-error
()
(
setf
(
delayed-constraint
slot
)
closure
)
(
unless
(
member
class
(
db-class-unfinished-classes
class
)
:test
(
lambda
(
x
y
)
(
eql
(
class-name
x
)
(
class-name
y
))))
(
push
class
(
db-class-unfinished-classes
class
)))
)))))
(
define-condition
sql-error
(
simple-error
)
((
table
:initarg
:table-name
:reader
table-name
))
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment