weblocks-filtering-widget/compare-sql-function.lisp at master · weblocks-framework/weblocks-filtering-widget · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80

(in-package :weblocks-filtering-widget)

(defun transform-like-expression-wildcards (string)
  (flet ((surround-with-percents-sign (string)
           (concatenate 'string "%" string "%"))
         (percent-signs-to-double-signs (string)
           (ppcre:regex-replace "%" string "%%"))
         (wildcards-to-percent-signs (string)
           (ppcre:regex-replace "\\*"  string "%")))
    (surround-with-percents-sign
      (wildcards-to-percent-signs
        (percent-signs-to-double-signs string)))))

(assert (string= "%test%" (transform-like-expression-wildcards "test")))
(assert (string= "%te%st%" (transform-like-expression-wildcards "te*st")))
(assert (string= "%te%%st%" (transform-like-expression-wildcards "te%st")))

(defun compare-sql-expression (filters)
  (let ((value (getf filters :value)))
    (when (getf value :compare-type)
      (let* ((is-a-not-expression (string=
                                    "not-"
                                    (subseq (getf value :compare-type) 0 4)))
             (string-expression (if is-a-not-expression
                                  (subseq (getf value :compare-type) 4)
                                  (getf value :compare-type)))
             (operator
               (cond
                 ((string= string-expression "equal") '=)
                 ((string= string-expression "like") 'like)
                 (t (error (format nil "Operation \"~A\" is not implemented" (getf value :compare-type))))))
             (sub-expressions
               (cond
                 ((string= string-expression "equal")
                  (list (intern (string (getf value :field))) (getf value :compare-value)))
                 ((string= string-expression "like")
                  (list (intern (string (getf value :field)))
                        (transform-like-expression-wildcards
                          (getf value :compare-value))))))
             (expression
               (make-instance
                 (intern "SQL-RELATIONAL-EXP" "CLSQL-SYS")
                 :operator operator
                 :sub-expressions sub-expressions)))
        (when is-a-not-expression
          (setf expression
                (make-instance
                  (intern "SQL-VALUE-EXP" "CLSQL-SYS")
                  :modifier 'not
                  :components
                  (list
                    expression))))
        expression))))

(defun assert-expressions-equal (expression1 expression2)
  (assert (string=
            (write-to-string expression1)
            (write-to-string expression2))))

(when (find-package :clsql)
  (eval `(,(intern "LOCALLY-ENABLE-SQL-READER-SYNTAX" "CLSQL")))

  (assert-expressions-equal
    [= 'post_subject "test"]
    (compare-sql-expression '(:VALUE (:FIELD :POST_SUBJECT :COMPARE-TYPE "equal" :COMPARE-VALUE "test") :ID "#:G1966" :AND NIL :OR NIL)))

  (assert-expressions-equal
    [not [= 'post_subject "test"]]
    (compare-sql-expression '(:VALUE (:FIELD :POST_SUBJECT :COMPARE-TYPE "not-equal" :COMPARE-VALUE "test") :ID "#:G1966" :AND NIL :OR NIL)))

  (assert-expressions-equal
    [like 'post_subject "%test%"]
    (compare-sql-expression '(:VALUE (:FIELD :POST_SUBJECT :COMPARE-TYPE "like" :COMPARE-VALUE "test") :ID "#:G1966" :AND NIL :OR NIL)))

  (assert-expressions-equal
    [not [like 'post_subject "%test%"]]
    (compare-sql-expression '(:VALUE (:FIELD :POST_SUBJECT :COMPARE-TYPE "not-like" :COMPARE-VALUE "test") :ID "#:G1966" :AND NIL :OR NIL)))

  (eval `(,(intern "RESTORE-SQL-READER-SYNTAX-STATE" "CLSQL"))))