--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM 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 General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+open Dbconn;;
+open Union;;
+open Intersect;;
+open Meet;;
+open Property;;
+open Sub;;
+open Context;;
+open Diff;;
+open Relation;;
+open Func;;
+open Pattern;;
+
+exception SVarUnbound of string;;
+exception RVarUnbound of string;;
+exception VVarUnbound of string;;
+exception PathUnbound of (string * string list);;
+
+exception InvalidConnection
+exception ConnectionFailed of string
+
+exception BooleExpTrue
+
+(* valuta una MathQL.set_exp e ritorna un MathQL.resource_set *)
+
+let galax_char = 'G'
+let stat_char = 'S'
+
+let execute_aux log m x =
+ let module M = MathQL in
+ let module X = MQueryMisc in
+let rec exec_set_exp c = function
+ M.SVar svar ->
+ (try
+ List.assoc svar c.svars
+ with Not_found ->
+ raise (SVarUnbound svar))
+ | M.RVar rvar ->
+ (try
+ [List.assoc rvar c.rvars]
+ with Not_found ->
+ raise (RVarUnbound rvar))
+ | M.Ref vexp -> List.map (fun s -> (s,[])) (exec_val_exp c vexp)
+ | M.Pattern vexp -> pattern_ex (exec_val_exp c vexp)
+ | M.Intersect (sexp1, sexp2) ->
+ let before = X.start_time() in
+ let rs1 = exec_set_exp c sexp1 in
+ let rs2 = exec_set_exp c sexp2 in
+ let res = intersect_ex rs1 rs2 in
+ let diff = X.stop_time before in
+ let ll1 = string_of_int (List.length rs1) in
+ let ll2 = string_of_int (List.length rs2) in
+ if String.contains m stat_char then
+ log ("INTERSECT(" ^ ll1 ^ "," ^ ll2 ^ ") = " ^ string_of_int (List.length res) ^
+ ": " ^ diff ^ "\n");
+ res
+ | M.Union (sexp1, sexp2) ->
+ let before = X.start_time () in
+ let res = union_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2) in
+ let diff = X.stop_time before in
+ if String.contains m stat_char then log ("UNION: " ^ diff ^ "\n");
+ res
+ | M.LetSVar (svar, sexp1, sexp2) ->
+ let before = X.start_time() in
+ let c1 = upd_svars c ((svar, exec_set_exp c sexp1) :: c.svars) in
+ let res = exec_set_exp c1 sexp2 in
+ if String.contains m stat_char then begin
+ log ("LETIN " ^ svar ^ " = " ^ string_of_int (List.length res) ^ ": ");
+ log (X.stop_time before ^ "\n");
+ end;
+ res
+ | M.LetVVar (vvar, vexp, sexp) ->
+ let before = X.start_time() in
+ let c1 = upd_vvars c ((vvar, exec_val_exp c vexp) :: c.vvars) in
+ let res = exec_set_exp c1 sexp in
+ if String.contains m stat_char then begin
+ log ("LETIN " ^ vvar ^ " = " ^ string_of_int (List.length res) ^ ": ");
+ log (X.stop_time before ^ "\n");
+ end;
+ res
+ | M.Relation (inv, rop, path, sexp, assl) ->
+ let before = X.start_time() in
+ if String.contains m galax_char then begin
+ let res = relation_galax_ex inv rop path (exec_set_exp c sexp) assl in
+ if String.contains m stat_char then begin
+ log ("RELATION-GALAX " ^ (fst path) ^ " = " ^ string_of_int(List.length res) ^ ": ");
+ log (X.stop_time before ^ "\n")
+ end;
+ res
+ end else begin
+ let res = relation_ex inv rop path (exec_set_exp c sexp) assl in
+ if String.contains m stat_char then begin
+ log ("RELATION " ^ (fst path) ^ " = " ^ string_of_int(List.length res) ^ ": ");
+ log (X.stop_time before ^ "\n")
+ end;
+ res
+ end
+ | M.Select (rvar, sexp, bexp) ->
+ let before = X.start_time() in
+ let rset = (exec_set_exp c sexp) in
+ let rec select_ex =
+ function
+ [] -> []
+ | r::tl ->
+ let c1 = upd_rvars c ((rvar,r)::c.rvars) in
+ if (exec_boole_exp c1 bexp) then
+ r::(select_ex tl)
+ else
+ select_ex tl
+ in
+ let res = select_ex rset in
+ if String.contains m stat_char then begin
+ log ("SELECT " ^ rvar ^ " = " ^ string_of_int (List.length res) ^ ": ");
+ log (X.stop_time before ^ "\n");
+ end;
+ res
+ | M.Diff (sexp1, sexp2) -> diff_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2)
+
+(* valuta una MathQL.boole_exp e ritorna un boole *)
+
+and exec_boole_exp c =
+ function
+ M.False -> false
+ | M.True -> true
+ | M.Not x -> not (exec_boole_exp c x)
+ | M.And (x, y) -> (exec_boole_exp c x) && (exec_boole_exp c y)
+ | M.Or (x, y) -> (exec_boole_exp c x) || (exec_boole_exp c y)
+ | M.Sub (vexp1, vexp2) ->
+ sub_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2)
+ | M.Meet (vexp1, vexp2) ->
+ meet_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2)
+ | M.Eq (vexp1, vexp2) -> (exec_val_exp c vexp1) = (exec_val_exp c vexp2)
+ | M.Ex l bexp ->
+ if l = [] then
+ (exec_boole_exp c bexp)
+ else
+ let latt =
+ List.map
+ (fun uri ->
+ let (r,attl) =
+ (try
+ List.assoc uri c.rvars
+ with Not_found -> assert false)
+ in
+ (uri,attl)
+ ) l (*latt = l + attributi*)
+ in
+ try
+ let rec prod c =
+ function
+ [] -> if (exec_boole_exp c bexp) then raise BooleExpTrue
+ | (uri,attl)::tail1 ->
+ (*per ogni el. di attl devo andare in ric. su tail1*)
+ let rec sub_prod attl =
+ match attl with
+ [] -> ()
+ | att::tail2 ->
+ let c1 = upd_groups c ((uri,att)::c.groups) in
+ prod c1 tail1; sub_prod tail2
+ in
+ sub_prod attl
+ in
+ prod c latt;
+ false
+ with BooleExpTrue -> true
+
+(* valuta una MathQL.val_exp e ritorna un MathQL.value *)
+
+and exec_val_exp c = function
+ M.Const x -> let
+ ol = List.sort compare x in
+ let rec edup = function
+
+ [] -> []
+ | s::tl -> if tl <> [] then
+ if s = (List.hd tl) then edup tl
+ else s::(edup tl)
+ else s::[]
+ in
+ edup ol
+ | M.Record (rvar, path) ->
+ (try
+ List.assoc path
+ (try
+ List.assoc rvar c.groups
+ with Not_found ->
+ raise (RVarUnbound rvar))
+ with Not_found ->
+ raise (PathUnbound path))
+ | M.VVar s ->
+ (try
+ List.assoc s c.vvars
+ with Not_found ->
+ raise (VVarUnbound s))
+ | M.RefOf sexp -> List.map (fun (s,_) -> s) (exec_set_exp c sexp)
+ | M.Fun (s, vexp) -> fun_ex s (exec_val_exp c vexp)
+ | M.Property (inv, rop, path, vexp) -> property_ex rop path inv (exec_val_exp c vexp)
+
+(* valuta una MathQL.set_exp nel contesto vuoto e ritorna un MathQL.resource_set *)
+in
+ exec_set_exp {svars = []; rvars = []; groups = []; vvars = []} x
+
+(* new interface ***********************************************************)
+
+module type Callbacks =
+ sig
+ val log : string -> unit (* logging function *)
+ end
+
+module Make (C: Callbacks) =
+ struct
+
+ let postgres = "P"
+ let galax = "G"
+ let stat = "S"
+ let quiet = "Q"
+ let warn = "W"
+
+ let execute m x = execute_aux C.log m x
+
+ let init m =
+ let default_connection_string =
+ "host=mowgli.cs.unibo.it dbname=helm_mowgli_new_schema user=helm"
+ in
+ let connection_string =
+ try Sys.getenv "POSTGRESQL_CONNECTION_STRING"
+ with Not_found -> default_connection_string
+ in
+ if String.contains m galax_char then true else
+ try Dbconn.init connection_string; true
+ with ConnectionFailed s -> false
+
+ let close m =
+ if String.contains m galax_char then () else Dbconn.close ()
+
+ let check m =
+ if String.contains m galax_char then false else
+ try ignore (Dbconn.pgc ()); true with InvalidConnection -> false
+
+ end
projects / helm.git / blobdiff