File: otags.ml

package info (click to toggle)
otags 4.05.1-1
  • links: PTS, VCS
  • area: main
  • in suites: buster, sid
  • size: 424 kB
  • ctags: 356
  • sloc: ml: 1,267; sh: 212; makefile: 194
file content (338 lines) | stat: -rw-r--r-- 10,006 bytes parent folder | download
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
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
(* Otags III
 * 
 * Hendrik Tews Copyright (C) 2010 - 2017
 * 
 * This file is part of "Otags III".
 * 
 * "Otags III" is free software: you can redistribute it and/or
 * modify it under the terms of the GNU General Public License as
 * published by the Free Software Foundation, either version 3 of the
 * License, or (at your option) any later version.
 * 
 * "Otags III" is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
 * General Public License in file COPYING in this or one of the parent
 * directories for more details.
 * 
 * You should have received a copy of the GNU General Public License
 * along with "Otags III". If not, see
 * <http://www.gnu.org/licenses/>.
 * 
 * main module with main function
 * 
 *)

open Conf
open Otags_misc
open Global
open Otags_types
open Source_channel
open Fix_location

module U = Unix
module UL = Unix.LargeFile


let parser_error_message loc msg =
  if not !silent then
    begin
      Location.print_error Format.err_formatter loc;
      Format.fprintf Format.err_formatter " %s@." msg;
    end


let parse_file_internally unit file =
  if !verbose then
    Printf.eprintf "Parse %s internally as %s with OCaml standard parser\n" 
      file 
      (string_of_unit_type unit);
  let start_loc = Location.in_file file in
  let ic = 
    try get_channel ~primary_file:true start_loc 
    with
      | Otags_parsing_error(_loc, msg) ->
         (* Don't use _loc - it's the meaningless start_loc *)
	if not !silent then 
	  prerr_endline msg;
	exit_status := 1;
	raise Skip_entry	
  in
  let lex_buf = Lexing.from_channel ic in
  Location.init lex_buf file;
  let parse_fun = match unit with
      | Signature -> fun lex -> Sig_ast(Parse.interface lex)
      | Structure -> fun lex -> Struct_ast(Parse.implementation lex)
  in
  (try parse_fun lex_buf
   with
     | (Syntaxerr.Error _ | Lexer.Error _) as exc ->
	match Location.error_of_exn exc with
	  | Some error ->
             if not !silent then begin
	         Location.report_error Format.err_formatter error;
	         Format.pp_print_newline Format.err_formatter ();
               end;
	     exit_status := 1;
	     Sig_ast []
	  | None ->
	     prerr_endline "Location.error_of_exn failed";
	     raise exc
  )


let process_file tagfun unit file =
  (* 
   * let (parse_internal, parser_list) =
   *   try parser_hint file 
   *   with Not_found -> (!use_internal_parsers, !user_parser_list)
   * in
   * if parser_list = [] then begin
   *   if not !silent then 
   *     Printf.eprintf "Parser list empty for %s\n%!" file;
   *   exit 2
   * end;
   *)
  reset_locations ();
  let comp_unit = parse_file_internally unit file in
  (* prepare_line_directives (); *)
  tagfun.start_unit file;
  (try
     Tags.generate_tags tagfun.write_tag comp_unit
   with
     | Otags_parsing_error(loc, msg) ->
       parser_error_message loc msg;
       exit_status := 1;
  );
  tagfun.finish_unit();
  (* 
   * Printf.printf "process %s in %.2f ms\n"
   *   file
   *   ((Unix.gettimeofday() -. pa_start) *. 1000.0);
   *)
  ()

(* process file or directory f, generating output for tags_out_ref.
 * If subdir_ref_option <> None then process_entry has been called
 *      recursively from process_directory. In this case it must append 
 *      detected directories to the reference in subdir_ref_option. These 
 *      directories will be processed by process_directory later.
 * If subdir_ref_option = None then process_entry has been called
 *      from somewhere higher up. In this case it must invoke 
 *      process_directory 
 *      when it detects an directory (and option -r was present).
 *)
let rec process_entry tagfun f subdir_ref_option =
  if Filename.check_suffix f ".ml"
  then process_file tagfun Structure f
  else if Filename.check_suffix f ".mli"
  then process_file tagfun Signature f
  else if !recurse_subdirectories && is_directory f (subdir_ref_option = None)
  then 
    match subdir_ref_option with
      | None -> process_directory tagfun f
      | Some r -> 
	(* process_directory tagfun tags_out f *)
	r := f :: !r
  else if ((subdir_ref_option = None) && (not !silent)) || !verbose
  then begin
    Printf.eprintf
      "File \"%s\"\nSkip file because extension is not recognized\n"
      f;
    exit_status := 1;
  end
  else ()

and process_directory tagfun subdir =
  if !verbose then
    Printf.eprintf "Descend into directory %s\n" subdir;
  let subdirs = ref [] in
  let subdir_ref_option = Some subdirs in
  let handle = U.opendir subdir in
  let subdir_concat =
    if subdir = Filename.current_dir_name then "" else subdir in
  let not_finished = ref true in
  while !not_finished do
    match 
      try Some(U.readdir handle) with End_of_file -> None
    with
      | Some current_or_parent 
	  when current_or_parent = Filename.current_dir_name
	  || current_or_parent = Filename.parent_dir_name
	    -> ()
      | Some entry ->
	(try
	   process_entry tagfun
	     (Filename.concat subdir_concat entry)
	     subdir_ref_option	
	 with
	   | Skip_entry -> ()
	   | e -> 
	     if not !silent then
	       Printf.eprintf "Escaping exception during processing %s\n"
		 (Filename.concat subdir entry);
	     U.closedir handle;
	     raise e	
	)
      | None ->
	not_finished := false
  done;
  U.closedir handle;
  List.iter (process_directory tagfun) !subdirs



