~ubuntu-branches/ubuntu/jaunty/cmigrep/jaunty : revision 1

1

(* A utility to gather information from caml compiled interface files

2

3

4

5

This library is free software; you can redistribute it and/or

6

modify it under the terms of the GNU General Public License as

7

published by the Free Software Foundation; either version 2.1 of

8

the License, or (at your option) any later version.

9

10

This library is distributed in the hope that it will be useful,

11

but WITHOUT ANY WARRANTY; without even the implied warranty of

12

MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU

13

Lesser General Public License for more details.

14

15

You should have received a copy of the GNU General Public License

16

along with this library; if not, write to the Free Software

17

Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307

18

USA

19

*)

20

21

open Types

22

23

exception Break

24

25

module Ordpath = struct

26

type t = string

27

let trailing_slash = Pcre.regexp "/\\s*$|\\\\\\s*$"

28

let compare p1 p2 =

29

let p1' = Pcre.replace ~rex:trailing_slash ~templ:"" p1 in

30

let p2' = Pcre.replace ~rex:trailing_slash ~templ:"" p2 in

31

String.compare p1' p2'

32

end

33

module Strset = Set.Make(Ordpath)

34

35

(* the standard library should not be so deficient *)

36

module My_list = struct

37

include List

38

39

let filter_map f l =

40

List.fold_left

41

(fun acc item ->

42

match f item with

43

| Some x -> x :: acc

44

| None -> acc)

45

[]

46

l

47

48

let find_map f l =

49

let res = ref None in

50

try

51

List.iter

52

(fun x ->

53

match f x with

54

| None -> ()

55

| Some y -> res := Some y; raise Break)

56

l;

57

raise Not_found

58

with Break ->

59

begin match !res with

60

| Some y -> y

61

| None -> raise Break

62

end

63

64

let map f l =

65

let r = rev_map f l in

66

rev r

67

end

68

69

module My_unix = struct

70

include Unix

71

72

let fold_path ~f ~init path =

73

let dir = Unix.opendir path in

74

let acc = ref init in

75

try

76

while true do

77

let file = Unix.readdir dir in

78

acc := f file !acc

79

done;

80

!acc

81

with

82

| End_of_file -> Unix.closedir dir; !acc

83

| exn -> Unix.closedir dir; raise exn

84

end

85

86

module List = My_list

87

module Unix = My_unix

88

89

type mode =

90

| Find_type of Pcre.regexp

91

| Find_constructor of Pcre.regexp

92

| Find_polymorphic_variant of Pcre.regexp

93

| Find_record_label of Pcre.regexp

94

| Find_value of Pcre.regexp

95

| Find_exception of Pcre.regexp

96

| Find_module

97

| Find_class of Pcre.regexp

98

| Find_all of Pcre.regexp

99

100

type module_expression =

101

| Exact of string

102

| Begins_with of string * Pcre.regexp

103

| Ends_with of string * Pcre.regexp

104

| Begins_and_ends of string * Pcre.regexp

105

| Contains of string * Pcre.regexp

106

| Any

107

108

type module_tree =

109

| Leaf of string * signature

110

| Node of string * signature * module_tree list

111

112

type args = {

113

mode: mode;

114

path: Strset.t;

115

context: module_expression list list; (* open modules *)

116

modname: module_expression list list;

117

}

118

119

let module_expression_to_string e =

120

match e with

121

| Exact m -> m

122

| Begins_with (s, _)

123

| Ends_with (s, _)

124

| Begins_and_ends (s, _)

125

| Contains (s, _) -> s

126

| Any -> "*"

127

128

(* ModA,ModB,Foo*.Make *)

129

let comma = Pcre.regexp "\\s*,\\s*"

130

let dot = Pcre.regexp "\\."

131

let capname = Pcre.regexp "^[A-Z][A-Za-z_'0-9]*$"

132

