|
Revision 3942, 1.3 kB
(checked in by hans, 2 months ago)
|
Merge from anon-transaction-fixes-2 branch. This changeset removes
make-object and initialize-persistent-instance, makes the allocation
of object IDs simpler and more safe and removes several relicts from
previous refactoring iterations. Also, the store tests have been
extended significantly to test pathological cases and create objects
from multiple threads.
|
| Line | |
|---|
| 1 |
;; news.lisp |
|---|
| 2 |
|
|---|
| 3 |
;; multi-lingual news class |
|---|
| 4 |
|
|---|
| 5 |
(in-package :bos.m2) |
|---|
| 6 |
|
|---|
| 7 |
(define-persistent-class news-item (rss-item) |
|---|
| 8 |
((time :read :initform (get-universal-time)) |
|---|
| 9 |
(title :none :initform (make-string-hash-table)) |
|---|
| 10 |
(text :none :initform (make-string-hash-table)))) |
|---|
| 11 |
|
|---|
| 12 |
(deftransaction make-news-item (&key language title text) |
|---|
| 13 |
(let ((news-item (make-instance 'news-item))) |
|---|
| 14 |
(setf (slot-string news-item 'title language) title) |
|---|
| 15 |
(setf (slot-string news-item 'text language) text) |
|---|
| 16 |
news-item)) |
|---|
| 17 |
|
|---|
| 18 |
(deftransaction update-news-item (news-item language &key title text) |
|---|
| 19 |
(when title |
|---|
| 20 |
(setf (slot-string news-item 'title language) title)) |
|---|
| 21 |
(when text |
|---|
| 22 |
(setf (slot-string news-item 'text language) text))) |
|---|
| 23 |
|
|---|
| 24 |
(defmethod news-item-title ((news-item news-item) language) |
|---|
| 25 |
(slot-string news-item 'title language)) |
|---|
| 26 |
|
|---|
| 27 |
(defmethod news-item-text ((news-item news-item) language) |
|---|
| 28 |
(slot-string news-item 'text language)) |
|---|
| 29 |
|
|---|
| 30 |
(defun news-item-published (item language) |
|---|
| 31 |
(and (slot-string item 'title language nil) |
|---|
| 32 |
(slot-string item 'text language nil))) |
|---|
| 33 |
|
|---|
| 34 |
(defun all-news-items (&optional language) |
|---|
| 35 |
(if language |
|---|
| 36 |
(remove-if-not (lambda (item) (news-item-published item language)) |
|---|
| 37 |
(store-objects-with-class 'news-item)) |
|---|
| 38 |
(sort (copy-list (store-objects-with-class 'news-item)) #'> :key #'news-item-time))) |
|---|
