Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 201 lines (189 sloc) 7.609 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
19 (* THIS FILE HAS A DOCUMENTED MLI *)
20
21 type debug_var = string option
22
23 let other_mlstate_variables = ["no_embedded_lib"; "noide"]
24 let table = Hashtbl.create 100
25
26 let var var =
27 let var = "MLSTATE_" ^ (String.uppercase var) in
28 let value =
29 try
30 Some (Sys.getenv var)
31 with
32 | Not_found -> None in
33 assert (not (Hashtbl.mem table var));
34 Hashtbl.add table var value ;
35 value
36
37 let () = List.iter (fun s -> ignore (var s)) other_mlstate_variables
38 (* *PLEASE* keep in alphabetical order (here and in mli) *)
39 let add_stdlib = var "add_stdlib"
40 let badop_debug = var "badop_debug"
41 let badop_xml_import_commit_transaction_step = var "badop_xml_import_commit_transaction_step"
42 let bsl_loading = var "bsl_loading"
43 let bsl_no_restriction = var "bsl_no_restriction"
44 let bsl_projection = var "bsl_projection"
45 let bsl_register = var "bsl_register"
46 let bsl_sl = var "bsl_sl"
47 let bypass_hoisting = var "bypass_hoisting"
48 let check_vars = var "check_vars"
49 let closure_debug = var "closure_debug"
50 let closure_opt = var "closure_opt"
51 let closure_stat = var "closure_stat"
52 let const_sharing_client_float = var "const_sharing_client_float"
53 let const_sharing_client_record = var "const_sharing_client_record"
54 let const_sharing_client_remove_coerce = var "const_sharing_client_remove_coerce"
55 let const_sharing_client_string = var "const_sharing_client_string"
56 let const_sharing_server_float = var "const_sharing_server_float"
57 let const_sharing_server_record = var "const_sharing_server_record"
58 let const_sharing_server_remove_coerce = var "const_sharing_server_remove_coerce"
59 let const_sharing_server_string = var "const_sharing_server_string"
60 let cps_blocking_wait = var "cps_blocking_wait"
61 let cps_debug = var "cps_debug"
62 let cps_keep_letcont = var "cps_keep_letcont"
63 let cps_noskip = var "cps_noskip"
64 let cps_stack_trace = var "cps_stack_trace"
65 let cps_verbose = var "cps_verbose"
66 let db3_no_final_snapshot = var "db3_no_final_snapshot"
67 let low_level_db_log = var "low_level_db_log"
68 let db3_transaction_limit = var "db3_transaction_limit"
69 let dbgen_always_upgrade = var "dbgen_always_upgrade"
70 let dbgen_butcher = var "dbgen_butcher"
71 let dbgen_debug = var "dbgen_debug"
72 let dbgen_flags = var "dbgen_flags"
73 let debug_db = var "debug_db"
74 let debug_db_index = var "debug_db_index"
75 let debug_db_max_delta = var "debug_db_max_delta"
76 let debug_paxos = var "debug_paxos"
77 let debug_paxos_cluster = var "debug_paxos_cluster"
78 let debug_paxos_consensus = var "debug_paxos_consensus"
79 let debug_paxos_le = var "debug_paxos_le"
80 let debug_paxos_rbr = var "debug_paxos_rbr"
81 let debug_paxos_sched = var "debug_paxos_sched"
bc2add4 [cleanup] Log: add a debug variable for xml
Raja authored
82 let debug_xml = var "debug_xml"
fccc685 Initial open-source release
MLstate authored
83 let diffing = var "diffing"
84 let effects_show = var "effects_show"
85 let expl_inst_debug = var "expl_inst_debug"
86 let expl_inst_no_memo = var "expl_inst_no_memo"
87 let expl_inst_normalize = var "expl_inst_normalize"
88 let expl_inst_opt_debug = var "expl_inst_opt_debug"
89 let expl_inst_typename = var "expl_inst_typename"
90 let libnet_cluster = var "libnet_cluster"
91 let hlnet_debug = var "hlnet_debug"
92 let hldir_debug = var "hldir_debug"
93 let http_debug = var "http_debug"
94 let http_no_cookie = var "http_no_cookie"
95 let js_imp = var "js_imp"
96 let js_match_compilation = var "js_match_compilation"
97 let js_no_split = var "js_no_split"
98 let js_no_tailcall = var "js_no_tailcall"
99 let js_renaming = var "js_renaming"
100 let js_serialize = var "js_serialize"
101 let lambda_coerce = var "lambda_coerce"
102 let lambda_correct = var "lambda_correct"
103 let lambda_debug = var "lambda_debug"
104 let no_access_log = var "no_access_log"
105 let no_database_upgrade = var "no_database_upgrade"
106 let no_flood_prevention = var "no_flood_prevention"
107 let no_server_info = var "no_server_info"
108 let nocache = var "nocache"
109 let object_debug = var "object_debug"
110 let ocamldep_show_logs = var "ocamldep_show_logs"
111 let omanager_debug = var "omanager_debug"
112 let opacapi_loose = var "opacapi_loose"
113 let opadoc = var "opadoc"
114 let opatop_annot = var "opatop_annot"
115 let opatop_expr = var "opatop_expr"
116 let opatop_hook = var "opatop_hook"
117 let opatop_unvalrec = var "opatop_unvalrec"
118 let parser_cache_debug = var "parser_cache_debug"
119 let patterns_normalize = var "patterns_normalize"
120 let patterns_real_patas = var "patterns_real_patas"
121 let ping_debug = var "ping_debug"
122 let ppdebug = var "ppdebug"
123 let protocol_debug = var "protocol_debug"
124 let qmlc_no_magic = var "qmlc_no_magic"
125 let qmltop_time = var "qmltop_time"
126 let redundancy = var "redundancy"
127 let reorder = var "reorder"
128 let resource_tracker_debug = var "resource_tracker_debug"
129 let rpc_alt_skeleton = var "rpc_alt_skeleton"
130 let rpc_debug = var "rpc_debug"
131 let sa_dependencies = var "sa_dependencies"
132 let sa_printer_annot = var "sa_printer_annot"
133 let sa_printer_ty = var "sa_printer_ty"
134 let sa_trx = var "sa_trx"
135 let sa_xml_pattern = var "sa_xml_pattern"
136 let scheduler_debug = var "scheduler_debug"
137 let server_serialize = var "server_serialize"
138 let server_stats = var "server_stats"
139 let session_debug = var "session_debug"
140 let show_logs = var "show_logs"
141 let simplifymagic_disable = var "simplifymagic_disable"
142 let simplifymagic_failures = var "simplifymagic_failures"
143 let slicer_cond = var "slicer_cond"
144 let slicer_debug = var "slicer_debug"
145 let slicer_time = var "slicer_time"
146 let ssl_debug = var "ssl_debug"
147 let testing = var "testing"
148 let typer = var "typer"
149 let weblib_debug = var "weblib_debug"
150 (* testers *)
151 type debug_tester = debug_var -> bool
152 let default = function Some x -> x <> "0" | None -> false
153 let null d = not (default d)
154 let defined s = s <> None
155 let undefined s = s = None
156 let equals s = function
157 | None -> false
158 | Some s' -> String.compare s s' = 0
159 let toggle = equals "1"
160 let level cond = function
161 | None -> false
162 | Some s ->
163 begin
164 match Base.int_of_string_opt s with
165 | Some i -> cond i
166 | _ -> false
167 end
168 let islevel n = level (fun i -> i = n)
169 let maxlevel n = level (fun i -> i <= n)
170 let minlevel n = level (fun i -> i >= n)
171 let contains substr = function
172 | None -> false
173 | Some envvar -> Base.String.is_contained substr envvar
174 let cont cont var = cont var
175 let is_contained str = function
176 | None -> false
177 | Some envvar -> Base.String.is_contained envvar str
178
179 let flag str = function
180 | None -> false
181 | Some var -> List.mem str (Base.String.split (function ',' -> true | _ -> false) var)
182
183 let _ =
184 match check_vars with
185 | Some "0"
186 | None -> ()
187 | Some s ->
188 let strong = s = "s" in
189 let error = ref false in
190 let iter var_equal_value =
191 let var = Base.String.left_at var_equal_value '=' in
192 if (Base.String.is_prefix "MLSTATE_" var)
193 && not (Hashtbl.mem table var)
194 then
195 begin
196 Printf.eprintf "[!] DebugVariables(MLSTATE_CHECK_VARS) -- process environment contains an unknown var :\n\t%s\n%!" var ;
197 if strong then error := true
198 end in
199 Array.iter iter (Unix.environment ());
200 if !error then (Printf.eprintf "[!] MLSTATE_CHECK_VARS=s => exit 1\n%!"; exit 1)
Something went wrong with that request. Please try again.