let starend = Pcre.regexp "^[A-Z][A-Za-z0-9_']*\\*$"

133

let starbegin = Pcre.regexp "^\\*[A-Za-z0-9_']+$"

134

let starboth = Pcre.regexp "^\\*[A-Za-z0-9_']+\\*$"

135

let starmiddle = Pcre.regexp "^([A-Z][A-Za-z0-9_']*)\\*([A-Za-z0-9_']+)$"

136

let star = Pcre.regexp "\\*"

137

let parse_module_expression exp =

138

List.map

139

(fun token ->

140

let token_no_star = Pcre.replace ~rex:star ~templ:"" token in

141

if token = "*" then

142

Any

143

else if Pcre.pmatch ~rex:capname token then

144

Exact token

145

else if Pcre.pmatch ~rex:starboth token then

146

Contains (token, Pcre.regexp ("^.*" ^ token_no_star ^ ".*$"))

147

else if Pcre.pmatch ~rex:starmiddle token then

148

begin match Pcre.extract ~rex:starmiddle token with

149

| [|_whole; begins; ends |] ->

150

let rex = Pcre.regexp (Printf.sprintf "^%s.*%s$" begins ends) in

151

Begins_and_ends (token, rex)

152

| _ -> failwith "invalid begins and ends with match"

153

end

154

else if Pcre.pmatch ~rex:starbegin token then

155

Ends_with (token, Pcre.regexp (Printf.sprintf "%s$" token_no_star))

156

else if Pcre.pmatch ~rex:starend token then

157

Begins_with (token, Pcre.regexp (Printf.sprintf "^%s" token_no_star))

158

else

159

failwith "invalid module expression")

160

(Pcre.split ~rex:dot exp)

161

162

let parse_args () =

163

let module Parse = struct

164

open Arg

165

let mode = ref None

166

let path = ref (Strset.add "." (Strset.singleton Config.standard_library))

167

let context = ref ["Pervasives"]

168

let modname = ref []

169

170

let set_mode m =

171

match !mode with

172

| None -> mode := Some m;

173

| Some _ -> raise (Invalid_argument "the mode is already set")

174

175

let add_packages p =

176

Findlib.init ();

177

let packages = Pcre.split ~rex:comma p in

178

List.iter

179

(fun package ->

180

let dir = Findlib.package_directory package in

181

path := Strset.add dir !path)

182

packages

183

184

let add_opens s = context := Pcre.split ~rex:comma s

185

186

let args =

187

Arg.align

188

[("-t", String (fun s -> set_mode (Find_type (Pcre.regexp s))),

189

" (regexp) print types with matching names");

190

("-r", String (fun s -> set_mode (Find_record_label (Pcre.regexp s))),

191

" (regexp) print record field labels with matching names");

192

("-c", String (fun s -> set_mode (Find_constructor (Pcre.regexp s))),

193

" (regexp) print constructors with matching names");

194

("-p", String (fun s ->

195

set_mode

196

(Find_polymorphic_variant

197

(Pcre.regexp s))),

198

" (regexp) print polymorphic variants with matching names");

199

("-m", Unit (fun () -> set_mode Find_module),

200

" (regexp) print all matching module names in the path");

201

("-v", String (fun s -> set_mode (Find_value (Pcre.regexp s))),

202

" (regexp) print values with matching names");

203

("-e", String (fun s -> set_mode (Find_exception (Pcre.regexp s))),

204

" (regexp) print exceptions with matching constructors");

205

("-o", String (fun s -> set_mode (Find_class (Pcre.regexp s))),

206

" (regexp) print all classes with matching names");

207

("-a", String (fun s -> set_mode (Find_all (Pcre.regexp s))),

208

" (regexp) print all names which match the given expression");

209

("-I", String (fun s -> path := Strset.add s !path),

210

" (directory) add additional directory to the search path");

211

("-package", String (fun s -> add_packages s),

212

" (packages) comma seperated list of findlib packages to search");

213

("-open", String (fun s -> add_opens s),

214

" (modules) comma seperated list of open modules (in order!)")]

