diff --git a/source/clog-dbi.lisp b/source/clog-dbi.lisp index a4f6fc6..9e24ae1 100644 --- a/source/clog-dbi.lisp +++ b/source/clog-dbi.lisp @@ -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 "" + (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)) diff --git a/source/clog-element-common.lisp b/source/clog-element-common.lisp index b3875fd..528298f 100644 --- a/source/clog-element-common.lisp +++ b/source/clog-element-common.lisp @@ -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) diff --git a/source/clog-form.lisp b/source/clog-form.lisp index de63ef6..0c0b032 100644 --- a/source/clog-form.lisp +++ b/source/clog-form.lisp @@ -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 "" +(defmethod add-select-option ((obj clog-select) value content &key selected disabled) + (create-child obj (format nil "~A" + (if selected + " selected" + "") + (if disabled + " disabled" + "") (escape-string value) (escape-string content)) :clog-type 'clog-element :auto-place t)) diff --git a/source/clog.lisp b/source/clog.lisp index d1c53c4..41abc87 100644 --- a/source/clog.lisp +++ b/source/clog.lisp @@ -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" diff --git a/test/lookup.clog b/test/lookup.clog new file mode 100644 index 0000000..f5f04ea --- /dev/null +++ b/test/lookup.clog @@ -0,0 +1 @@ +
span \ No newline at end of file diff --git a/test/test.db b/test/test.db new file mode 100644 index 0000000..6e01b2c Binary files /dev/null and b/test/test.db differ diff --git a/tools/clog-builder-settings.lisp b/tools/clog-builder-settings.lisp index 7e6a53f..ad8daf9 100644 --- a/tools/clog-builder-settings.lisp +++ b/tools/clog-builder-settings.lisp @@ -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