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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
(** *)
let hack_cmxs = ref false;;
let create_cmxs src =
let dst = Filename.temp_file ("stog-"^(Filename.basename src)) ".cmxs" in
let options =
match Filename.basename (Filename.chop_extension src) with
"ulexing" | "cryptokit" | "pcre" -> " -linkall"
| _ -> ""
in
let includes = "-I "^(Filename.quote (Filename.dirname src)) in
let com = "ocamlopt -shared -o "^(Filename.quote dst)^" "^includes^options^" "^(Filename.quote src) in
match Sys.command com with
0 -> dst
| _ -> failwith ("Command failed: "^com)
;;
let _ = Dynlink.allow_unsafe_modules true;;
let load_file file =
let name = Filename.chop_extension (Filename.basename file) in
match name with
| "dynlink"
| "ocamlcommon" ->
Log.info (fun m -> m "Ignoring loading of file %s" file);
| _ ->
Log.info (fun m -> m "Loading file %s" file);
try Dynlink.loadfile file
with Dynlink.Error e ->
match e with
| Dynlink.Module_already_loaded _ -> ()
| _ when name = "threads" ->
Log.info (fun m -> m "Ignoring: %s" (Dynlink.error_message e))
| _ -> failwith (Dynlink.error_message e)
let loaded_files = ref [];;
let hack_load_file file =
match Filename.chop_extension (Filename.basename file) with
"cryptokit" | "pcre" ->
let cmxs = create_cmxs ((Filename.chop_extension file)^".cmxa") in
load_file cmxs;
Sys.remove cmxs
| _ ->
match Filename.check_suffix file ".cmxa" ||
Filename.check_suffix file ".cmx"
with
false -> load_file file
| true ->
let cmxs = (Filename.chop_extension file)^".cmxs" in
if Sys.file_exists cmxs then
load_file cmxs
else
(
let cmxs = create_cmxs file in
load_file cmxs ;
)
;;
let check_file_has_extension file =
try ignore(Filename.chop_extension file)
with _ ->
failwith ("Filename "^file^" has no extension.");
;;
let check_files_have_extension files =
List.iter
(fun file ->
try check_file_has_extension file
with Failure msg ->
let msg = msg^"\nDid you mean --package ?" in
failwith msg
)
files
let load_files =
let load_file file =
check_file_has_extension file ;
if !hack_cmxs then
hack_load_file file
else
load_file (Dynlink.adapt_filename file)
in
let f file =
if List.mem file !loaded_files then
Log.info (fun m -> m "Not loading already loaded file %s" file)
else
begin
load_file file;
loaded_files := file :: !loaded_files;
end
in
List.iter f
;;
let files_of_packages kind pkg_names =
let file = Filename.temp_file "stog" ".txt" in
let com =
Printf.sprintf "ocamlfind query %s -predicates plugin,%s -r -format %%d/%%a > %s"
(String.concat " " (List.map Filename.quote pkg_names))
(match kind with `Byte -> "byte" | `Native -> "native")
(Filename.quote file)
in
match Sys.command com with
0 ->
let s =Stog_base.Misc.string_of_file file in
Sys.remove file;
Stog_base.Misc.split_string s ['\n']
| n ->
let msg = Printf.sprintf "Command failed (%d): %s" n com in
failwith msg
;;
let load_packages_comma pkg_names =
let kind = if Dynlink.is_native then `Native else `Byte in
let pkg_names =Stog_base.Misc.split_string pkg_names [','] in
let files = files_of_packages kind pkg_names in
load_files files
;;
let load_packages packages =
List.iter load_packages_comma packages
;;