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
1adf1ba2
Commit
1adf1ba2
authored
Aug 13, 2007
by
ryszard.szopa
Browse files
file refactoring
darcs-hash:c3f629f6b65bd889d8fb408e12b61d1173760000
parent
02caa2ae
Changes
4
Hide whitespace changes
Inline
Side-by-side
meta
.lisp
→
db
.lisp
View file @
1adf1ba2
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; -*-
(
in-package
:asdf
)
(
defpackage
:submarine
(
:use
:cl
:s-sql
:cl-postgres
:sb-mop
:iterate
))
(
in-package
:submarine
)
;;
;; Utilities
;;
;;
(
defun
class-name-of
(
object
)
"The class-name of the class of OBJECT."
(
class-name
(
class-of
object
)))
(
defun
class-non-transient-slots
(
class
)
"Return the list of non-transient slots of a class."
(
remove-if
#'
transient-p
(
class-slots
class
)))
(
defun
slots-of
(
object
)
"List of names of the slots of OBJECT."
(
mapcar
#'
slot-definition-name
(
class-slots
(
class-of
object
))))
(
defun
non-transient-slots-of
(
object
)
"List of names of non-transient slots of OBJECT."
(
mapcar
#'
slot-definition-name
(
remove-if
#'
transient-p
(
class-slots
(
class-of
object
)))))
(
defun
slot-value-or-id-if-foreign
(
object
slot
)
"SLOT-VALUE if SLOT in OBJECT is not foreign, the ID of the object in the slot otherwise."
(
let
((
value
(
slot-value
object
slot
)))
(
or
(
and
(
typep
value
'dao
)
(
get-id
value
))
value
)))
;;
;; MOP
;;
;;
(
defclass
db-class
(
standard-class
)
((
checked-schema-congruence
:initform
nil
:reader
class-checked-schema-congruence-p
)
(
indices
:initarg
:indices
:initform
()
:reader
db-class-indices
)))
(
defmethod
validate-superclass
((
class
db-class
)
(
superclass
standard-class
))
t
)
(
defclass
db-class-slot-definition
()
((
transient
:initform
nil
:initarg
:transient
:accessor
transient-p
:documentation
"Whether this slot should be treated as transient and
ignored in all database related operations."
)))
(
defclass
db-class-direct-slot-definition
(
standard-direct-slot-definition
db-class-slot-definition
)
())
(
defclass
db-class-effective-slot-definition
(
db-class-slot-definition
standard-effective-slot-definition
)
())
;; Why we need this method is magic for me... I don't know why the
;; values of initargs are not propagated to the effective slots by
;; default... Copied form mopintro.
(
defmethod
compute-effective-slot-definition
:around
((
class
db-class
)
slot-name
direct-slot-definitions
)
(
let
((
slotd
(
call-next-method
)))
(
setf
(
transient-p
slotd
)
(
every
#'
transient-p
direct-slot-definitions
))
slotd
))
(
defgeneric
foreign-type-p
(
slot
)
(
:method
((
slot
db-class-slot-definition
))
(
typep
(
find-class
(
slot-definition-type
slot
))
'db-class
)))
(
defmethod
direct-slot-definition-class
((
class
db-class
)
&rest
initargs
)
(
declare
(
ignore
initargs
))
;(call-next-method)
(
find-class
'db-class-direct-slot-definition
))
(
defmethod
effective-slot-definition-class
((
class
db-class
)
&rest
initargs
)
(
declare
(
ignore
initargs
))
;(call-next-method)
(
find-class
'db-class-effective-slot-definition
))
(
defmethod
shared-initialize
:after
((
class
db-class
)
slots
&rest
rest
)
;; create the right table, or, if a table of the right name exists,
;; check whether it meets the spec. Alter it if this is not the
;; case.
(
declare
(
ignore
rest
))
(
finalize-inheritance
class
)
(
unless
(
eq
(
class-name
class
)
'dao
)
(
create-table
class
)))
;;
;; Database stuff
...
...
@@ -243,12 +153,6 @@ table ~A. This may indicate that something is wrong." (first column) (second col
(
:documentation
"Base class for any PostgreSQL aware classes."
))
;; (defmethod shared-initialize ((instance dao) slots &rest rest)
;; ;; if id is provided, just get fill the slots from the database.
;; ;; otherwise, create a fresh one.
;; ;; If the
;; )
(
defgeneric
save-dao
(
object
)
(
:documentation
"Save a dao: update it when it already exists, insert it otherwise."
)
(
:method
((
dao
dao
))
...
...
@@ -290,7 +194,7 @@ exists in the database.")
(
:documentation
"Update the dao's representation in the database
with the values in the given object."
))
(
defmethod
update-dao
((
dao
class
))
(
defmethod
update-dao
((
dao
dao
))
(
postmodern::execute
(
sql-compile
`
(
:update
,
(
class-name-of
dao
)
:set
,@
(
set-fields
dao
)
:where
(
:=
'id
(
get-id
dao
))))))
...
...
mop.lisp
0 → 100644
View file @
1adf1ba2
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; -*-
(
in-package
:submarine
)
;;
;; MOP
;;
;;
(
defclass
db-class
(
standard-class
)
((
indices
:initarg
:indices
:initform
()
:reader
db-class-indices
)))
(
defmethod
validate-superclass
((
class
db-class
)
(
superclass
standard-class
))
t
)
(
defclass
db-class-slot-definition
()
((
transient
:initform
nil
:initarg
:transient
:accessor
transient-p
:documentation
"Whether this slot should be treated as transient and
ignored in all database related operations."
)))
(
defclass
db-class-direct-slot-definition
(
standard-direct-slot-definition
db-class-slot-definition
)
())
(
defclass
db-class-effective-slot-definition
(
db-class-slot-definition
standard-effective-slot-definition
)
())
;; Why we need this method is magic for me... I don't know why the
;; values of initargs are not propagated to the effective slots by
;; default... Copied form mopintro.
(
defmethod
compute-effective-slot-definition
:around
((
class
db-class
)
slot-name
direct-slot-definitions
)
(
let
((
slotd
(
call-next-method
)))
(
setf
(
transient-p
slotd
)
(
every
#'
transient-p
direct-slot-definitions
))
slotd
))
(
defgeneric
foreign-type-p
(
slot
)
(
:method
((
slot
db-class-slot-definition
))
(
typep
(
find-class
(
slot-definition-type
slot
))
'db-class
)))
(
defmethod
direct-slot-definition-class
((
class
db-class
)
&rest
initargs
)
(
declare
(
ignore
initargs
))
(
find-class
'db-class-direct-slot-definition
))
(
defmethod
effective-slot-definition-class
((
class
db-class
)
&rest
initargs
)
(
declare
(
ignore
initargs
))
(
find-class
'db-class-effective-slot-definition
))
(
defmethod
shared-initialize
:after
((
class
db-class
)
slots
&rest
rest
)
;; create the right table, or, if a table of the right name exists,
;; check whether it meets the spec. Alter it if this is not the
;; case.
(
declare
(
ignore
rest
))
(
finalize-inheritance
class
)
(
unless
(
eq
(
class-name
class
)
'dao
)
(
create-table
class
)))
submarine.asd
View file @
1adf1ba2
...
...
@@ -6,7 +6,10 @@
(
in-package
:submarine-system
)
(
defsystem
:submarine
:depends-on
(
:postmodern
)
:depends-on
(
:postmodern
:iterate
)
:serial
t
:components
((
:file
"package"
)
(
:file
"meta"
:depends-on
(
"package"
))))
\ No newline at end of file
(
:file
"utilities"
)
(
:file
"mop"
)
(
:file
"db"
)))
\ No newline at end of file
utilities.lisp
0 → 100644
View file @
1adf1ba2
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; -*-
(
in-package
:submarine
)
;;
;; Utilities
;;
;;
(
defun
class-name-of
(
object
)
"The class-name of the class of OBJECT."
(
class-name
(
class-of
object
)))
(
defun
class-non-transient-slots
(
class
)
"Return the list of non-transient slots of a class."
(
remove-if
#'
transient-p
(
class-slots
class
)))
(
defun
slots-of
(
object
)
"List of names of the slots of OBJECT."
(
mapcar
#'
slot-definition-name
(
class-slots
(
class-of
object
))))
(
defun
non-transient-slots-of
(
object
)
"List of names of non-transient slots of OBJECT."
(
mapcar
#'
slot-definition-name
(
remove-if
#'
transient-p
(
class-slots
(
class-of
object
)))))
(
defun
slot-value-or-id-if-foreign
(
object
slot
)
"SLOT-VALUE if SLOT in OBJECT is not foreign, the ID of the object in the slot otherwise."
(
let
((
value
(
slot-value
object
slot
)))
(
or
(
and
(
typep
value
'dao
)
(
get-id
value
))
value
)))
\ No newline at end of file
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