Commit | Line | Data |
---|---|---|
2b0fd9c8 DC |
1 | (in-package :lisp-on-lines) |
2 | ||
3 | ||
4 | (defmethod simple-word-search (class-name slots search-terms) | |
5 | (select class-name | |
6 | :where (simple-word-search-where class-name slots search-terms) | |
7 | :flatp t)) | |
8 | ||
9 | (defmethod simple-word-search-where (class-name slots search-terms) | |
10 | (sql-or | |
11 | (mapcar #'(lambda (term) | |
12 | (apply #'sql-or | |
13 | (mapcar #'(lambda (slot) | |
14 | (sql-uplike | |
15 | (sql-slot-value class-name slot) | |
16 | (format nil "%~a%" term))) | |
17 | slots))) | |
18 | search-terms))) | |
19 | ||
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" | |
23 | (let (ty) | |
24 | (if types-supplied-p | |
25 | (setf ty types) | |
26 | (setf ty (list type))) | |
27 | (remove nil (mapcar #'(lambda (st) (when (member (second st) ty) | |
28 | (first st))) | |
29 | (list-slot-types model))))) | |
30 | ||
31 | ;;;; * Simple Search Component | |
32 | ||
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))) | |
38 | ||
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))) | |
42 | ||
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) | |
47 | (simple-word-search x | |
48 | (find-slots-of-type x) | |
49 | (split-sequence #\Space (search-term self)))) | |
50 | base-classes))) | |
51 | ||
52 | ||
53 | (defaction do-search ((self simple-search)) | |
54 | (let* ((target (or (slot-value self 'ucw::parent) self)) | |
55 | (result (call-component | |
56 | target | |
57 | (make-instance 'simple-search-results | |
58 | :listing (listing self) | |
59 | :results | |
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)))))) | |
63 | (when result | |
64 | (if (select-returns-p self) | |
65 | (answer result) | |
66 | (call-component target (make-presentation result :type :viewer)))))) | |
67 | ||
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))) | |
72 | ||
73 | (defmethod view-name (view) | |
74 | (class-name (class-of view))) | |
75 | ||
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)) | |
79 | (<:fieldset | |
80 | (<:legend (<:as-html (format nil "Found ~A results in ~A:" (length r) (view-name (car r))))) | |
81 | (render-on res | |
82 | (embed-component | |
83 | self | |
84 | (make-presentation | |
85 | (car r) | |
86 | :type :listing | |
87 | :initargs `(:instances ,r))))))) | |
88 | ||
89 | (defaction ok ((self simple-search-results) &optional arg) | |
90 | (declare (ignore arg)) | |
91 | (answer nil)) | |
92 | ||
93 | ||
94 | ||
95 | ;;;; * Advanced Search Component | |
96 | ||
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))) | |
101 | ||
102 | (defmethod render-on ((res response) (self advanced-search)) | |
103 | (<:h2 (<:as-html "Advanced Search")) | |
104 | ;; simple search : | |
105 | (<:fieldset | |
106 | (<:legend (<:as-html "simple text search")) | |
107 | (render-on res (simple-search self))) | |
108 | ;; complex-search | |
109 | (<:fieldset | |
110 | (<:legend (<:as-html "Complex Search")) | |
111 | (<:as-html "Choose search table:") | |
112 | (<ucw:select | |
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") | |
117 | ;; | |
118 | (when (search-presentation self) | |
119 | (<:fieldset | |
120 | (<:legend (<:as-html (format nil "search ~A" (search-table self)))) | |
121 | (render-on res (embed-component self (search-presentation self))))))) | |
122 | ||
123 | ||
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 | (defaction 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) )) | |
133 | ||
134 | ||
135 | (defcomponent table-search | |
136 | ||
137 | ||
138 | ||
139 |