;; Copyright (c) 2003-2005 Edward Marco Baringer ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are ;; met: ;; ;; - Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; - Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names ;; of its contributors may be used to endorse or promote products ;; derived from this software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package :org.unknownlamer.ucw-im) (eval-when (:compile-toplevel :load-toplevel :execute) (define-ie-method applicable-criteria nconc ((e (ie-type t))) '()) (define-ie-method negative-criteria ((e (ie-type t))) nil) (define-ie-generic criteria-label (criteria interface-element) (:method ((c (eql :not)) (e (ie-type t))) "not") (:method ((c (eql :=)) (e (ie-type t))) "equal to") (:method ((c (eql :>)) (e (ie-type t))) "greater than") (:method ((c (eql :<)) (e (ie-type t))) "less than") (:method ((c (eql :contains)) (e (ie-type t))) "contains") (:method ((c (eql :starts-with)) (e (ie-type t))) "starts with") (:method ((c (eql :ends-with)) (e (ie-type t))) "ends with") (:method ((c (eql :>)) (e (ie-type time))) "after") (:method ((c (eql :<)) (e (ie-type time))) "before")) (define-ie-generic make-criteria-attribute-value (element) (:method ((e (ie-type t))) (let ((ce (clone-element e :constraints nil :direct-value nil))) (setf (editablep ce) t) ce))) (define-ie-method negative-criteria ((e (ie-type interface-element))) :not) (define-ie-method applicable-criteria nconc ((e (ie-type text))) '(:= :contains :starts-with :ends-with)) (define-ie-method applicable-criteria nconc ((e (ie-type number))) '(:= :> :<)) (define-ie-method applicable-criteria nconc ((e (ie-type time))) '(:= :> :<)) (define-ie-method applicable-criteria nconc ((e (ie-type selector))) '(:=)) (define-ie-method applicable-criteria nconc ((e (ie-type checkbox))) '(:=)) (define-ie-method negative-criteria ((e (ie-type checkbox))) nil) ) (defclass alist-selector (select-element) () (:metaclass standard-component-class) (:default-initargs :key #'car :output-format #'(lambda (&rest args) (cdr (car args))))) (defclass search-criteria (composite-element) ((attribute :accessor attribute :initarg :attribute :documentation "Attribute name criteria is applied to.") (negativep :accessor negativep :component (alist-selector) :documentation "Is criteria negative.") (criteria :accessor criteria :component (alist-selector) :documentation "Criteria to add into a query.") (attribute-value :accessor attribute-value :initarg :attribute-value :documentation "Value of attribute.")) (:metaclass standard-component-class) (:default-initargs :slot-view (make-instance 'ieview :labelp nil)) (:documentation "Search criteria.")) (defmethod shared-initialize :after ((sc search-criteria) slot-names &key &allow-other-keys) (declare (ignore slot-names)) (with-slots (attribute-value criteria negativep label slot-view) sc (setf label (label attribute-value)) (let ((ac (applicable-criteria attribute-value))) (setf (options criteria) (mapcar #'(lambda (c) (cons c (criteria-label c attribute-value))) ac)) (case (length ac) (0 (setf (enabledp sc) nil)) ; no criteria, disable it (1 (setf (lisp-value criteria) (car ac) ; single criteria (editablep criteria) nil)) ; fix value (otherwise t))) (aif (negative-criteria attribute-value) (setf (options negativep) (acons nil "---" (acons it (criteria-label it attribute-value) nil))) (setf (enabledp negativep) nil)))) (defmethod query-value ((sc search-criteria)) (let ((lv (lisp-value sc)) negative criteria attr-value) (setf (values negative criteria attr-value) (values-list (mapcar #'(lambda (sn) (cdr (assoc sn lv))) '(negativep criteria attribute-value)))) (when criteria (if (and (enabledp (negativep sc)) negative) (list negative (list criteria attr-value)) (list criteria attr-value))))) (defmethod (setf query-value) (new (sc search-criteria)) (when new (let (negative criteria attr-value) (destructuring-bind (op op-value) new (awhen (eq op (negative-criteria (attribute-value sc))) (setf negative (negative-criteria (attribute-value sc)) (values op op-value) (values-list op-value))) (setf criteria op attr-value op-value)) (setf (lisp-value sc) (pairlis '(negativep criteria attribute-value) (list negative criteria attr-value)))))) (defmethod accept ((sc search-criteria) (view composite-view)) (with-slots (attribute-value) sc (setf (view attribute-value) view) (render attribute-value))) (defclass search-attribute-selector (select-element) () (:metaclass standard-component-class) (:default-initargs :label "Add to query" :output-format #'(lambda (v e) (declare (ignore e)) (label (cdr v))))) (defmethod render-element ((view composite-view) (e search-attribute-selector)) (accept view e) (