Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 249 lines (199 sloc) 7.91 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 BPI = BslPluginInterface
21
22 (* CF BslPluginInterface *)
23 type implementation = string
24 type skey = string
25 type language = string
26 type path = string
27 type filename = string
28 type module_name = string
29 type uniq_id = string
30 type contents = string
31
32 (* essentially the same as a BslPluginInterface.plugin
33 without any functional values for safe marshaling *)
34 type t = {
35 basename : BPI.plugin_basename ;
36 self_module_name : module_name ;
37 uniq_id : uniq_id ;
38 conf : BslConf.conf ;
39 ml_runtime : module_name ;
40 depends : BPI.plugin_basename list ;
41
42 opa_code : ( filename * contents ) list ;
43 js_code : ( filename * contents * BslJsConf.conf ) list ;
44
45 ocaml_env : BPI.ocaml_env ;
46 javascript_env : BPI.javascript_env ;
47
48 row_register_primitive : BPI.register_primitive_arguments list ;
49 row_register_type : BPI.register_type_arguments list ;
50 }
51
52 type session = {
53 mutable s_basename : BPI.plugin_basename ;
54 mutable s_self_module_name : module_name ;
55 mutable s_uniq_id : uniq_id ;
56 mutable s_conf : BslConf.conf ;
57 mutable s_ml_runtime : module_name ;
58 mutable s_depends : BPI.plugin_basename list ;
59
60 mutable s_opa_code : ( filename * contents ) list ;
61 mutable s_js_code : ( filename * contents * BslJsConf.conf ) list ;
62
63 mutable s_ocaml_env : BPI.ocaml_env option ;
64 mutable s_javascript_env : BPI.javascript_env option ;
65
66 (* we can use a stack if we provide a Stack.fold function *)
67
68 s_register_primitive_arguments : BPI.register_primitive_arguments Queue.t ;
69 s_register_type_arguments : BPI.register_type_arguments Queue.t ;
70 }
71
72 let create () = {
73 s_basename = "" ;
74 s_self_module_name = "" ;
75 s_uniq_id = "" ;
76 s_conf = BslConf.default_conf ;
77 s_ml_runtime = "" ;
78 s_depends = [] ;
79
80 s_opa_code = [] ;
81 s_js_code = [] ;
82
83 s_ocaml_env = None ;
84 s_javascript_env = None ;
85
86 s_register_primitive_arguments = Queue.create () ;
87 s_register_type_arguments = Queue.create () ;
88 }
89
90 let list_of_queue q =
91 List.rev ( Queue.fold ( fun acc e -> e::acc ) [] q )
92
93 let finalize s = {
94 basename = s.s_basename ;
95 self_module_name = s.s_self_module_name ;
96 uniq_id = s.s_uniq_id ;
97 conf = s.s_conf ;
98 ml_runtime = s.s_ml_runtime ;
99 depends = s.s_depends ;
100
101 opa_code = s.s_opa_code ;
102 js_code = s.s_js_code ;
103
104 ocaml_env = Option.get s.s_ocaml_env ;
105 javascript_env = Option.get s.s_javascript_env ;
106
107 row_register_primitive = list_of_queue s.s_register_primitive_arguments ;
108 row_register_type = list_of_queue s.s_register_type_arguments ;
109 }
110
111 let unsafe_register_primitive s ~ks ~ty ~ips ?obj:_ () =
112 let rp =
113 { BPI.
114 rp_ks = ks ;
115 rp_ty = ty ;
116 rp_ips = ips ;
117 rp_obj = None ;
118 } in
119 Queue.add rp s.s_register_primitive_arguments
120
121 let unsafe_register_type s ~ks ~ty =
122 let rt =
123 { BPI.
124 rt_ks = ks ;
125 rt_ty = ty ;
126 } in
127 Queue.add rt s.s_register_type_arguments
128
129 let register_basename s b = s.s_basename <- b
130 let register_module_name s m = s.s_self_module_name <- m
131 let register_uniq_id s id = s.s_uniq_id <- id
132 let register_conf s conf = s.s_conf <- conf
133 let register_ml_runtime s n = s.s_ml_runtime <- n
134 let register_depends s d = s.s_depends <- d
135
136 let register_opa_code s c = s.s_opa_code <- c
137 let register_js_code s c = s.s_js_code <- c
138
139 let register_ocaml_env s env = s.s_ocaml_env <- Some env
140 let register_javascript_env s env = s.s_javascript_env <- Some env
141
142 let fail action filename message =
143 OManager.printf "Primitives librairy plugin:@ Cannot %s file @{<bright>%S@}@\n" action filename;
144 OManager.error "@[<2>@{<bright>Hint@}:@\n%s@]@\n" message
145
146 (* for simplicity, every time the compiler changes, the object files are invalid *)
147 let this_file_version = BuildInfos.opalang_git_sha
148
149 (* I/O : beware, read the ocaml doc, Marshal should be used with binary
150 channel for a Windows OS compatibility *)
151
152 let output oc_b t =
153 try
154 Printf.fprintf oc_b "%s\n" this_file_version ;
155 Marshal.to_channel oc_b t [] ;
156 flush oc_b
157 with
158 | Failure s
159 | Sys_error s ->
160 fail "output" "out_channel" s
161
162 let input ~filename ic_b =
163 try
164 let version = input_line ic_b in
165 if version <> this_file_version then
166 OManager.error (
167 "The file %S@\nwas compiled with a different version of the compiler.@\n"^^
168 "@[<2>@{<bright>Hint@}:@\nTry to recompile the plugin @{<bright>%s@}@\n@]"
169 ) filename (Filename.basename (Filename.dirname filename)) ;
170 Marshal.from_channel ic_b
171 with
172 | Sys_error s
173 | Failure s ->
174 fail "input" "in_channel" s
175
176 let output_file filename t =
177 try
178 let oc_b = open_out_bin filename in
179 output oc_b t ;
180 close_out oc_b
181 with
182 | Failure s
183 | Sys_error s ->
184 fail "output" filename s
185
186 let input_file filename =
187 try
188 let ic_b = open_in_bin filename in
189 let t = input ~filename ic_b in
190 close_in ic_b ;
191 t
192 with
193 | Sys_error s
194 | Failure s ->
195 fail "input" filename s
196
197 let plugin t =
198 let plugin_name = t.basename in
199 let uniq_id = t.uniq_id in
200 let dynloader ( get_register : BslPluginInterface.multi_loading_safe_get_dynloader_interface ) =
201 match get_register ~uniq_id ~plugin_name with
202 | None -> ()
203 | Some { BslPluginInterface.
204 register_primitive = register_primitive ;
205 register_type = register_type ;
206
207 } -> (
208
209 let iter_register_type rt =
210 BPI.apply_register_type register_type rt
211 in
212
213 let iter_register_primitive rp =
214 BPI.apply_register_primitive register_primitive rp
215 in
216
217 (* type before primitive using types *)
218 List.iter iter_register_type t.row_register_type ;
219 List.iter iter_register_primitive t.row_register_primitive ;
220
221 ()
222
223 )
224 in
225 { BslPluginInterface.
226
227 basename = t.basename ;
228 self_module_name = t.self_module_name ;
229 uniq_id = t.uniq_id ;
230 conf = t.conf ;
231 ml_runtime = t.ml_runtime ;
232 depends = t.depends ;
233
234 opa_code = t.opa_code ;
235 js_code = t.js_code ;
236
237 ocaml_env = t.ocaml_env ;
238 javascript_env = t.javascript_env ;
239
240 dynloader = dynloader ;
241 }
242
243 let loadfile_private file =
244 let t = input_file file in
245 let plugin = plugin t in
246 BslPluginTable.store plugin
247
248 let loadfile = loadfile_private
Something went wrong with that request. Please try again.