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
23674ba1
Commit
23674ba1
authored
Sep 06, 2007
by
ryszard.szopa
Browse files
db-class can have multislot unique constraints.
darcs-hash:777c54511cd689a703ef292ebb5d6578fc4f1368
parent
25b23bbe
Changes
3
Hide whitespace changes
Inline
Side-by-side
db.lisp
View file @
23674ba1
...
...
@@ -77,7 +77,8 @@ be reverted.)"
(
warn
"Table ~A already exists."
(
class-name
class
)))
(
error
err
))))
; here should be some code dropping constraints that are not necessary
(
apply-foreign-key-constraints
class
)))
(
apply-foreign-key-constraints
class
)
(
apply-unique-constraints
class
)))
(
defmethod
create-table
((
name
symbol
))
(
let
((
class
(
find-class
name
)))
...
...
@@ -106,6 +107,18 @@ be reverted.)"
(
format
nil
"UNIQUE ~A"
(
sql-ize
(
slot-definition-name
slot
))))
(
defmethod
add-constraint
((
list
list
)
(
constraint
(
eql
:unique
)))
(
assert
(
every
(
lambda
(
x
)
(
typep
x
'db-class-slot-definition
))
list
))
(
let
((
class
(
slot-value
(
car
list
)
'sb-pcl::allocation-class
)))
(
with-class-connection
(
class
)
(
postmodern:execute
(
format
nil
"ALTER TABLE ~A ADD UNIQUE (~A~{, ~A~});"
(
sql-ize
(
class-name
class
))
(
sql-ize
(
slot-definition-name
(
car
list
)))
(
mapcar
#'
(
lambda
(
x
)
(
sql-ize
(
slot-definition-name
x
)))
(
cdr
list
)))))))
(
defmethod
apply-foreign-key-constraints
((
class
db-class
))
(
iter
(
for
slot
in
(
db-class-foreign-keys
class
))
(
let
((
closure
(
lambda
()
...
...
mop.lisp
View file @
23674ba1
...
...
@@ -32,6 +32,7 @@ wrong with its SQL counterpart.")))
(
defmetaclass
db-class
(
standard-class
)
((
indices
:initarg
:indices
:initform
()
:reader
db-class-indices
)
(
unique
:initarg
:unique
:initform
()
:reader
db-class-unique
)
;; TODO: Additional slot, CONSTRAINTS.
(
connection-spec
:initarg
:connection-spec
:initform
nil
:reader
db-class-connection-spec
)
...
...
@@ -100,7 +101,9 @@ metaclass set to DB-CLASS."
(
when
(
foreign-type-p
slot
)
(
push
slot
(
db-class-foreign-keys
class
)))
(
when
(
unique
slot
)
(
push
slot
(
db-class-unique-keys
class
)))))
(
push
slot
(
db-class-unique-keys
class
))))
(
iter
(
for
constraint
in
(
db-class-unique
class
))
(
push
(
mapcar
(
lambda
(
x
)
(
get-slot-by-name
class
x
))
constraint
)
(
db-class-unique-keys
class
))))
(
defgeneric
remove-finished-classes
(
class
)
(
:documentation
"Remove classes that are already finished from UNFINISHED-CLASSES of CLASS."
)
...
...
submarine-tests.lisp
View file @
23674ba1
...
...
@@ -270,6 +270,17 @@ metaclass set to HTML and the right connection-spec."
(
is
(
null
(
select-dao
'some-long-name
))))
(
db-test
(
unique-constraints
:depends-on
dao-definition
)
(
finishes
(
defdao-example
cinco
()
((
foo
:type
integer
:accessor
foo
:initarg
:foo
)
(
bar
:type
integer
:accessor
bar
:initarg
:bar
))
(
:unique
(
foo
bar
))))
(
make-and-save
'cinco
:foo
1
:bar
1
)
(
finishes
(
make-and-save
'cinco
:foo
1
:bar
2
))
(
finishes
(
make-and-save
'cinco
:foo
2
:bar
1
))
(
signals
cl-postgres:database-error
(
make-and-save
'cinco
:foo
1
:bar
1
)))
;;; Copyright (C) 2007
;;; Ryszard Szopa <ryszard.szopa@gmail.com> &
;;; Streamtech http://streamtech.nl/
...
...
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