File: main.ml

package info (click to toggle)
headache 1.03-27
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 556 kB
  • ctags: 190
  • sloc: ml: 621; xml: 218; makefile: 70
file content (242 lines) | stat: -rw-r--r-- 6,580 bytes parent folder | download | duplicates (5)
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
(**************************************************************************)
(*                                                                        *)
(*                               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/  *)
(*                                                                        *)
(**************************************************************************)

(* $Id: main.ml,v 1.2 2003/11/13 16:08:44 simonet Exp $ *)

open Printf
open Config_builtin



(***************************************************************************)
(** {2 Configuration files} *)

let generators : (Str.regexp * Model.generator) list ref = ref []

let skips : (Str.regexp * Skip.regexp_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 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 (UTF8.length line) w)  
      0
      header
  in
    header, header_width

(***************************************************************************)
(** {2 Processing files} *)

external random_seed: unit -> int = "sys_random_seed"

let temp_file_counter = ref 0
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 copy ic oc =
  let len = 256 in
  let buf = String.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 skip_lst ic oc in
    let line = generator.Model.remove ic in
    let () = Skip.skip skip_lst ic 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 skip_lst ic oc in
    let line = generator.Model.remove ic in
    let () = Skip.skip skip_lst ic oc in
    output_string oc line;
    copy ic oc
  ) filename





(***************************************************************************)
(** {2 Main loop} *)

type action =
    Create of string list * int
  | Remove


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
  in

  Arg.parse [

  "-h",
  Arg.String (fun s -> let (header, header_width) = (read_headerfile s) in action := Create (header, header_width)),
  "<file>  Create headers with text from <file>";

  "-c",
  Arg.String read_configfile,
  "<file>  Read the given configuration file";

  "-r",
  Arg.Unit (fun () -> action := Remove),
  "        Remove headers in files";
  
  ]
  
    anonymous

    (sprintf
       "%s, version %s\n\
       Usage: %s <arguments>\nArguments are:\n  \
       <file>     Process file <file>"
    Info.name Info.version Info.name);

  
  ()



let () =
  try
    main ()
  with
    Sys_error msg ->
      eprintf "%s: %s\n" Sys.argv.(0) msg