Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 7c62863b04
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 112 lines (95 sloc) 3.664 kb
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 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111
(*
* Copyright (C) 2006-2009 Citrix Systems Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; version 2.1 only. with the special
* exception on linking described in file LICENSE.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
(* Support for simple expression language for filtering database rows. *)

(* Language is stratified into values (field names or literals) and
boolean expressions. *)

open Db_filter_types

let string_of_val = function
  | Field x -> "Field " ^ x
  | Literal x -> "Literal " ^ x

let rec string_of_expr =
  let binexpr name a b = Printf.sprintf "%s (%s, %s)" name (string_of_expr a) (string_of_expr b) in
  let binval name a b = Printf.sprintf "%s (%s, %s)" name (string_of_val a) (string_of_val b) in
  function
  | True -> "True"
  | False -> "False"
  | Not x -> Printf.sprintf "Not ( %s )" (string_of_expr x)
  | And(a, b) -> binexpr "And" a b
  | Or(a, b) -> binexpr "Or" a b
  | Eq(a, b) -> binval "Eq" a b

exception XML_unmarshall_error
let val_of_xml xml =
  match (XMLRPC.From.array (fun x->x) xml) with
      [a; s] ->
begin
match (XMLRPC.From.string a) with
"field" -> Field (XMLRPC.From.string s)
| "literal" -> Literal (XMLRPC.From.string s)
| _ -> raise XML_unmarshall_error
end
    | _ -> raise XML_unmarshall_error

let rec expr_of_xml xml =
  match (XMLRPC.From.array (fun x->x) xml) with
      [x] ->
begin
match (XMLRPC.From.string x) with
"true" -> True
| "false" -> False
| _ -> raise XML_unmarshall_error
end
    | [x;y] ->
begin
match (XMLRPC.From.string x) with
"not" -> Not (expr_of_xml y)
| _ -> raise XML_unmarshall_error
end
    | [x;y;z] ->
begin
match (XMLRPC.From.string x) with
"and" -> And(expr_of_xml y, expr_of_xml z)
| "or" -> Or(expr_of_xml y, expr_of_xml z)
| "eq" -> Eq(val_of_xml y, val_of_xml z)
| _ -> raise XML_unmarshall_error
end
| _ -> raise XML_unmarshall_error

let xml_of_val v =
  match v with
      Field s -> XMLRPC.To.array [XMLRPC.To.string "field"; XMLRPC.To.string s]
    | Literal s -> XMLRPC.To.array [XMLRPC.To.string "literal"; XMLRPC.To.string s]

let rec xml_of_expr e =
  match e with
      True -> XMLRPC.To.array [XMLRPC.To.string "true"]
    | False -> XMLRPC.To.array [XMLRPC.To.string "false"]
    | Not e -> XMLRPC.To.array [XMLRPC.To.string "not";xml_of_expr e]
    | And(a,b) -> XMLRPC.To.array [XMLRPC.To.string "and"; xml_of_expr a; xml_of_expr b]
    | Or(a,b) -> XMLRPC.To.array [XMLRPC.To.string "or"; xml_of_expr a; xml_of_expr b]
    | Eq(a,b) -> XMLRPC.To.array [XMLRPC.To.string "eq"; xml_of_val a; xml_of_val b]


(** Evaluate a predicate over a database row represented by a function
'lookup_val' which knows how to return the contents of fields. *)
let eval_expr (lookup_val: _val -> string) =
  let compare f _a _b = f (lookup_val _a) (lookup_val _b) in
  let rec f = function
    | True -> true
    | Not x -> not (f x)
    | And (a, b) -> f a && (f b)
    | Eq (_a, _b) -> compare (=) _a _b
    | False -> false
    | Or (a, b) -> f a || (f b)
  in f

exception Expression_error of (string * exn)

(* A simple parser for the expression language: *)
let expr_of_string x = try
Db_filter_parse.exprstr Db_filter_lex.lexer
(Lexing.from_string x)
  with e -> raise (Expression_error (x, e))




Something went wrong with that request. Please try again.