Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 235 lines (208 sloc) 8.711 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* CF mli *)
19
20 module List = BaseList
21
22 module Arg =
23 struct
24 module A = Base.Arg
25
26 (* overriding db options *)
27 let commandline_override =
28 ref (StringListMap.empty : QmlAst.Db.options list StringListMap.t)
29
30 let parse_opts s =
31 try
32 let (engine, arg) = BaseString.split_char '(' s in
33 let arg = if arg = "" then arg else BaseString.remove_prefix "\"" arg in
34 let arg = if arg = "" then arg else BaseString.remove_suffix "\")" arg in
35 let arg_opt = if arg = "" then None else Some arg in
36 match engine with
37 | "local" -> [`engine (`db3 arg_opt)]
f764139 Norman Scaife [feature] Badop_light: Attempt at OPA integration (partially successful...
nrs135 authored
38 | "light" -> [`engine (`db3light arg_opt)]
fccc685 Initial open-source release
MLstate authored
39 | "meta" -> [`engine `meta]
40 | "shared" ->
41 let (hostname, port) = BaseString.split_char ':' arg in
42 let hostname = if hostname = "" then None else Some hostname in
43 let port = if port = "" then None else Some (int_of_string port) in
44 [`engine (`client (hostname, port))]
45 | _ -> failwith "bad engine"
46 with
47 | Not_found
48 | Failure _ -> failwith "The syntax of database options should be as in source code, e.g., --database 'db1:\"@local(./file)\"'."
49
50 (* display enforce output *)
51 let export_schema = (Hashtbl.create 1 : (string option,string) Hashtbl.t) (* db_name -> file *)
52 let output_schema = ref false
53
54 let options = [
55
56 "--database",
57 A.String (fun s ->
58 try
59 let (name, opt_string) = BaseString.split_char '@' s in
60 let point =
61 if name = "" then []
62 else [BaseString.remove_suffix ":" name]
63 in
64 let opts = parse_opts opt_string in
65 commandline_override :=
66 StringListMap.add point opts !commandline_override;
67 ()
68 with
69 | Not_found -> failwith "Separate the name of the database and the options with a colon, e.g., --database 'db1:\"@shared(:4849)\"'."
70 ),
71 " Override options of a database";
72
73 "--export-db-schema",
74 A.String (fun s ->
75 let db,file = if String.contains s ':' then Base.String.split_char ':' s else "",s in
76 Hashtbl.add export_schema (if db = "" then None else Some db) file),
77 " Exports the database schema to the given file (format depends on the extension: use gml for manipulating it with opa-db-tool, or dot (the default) for display). Use [database_name]:file_name if you have multiple databases.";
78
79 "--print-dbschema",
80 A.Set output_schema,
81 " Dump the db-schema using the track system" ;
82
83 ]
84 end
85
86 (*
87 The name of the file where to output the schema.
88 <!> keep synchro with opatrack
89 *)
90 let schema_filename = "schema"
91
92 (* displaying the schema if asked, and fork for seeing it with display if asked *)
93 let auto_disp_schema schema =
94 if !Arg.output_schema then
95 try
96 let pp fmt schema =
97 QmlDbGen.Schema.to_dot schema fmt
98 in
99 let filename = schema_filename in
100 ignore (PassTracker.file ~filename pp schema)
101 with
102 | e ->
103 OManager.warning ~wclass:WarningClass.dbgen_schema
978b7c4 Adam Koprowski [fix] typo: occurence->occurrence, occured->occurred
akoprow authored
104 "@[<2> An error occurred while trying to display the output the db schema@\n%s@]"
fccc685 Initial open-source release
MLstate authored
105 (Printexc.to_string e)
106 else
107 if ObjectFiles.compilation_mode() = `init then (* Only export the full schema, ie after `init *)
108 Hashtbl.iter
109 (fun db filename ->
110 try
111 let ch = open_out filename in
112 if Base.String.is_suffix ".gml" filename
113 then QmlDbGen.Schema.db_to_gml schema db ch
114 else QmlDbGen.Schema.db_to_dot schema db ch;
115 close_out ch
116 with
117 | Not_found ->
118 OManager.warning ~wclass:WarningClass.dbgen_schema
119 "@[<2> Could not dump the database schema: database \"%s\" not found@]"
120 (Option.default "<default>" db)
121 | Sys_error msg ->
122 OManager.warning ~wclass:WarningClass.dbgen_schema
123 "@[<2> Could not open file for outputting the database schema%s@\n%s@]"
124 (match db with Some db -> " of database "^db | None -> "")
125 msg)
126 Arg.export_schema
127
128 (* separation *)
129 module S =
130 struct
131 type t = QmlDbGen.Schema.t
132 let pass = "pass_DbSchemaGeneration"
133 let pp f _ = Format.pp_print_string f "<dummy>"
134 end
135 module R = ObjectFiles.Make(S)
136
137 let process_code gamma _annotmap schema code =
138 assert(schema == QmlDbGen.Schema.initial);
139
140 (* getting the schema of other packages *)
141 let merge package schema1 schema2 =
142 (* UNNEEDED: because the types aren't supposed to contain type variables
143 let schema2 = QmlDbGen.Schema.map_types (QmlRefresh.refresh_typevars_from_ty package) schema2 in *)
144 let schema2 = QmlDbGen.Schema.map_expr (QmlRefresh.refresh_expr_no_annotmap package) schema2 in
145 (* let oc1 = open_out ("schema1"^(fst package)) in *)
146 (* let _ = QmlDbGen.Schema.to_dot schema1 oc1 in *)
147 (* let oc2 = open_out ("schema2"^(fst package)) in *)
148 (* let _ = QmlDbGen.Schema.to_dot schema2 oc2 in *)
149 let merged_schema = QmlDbGen.Schema.merge schema1 schema2 in
150 (* let oc3 = open_out ("schema3"^(fst package)) in *)
151 (* let _ = QmlDbGen.Schema.to_dot merged_schema oc3 in *)
152 (* let _ = close_out oc1; close_out oc2; close_out oc3 in *)
153 merged_schema
154 in
155 let schema =
156 if ObjectFiles.compilation_mode() = `init
157 then
158 let sch = R.fold_with_name ~packages:true ~deep:true merge schema in
159 sch
160 else R.fold_with_name merge schema
161 in
162
163 (* registering Database definitions
164 The construction of the schema needs to get
165 Database nodes before NewDbValue.
166 *)
167 let (schema, gamma) =
168 List.fold_left
169 (fun ((schema, gamma) as acc) code_elt ->
170 match code_elt with
171 | QmlAst.Database (label, ident, p, opts) ->
172 QmlDbGen.Schema.register_db_declaration
173 schema gamma (label, ident, p, opts)
174 | _ -> acc
175 ) (schema, gamma) code in
176
177 (* registering NewDbValue definitions *)
178 let schema, code =
179 List.fold_left_collect (
180 fun schema code_elt ->
181 match code_elt with
182 | QmlAst.NewDbValue (label, value) ->
183 let schema, o =
184 QmlDbGen.Schema.register_new_db_value ~name_default_values:true
185 schema gamma (label, value) in
186 let code =
187 match o with
188 | Some (binding, value) ->
189 let code_elt = QmlAst.NewVal (Annot.refresh label, [binding]) in
190 [code_elt; QmlAst.NewDbValue (label, value)]
191 | None -> [code_elt] in
192 schema, code
193 | _ -> schema, [code_elt]
194 ) schema code in
195
196 (* modify by commandline options: *)
197 let schema =
198 let override point (ident, db_options) =
199 if StringListMap.mem point !Arg.commandline_override then begin
200 let opts = StringListMap.find point !Arg.commandline_override in
201 Arg.commandline_override :=
202 StringListMap.remove point !Arg.commandline_override;
203 (ident, opts)
204 end else begin
205 (ident, db_options)
206 end
207 in
208 let schema = QmlDbGen.Schema.mapi override schema in
209 if StringListMap.is_empty !Arg.commandline_override then schema
210 else begin
211 let (key, _) = StringListMap.min !Arg.commandline_override in
212 match key with
213 | [] -> failwith "No anonymous database declared in the source code."
214 | l ->
215 let n = String.concat "/" l in
216 let msg = Printf.sprintf "No database with name '%s' declared." n in
217 failwith msg (* TODO: register the error somewhere *)
218 end
219 in
220
221 (* finalizing the schema *)
222 let schema, partial_schema =
223 match QmlDbGen.Schema.finalize schema with
224 | Some schema ->
225 schema,
226 QmlDbGen.Schema.of_package schema (ObjectFiles.get_current_package_name())
227 | None -> schema, schema (* empty schemas *)
228 in
229
230 let _ = R.save partial_schema in
231
232 let _ = auto_disp_schema schema in
233
234 (gamma, schema, code)
Something went wrong with that request. Please try again.