(* Print version and exit *)
let print_version () =
  Printf.printf "otags version %s for ocaml %s.x compiled with ocaml %s\n"
    otags_version ocaml_version Sys.ocaml_version;
  exit 0
      
  
type otags_actions =
  | Process_file of string * unit_type option


let action_list = ref []

let queue_action a () = 
  action_list := a :: !action_list

let queue_interface i = queue_action(Process_file(i, Some Signature))()

let queue_implementation i = queue_action(Process_file(i, Some Structure))()


let anon_fun s = queue_action(Process_file(s, None)) ()

let arguments = Arg.align [
  ("-r", Arg.Set recurse_subdirectories,
   " descend recursively into directories");
  ("-o", Arg.String (fun f -> tags_file_name := Some f),
   "file output file [default TAGS for Emacs and tags for vi]");
  ("-a", Arg.Set append_to_tags_file,
   " append to an existing TAGS file");
  ("-vi", Arg.Clear emacs_mode,
   " generate tags for vi");
  ("-intf", Arg.String queue_interface,
   "file tag file as an interface");
  ("-impl", Arg.String queue_implementation,
   "file tag file as an implementation");
  ("-add-path", Arg.Set_string relative_file_prefix,
   "path prepend path to relative file names in tags file");
  ("-version", Arg.Unit print_version,
   " print version and exit");
  ("-v", Arg.Unit(fun () -> verbose := true; silent := false),
   " be more verbose");
  ("-q", Arg.Unit(fun () -> verbose := false; silent := true),
   " be quiet");
]


let usage_message =
  Printf.sprintf 
    "Usage %s [arguments...]\n\
     Creates tags files for Emacs or vi[m] from OCaml sources.\n\
     Options and file arguments can be mixed. Order matters for many options.\n\
     The options -r, -o, -a, -vi, -I, -parser-hints, -add-path, -v and -q\n\
     have a global effect regardless of their position. The options -pc,\n\
     -pa, -pr, -pp, -extern and -intern affect only file arguments which \n\
     follow them.\n\n\
     Recognized options:"
    Sys.argv.(0)


let run_action tagfun = function
  | Process_file(file, unit_option) -> 
    try
      match unit_option with
	| None -> process_entry tagfun file None
	| Some unit -> process_file tagfun unit file
    with
      | Skip_entry -> ()
      | e -> 
	if not !silent then
	  Printf.eprintf "Escaping exception during processing %s\n" file;
	raise e


let main () =
  Warnings.parse_options false "-a";
  Warnings.parse_options true "-a";
  Arg.parse arguments anon_fun usage_message;
  if !append_to_tags_file && !emacs_mode = false then begin
    if not !silent then
      prerr_endline 
	"Appending to tags files is only supported for emacs TAGS files!";
    exit 2;
  end;
  let output_name = match !tags_file_name with
    | Some f -> f
    | None -> match !emacs_mode with
	| true -> "TAGS"
	| false -> "tags"
  in
  let tags_oc = 
    if output_name = "-"
    then stdout
    else
      open_out_gen 
	(if !append_to_tags_file 
	 then [Open_append; Open_creat; Open_text]
	 else [Open_wronly; Open_trunc; Open_creat; Open_text])
	0o666 output_name
  in
  let tagfun = 
    if !emacs_mode 
    then Emacs.init tags_oc
    else Vi.init tags_oc
  in
  List.iter 
    (run_action tagfun)
    (List.rev !action_list);
  tagfun.finish_tagging();
  close_out tags_oc


let main_ex () =
  try
    if Array.length Sys.argv >= 2 && Sys.argv.(1) = "-v" then
      Printexc.record_backtrace true;
    main ();
    exit !exit_status
  with
    | e -> 
      let backtrace = if !verbose then Printexc.get_backtrace() else "" in
      prerr_string "\nFatal error: escaping exception ";
      prerr_endline (Printexc.to_string e);
      (match e with
	(* XXX ??
         * | Loc.Exc_located(loc, oe) ->
	 *   prerr_endline "Breaking apart the located exception gives:";
	 *   prerr_endline (Loc.to_string loc);
	 *   prerr_endline (Printexc.to_string oe);
	 *   prerr_endline "Try ErrorHandler on the located exception:";
	 *   prerr_endline (Camlp4.ErrorHandler.to_string oe);
         *)
	| U.Unix_error(error, _func, _info) ->
	  Printf.eprintf "%s\n" (U.error_message error)      
	| _ -> ()
      );
      prerr_endline "";
      if Printexc.backtrace_status() then begin
	prerr_string backtrace;
	prerr_endline 
	  "\n\
           Please send the command line, the input files and the output\n\
           above as bug report to otags@askra.de";
      end
      else 
	prerr_endline 
	  "Please rerun otags with -v as *first* option to get a backtrace\n\
           and send the command line, the input files and the backtrace\n\
           as bug report to otags@askra.de";
      exit 3

;;

main_ex()