source: project/sqlite3-tinyclos/sqlite3-tinyclos.scm @ 384

Last change on this file since 384 was 384, checked in by Thomas Chust, 15 years ago

Useless keyword argument add-slot removed from
sqlite3:define-stored-object-class

File size: 9.9 KB
Line 
1;;;; sqlite3-tinyclos.scm {{{
2;;;; Provides a bridge between persistent storage in SQLite3 tables and
3;;;; TinyCLOS objects.
4
5(define-extension sqlite3-tinyclos
6  (export
7    <sqlite3:stored-object-class>
8    <sqlite3:stored-object>
9      <sqlite3:stored-object/automatic-integer-pk>
10    initialize
11    sqlite3:db
12    sqlite3:table
13    sqlite3:pk
14    sqlite3:pk/select
15    sqlite3:pk/update
16    sqlite3:pk/where
17    sqlite3:fields
18    sqlite3:set-pk!
19    sqlite3:in-store?
20    sqlite3:create-in-store!
21    sqlite3:remove-from-store!
22    sqlite3:get-stored-property
23    sqlite3:set-stored-property!
24    sqlite3:field-name->getter-symbol
25    sqlite3:field-name->setter-symbol
26    sqlite3:define-stored-object-class))
27
28(require-extension
29  (srfi 1) (srfi 13) (srfi 26) lolevel extras tinyclos sqlite3)
30;;;; }}}
31
32;;; metaclass for database object classes {{{
33(define-class <sqlite3:stored-object-class> (<class>)
34  (db table pk fields))
35
36;; initialize an instance {{{
37(define-method (initialize (self <sqlite3:stored-object-class>) initargs)
38  (call-next-method)
39  (initialize-slots self initargs)
40  (let ((fields (sqlite3:map-row
41                  (lambda (cid name type not-null? default-value pk?)
42                    (cons (not (zero? pk?)) name))
43                  (sqlite3:db self)
44                  (sprintf "PRAGMA table_info(~A);" (sqlite3:table self)))))
45    (slot-set! self 'pk
46      (filter-map (lambda (f) (and (car f) (cdr f))) fields))
47    (slot-set! self 'fields
48      (filter-map (lambda (f) (and (not (car f)) (cdr f))) fields))))
49;; }}}
50
51;; get database handle {{{
52(define-generic sqlite3:db)
53(define-method (sqlite3:db (self <sqlite3:stored-object-class>))
54  (slot-ref self 'db))
55;; }}}
56
57;; get database table name {{{
58(define-generic sqlite3:table)
59(define-method (sqlite3:table (self <sqlite3:stored-object-class>))
60  (slot-ref self 'table))
61;; }}}
62
63;; get database table primary key {{{
64(define-generic sqlite3:pk)
65(define-method (sqlite3:pk (self <sqlite3:stored-object-class>))
66  (slot-ref self 'pk))
67
68(define-generic sqlite3:pk/select)
69(define-method (sqlite3:pk/select (self <sqlite3:stored-object-class>))
70  (string-intersperse (sqlite3:pk self) ", "))
71
72(define-generic sqlite3:pk/update)
73(define-method (sqlite3:pk/update (self <sqlite3:stored-object-class>))
74  (string-intersperse
75    (map (cut string-append <> " = ?") (sqlite3:pk self)) ", "))
76
77(define-generic sqlite3:pk/where)
78(define-method (sqlite3:pk/where (self <sqlite3:stored-object-class>))
79  (string-intersperse
80    (map (cut string-append <> " = ?") (sqlite3:pk self)) " AND "))
81;; }}}
82
83;; get database table fields {{{
84(define-generic sqlite3:fields)
85(define-method (sqlite3:fields (self <sqlite3:stored-object-class>))
86  (slot-ref self 'fields))
87;; }}}
88;;; }}}
89
90;;; base class for database objects {{{
91(define-class <sqlite3:stored-object>
92  (<object>)
93  (pk))
94
95;; initialize an instance {{{
96(define-method (initialize (self <sqlite3:stored-object>) initargs)
97  (call-next-method)
98  (if (and (pair? initargs) (symbol? (car initargs)))
99    (initialize-slots self initargs)
100    (slot-set! self 'pk initargs))
101  (unless (sqlite3:in-store? self)
102    (sqlite3:create-in-store! self)))
103;; }}}
104
105;; get primary key data {{{
106(define-method (sqlite3:pk (self <sqlite3:stored-object>))
107  (slot-ref self 'pk))
108;; }}}
109
110;; set primary key data {{{
111(define-generic sqlite3:set-pk!)
112(define-method (sqlite3:set-pk! (self <sqlite3:stored-object>) . new-pk)
113  (apply sqlite3:exec
114    (sqlite3:db self)
115    (sprintf "UPDATE ~A SET ~A WHERE ~A;"
116      (sqlite3:table self)
117      (sqlite3:pk/update self)
118      (sqlite3:pk/where self))
119    (append new-pk (sqlite3:pk self)))
120  (slot-set! self 'pk new-pk))
121;; }}}
122
123;; get database, table, primary key and field information from class {{{
124(define-method (sqlite3:db (self <sqlite3:stored-object>))
125  (sqlite3:db (class-of self)))
126
127(define-method (sqlite3:table (self <sqlite3:stored-object>))
128  (sqlite3:table (class-of self)))
129
130(define-method (sqlite3:pk/select (self <sqlite3:stored-object>))
131  (sqlite3:pk/select (class-of self)))
132
133(define-method (sqlite3:pk/update (self <sqlite3:stored-object>))
134  (sqlite3:pk/update (class-of self)))
135
136(define-method (sqlite3:pk/where (self <sqlite3:stored-object>))
137  (sqlite3:pk/where (class-of self)))
138
139(define-method (sqlite3:fields (self <sqlite3:stored-object>))
140  (sqlite3:fields (class-of self)))
141;; }}}
142
143;; check for existence of the stored representation {{{
144(define-generic sqlite3:in-store?)
145(define-method (sqlite3:in-store? (self <sqlite3:stored-object>))
146  (not (zero? (apply sqlite3:first-result
147                (sqlite3:db self)
148                (sprintf "SELECT count(*) FROM ~A WHERE ~A;"
149                  (sqlite3:table self) (sqlite3:pk/where self))
150                (sqlite3:pk self)))))
151;; }}}
152
153;; create stored representation if it does not exist already {{{
154(define-generic sqlite3:create-in-store!)
155(define-method (sqlite3:create-in-store! (self <sqlite3:stored-object>))
156  (not (zero? (apply sqlite3:update
157                (sqlite3:db self)
158                (sprintf "INSERT OR IGNORE INTO ~A(~A) VALUES(~A);"
159                  (sqlite3:table self) (sqlite3:pk/select self)
160                  (string-intersperse
161                    (make-list (length (sqlite3:pk self)) "?") ", "))
162                (sqlite3:pk self)))))
163;; }}}
164
165;; remove stored representation of the object {{{
166(define-generic sqlite3:remove-from-store!)
167(define-method (sqlite3:remove-from-store! (self <sqlite3:stored-object>))
168  (not (zero? (apply sqlite3:update
169                (sqlite3:db self)
170                (sprintf "DELETE FROM ~A WHERE ~A;"
171                  (sqlite3:table self)
172                  (sqlite3:pk/where self))
173                (sqlite3:pk self)))))
174;; }}}
175
176;; get a stored property {{{
177(define-generic sqlite3:get-stored-property)
178(define-method (sqlite3:get-stored-property
179                 (self <sqlite3:stored-object>) (prop <string>))
180  (apply sqlite3:first-result
181    (sqlite3:db self)
182    (sprintf "SELECT ~A FROM ~A WHERE ~A;"
183      prop (sqlite3:table self) (sqlite3:pk/where self))
184    (slot-ref self 'pk)))
185;; }}}
186
187;; set a stored property {{{
188(define-generic sqlite3:set-stored-property!)
189(define-method (sqlite3:set-stored-property!
190                 (self <sqlite3:stored-object>) (prop <string>) value)
191  (apply sqlite3:exec
192    (sqlite3:db self)
193    (sprintf "UPDATE ~A SET ~A = ? WHERE ~A;"
194      (sqlite3:table self) prop (sqlite3:pk/where self))
195    value
196    (sqlite3:pk self)))
197;; }}}
198;;; }}}
199
200;;; base class with automatic INTEGER PRIMARY KEY allocation {{{
201;;; remember to lock the database for exclusive access when creating an object
202;;; of this class
203(define-class <sqlite3:stored-object/automatic-integer-pk>
204  (<sqlite3:stored-object>)
205  ())
206
207(define-method (sqlite3:in-store?
208                 (self <sqlite3:stored-object/automatic-integer-pk>))
209  (if (null? (sqlite3:pk self))
210    (begin
211      (slot-set! self 'pk
212        (sqlite3:first-row
213          (sqlite3:db self)
214          (sprintf "SELECT coalesce(max(~A), 0) + 1 FROM ~A;"
215            (car (sqlite3:pk (class-of self)))
216            (sqlite3:table self))))
217      #f)
218    (call-next-method)))
219;;; }}}
220
221;;; create a new database object class {{{
222(define (sqlite3:field-name->getter-symbol name #!optional (prefix "")) ;; {{{
223  (let ((name (string-translate name #\_ #\-)))
224    (string->symbol
225      (string-append
226        prefix
227        (if (string-prefix? "is-" name)
228          (string-append (substring name 3) "?")
229          name))))) ;; }}}
230
231(define (sqlite3:field-name->setter-symbol name #!optional (prefix "")) ;; {{{
232  (let ((name (string-translate name #\_ #\-)))
233    (string->symbol
234      (string-append
235        prefix
236        "set-"
237        (if (string-prefix? "is-" name)
238          (substring name 3)
239          name)
240        "!")))) ;; }}}
241
242(define (sqlite3:define-stored-object-class db table . key-params)
243  (let* ((key-pairs (map
244                      (lambda (l)
245                        (cons (car l) (cadr l)))
246                      (chop key-params 2)))
247         (prefix (->string (alist-ref prefix: key-pairs eq? "")))
248         (name/string (->string
249                        (alist-ref
250                          name: key-pairs eq?
251                          (string-append
252                            prefix (string-trim-right table #\s)))))
253         (name (string->symbol name/string))
254         (symbol/string (->string
255                          (alist-ref
256                            symbol: key-pairs eq?
257                            (string-append "<" name/string ">"))))
258         (symbol (string->symbol symbol/string))
259         (supers (append
260                   (filter-map
261                     (lambda (key-value)
262                       (and (eq? (car key-value) add-super:) (cdr key-value)))
263                     key-pairs)
264                   (alist-ref
265                     supers: key-pairs eq? (list <sqlite3:stored-object>))))
266         (slots (alist-ref slots: key-pairs eq? '()))
267         (class (make <sqlite3:stored-object-class>
268                  'name name
269                  'direct-supers supers
270                  'direct-slots slots
271                  'db db
272                  'table table))
273         (no-getter-or-setter (alist-ref
274                                no-getter-or-setter: key-pairs eq? '()))
275         (no-getter (append
276                      no-getter-or-setter
277                      (alist-ref no-getter: key-pairs eq? '())))
278         (no-setter (append
279                      no-getter-or-setter
280                      (alist-ref no-setter: key-pairs eq? '()))))
281    (for-each
282      (lambda (name)
283        (unless (member name no-getter)
284          (let* ((getter-sym (sqlite3:field-name->getter-symbol name prefix))
285                 (getter (if (global-bound? getter-sym)
286                           (global-ref getter-sym)
287                           (let ((getter (make-generic
288                                           (symbol->string getter-sym))))
289                             (global-set! getter-sym getter)
290                             getter))))
291            (add-method getter
292              (make-method (list class)
293                (if (string-prefix? "is_" name)
294                  (lambda (call-next-method self)
295                    (let ((flag? (sqlite3:get-stored-property self name)))
296                      (and flag? (not (zero? flag?)))))
297                  (lambda (call-next-method self)
298                    (sqlite3:get-stored-property self name)))))))
299        (unless (member name no-setter)
300          (let* ((setter-sym (sqlite3:field-name->setter-symbol name prefix))
301                 (setter (if (global-bound? setter-sym)
302                           (global-ref setter-sym)
303                           (let ((setter (make-generic
304                                           (symbol->string setter-sym))))
305                             (global-set! setter-sym setter)
306                             setter))))
307            (add-method setter
308              (if (string-prefix? "is_" name)
309                (make-method (list class <top>)
310                  (lambda (call-next-method self flag?)
311                    (sqlite3:set-stored-property! self name (if flag? 1 0))))
312                (make-method (list class <top>)
313                  (lambda (call-next-method self value)
314                    (sqlite3:set-stored-property! self name value))))))))
315      (sqlite3:fields class))
316    (global-set! symbol class)))
317;;; }}}
318
319;;;; vim:set shiftwidth=2 softtabstop=2 foldmethod=marker: ;;;;
Note: See TracBrowser for help on using the repository browser.