mirrors/clog
1
Fork 0
mirror of https://github.com/rabbibotton/clog.git synced 2025-12-15 15:00:24 -08:00
Code Issues Projects Releases Wiki Activity

CLOG-One-Row control for using the CLOG-Database

Browse source
This commit is contained in:
David Botton 2022-02-23 19:20:23 -05:00
parent 9e81d7d8ad
commit 254782cd83
4 changed files with 201 additions and 35 deletions
Download patch file Download diff file Expand all files Collapse all files

66
source/clog-data.lisp
View file

@ -18,28 +18,32 @@
;; data-load-plist ;;
;;;;;;;;;;;;;;;;;;;;;
(defun data-load-plist (obj plist &key (upcase-key t))
(defun data-load-plist (obj plist &key (row-id-name nil) (upcase-key t))
"Load a PLIST in to OBJ where key of plist is the name of slot on
OBJ and the value is the data to load. If slot contains a CLOG-ELEMENT
TEXT-VALUE is set, if not the slot is set to the value. If key is not
the name of a slot it is ignored. The key is coverted to a string and
upper cased before attempting to match it to a slot if :UPCASE-KEY t
(default)."
(loop for (key value) on plist by #'cddr while value
do
(let* ((slot-str (format nil "~A" key))
(slot-name (if upcase-key
(string-upcase slot-str)
slot-str))
(slot-sym (closer-mop:slot-definition-name
(find slot-name (closer-mop:compute-slots (class-of obj))
:key #'closer-mop:slot-definition-name
:test #'string=))))
(when slot-sym
(if (and (slot-boundp obj slot-sym)
(typep (slot-value obj slot-sym) 'clog:clog-element))
(setf (text-value (slot-value obj slot-sym)) value)
(setf (slot-value obj slot-sym) value))))))
(default). If :ROW-ID-NAME is set returns that fields value."
(let ((result))
(loop for (key value) on plist by #'cddr while value
do
(let* ((slot-str (format nil "~A" key))
(slot-name (if upcase-key
(string-upcase slot-str)
slot-str))
(slot-sym (find slot-name (closer-mop:compute-slots (class-of obj))
:key #'closer-mop:slot-definition-name
:test #'string=)))
(when (equalp row-id-name slot-name)
(setf result value))
(when slot-sym
(setf slot-sym (closer-mop:slot-definition-name slot-sym))
(if (and (slot-boundp obj slot-sym)
(typep (slot-value obj slot-sym) 'clog:clog-element))
(setf (text-value (slot-value obj slot-sym)) value)
(setf (slot-value obj slot-sym) value)))))
result))
;;;;;;;;;;;;;;;;;;;;;;
;; data-write-list ;;
@ -79,8 +83,9 @@ the key is the slot name. If a slot contains a CLOG-ELEMENT then
TEXT-VALUE is used to retrieve the value otherwise it is the
slot-value. Slot names may be symbols, keywords, or text (and will be
upcased before looking up symbol if :UPCASE-KEY t). All slot-names
must be bound. If :KEYS-AS-KEYWORDS t (default) then the keys will be
symbols in the keyword package."
must be bound. If slot-name does not exist left out of returned
plist. If :KEYS-AS-KEYWORDS t (default) then the keys will be symbols
in the keyword package."
(let ((result))
(dolist (slot (reverse slot-name-list))
(when (keywordp slot)
@ -88,17 +93,18 @@ symbols in the keyword package."
(unless (symbolp slot)
(when upcase-key
(setf slot (string-upcase slot))))
(setf slot (closer-mop:slot-definition-name
(find slot (closer-mop:compute-slots (class-of obj))
(setf slot (find slot (closer-mop:compute-slots (class-of obj))
:key #'closer-mop:slot-definition-name
:test #'string=)))
(if (and (slot-boundp obj slot)
(typep (slot-value obj slot) 'clog:clog-element))
(push (text-value (slot-value obj slot)) result)
(push (slot-value obj slot) result))
(if keys-as-keywords
(push (find-symbol (format nil "~A" slot) 'keyword) result)
(push slot result)))
:test #'string=))
(when slot
(setf slot (closer-mop:slot-definition-name slot))
(if (and (slot-boundp obj slot)
(typep (slot-value obj slot) 'clog:clog-element))
(push (text-value (slot-value obj slot)) result)
(push (slot-value obj slot) result))
(if keys-as-keywords
(push (intern (format nil "~A" slot) 'keyword) result)
(push slot result))))
result))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -188,7 +194,7 @@ character '?'."
(if (consp table)
(sql-field-list table)
table)
(if where
(if (and where (not (equal where "")))
(format nil " where ~A" where)
"")))

116
source/clog-dbi.lisp
View file

@ -43,14 +43,122 @@ CLOG-Builder. If not using builder use to connect:
:html-id html-id
:auto-place auto-place)
'clog-database)))
;; default values for builder
(setf (attribute new-obj "data-clog-dbi-dbtype") ":sqlite3")
(setf (attribute new-obj "data-clog-dbi-dbname") ":memory:")
new-obj))
;;;;;;;;;;;;;;;;;;;;;;;;;
;; database-connection ;;
;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric database-connection (clog-database)
(defgeneric database-connection (clog-obj)
(:documentation "Accessor to the database handle"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - CLOG-One-Row
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass clog-one-row (clog-element)
((clog-database
:accessor clog-database
:initform nil
:documentation "Database control table connected to.")
(table
:accessor table-name
:initform nil
:documentation "Table name")
(where-clause
:accessor where-clause
:initform nil
:documentation "Where clause")
(id
:accessor row-id-name
:initform nil
:documentation "Column used to indicate id of row")
(rowid
:accessor rowid
:initform nil
:documentation "Current rowid")
(columns
:accessor table-columns
:initform nil
:documentation "Columns of table to be retrieved"))
(:documentation "Manipulate one row of a table."))
;;;;;;;;;;;;;;;;;;;;
;; create-one-row ;;
;;;;;;;;;;;;;;;;;;;;
(defgeneric create-one-row (clog-obj &key clog-database
hidden class html-id auto-place)
(:documentation "Create a new CLOG-One-Row element. A CLOG Database
must be a parent to CLOG-One-Row."))
(defmethod create-one-row ((obj clog-obj) &key (clog-database nil)
(hidden nil)
(class nil)
(html-id nil) (auto-place t))
(let ((new-obj (change-class (create-div obj :content ""
:hidden hidden
:class class
:html-id html-id
:auto-place auto-place)
'clog-one-row)))
(setf (clog-database new-obj) clog-database)
new-obj))
(defgeneric get-row (clog-obj panel)
(:documentation "Get a row from a database table based on
CLOG-OBJECT's table-name using where-clause and table-columns.
row-id-name is required. All PANEL items or custom rows
on panel will be set use DATA-LOAD-PLIST."))
(defmethod get-row ((obj clog-obj) panel)
(setf (rowid obj) (data-load-plist panel
(dbi:fetch
(dbi:execute
(dbi:prepare
(database-connection (clog-database obj))
(sql-select (table-name obj)
(table-columns obj)
:where (where-clause obj)))))
:row-id-name (row-id-name obj))))
(defgeneric insert-row (clog-obj panel)
(:documentation "Insert new row in to database table based on
CLOG-OBJECT's table-name and table-columns. DATA-WRITE-PLIST is
used to extract data from PANEL items and custom rows."))
(defmethod insert-row ((obj clog-obj) panel)
(dbi:do-sql (database-connection (clog-database obj))
(sql-insert* (table-name obj)
(data-write-plist panel (table-columns obj)))))
(defgeneric update-row (clog-obj panel)
(:documentation "Update row in database table based on
CLOG-OBJECT's table-name using current rowid and table-columns.
row-id-name is required. All PANEL items or custom rows
on panel will be retrieved from PANEL using DATA-WRITE-PLIST."))
(defmethod update-row ((obj clog-obj) panel)
(dbi:do-sql (database-connection (clog-database obj))
(sql-update (table-name obj)
(data-write-plist panel (table-columns obj))
(format nil "~A=~A" (row-id-name obj) (rowid obj)))))
(defgeneric delete-row (clog-obj)
(:documentation "Delete a row from a database table based on
current rowid"))
(defmethod delete-row ((obj clog-obj))
(dbi:do-sql (database-connection (clog-database obj))
(format nil "delete from ~A where ~A=~A"
(table-name obj)
(row-id-name obj)
(rowid obj))))
(defgeneric clear-row (clog-obj panel)
(:documentation "Clear current rowid and all fields in PANEL
using DATA-WRITE-PLIST based on table-columns."))
(defmethod clear-row ((obj clog-obj) panel)
(let ((result))
(dolist (c (table-columns obj))
(push "" result)
(push c result))
(data-load-plist panel result)
(setf (rowid obj) nil)))

16
source/clog.lisp
View file

@ -541,8 +541,22 @@ embedded in a native template application.)"
(defsection @clog-dbi (:title "CLOG DBI")
"CLOG-Database - CLOG Database Connection"
(clog-database class)
(create-database generic-function)
(database-connection generic-function)
(create-database generic-function))
(clog-one-row class)
(create-one-row generic-function)
(clog-database generic-function)
(table-name generic-function)
(where-clause generic-function)
(row-id-name generic-function)
(rowid generic-function)
(table-columns generic-function)
(get-row generic-function)
(insert-row generic-function)
(update-row generic-function)
(clear-row generic-function)
(delete-row generic-function))
(defsection @clog-panels (:title "CLOG Panels")
"CLOG-Panel - CLOG Panels"

38
tools/clog-builder-settings.lisp
View file

@ -1338,6 +1338,11 @@
:clog-type clog:clog-database
:create clog:create-database
:create-type :base
:setup ,(lambda (control content control-record)
(declare (ignore content) (ignore control-record))
(setf (attribute control "data-clog-dbi-dbtype") ":sqlite3")
(setf (attribute control "data-clog-dbi-dbname") ":memory:")
(setf (attribute control "data-clog-dbi-dbparams") ""))
:on-setup ,(lambda (control control-record)
(declare (ignore control-record))
(format nil "(setf (database-connection target) ~
@ -1352,6 +1357,39 @@
:attr "data-clog-dbi-dbparams")
(:name "database name"
:attr "data-clog-dbi-dbname")
,@*props-element*))
`(:name "one-row"
:description "Table One Row"
:clog-type clog:clog-one-row
:create clog:create-one-row
:create-type :base
:setup ,(lambda (control content control-record)
(declare (ignore content) (ignore control-record))
(setf (attribute control "data-clog-one-row-table") "")
(setf (attribute control "data-clog-one-row-where") "")
(setf (attribute control "data-clog-one-row-id-name") "rowid")
(setf (attribute control "data-clog-one-row-columns") "rowid"))
:on-setup ,(lambda (control control-record)
(declare (ignore control-record))
(format nil "(setf (clog-database target) (~A panel)) ~
(setf (table-name target) \"~A\") ~
(setf (where-clause target) \"~A\") ~
(setf (row-id-name target) \"~A\") ~
(setf (table-columns target) '(~A))"
(attribute (parent-element control) "data-clog-name")
(attribute control "data-clog-one-row-table")
(attribute control "data-clog-one-row-where")
(attribute control "data-clog-one-row-id-name")
(attribute control "data-clog-one-row-columns")))
:events (,@*events-element*)
:properties ((:name "table name"
:attr "data-clog-one-row-table")
(:name "where clause (optional)"
:attr "data-clog-one-row-where")
(:name "table row id name"
:attr "data-clog-one-row-id-name")
(:name "table columns"
:attr "data-clog-one-row-columns")
,@*props-element*))))
(defparameter *supported-templates*