215

let usage =

216

Printf.sprintf

217

("%s: <args> <module-expr> \n" ^^

218

"extract information from caml compiled interface files\n" ^^

219

" <module-expr> can be an exact module name, " ^^

220

" or a shell wildcard. Multiple modules can be specified " ^^

221

"E.G. \"ModA ModB Foo*.Make\" means to search ModA, ModB, and " ^^

222

"any submodule Make of a module that starts with Foo.")

223

Sys.argv.(0)

224

225

let parse () =

226

Arg.parse args

227

(fun anon -> modname := (parse_module_expression anon) :: !modname)

228

usage

229

230

let error msg =

231

prerr_endline msg;

232

Arg.usage args usage;

233

exit 1

234

end

235

in

236

Parse.parse ();

237

let mode =

238

match !Parse.mode with

239

| Some m -> m

240

| None -> Parse.error "you must specify a search mode"

241

in

242

{mode = mode;

243

path =

244

if Strset.is_empty !Parse.path then Parse.error "you must specify a search path"

245

else !Parse.path;

246

context =

247

List.map

248

(fun m -> List.map (fun m -> Exact m) (Pcre.split ~rex:dot m))

249

!Parse.context;

250

modname =

251

(match !Parse.modname with

252

| [] ->

253

if !Parse.context = [] then

254

Parse.error "you must specify a module expression, or a list of open modules"

255

else

256

[]

257

| name -> name)}

258

259

let match_ident exp id = Pcre.pmatch ~rex:exp (Ident.name id)

260

261

let whsp = Pcre.regexp ~study:true "\\s+|$"

262

263

let print_type print_path path s exp =

264

List.iter

265

(function

266

| Tsig_type (id, type_decl, rec_status) ->

267

if match_ident exp id then begin

268

Printtyp.type_declaration id Format.std_formatter type_decl;

269

if print_path then

270

Format.print_string (Printf.sprintf " (* %s *)" path);

271

Format.print_newline ()

272

end

273

| _ -> ())

274

s

275

276

let print_constructor print_path path s exp =

277

let type_expr_to_string exp =

278

Printtyp.type_expr Format.str_formatter exp;

279

Format.flush_str_formatter ();

280

in

281

List.iter

282

(function

283

| Tsig_type (id, type_decl, _rec_status) ->

284

begin match type_decl.type_kind with

285

| Type_variant (constructors, _private) ->

286

List.iter

287

(fun (name, type_exprs) ->

288

if Pcre.pmatch ~rex:exp name then begin

289

Format.print_string name;

290

if type_exprs <> [] then begin

291

Format.print_string " of ";

292

Format.print_string

293

(String.concat " * "

294

(List.map

295

(fun e -> type_expr_to_string e)

296

type_exprs))

297

end;

298

Format.print_string " (* ";

299

if print_path then

300

Format.print_string (path ^ ".");

301

Format.print_string (Ident.name id);

302

Format.print_string " *)";

303

Format.print_newline ()

304

end)

305

constructors

306

| _ -> ()

307

end

308

| _ -> ())

309

s

310

311

let print_polymorphic_variant print_path path s expr =

312

let print_if_polymorphic_variant id type_decl =

313

begin match type_decl.type_manifest with

314

| None -> ()

315

| Some {desc = type_descr} ->

316

begin match type_descr with

317

| Tvariant variant_descr ->

318

List.iter

319

