1 (in-package :lisp-on-lines
)
4 (defmethod simple-word-search (class-name slots search-terms
)
6 :where
(simple-word-search-where class-name slots search-terms
)
9 (defmethod simple-word-search-where (class-name slots search-terms
)
11 (mapcar #'(lambda (term)
13 (mapcar #'(lambda (slot)
15 (sql-slot-value class-name slot
)
16 (format nil
"%~a%" term
)))
20 (defmethod find-slots-of-type (model &key
(type 'string
)
21 (types '((string)) types-supplied-p
))
22 "returns a list of slots matching TYPE, or matching any of TYPES"
26 (setf ty
(list type
)))
27 (remove nil
(mapcar #'(lambda (st) (when (member (second st
) ty
)
29 (list-slot-types model
)))))
31 ;;;; * Simple Search Component
33 (defcomponent simple-search
()
34 ((search-term :initarg
:search-term
:accessor search-term
:initform
"")
35 (listing :initarg
:listing
:accessor listing
:initform
:listing
)
36 (select-returns-p :initarg
:select-returns-p
:accessor select-returns-p
:initform nil
)
37 (search-tables :initarg
:search-tables
:accessor search-tables
:initform nil
)))
39 (defmethod render-on ((res response
)(self simple-search
))
40 (<ucw
:input
:type
"text" :accessor
(search-term self
))
41 (<ucw
:submit
:action
(do-search self
)))
43 (defmethod perform-simple-search ((self simple-search
) &key
(base-classes (meta-model:list-base-classes
:clsql
)))
44 (when (search-tables self
)
45 (setf base-classes
(search-tables self
)))
46 (remove nil
(mapcar #'(lambda (x)
48 (find-slots-of-type x
)
49 (split-sequence #\Space
(search-term self
))))
53 (defmethod/cc do-search
((self simple-search
))
54 (let* ((target (or (slot-value self
'ucw
::parent
) self
))
55 (result (call-component
57 (make-instance 'simple-search-results
58 :listing
(listing self
)
60 (perform-simple-search self
:base-classes
61 (remove 'claim-history
(meta-model:list-base-classes
:clsql
)))
62 :search-term
(split-sequence #\Space
(search-term self
))))))
64 (if (select-returns-p self
)
66 (call-component target
(make-presentation result
:type
:viewer
))))))
68 (defcomponent simple-search-results
()
69 ((results :accessor results
:initarg
:results
:initform nil
)
70 (listing :initarg
:listing
:accessor listing
:initform
:listing
)
71 (search-term :initarg
:search-term
:accessor search-term
:initform nil
)))
73 (defmethod view-name (view)
74 (class-name (class-of view
)))
76 (defmethod render-on ((res response
) (self simple-search-results
))
77 (<:h3
(<:as-html
"Search results for " (search-term self
)))
78 (dolist (r (results self
))
80 (<:legend
(<:as-html
(format nil
"Found ~A results in ~A:" (length r
) (view-name (car r
)))))
87 :initargs
`(:instances
,r
)))))))
89 (defmethod/cc ok
((self simple-search-results
) &optional arg
)
90 (declare (ignore arg
))
95 ;;;; * Advanced Search Component
97 (defcomponent advanced-search
()
98 ((simple-search :component simple-search
:accessor simple-search
)
99 (search-table :accessor search-table
:initform nil
)
100 (search-presentation :accessor search-presentation
:initform nil
)))
102 (defmethod render-on ((res response
) (self advanced-search
))
103 (<:h2
(<:as-html
"Advanced Search"))
106 (<:legend
(<:as-html
"simple text search"))
107 (render-on res
(simple-search self
)))
110 (<:legend
(<:as-html
"Complex Search"))
111 (<:as-html
"Choose search table:")
113 :accessor
(search-table self
)
114 (dolist (tbl (meta-model:list-base-classes
:clsql
))
115 (<ucw
:option
:value tbl
(<:as-html tbl
))))
116 (<ucw
:submit
:action
(select-search-table self
) :value
"select")
118 (when (search-presentation self
)
120 (<:legend
(<:as-html
(format nil
"search ~A" (search-table self
))))
121 (render-on res
(embed-component self
(search-presentation self
)))))))
124 (defun make-search-presentation (instance )
125 (make-instance 'mewa
::mewa-presentation-search
126 :search-presentation
(make-presentation instance
:type
:search-model
)
127 :list-presentation
(make-presentation instance
:type
:listing
128 (defmethod/cc select-search-table
((self advanced-search
))
129 (let* ((i (make-instance (search-table self
)))
130 (p (make-search-presentation i
)))
131 (embed-component self p
)
132 (setf (search-presentation self
) p
) ))
135 (defcomponent table-search