On Sat, 22 Apr 2006, ThomasChust wrote:
[...]
A small example using TinyCLOS and SQLite3 is attached. It does runtime
generation of classes and accessor methods completely automatically from the
database schema and is terribly easy to use because I didn't have the time to
make up something sophisticated.
[...]
Oops, I just found some parameter handling mistakes in my quick hack that
would break it with more "advanced" usage. Here is a better version.
cu,
Thomas
;;;; sqlite3-tinyclos.scm {{{
;;;; Provides a bridge between persistent storage in SQLite3 tables and
;;;; TinyCLOS objects.
(define-extension sqlite3-tinyclos
(export
<sqlite3:stored-object-class>
<sqlite3:stored-object>
initialize
sqlite3:db
sqlite3:table
sqlite3:pk
sqlite3:pk/select
sqlite3:pk/update
sqlite3:pk/where
sqlite3:fields
sqlite3:set-pk!
sqlite3:in-store?
sqlite3:create-in-store!
sqlite3:remove-from-store!
sqlite3:get-stored-property
sqlite3:set-stored-property!
sqlite3:field-name->getter-symbol
sqlite3:field-name->setter-symbol
sqlite3:define-stored-object-class))
(require-extension
(srfi 1) (srfi 13) (srfi 26) lolevel extras tinyclos sqlite3)
;;;; }}}
;;; metaclass for database object classes {{{
(define-class <sqlite3:stored-object-class> (<class>)
(db table pk fields))
;; initialize an instance {{{
(define-method (initialize (self <sqlite3:stored-object-class>) initargs)
(call-next-method)
(initialize-slots self initargs)
(let ((fields (sqlite3:map-row
(lambda (cid name type not-null? default-value pk?)
(cons (not (zero? pk?)) name))
(sqlite3:db self)
(sprintf "PRAGMA table_info(~A);" (sqlite3:table self)))))
(slot-set! self 'pk
(filter-map (lambda (f) (and (car f) (cdr f))) fields))
(slot-set! self 'fields
(filter-map (lambda (f) (and (not (car f)) (cdr f))) fields))))
;; }}}
;; get database handle {{{
(define-generic sqlite3:db)
(define-method (sqlite3:db (self <sqlite3:stored-object-class>))
(slot-ref self 'db))
;; }}}
;; get database table name {{{
(define-generic sqlite3:table)
(define-method (sqlite3:table (self <sqlite3:stored-object-class>))
(slot-ref self 'table))
;; }}}
;; get database table primary key {{{
(define-generic sqlite3:pk)
(define-method (sqlite3:pk (self <sqlite3:stored-object-class>))
(slot-ref self 'pk))
(define-generic sqlite3:pk/select)
(define-method (sqlite3:pk/select (self <sqlite3:stored-object-class>))
(string-intersperse (sqlite3:pk self) ", "))
(define-generic sqlite3:pk/update)
(define-method (sqlite3:pk/update (self <sqlite3:stored-object-class>))
(string-intersperse
(map (cut string-append <> " = ?") (sqlite3:pk self)) ", "))
(define-generic sqlite3:pk/where)
(define-method (sqlite3:pk/where (self <sqlite3:stored-object-class>))
(string-intersperse
(map (cut string-append <> " = ?") (sqlite3:pk self)) " AND "))
;; }}}
;; get database table fields {{{
(define-generic sqlite3:fields)
(define-method (sqlite3:fields (self <sqlite3:stored-object-class>))
(slot-ref self 'fields))
;; }}}
;;; }}}
;;; base class for database objects {{{
(define-class <sqlite3:stored-object> (<object>)
(pk))
;; initialize an instance {{{
(define-method (initialize (self <sqlite3:stored-object>) initargs)
(call-next-method)
(if (and (pair? initargs) (symbol? (car initargs)))
(initialize-slots self initargs)
(slot-set! self 'pk initargs))
(unless (sqlite3:in-store? self)
(sqlite3:create-in-store! self)))
;; }}}
;; get primary key data {{{
(define-method (sqlite3:pk (self <sqlite3:stored-object>))
(slot-ref self 'pk))
;; }}}
;; set primary key data {{{
(define-generic sqlite3:set-pk!)
(define-method (sqlite3:set-pk! (self <sqlite3:stored-object>) . new-pk)
(apply sqlite3:exec
(sqlite3:db self)
(sprintf "UPDATE ~A SET ~A WHERE ~A;"
(sqlite3:table self)
(sqlite3:pk/update self)
(sqlite3:pk/where self))
(append new-pk (sqlite3:pk self)))
(slot-set! self 'pk new-pk))
;; }}}
;; get database, table, primary key and field information from class {{{
(define-method (sqlite3:db (self <sqlite3:stored-object>))
(sqlite3:db (class-of self)))
(define-method (sqlite3:table (self <sqlite3:stored-object>))
(sqlite3:table (class-of self)))
(define-method (sqlite3:pk/select (self <sqlite3:stored-object>))
(sqlite3:pk/select (class-of self)))
(define-method (sqlite3:pk/update (self <sqlite3:stored-object>))
(sqlite3:pk/update (class-of self)))
(define-method (sqlite3:pk/where (self <sqlite3:stored-object>))
(sqlite3:pk/where (class-of self)))
(define-method (sqlite3:fields (self <sqlite3:stored-object>))
(sqlite3:fields (class-of self)))
;; }}}
;; check for existence of the stored representation {{{
(define-generic sqlite3:in-store?)
(define-method (sqlite3:in-store? (self <sqlite3:stored-object>))
(not (zero? (apply sqlite3:first-result
(sqlite3:db self)
(sprintf "SELECT count(*) FROM ~A WHERE ~A;"
(sqlite3:table self) (sqlite3:pk/where self))
(sqlite3:pk self)))))
;; }}}
;; create stored representation if it does not exist already {{{
(define-generic sqlite3:create-in-store!)
(define-method (sqlite3:create-in-store! (self <sqlite3:stored-object>))
(not (zero? (apply sqlite3:update
(sqlite3:db self)
(sprintf "INSERT OR IGNORE INTO ~A(~A) VALUES(~A);"
(sqlite3:table self) (sqlite3:pk/select self)
(string-intersperse
(make-list (length (sqlite3:pk self)) "?") ", "))
(sqlite3:pk self)))))
;; }}}
;; remove stored representation of the object {{{
(define-generic sqlite3:remove-from-store!)
(define-method (sqlite3:remove-from-store! (self <sqlite3:stored-object>))
(not (zero? (apply sqlite3:update
(sqlite3:db self)
(sprintf "DELETE FROM ~A WHERE ~A;"
(sqlite3:table self)
(sqlite3:pk/where self))
(sqlite3:pk self)))))
;; }}}
;; get a stored property {{{
(define-generic sqlite3:get-stored-property)
(define-method (sqlite3:get-stored-property
(self <sqlite3:stored-object>) (prop <string>))
(apply sqlite3:first-result
(sqlite3:db self)
(sprintf "SELECT ~A FROM ~A WHERE ~A;"
prop (sqlite3:table self) (sqlite3:pk/where self))
(slot-ref self 'pk)))
;; }}}
;; set a stored property {{{
(define-generic sqlite3:set-stored-property!)
(define-method (sqlite3:set-stored-property!
(self <sqlite3:stored-object>) (prop <string>) value)
(apply sqlite3:exec
(sqlite3:db self)
(sprintf "UPDATE ~A SET ~A = ? WHERE ~A;"
(sqlite3:table self) prop (sqlite3:pk/where self))
value
(sqlite3:pk self)))
;; }}}
;;; }}}
;;; create a new database object class {{{
(define (sqlite3:field-name->getter-symbol name #!optional (prefix "")) ;; {{{
(let ((name (string-translate name #\_ #\-)))
(string->symbol
(string-append
prefix
(if (string-prefix? "is-" name)
(string-append (substring name 3) "?")
name))))) ;; }}}
(define (sqlite3:field-name->setter-symbol name #!optional (prefix "")) ;; {{{
(let ((name (string-translate name #\_ #\-)))
(string->symbol
(string-append
prefix
"set-"
(if (string-prefix? "is-" name)
(substring name 3)
name)
"!")))) ;; }}}
(define (sqlite3:define-stored-object-class db table . key-params)
(let* ((key-pairs (map
(lambda (l)
(cons (car l) (cadr l)))
(chop key-params 2)))
(prefix (->string (alist-ref prefix: key-pairs eq? "")))
(name/string (->string
(alist-ref
name: key-pairs eq?
(string-append
prefix (string-trim-right table #\s)))))
(name (string->symbol name/string))
(symbol/string (->string
(alist-ref
symbol: key-pairs eq?
(string-append "<" name/string ">"))))
(symbol (string->symbol symbol/string))
(supers (alist-ref supers: key-pairs eq? '()))
(slots (alist-ref slots: key-pairs eq? '()))
(class (make <sqlite3:stored-object-class>
'name name
'direct-supers (append supers (list <sqlite3:stored-object>))
'direct-slots slots
'db db
'table table)))
(for-each
(lambda (name)
(let* ((getter-sym (sqlite3:field-name->getter-symbol name prefix))
(getter (if (global-bound? getter-sym)
(global-ref getter-sym)
(let ((getter (make-generic
(symbol->string getter-sym))))
(global-set! getter-sym getter)
getter))))
(add-method getter
(make-method (list class)
(if (string-prefix? "is_" name)
(lambda (call-next-method self)
(let ((flag? (sqlite3:get-stored-property self name)))
(and flag? (not (zero? flag?)))))
(lambda (call-next-method self)
(sqlite3:get-stored-property self name))))))
(let* ((setter-sym (sqlite3:field-name->setter-symbol name prefix))
(setter (if (global-bound? setter-sym)
(global-ref setter-sym)
(let ((setter (make-generic
(symbol->string setter-sym))))
(global-set! setter-sym setter)
setter))))
(add-method setter
(if (string-prefix? "is_" name)
(make-method (list class <boolean>)
(lambda (call-next-method self flag?)
(sqlite3:set-stored-property! self name (if flag? 1 0))))
(make-method (list class <top>)
(lambda (call-next-method self value)
(sqlite3:set-stored-property! self name value)))))))
(sqlite3:fields class))
(global-set! symbol class)))
;;; }}}
;;;; vim:set shiftwidth=2 softtabstop=2 foldmethod=marker: ;;;;
_______________________________________________
Chicken-users mailing list
Chicken-users@nongnu.org
http://lists.nongnu.org/mailman/listinfo/chicken-users