(fun (name, param) ->

320

let src_name = "`" ^ name in

321

if Pcre.pmatch ~rex:expr src_name then begin

322

Format.print_string src_name;

323

begin match param with

324

| Rpresent None -> ()

325

| Rabsent -> ()

326

| Reither _ -> () (* this can't happen in a type *)

327

| Rpresent (Some type_expr) ->

328

Format.print_string " of ";

329

Printtyp.type_expr

330

Format.str_formatter type_expr;

331

let s =

332

Pcre.replace ~rex:whsp ~templ:" "

333

(Format.flush_str_formatter ())

334

in

335

Format.print_string s;

336

end;

337

Format.print_string

338

(Printf.sprintf " (* %s%s *)"

339

(if print_path then (path ^ ".") else "")

340

(Ident.name id));

341

Format.print_newline ()

342

end)

343

variant_descr.row_fields

344

| _ -> ()

345

end

346

end

347

in

348

List.iter

349

(function

350

| Tsig_type (id, type_decl, _rec_status) ->

351

begin match type_decl.type_kind with

352

| Type_abstract -> print_if_polymorphic_variant id type_decl

353

| _ -> ()

354

end

355

| _ -> ())

356

s

357

358

let print_record_label print_path path s exp =

359

List.iter

360

(function

361

| Tsig_type (id, type_decl, _rec_status) ->

362

begin match type_decl.type_kind with

363

| Type_record (labels, _, _) ->

364

List.iter

365

(fun (name, mutable_flag, type_expr) ->

366

if Pcre.pmatch ~rex:exp name then begin

367

begin match mutable_flag with

368

| Asttypes.Mutable -> Format.print_string "mutable "

369

| Asttypes.Immutable -> ()

370

end;

371

Format.print_string name;

372

Format.print_string ": ";

373

Printtyp.type_expr Format.std_formatter type_expr;

374

Format.print_string " (* ";

375

if print_path then

376

Format.print_string (path ^ ".");

377

Format.print_string (Ident.name id);

378

Format.print_string " *)";

379

Format.print_newline ()

380

end)

381

labels

382

| _ -> ()

383

end

384

| _ -> ())

385

s

386

387

let print_value print_path path s exp =

388

List.iter

389

(function

390

| Tsig_value (id, desc) ->

391

if match_ident exp id then begin

392

Printtyp.value_description id Format.str_formatter desc;

393

let s =

394

Pcre.replace ~rex:whsp ~templ:" "

395

(Format.flush_str_formatter ())

396

in

397

if print_path then

398

print_endline (s ^ (Printf.sprintf " (* %s *)" path))

399

else

400

print_endline s

401

end

402

| _ -> ())

403

s

404

405

let print_class print_path path s exp =

406

List.iter

407

(function

408

| Tsig_class (id, cd, _) when match_ident exp id ->

409

Printtyp.class_declaration id Format.std_formatter cd;

410

if print_path then

411

Format.print_string (Printf.sprintf " (* %s *)" path);

412

Format.print_newline ()

413

| Tsig_cltype (id, ct, _) when match_ident exp id ->

414

Printtyp.cltype_declaration id Format.std_formatter ct;

415

if print_path then

416

Format.print_string (Printf.sprintf " (* %s *)" path);

417

Format.print_newline ()

418

| _ -> ())

419

s

420

421

let print_all print_path path s exp =

422

let new_s =

423

List.filter

424

(function

425

| Tsig_value (id, _)

426

| Tsig_type (id, _, _)

427

| Tsig_exception (id, _)

428

| Tsig_module (id, _, _)

429

| Tsig_modtype (id, _)

430

| Tsig_class (id, _, _)

431

| Tsig_cltype (id, _, _) ->

432

match_ident exp id)

433

s

434

in

435

Printtyp.signature Format.std_formatter new_s;

436

if print_path then

437

Format.print_string (Printf.sprintf " (* %s *)" path);

438

Format.print_newline ()

439

440

let print_exception print_path path s exp =

441

List.iter

442

(function

443

| Tsig_exception (id, exn) ->

444

if match_ident exp id then begin

445

Printtyp.exception_declaration id Format.std_formatter exn;

446

if print_path then

447

Format.print_string (Printf.sprintf " (* %s *)" path);

448

Format.print_newline ()

449

end

450

| _ -> ())

451

s

452

453

let warn_env_error e =

454

Env.report_error Format.str_formatter e;

455

let e = Format.flush_str_formatter () in

456

Printf.eprintf "%s\n%!" e

457

458

let match_mod_expr expr mod_name =

459

match expr with

460

| Exact name -> mod_name = name

461

| Begins_with (_, rex)

462

| Ends_with (_, rex)

463

| Begins_and_ends (_, rex)

464

| Contains (_, rex) -> Pcre.pmatch ~rex mod_name

465

| Any -> true

466

467

let cmi_file = Pcre.regexp "\\.cmi$"

468

let modname_of_cmi f =

469

String.capitalize (Pcre.replace ~templ:"" ~rex:cmi_file f)

470

471

let cmi_of_modname n = (String.lowercase n) ^ ".cmi"

472

473

let cmi_files args mod_expr =

474

match mod_expr with

475

| Exact mod_name ->

476

let cmi_name = cmi_of_modname mod_name in

477

Strset.fold

478

(fun path acc ->

479

if Sys.file_exists (Filename.concat path cmi_name) then

480

(mod_name, Filename.concat path cmi_name) :: acc

481

else

482

acc)

483

args.path

484

[]

485

| _ ->

486

Strset.fold

487

(fun path cmi_files ->

488

Unix.fold_path

489

~f:(fun file cmi_files ->

490

if Pcre.pmatch ~rex:cmi_file file then begin

491

let mod_name = modname_of_cmi file in

492

if match_mod_expr mod_expr mod_name then

493

(mod_name, Filename.concat path file) :: cmi_files

494

else

495

cmi_files

496

end else

497

cmi_files)

498

~init:cmi_files

499

path)

500

args.path

501

[]

502

503

let rec matching_submods mod_expr s =

504

match s with

505

| Tsig_module (id, mt, _) :: tl when match_mod_expr mod_expr (Ident.name id) ->

506

begin match mt with

507

| Tmty_signature sg -> (Ident.name id, sg) :: matching_submods mod_expr tl

508

| Tmty_functor (_, mt, _) ->

509

begin match mt with

510

| Tmty_signature sg -> (Ident.name id, sg) :: matching_submods mod_expr tl

511

| _ -> matching_submods mod_expr tl

512

end

513

| Tmty_ident _ -> matching_submods mod_expr tl

514

end

515

| _ :: tl -> matching_submods mod_expr tl

516

| [] -> []

517

518

let rec build_module_tree name root mod_expr =

519

match mod_expr with

520

| [] -> Leaf (name, root)

521

| mod_expr :: tl ->

522

begin match matching_submods mod_expr root with

523

| [] -> Leaf (name, root)

524

| mods ->

525

let children =

526

List.map

527

(fun (name, sg) -> build_module_tree name sg tl)

528

mods

529

in

530

Node (name, root, children)

531

end

532

533

let rec extract_nodes depth path modtree =

534

let concatpath path name =

535

if path = "" then name

536

else (path ^ "." ^ name)

537

in

538

match modtree with

539

| Leaf (name, sg) -> [(concatpath path name, depth, sg)]

540

| Node (name, sg, children) ->

541

(concatpath path name, depth, sg) ::

542

(List.flatten

543

(List.map

544

(fun submod -> extract_nodes (depth + 1) (concatpath path name) submod)

545

children))

546

547

let print_requested_stuff print_path name s args =

548

match args.mode with

549

| Find_type e -> print_type print_path name s e

550

| Find_constructor e -> print_constructor print_path name s e

551

| Find_polymorphic_variant e -> print_polymorphic_variant print_path name s e

552

| Find_record_label e -> print_record_label print_path name s e

553

| Find_value e -> print_value print_path name s e

554

| Find_exception e -> print_exception print_path name s e

555

| Find_class e -> print_class print_path name s e

556

| Find_all e -> print_all print_path name s e

557

| Find_module ->

558

Format.print_string name;

559

Format.print_newline ()

560

561

let read_cmi_file filename =

562

let ic = open_in_bin filename in

563

try

564

let buffer = String.create (String.length Config.cmi_magic_number) in

565

really_input ic buffer 0 (String.length Config.cmi_magic_number);

566

if buffer <> Config.cmi_magic_number then begin

567

close_in ic;

568

failwith (Printf.sprintf "not an interface: %s" filename)

569

end;

570

let (name, sg) = input_value ic in

571

close_in ic;

572

sg

573

with exn ->

574

close_in ic;

575

failwith

576

(Printf.sprintf

577

"bad cmi file: %s, error: %s"

578

filename

579

(Printexc.to_string exn))

580

581

let module_exists args mod_exp =

582

let expr_len = List.length mod_exp in

583

let mod_name = List.hd mod_exp in

584

let submods = List.tl mod_exp in

585

match cmi_files args mod_name with

586

| [] -> false

587

| cmi_files ->

588

List.exists

589

(fun (name, cmi_file) ->

590

let s = read_cmi_file cmi_file in

591

let sgs =

592

List.filter

593

(fun (_, depth, _) -> depth = expr_len)

594

(extract_nodes 1 "" (build_module_tree name s submods))

595

in

596

List.length sgs > 0)

597

cmi_files

598

599

let gen_qualified args context =

600

let context = Array.of_list context in

601

for i = 0 to Array.length context - 1 do

602

try

603

for j = i downto 0 do

604

let maybe_parent = context.(j) in

605

let child = context.(i) in

606

let qualified = maybe_parent @ child in

607

if module_exists args qualified then begin

608

context.(i) <- qualified;

609

raise Break

610

end

611

done

612

with Break -> ()

613

done;

614

Array.to_list context

615

616

let () =

617

let args = parse_args () in

618

let qualified_context = gen_qualified args args.context in

619

let mod_exprs =

620

(* combine the list of fully qualified open modules with the

621

module expressions that the user has specified following the

622

compiler's rules about module opens for exact expressions, and

623

combining everything for non exact expressions. *)

624

let is_exact e = List.for_all (function Exact _ -> true | _ -> false) e in

625

match args.modname with

626

| [] -> qualified_context

627

| exps ->

628

List.flatten

629

(List.map

630

(fun exp ->

631

if is_exact exp then

632

[try

633

List.find_map

634

(fun qual ->

635

let exp' = qual @ exp in

636

if module_exists args exp' then Some exp'

637

else None)

638

(List.rev qualified_context) (* look from the bottom up *)

639

with Not_found -> exp]

640

else

641

exp ::

642

(List.rev_map

643

(fun qual -> qual @ exp)

644

qualified_context))

645

exps)

646

in

647

List.iter

648

(fun mod_expr ->

649

try

650

let expr_len = List.length mod_expr in

651

let mod_name = List.hd mod_expr in

652

let submods = List.tl mod_expr in

653

let cmi_files = cmi_files args mod_name in

654

List.iter

655

(fun (name, cmi_file) ->

656

let s = read_cmi_file cmi_file in

657

let sgs =

658

List.filter

659

(fun (_, depth, _) -> depth = expr_len)

660

(extract_nodes 1 "" (build_module_tree name s submods))

661

in

662

let print_path =

663

List.length sgs > 1 ||

664

List.length cmi_files > 1 ||

665

List.length args.modname > 1

666

in

667

List.iter

668

(fun (name, _, sg) -> print_requested_stuff print_path name sg args)

669

sgs)

670

cmi_files

671

with exn ->

672

Printf.eprintf

673

"failed to operate on: \"%s\", %s\n%!"

674

(String.concat " " (List.map module_expression_to_string mod_expr))

675

(Printexc.to_string exn))

676

mod_exprs