-
Notifications
You must be signed in to change notification settings - Fork 6
/
Copy pathheadache_tool.ml
266 lines (211 loc) · 7.1 KB
/
headache_tool.ml
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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
(**************************************************************************)
(* *)
(* Headache *)
(* *)
(* Vincent Simonet, Projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2002 *)
(* Institut National de Recherche en Informatique et en Automatique. *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Library General Public License. *)
(* *)
(* Vincent.Simonet@inria.fr http://cristal.inria.fr/~simonet/ *)
(* *)
(**************************************************************************)
open Printf
open Config_builtin
open Headache
(***************************************************************************)
(** {2 Command-line options} *)
let verbose = ref false
(***************************************************************************)
(** {2 Configuration files} *)
let generators : (Str.regexp * Model.generator) list ref = ref []
let skips : (Str.regexp * Skip.param_skip) list ref = ref []
let read_configfile filename =
let ic = open_in filename in
let lexbuf = Lexing.from_channel ic in
try
let (config_generators, config_skips) =
(Config_parse.configfile Config_lex.token lexbuf)
in
skips := config_skips @ !skips;
generators := config_generators @ !generators;
close_in ic
with
Config.Error (msg, loc1, loc2) ->
eprintf "%s: Configuration file %s, error at characters %d-%d:\n%s\n"
Sys.argv.(0)
filename loc1 loc2 msg;
exit 2
| Parsing.Parse_error ->
eprintf "%s: Configuration file %s, syntax error at characters %d-%d:\n"
Sys.argv.(0)
filename (Lexing.lexeme_start lexbuf) (Lexing.lexeme_end lexbuf)
let find_generator filename =
let basename = Filename.basename filename in
try
let _, generator =
List.find (function regexp, _ ->
Str.string_match regexp basename 0
) (! generators)
in
generator
with
Not_found ->
eprintf "%s: No generator found for file %s\n"
Sys.argv.(0) filename;
exit 2
let find_skips filename =
List.filter
(fun (rg_filename, _) -> Str.string_match rg_filename filename 0)
!skips
(***************************************************************************)
(** {2 Builtin config} *)
let _ =
try
generators :=
List.map (function regexp, model, parameters ->
(Str.regexp (sprintf "^%s$" regexp), (Model.find model) parameters)
) builtin_config
with
Not_found ->
eprintf "%s: Error in builtin configuration\n" Sys.argv.(0);
exit 2
(***************************************************************************)
(** {2 Header files} *)
let read_headerfile filename =
let ic = open_in filename in
let rec loop () =
try
let line = input_line ic in
line :: loop ()
with
End_of_file -> close_in ic; []
in
let header =
loop ()
in
let header_width =
List.fold_left
(fun w line -> max (Model.string_length line) w)
0
header
in
header, header_width
(***************************************************************************)
(** {2 Processing files} *)
let prng = Random.State.make_self_init ();;
let temp_file_name directory prefix suffix =
let rnd = (Random.State.bits prng) land 0xFFFFFF in
Filename.concat directory (Printf.sprintf "%s%06x%s" prefix rnd suffix)
;;
let open_temp_file ?(mode = [Open_text]) directory prefix suffix =
let rec try_name counter =
if counter >= 1000 then
invalid_arg "Filename.open_temp_file: temp dir nonexistent or full";
let name = temp_file_name directory prefix suffix in
try
(name,
open_out_gen (Open_wronly::Open_creat::Open_excl::mode) 0o600 name)
with Sys_error _ ->
try_name (counter + 1)
in try_name 0
let pipe_file f filename =
let directory = Filename.dirname filename in
let ic = open_in filename in
let tempname, oc = open_temp_file directory "header" "tmp" in
f ic oc;
close_in ic;
close_out oc;
Unix.chmod tempname (Unix.stat filename).Unix.st_perm;
Sys.remove filename;
Sys.rename tempname filename
let rd_pipe_file f filename =
let ic = open_in filename in
f ic;
close_in ic
let copy ic oc =
let len = 256 in
let buf = Bytes.create len in
let rec loop () =
let i = input ic buf 0 len in
if i > 0 then begin
output oc buf 0 i;
loop ()
end
in
loop ()
let create_header header header_width filename =
let generator = find_generator filename in
let skip_lst = find_skips filename in
pipe_file (fun ic oc ->
let () = Skip.skip ~verbose:!verbose skip_lst ic (Some oc) in
let line = generator.Model.remove ic in
let () = Skip.skip ~verbose:!verbose skip_lst ic (Some oc) in
generator.Model.create oc header header_width;
output_string oc line;
copy ic oc
) filename
let remove_header filename =
let generator = find_generator filename in
let skip_lst = find_skips filename in
pipe_file (fun ic oc ->
let () = Skip.skip ~verbose:!verbose skip_lst ic (Some oc) in
let line = generator.Model.remove ic in
let () = Skip.skip ~verbose:!verbose skip_lst ic (Some oc) in
output_string oc line;
copy ic oc
) filename
let extract_header filename =
let generator = find_generator filename in
let skip_lst = find_skips filename in
rd_pipe_file (fun ic ->
let () = Skip.skip ~verbose:!verbose skip_lst ic None in
generator.Model.extract ic
) filename
(***************************************************************************)
(** {2 Main loop} *)
type action =
Create of string list * int
| Remove
| Extract
let main () =
let action = ref (Create ([], 0)) in
let anonymous filename =
match !action with
Create (header, header_width) -> create_header header header_width filename
| Remove -> remove_header filename
| Extract -> extract_header filename
in
Arg.parse [
"-h",
Arg.String (fun s -> let (header, header_width) = (read_headerfile s) in action := Create (header, header_width)),
"<header-file> Create headers with text from the header file";
"-c",
Arg.String read_configfile,
"<config-file> Read the given configuration file";
"-r",
Arg.Unit (fun () -> action := Remove),
" Remove headers in files";
"-e",
Arg.Unit (fun () -> action := Extract),
" Extract headers from files";
"-v",
Arg.Set verbose,
" Enable verbose output";
]
anonymous
(sprintf
"%s, version %s\n\
Usage: %s <options> <files>\n \
Process headers of given files\n\
Optional arguments are:"
Info.name Info.version Info.name);
()
let () =
try
main ()
with
Sys_error msg ->
eprintf "%s: %s\n" Sys.argv.(0) msg