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

clog-lookup database table lookups for drop downs and lists boxes

Browse source
This commit is contained in:
David Botton 2022-02-27 14:14:19 -05:00
parent d903791c86
commit f010b232bb
7 changed files with 271 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

105
source/clog-dbi.lisp
View file

@ -109,7 +109,7 @@ CLOG-Builder. If not using builder use to connect:
:accessor on-fetch
:initform nil
:documentation "on-fetch event, called after fetch complete. (private)"))
(:documentation "Manipulate one row of a table."))
(:documentation "Manipulate one row of a table at a time on panel."))
;;;;;;;;;;;;;;;;;;;;
;; create-one-row ;;
@ -131,15 +131,15 @@ of type-of CLOG-DATABASE it is used as database source unless
:html-id html-id
:auto-place auto-place)
'clog-one-row)))
(when (and (typep obj 'clog-database) (not clog-database))
(setf clog-database obj))
(setf (clog-database new-obj) clog-database)
(if (and (typep obj 'clog-database) (not clog-database))
(setf (clog-database new-obj) obj)
(setf (clog-database new-obj) clog-database))
new-obj))
(defgeneric query-row (clog-one-row panel sql)
(:documentation "Ignore query related prperties and instead execute
SQL. row-id-name is required for updates. All PANEL items or custom
rows on panel will be set using DATA-LOAD-PLIST."))
slots on panel will be set using DATA-LOAD-PLIST."))
(defmethod query-row ((obj clog-one-row) panel sql)
(setf (queryid obj) (dbi:execute
(dbi:prepare
@ -150,7 +150,7 @@ rows on panel will be set using DATA-LOAD-PLIST."))
(defgeneric get-row (clog-one-row panel)
(:documentation "Get first row from a database table based on
CLOG-ONE-ROW's table-name using where-clause and table-columns.
row-id-name is required. All PANEL items or custom rows on panel will
row-id-name is required. All PANEL items or custom slots on panel will
be set using DATA-LOAD-PLIST."))
(defmethod get-row ((obj clog-one-row) panel)
(let ((where (where-clause obj)))
@ -177,7 +177,7 @@ be set using DATA-LOAD-PLIST."))
(defgeneric next-row (clog-one-row panel)
(:documentation "Get next row from a database table based on query
made for get-row. All PANEL items or custom rows on panel will be set
made for get-row. All PANEL items or custom slots on panel will be set
using DATA-LOAD-PLIST."))
(defmethod next-row ((obj clog-one-row) panel)
(dolist (slave (slaves obj))
@ -198,7 +198,7 @@ using DATA-LOAD-PLIST."))
(defgeneric insert-row (clog-one-row panel)
(:documentation "Insert new row in to database table based on
CLOG-ONE-ROW's table-name and table-columns. DATA-WRITE-PLIST is
used to extract data from PANEL items and custom rows."))
used to extract data from PANEL items and custom slots."))
(defmethod insert-row ((obj clog-one-row) panel)
(dbi:do-sql (database-connection (clog-database obj))
(sql-insert* (table-name obj)
@ -254,3 +254,92 @@ Calculated fields, transformations to field values, etc. can be done in on-fetch
new-row will block until on-fetch returns."))
(defmethod set-on-fetch ((obj clog-one-row) on-fetch-handler)
(setf (on-fetch obj) on-fetch-handler))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - clog-lookup
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass clog-lookup (clog-one-row clog-select)
((value-field
:accessor value-field
:initform nil
:documentation "Field used to for value of lookup option.
Case sensitive keyword")
(option-field
:accessor option-field
:initform nil
:documentation "Filed used to display for value of lookup option.
Case sensitive keyword"))
(:documentation "CLOG Table Lookup Object"));
;;;;;;;;;;;;;;;;;;;
;; create-lookup ;;
;;;;;;;;;;;;;;;;;;;
(defgeneric create-lookup (clog-obj &key name multiple label class html-id)
(:documentation "Create a new clog-lookup as child of CLOG-OBJ."))
(defmethod create-lookup ((obj clog-obj)
&key (clog-database nil)
(name nil)
(multiple nil)
(label nil)
(class nil)
(html-id nil))
(let ((element (create-child
obj (format nil "<select~A~A~A/>"
(if multiple
" multiple"
"")
(if name
(format nil " name='~A'" name)
"")
(if class
(format nil " class='~A'"
(escape-string class))
""))
:clog-type 'clog-lookup :html-id html-id :auto-place t)))
(when label
(label-for label element))
(if (and (typep obj 'clog-database) (not clog-database))
(setf (clog-database element) obj)
(setf (clog-database element) clog-database))
element))
(defmethod next-row ((obj clog-lookup) panel)
"In clog-lookup objects, next-row adds options to lookup's
select tag for every row returned. The option value is set to
the VALUE-FIELD property and the OPTION-FIELD property is the
the displayed option."
(dolist (slave (slaves obj))
(clear-row slave panel))
;; loop through fetches
(let ((select-value (text-value obj)))
(setf (rowid obj) nil)
(setf (inner-html obj) "")
(loop
(let ((selected nil)
(row (dbi:fetch (queryid obj))))
(unless row
(return))
(when (on-fetch obj)
(funcall (on-fetch obj) obj))
(when (equal select-value (getf row (value-field obj)))
(setf selected t)
(setf (rowid obj) (data-load-plist panel
(last-fetch obj)
:row-id-name (row-id-name obj))))
(add-select-option obj
(getf row (value-field obj))
(getf row (option-field obj))
:selected selected))))
(if (rowid obj)
(dolist (slave (slaves obj))
(get-row slave panel))
(unless (slave-to-slot obj)
(clear-row obj panel)))
(rowid obj))
(defmethod clear-row ((obj clog-lookup) panel)
(setf (inner-html obj) "")
(call-next-method))

4
source/clog-element-common.lisp
View file

@ -1289,9 +1289,9 @@ and if :AUTO-PLACE (default t) place-inside-bottom-of CLOG-OBJ"))
(defclass clog-table-footer (clog-table)()
(:documentation "CLOG Table-Footer Objects."))
;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;
;; create-table-footer ;;
;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric create-table-footer (clog-obj &key hidden
class html-id auto-place)

12
source/clog-form.lisp
View file

@ -1029,11 +1029,17 @@ optionally fill in with contents of data-list."))
;; add-select-option ;;
;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric add-select-option (clog-select value content)
(defgeneric add-select-option (clog-select value content &key selected disabled)
(:documentation "Add option VALUE to select."))
(defmethod add-select-option ((obj clog-select) value content)
(create-child obj (format nil "<option value='~A'>~A</option>"
(defmethod add-select-option ((obj clog-select) value content &key selected disabled)
(create-child obj (format nil "<option~A~A value='~A'>~A</option>"
(if selected
" selected"
"")
(if disabled
" disabled"
"")
(escape-string value)
(escape-string content))
:clog-type 'clog-element :auto-place t))

7
source/clog.lisp
View file

@ -563,7 +563,12 @@ embedded in a native template application.)"
(insert-row generic-function)
(update-row generic-function)
(clear-row generic-function)
(delete-row generic-function))
(delete-row generic-function)
(clog-lookup class)
(create-lookup generic-function)
(value-field generic-function)
(option-field generic-function))
(defsection @clog-panels (:title "CLOG Panels")
"CLOG-Panel - CLOG Panels"

1
test/lookup.clog Normal file
View file

@ -0,0 +1 @@
<data id="I3854977833" data-in-package="clog-user" data-custom-slots="" data-clog-next-id="8" data-clog-title="panel-1"></data><div data-clog-type="database" data-clog-dbi-dbtype=":sqlite3" data-clog-dbi-dbname="/home/dbotton/common-lisp/clog/test/test.db" data-clog-dbi-dbparams="" data-clog-name="database-1" style="box-sizing: content-box; position: static; left: 17px; top: 18px;"><div data-clog-type="one-row" data-clog-one-row-table="r" data-clog-one-row-where="" data-clog-one-row-order="" data-clog-one-row-limit="" data-clog-one-row-master="" data-clog-one-row-id-name="rowid" data-clog-one-row-columns="rowid name nickname" data-clog-name="one-row-2" style="box-sizing: content-box; position: static; left: 69px; top: 6px;"><select data-clog-type="lookup-list" size="4" data-clog-one-row-table="i" data-clog-lookup-value="invoice" data-clog-lookup-option="invoice" data-clog-one-row-where="" data-clog-one-row-order="" data-clog-one-row-limit="" data-clog-one-row-master="name" data-clog-one-row-id-name="rowid" data-clog-one-row-columns="rowid name invoice" data-clog-name="invoice" style="box-sizing: content-box; position: absolute; left: 81px; top: 106px; width: 260px; height: 74px;"></select><select data-clog-type="lookup-drop" data-clog-one-row-table="i" data-clog-lookup-value="invoice" data-clog-lookup-option="invoice" data-clog-one-row-where="" data-clog-one-row-order="" data-clog-one-row-limit="" data-clog-one-row-master="name" data-clog-one-row-id-name="rowid" data-clog-one-row-columns="rowid name invoice" data-clog-name="lookup-drop-7" style="box-sizing: content-box; position: absolute; left: 93px; top: 197px; width: 237px; height: 20px;" data-on-create="(get-row (one-row-2 panel) panel)"></select></div></div><span data-clog-type="span" data-clog-name="name" style="box-sizing: content-box; position: absolute; left: 97px; top: 42px; width: 205px; height: 23px; color: rgb(0, 0, 0); background-attachment: scroll; background-color: rgb(221, 221, 50);">span</span><input type="TEXT" value="" data-clog-type="input" data-clog-name="nickname" style="box-sizing: content-box; position: absolute; left: 97px; top: 68px;">

BIN
test/test.db Normal file
View file

Binary file not shown.

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

@ -1416,7 +1416,162 @@
:attr "data-clog-one-row-limit")
(:name "join to slot-name (optional)"
:attr "data-clog-one-row-master")
,@*props-element*))))
,@*props-element*))
`(:name "lookup-drop"
:description "Drop down table lookup"
:clog-type clog:clog-lookup
:create clog:create-lookup
: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-lookup-value") "")
(setf (attribute control "data-clog-lookup-option") "")
(setf (attribute control "data-clog-one-row-where") "")
(setf (attribute control "data-clog-one-row-order") "")
(setf (attribute control "data-clog-one-row-limit") "")
(setf (attribute control "data-clog-one-row-master") "")
(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))
(let ((parent (attribute (parent-element control) "data-clog-name"))
(master (attribute control "data-clog-one-row-master")))
(when (equal master "")
(setf master nil))
(format nil "(setf (clog-database target) ~A) ~
~A ~
(setf (table-name target) \"~A\") ~
(setf (value-field target) :|~A|) ~
(setf (option-field target) :|~A|) ~
(setf (where-clause target) \"~A\") ~
(setf (order-by target) \"~A\") ~
(setf (limit target) \"~A\") ~
(setf (row-id-name target) \"~A\") ~
(setf (table-columns target) '(~A))"
(if master
(format nil "(clog-database (~A panel))" parent)
(format nil "(~A panel)" parent))
(if master
(format nil "(set-master-one-row target (~A panel) \"~A\")"
parent master)
"")
(attribute control "data-clog-one-row-table")
(attribute control "data-clog-lookup-value")
(attribute control "data-clog-lookup-option")
(attribute control "data-clog-one-row-where")
(attribute control "data-clog-one-row-order")
(attribute control "data-clog-one-row-limit")
(attribute control "data-clog-one-row-id-name")
(attribute control "data-clog-one-row-columns"))))
:events ((:name "on-fetch"
:parameters "target")
,@*events-element*)
:properties ((:name "multiple select"
:get ,(lambda (control)
(property control "multiple"))
:set ,(lambda (control obj)
(if (or (equalp (text obj) "true") (equalp (text obj) "multiple"))
(setf (attribute control "multiple") t)
(remove-attribute control "multiple"))
(property control "multiple")))
(:name "table name"
:attr "data-clog-one-row-table")
(:name "table row id name"
:attr "data-clog-one-row-id-name")
(:name "table columns"
:attr "data-clog-one-row-columns")
(:name "value field"
:attr "data-clog-lookup-value")
(:name "value display field"
:attr "data-clog-lookup-option")
(:name "where clause (optional)"
:attr "data-clog-one-row-where")
(:name "order by (optional)"
:attr "data-clog-one-row-order")
(:name "limit (optional)"
:attr "data-clog-one-row-limit")
(:name "join to slot-name (optional)"
:attr "data-clog-one-row-master")
,@*props-form-element*))
`(:name "lookup-list"
:description "Listbox table lookup"
:clog-type clog:clog-lookup
:create clog:create-lookup
:create-type :base
:setup ,(lambda (control content control-record)
(declare (ignore content) (ignore control-record))
(setf (size control) "4")
(setf (attribute control "data-clog-one-row-table") "")
(setf (attribute control "data-clog-lookup-value") "")
(setf (attribute control "data-clog-lookup-option") "")
(setf (attribute control "data-clog-one-row-where") "")
(setf (attribute control "data-clog-one-row-order") "")
(setf (attribute control "data-clog-one-row-limit") "")
(setf (attribute control "data-clog-one-row-master") "")
(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))
(let ((parent (attribute (parent-element control) "data-clog-name"))
(master (attribute control "data-clog-one-row-master")))
(when (equal master "")
(setf master nil))
(format nil "(setf (clog-database target) ~A) ~
~A ~
(setf (table-name target) \"~A\") ~
(setf (value-field target) :|~A|) ~
(setf (option-field target) :|~A|) ~
(setf (where-clause target) \"~A\") ~
(setf (order-by target) \"~A\") ~
(setf (limit target) \"~A\") ~
(setf (row-id-name target) \"~A\") ~
(setf (table-columns target) '(~A))"
(if master
(format nil "(clog-database (~A panel))" parent)
(format nil "(~A panel)" parent))
(if master
(format nil "(set-master-one-row target (~A panel) \"~A\")"
parent master)
"")
(attribute control "data-clog-one-row-table")
(attribute control "data-clog-lookup-value")
(attribute control "data-clog-lookup-option")
(attribute control "data-clog-one-row-where")
(attribute control "data-clog-one-row-order")
(attribute control "data-clog-one-row-limit")
(attribute control "data-clog-one-row-id-name")
(attribute control "data-clog-one-row-columns"))))
:events ((:name "on-fetch"
:parameters "target")
,@*events-element*)
:properties ((:name "multiple select"
:get ,(lambda (control)
(property control "multiple"))
:set ,(lambda (control obj)
(if (or (equalp (text obj) "true") (equalp (text obj) "multiple"))
(setf (attribute control "multiple") t)
(remove-attribute control "multiple"))
(property control "multiple")))
(:name "table name"
:attr "data-clog-one-row-table")
(:name "table row id name"
:attr "data-clog-one-row-id-name")
(:name "table columns"
:attr "data-clog-one-row-columns")
(:name "value field"
:attr "data-clog-lookup-value")
(:name "value display field"
:attr "data-clog-lookup-option")
(:name "where clause (optional)"
:attr "data-clog-one-row-where")
(:name "order by (optional)"
:attr "data-clog-one-row-order")
(:name "limit (optional)"
:attr "data-clog-one-row-limit")
(:name "join to slot-name (optional)"
:attr "data-clog-one-row-master")
,@*props-form-element*))))
(defparameter *supported-templates*
(list