Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / setup.ml @ 719f9992

History | View | Annotate | Download (175 KB)

1
(* setup.ml generated for the first time by OASIS v0.2.0 *)
2

    
3
(* OASIS_START *)
4
(* DO NOT EDIT (digest: d0957d7fdd9eb6ce163190fb18a724b8) *)
5
(*
6
   Regenerated by OASIS v0.4.4
7
   Visit http://oasis.forge.ocamlcore.org for more information and
8
   documentation about functions used in this file.
9
*)
10
module OASISGettext = struct
11
(* # 22 "src/oasis/OASISGettext.ml" *)
12

    
13

    
14
  let ns_ str =
15
    str
16

    
17

    
18
  let s_ str =
19
    str
20

    
21

    
22
  let f_ (str: ('a, 'b, 'c, 'd) format4) =
23
    str
24

    
25

    
26
  let fn_ fmt1 fmt2 n =
27
    if n = 1 then
28
      fmt1^^""
29
    else
30
      fmt2^^""
31

    
32

    
33
  let init =
34
    []
35

    
36

    
37
end
38

    
39
module OASISContext = struct
40
(* # 22 "src/oasis/OASISContext.ml" *)
41

    
42

    
43
  open OASISGettext
44

    
45

    
46
  type level =
47
    [ `Debug
48
    | `Info
49
    | `Warning
50
    | `Error]
51

    
52

    
53
  type t =
54
    {
55
      (* TODO: replace this by a proplist. *)
56
      quiet:                 bool;
57
      info:                  bool;
58
      debug:                 bool;
59
      ignore_plugins:        bool;
60
      ignore_unknown_fields: bool;
61
      printf:                level -> string -> unit;
62
    }
63

    
64

    
65
  let printf lvl str =
66
    let beg =
67
      match lvl with
68
        | `Error -> s_ "E: "
69
        | `Warning -> s_ "W: "
70
        | `Info  -> s_ "I: "
71
        | `Debug -> s_ "D: "
72
    in
73
      prerr_endline (beg^str)
74

    
75

    
76
  let default =
77
    ref
78
      {
79
        quiet                 = false;
80
        info                  = false;
81
        debug                 = false;
82
        ignore_plugins        = false;
83
        ignore_unknown_fields = false;
84
        printf                = printf;
85
      }
86

    
87

    
88
  let quiet =
89
    {!default with quiet = true}
90

    
91

    
92
  let fspecs () =
93
    (* TODO: don't act on default. *)
94
    let ignore_plugins = ref false in
95
    ["-quiet",
96
     Arg.Unit (fun () -> default := {!default with quiet = true}),
97
     s_ " Run quietly";
98

    
99
     "-info",
100
     Arg.Unit (fun () -> default := {!default with info = true}),
101
     s_ " Display information message";
102

    
103

    
104
     "-debug",
105
     Arg.Unit (fun () -> default := {!default with debug = true}),
106
     s_ " Output debug message";
107

    
108
     "-ignore-plugins",
109
     Arg.Set ignore_plugins,
110
     s_ " Ignore plugin's field.";
111

    
112
     "-C",
113
     (* TODO: remove this chdir. *)
114
     Arg.String (fun str -> Sys.chdir str),
115
     s_ "dir Change directory before running."],
116
    fun () -> {!default with ignore_plugins = !ignore_plugins}
117
end
118

    
119
module OASISString = struct
120
(* # 22 "src/oasis/OASISString.ml" *)
121

    
122

    
123
  (** Various string utilities.
124

    
125
      Mostly inspired by extlib and batteries ExtString and BatString libraries.
126

    
127
      @author Sylvain Le Gall
128
    *)
129

    
130

    
131
  let nsplitf str f =
132
    if str = "" then
133
      []
134
    else
135
      let buf = Buffer.create 13 in
136
      let lst = ref [] in
137
      let push () =
138
        lst := Buffer.contents buf :: !lst;
139
        Buffer.clear buf
140
      in
141
      let str_len = String.length str in
142
        for i = 0 to str_len - 1 do
143
          if f str.[i] then
144
            push ()
145
          else
146
            Buffer.add_char buf str.[i]
147
        done;
148
        push ();
149
        List.rev !lst
150

    
151

    
152
  (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the
153
      separator.
154
    *)
155
  let nsplit str c =
156
    nsplitf str ((=) c)
157

    
158

    
159
  let find ~what ?(offset=0) str =
160
    let what_idx = ref 0 in
161
    let str_idx = ref offset in
162
      while !str_idx < String.length str &&
163
            !what_idx < String.length what do
164
        if str.[!str_idx] = what.[!what_idx] then
165
          incr what_idx
166
        else
167
          what_idx := 0;
168
        incr str_idx
169
      done;
170
      if !what_idx <> String.length what then
171
        raise Not_found
172
      else
173
        !str_idx - !what_idx
174

    
175

    
176
  let sub_start str len =
177
    let str_len = String.length str in
178
    if len >= str_len then
179
      ""
180
    else
181
      String.sub str len (str_len - len)
182

    
183

    
184
  let sub_end ?(offset=0) str len =
185
    let str_len = String.length str in
186
    if len >= str_len then
187
      ""
188
    else
189
      String.sub str 0 (str_len - len)
190

    
191

    
192
  let starts_with ~what ?(offset=0) str =
193
    let what_idx = ref 0 in
194
    let str_idx = ref offset in
195
    let ok = ref true in
196
      while !ok &&
197
            !str_idx < String.length str &&
198
            !what_idx < String.length what do
199
        if str.[!str_idx] = what.[!what_idx] then
200
          incr what_idx
201
        else
202
          ok := false;
203
        incr str_idx
204
      done;
205
      if !what_idx = String.length what then
206
        true
207
      else
208
        false
209

    
210

    
211
  let strip_starts_with ~what str =
212
    if starts_with ~what str then
213
      sub_start str (String.length what)
214
    else
215
      raise Not_found
216

    
217

    
218
  let ends_with ~what ?(offset=0) str =
219
    let what_idx = ref ((String.length what) - 1) in
220
    let str_idx = ref ((String.length str) - 1) in
221
    let ok = ref true in
222
      while !ok &&
223
            offset <= !str_idx &&
224
            0 <= !what_idx do
225
        if str.[!str_idx] = what.[!what_idx] then
226
          decr what_idx
227
        else
228
          ok := false;
229
        decr str_idx
230
      done;
231
      if !what_idx = -1 then
232
        true
233
      else
234
        false
235

    
236

    
237
  let strip_ends_with ~what str =
238
    if ends_with ~what str then
239
      sub_end str (String.length what)
240
    else
241
      raise Not_found
242

    
243

    
244
  let replace_chars f s =
245
    let buf = String.make (String.length s) 'X' in
246
      for i = 0 to String.length s - 1 do
247
        buf.[i] <- f s.[i]
248
      done;
249
      buf
250

    
251

    
252
end
253

    
254
module OASISUtils = struct
255
(* # 22 "src/oasis/OASISUtils.ml" *)
256

    
257

    
258
  open OASISGettext
259

    
260

    
261
  module MapExt =
262
  struct
263
    module type S =
264
    sig
265
      include Map.S
266
      val add_list: 'a t -> (key * 'a) list -> 'a t
267
      val of_list: (key * 'a) list -> 'a t
268
      val to_list: 'a t -> (key * 'a) list
269
    end
270

    
271
    module Make (Ord: Map.OrderedType) =
272
    struct
273
      include Map.Make(Ord)
274

    
275
      let rec add_list t =
276
        function
277
          | (k, v) :: tl -> add_list (add k v t) tl
278
          | [] -> t
279

    
280
      let of_list lst = add_list empty lst
281

    
282
      let to_list t = fold (fun k v acc -> (k, v) :: acc) t []
283
    end
284
  end
285

    
286

    
287
  module MapString = MapExt.Make(String)
288

    
289

    
290
  module SetExt  =
291
  struct
292
    module type S =
293
    sig
294
      include Set.S
295
      val add_list: t -> elt list -> t
296
      val of_list: elt list -> t
297
      val to_list: t -> elt list
298
    end
299

    
300
    module Make (Ord: Set.OrderedType) =
301
    struct
302
      include Set.Make(Ord)
303

    
304
      let rec add_list t =
305
        function
306
          | e :: tl -> add_list (add e t) tl
307
          | [] -> t
308

    
309
      let of_list lst = add_list empty lst
310

    
311
      let to_list = elements
312
    end
313
  end
314

    
315

    
316
  module SetString = SetExt.Make(String)
317

    
318

    
319
  let compare_csl s1 s2 =
320
    String.compare (String.lowercase s1) (String.lowercase s2)
321

    
322

    
323
  module HashStringCsl =
324
    Hashtbl.Make
325
      (struct
326
         type t = string
327

    
328
         let equal s1 s2 =
329
             (String.lowercase s1) = (String.lowercase s2)
330

    
331
         let hash s =
332
           Hashtbl.hash (String.lowercase s)
333
       end)
334

    
335
  module SetStringCsl =
336
    SetExt.Make
337
      (struct
338
         type t = string
339
         let compare = compare_csl
340
       end)
341

    
342

    
343
  let varname_of_string ?(hyphen='_') s =
344
    if String.length s = 0 then
345
      begin
346
        invalid_arg "varname_of_string"
347
      end
348
    else
349
      begin
350
        let buf =
351
          OASISString.replace_chars
352
            (fun c ->
353
               if ('a' <= c && c <= 'z')
354
                 ||
355
                  ('A' <= c && c <= 'Z')
356
                 ||
357
                  ('0' <= c && c <= '9') then
358
                 c
359
               else
360
                 hyphen)
361
            s;
362
        in
363
        let buf =
364
          (* Start with a _ if digit *)
365
          if '0' <= s.[0] && s.[0] <= '9' then
366
            "_"^buf
367
          else
368
            buf
369
        in
370
          String.lowercase buf
371
      end
372

    
373

    
374
  let varname_concat ?(hyphen='_') p s =
375
    let what = String.make 1 hyphen in
376
    let p =
377
      try
378
        OASISString.strip_ends_with ~what p
379
      with Not_found ->
380
        p
381
    in
382
    let s =
383
      try
384
        OASISString.strip_starts_with ~what s
385
      with Not_found ->
386
        s
387
    in
388
      p^what^s
389

    
390

    
391
  let is_varname str =
392
    str = varname_of_string str
393

    
394

    
395
  let failwithf fmt = Printf.ksprintf failwith fmt
396

    
397

    
398
end
399

    
400
module PropList = struct
401
(* # 22 "src/oasis/PropList.ml" *)
402

    
403

    
404
  open OASISGettext
405

    
406

    
407
  type name = string
408

    
409

    
410
  exception Not_set of name * string option
411
  exception No_printer of name
412
  exception Unknown_field of name * name
413

    
414

    
415
  let () =
416
    Printexc.register_printer
417
      (function
418
         | Not_set (nm, Some rsn) ->
419
             Some
420
               (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn)
421
         | Not_set (nm, None) ->
422
             Some
423
               (Printf.sprintf (f_ "Field '%s' is not set") nm)
424
         | No_printer nm ->
425
             Some
426
               (Printf.sprintf (f_ "No default printer for value %s") nm)
427
         | Unknown_field (nm, schm) ->
428
             Some
429
               (Printf.sprintf
430
                  (f_ "Field %s is not defined in schema %s") nm schm)
431
         | _ ->
432
             None)
433

    
434

    
435
  module Data =
436
  struct
437
    type t =
438
        (name, unit -> unit) Hashtbl.t
439

    
440
    let create () =
441
      Hashtbl.create 13
442

    
443
    let clear t =
444
      Hashtbl.clear t
445

    
446

    
447
(* # 78 "src/oasis/PropList.ml" *)
448
  end
449

    
450

    
451
  module Schema =
452
  struct
453
    type ('ctxt, 'extra) value =
454
        {
455
          get:   Data.t -> string;
456
          set:   Data.t -> ?context:'ctxt -> string -> unit;
457
          help:  (unit -> string) option;
458
          extra: 'extra;
459
        }
460

    
461
    type ('ctxt, 'extra) t =
462
        {
463
          name:      name;
464
          fields:    (name, ('ctxt, 'extra) value) Hashtbl.t;
465
          order:     name Queue.t;
466
          name_norm: string -> string;
467
        }
468

    
469
    let create ?(case_insensitive=false) nm =
470
      {
471
        name      = nm;
472
        fields    = Hashtbl.create 13;
473
        order     = Queue.create ();
474
        name_norm =
475
          (if case_insensitive then
476
             String.lowercase
477
           else
478
             fun s -> s);
479
      }
480

    
481
    let add t nm set get extra help =
482
      let key =
483
        t.name_norm nm
484
      in
485

    
486
        if Hashtbl.mem t.fields key then
487
          failwith
488
            (Printf.sprintf
489
               (f_ "Field '%s' is already defined in schema '%s'")
490
               nm t.name);
491
        Hashtbl.add
492
          t.fields
493
          key
494
          {
495
            set   = set;
496
            get   = get;
497
            help  = help;
498
            extra = extra;
499
          };
500
        Queue.add nm t.order
501

    
502
    let mem t nm =
503
      Hashtbl.mem t.fields nm
504

    
505
    let find t nm =
506
      try
507
        Hashtbl.find t.fields (t.name_norm nm)
508
      with Not_found ->
509
        raise (Unknown_field (nm, t.name))
510

    
511
    let get t data nm =
512
      (find t nm).get data
513

    
514
    let set t data nm ?context x =
515
      (find t nm).set
516
        data
517
        ?context
518
        x
519

    
520
    let fold f acc t =
521
      Queue.fold
522
        (fun acc k ->
523
           let v =
524
             find t k
525
           in
526
             f acc k v.extra v.help)
527
        acc
528
        t.order
529

    
530
    let iter f t =
531
      fold
532
        (fun () -> f)
533
        ()
534
        t
535

    
536
    let name t =
537
      t.name
538
  end
539

    
540

    
541
  module Field =
542
  struct
543
    type ('ctxt, 'value, 'extra) t =
544
        {
545
          set:    Data.t -> ?context:'ctxt -> 'value -> unit;
546
          get:    Data.t -> 'value;
547
          sets:   Data.t -> ?context:'ctxt -> string -> unit;
548
          gets:   Data.t -> string;
549
          help:   (unit -> string) option;
550
          extra:  'extra;
551
        }
552

    
553
    let new_id =
554
      let last_id =
555
        ref 0
556
      in
557
        fun () -> incr last_id; !last_id
558

    
559
    let create ?schema ?name ?parse ?print ?default ?update ?help extra =
560
      (* Default value container *)
561
      let v =
562
        ref None
563
      in
564

    
565
      (* If name is not given, create unique one *)
566
      let nm =
567
        match name with
568
          | Some s -> s
569
          | None -> Printf.sprintf "_anon_%d" (new_id ())
570
      in
571

    
572
      (* Last chance to get a value: the default *)
573
      let default () =
574
        match default with
575
          | Some d -> d
576
          | None -> raise (Not_set (nm, Some (s_ "no default value")))
577
      in
578

    
579
      (* Get data *)
580
      let get data =
581
        (* Get value *)
582
        try
583
          (Hashtbl.find data nm) ();
584
          match !v with
585
            | Some x -> x
586
            | None -> default ()
587
        with Not_found ->
588
          default ()
589
      in
590

    
591
      (* Set data *)
592
      let set data ?context x =
593
        let x =
594
          match update with
595
            | Some f ->
596
                begin
597
                  try
598
                    f ?context (get data) x
599
                  with Not_set _ ->
600
                    x
601
                end
602
            | None ->
603
                x
604
        in
605
          Hashtbl.replace
606
            data
607
            nm
608
            (fun () -> v := Some x)
609
      in
610

    
611
      (* Parse string value, if possible *)
612
      let parse =
613
        match parse with
614
          | Some f ->
615
              f
616
          | None ->
617
              fun ?context s ->
618
                failwith
619
                  (Printf.sprintf
620
                     (f_ "Cannot parse field '%s' when setting value %S")
621
                     nm
622
                     s)
623
      in
624

    
625
      (* Set data, from string *)
626
      let sets data ?context s =
627
        set ?context data (parse ?context s)
628
      in
629

    
630
      (* Output value as string, if possible *)
631
      let print =
632
        match print with
633
          | Some f ->
634
              f
635
          | None ->
636
              fun _ -> raise (No_printer nm)
637
      in
638

    
639
      (* Get data, as a string *)
640
      let gets data =
641
        print (get data)
642
      in
643

    
644
        begin
645
          match schema with
646
            | Some t ->
647
                Schema.add t nm sets gets extra help
648
            | None ->
649
                ()
650
        end;
651

    
652
        {
653
          set   = set;
654
          get   = get;
655
          sets  = sets;
656
          gets  = gets;
657
          help  = help;
658
          extra = extra;
659
        }
660

    
661
    let fset data t ?context x =
662
      t.set data ?context x
663

    
664
    let fget data t =
665
      t.get data
666

    
667
    let fsets data t ?context s =
668
      t.sets data ?context s
669

    
670
    let fgets data t =
671
      t.gets data
672
  end
673

    
674

    
675
  module FieldRO =
676
  struct
677
    let create ?schema ?name ?parse ?print ?default ?update ?help extra =
678
      let fld =
679
        Field.create ?schema ?name ?parse ?print ?default ?update ?help extra
680
      in
681
        fun data -> Field.fget data fld
682
  end
683
end
684

    
685
module OASISMessage = struct
686
(* # 22 "src/oasis/OASISMessage.ml" *)
687

    
688

    
689
  open OASISGettext
690
  open OASISContext
691

    
692

    
693
  let generic_message ~ctxt lvl fmt =
694
    let cond =
695
      if ctxt.quiet then
696
        false
697
      else
698
        match lvl with
699
          | `Debug -> ctxt.debug
700
          | `Info  -> ctxt.info
701
          | _ -> true
702
    in
703
      Printf.ksprintf
704
        (fun str ->
705
           if cond then
706
             begin
707
               ctxt.printf lvl str
708
             end)
709
        fmt
710

    
711

    
712
  let debug ~ctxt fmt =
713
    generic_message ~ctxt `Debug fmt
714

    
715

    
716
  let info ~ctxt fmt =
717
    generic_message ~ctxt `Info fmt
718

    
719

    
720
  let warning ~ctxt fmt =
721
    generic_message ~ctxt `Warning fmt
722

    
723

    
724
  let error ~ctxt fmt =
725
    generic_message ~ctxt `Error fmt
726

    
727
end
728

    
729
module OASISVersion = struct
730
(* # 22 "src/oasis/OASISVersion.ml" *)
731

    
732

    
733
  open OASISGettext
734

    
735

    
736

    
737

    
738

    
739
  type s = string
740

    
741

    
742
  type t = string
743

    
744

    
745
  type comparator =
746
    | VGreater of t
747
    | VGreaterEqual of t
748
    | VEqual of t
749
    | VLesser of t
750
    | VLesserEqual of t
751
    | VOr of  comparator * comparator
752
    | VAnd of comparator * comparator
753

    
754

    
755

    
756
  (* Range of allowed characters *)
757
  let is_digit c =
758
    '0' <= c && c <= '9'
759

    
760

    
761
  let is_alpha c =
762
    ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z')
763

    
764

    
765
  let is_special =
766
    function
767
      | '.' | '+' | '-' | '~' -> true
768
      | _ -> false
769

    
770

    
771
  let rec version_compare v1 v2 =
772
    if v1 <> "" || v2 <> "" then
773
      begin
774
        (* Compare ascii string, using special meaning for version
775
         * related char
776
         *)
777
        let val_ascii c =
778
          if c = '~' then -1
779
          else if is_digit c then 0
780
          else if c = '\000' then 0
781
          else if is_alpha c then Char.code c
782
          else (Char.code c) + 256
783
        in
784

    
785
        let len1 = String.length v1 in
786
        let len2 = String.length v2 in
787

    
788
        let p = ref 0 in
789

    
790
        (** Compare ascii part *)
791
        let compare_vascii () =
792
          let cmp = ref 0 in
793
          while !cmp = 0 &&
794
                !p < len1 && !p < len2 &&
795
                not (is_digit v1.[!p] && is_digit v2.[!p]) do
796
            cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]);
797
            incr p
798
          done;
799
          if !cmp = 0 && !p < len1 && !p = len2 then
800
            val_ascii v1.[!p]
801
          else if !cmp = 0 && !p = len1 && !p < len2 then
802
            - (val_ascii v2.[!p])
803
          else
804
            !cmp
805
        in
806

    
807
        (** Compare digit part *)
808
        let compare_digit () =
809
          let extract_int v p =
810
            let start_p = !p in
811
              while !p < String.length v && is_digit v.[!p] do
812
                incr p
813
              done;
814
              let substr =
815
                String.sub v !p ((String.length v) - !p)
816
              in
817
              let res =
818
                match String.sub v start_p (!p - start_p) with
819
                  | "" -> 0
820
                  | s -> int_of_string s
821
              in
822
                res, substr
823
          in
824
          let i1, tl1 = extract_int v1 (ref !p) in
825
          let i2, tl2 = extract_int v2 (ref !p) in
826
            i1 - i2, tl1, tl2
827
        in
828

    
829
          match compare_vascii () with
830
            | 0 ->
831
                begin
832
                  match compare_digit () with
833
                    | 0, tl1, tl2 ->
834
                        if tl1 <> "" && is_digit tl1.[0] then
835
                          1
836
                        else if tl2 <> "" && is_digit tl2.[0] then
837
                          -1
838
                        else
839
                          version_compare tl1 tl2
840
                    | n, _, _ ->
841
                        n
842
                end
843
            | n ->
844
                n
845
      end
846
    else
847
      begin
848
        0
849
      end
850

    
851

    
852
  let version_of_string str = str
853

    
854

    
855
  let string_of_version t = t
856

    
857

    
858
  let version_compare_string s1 s2 =
859
    version_compare (version_of_string s1) (version_of_string s2)
860

    
861

    
862
  let chop t =
863
    try
864
      let pos =
865
        String.rindex t '.'
866
      in
867
        String.sub t 0 pos
868
    with Not_found ->
869
      t
870

    
871

    
872
  let rec comparator_apply v op =
873
    match op with
874
      | VGreater cv ->
875
          (version_compare v cv) > 0
876
      | VGreaterEqual cv ->
877
          (version_compare v cv) >= 0
878
      | VLesser cv ->
879
          (version_compare v cv) < 0
880
      | VLesserEqual cv ->
881
          (version_compare v cv) <= 0
882
      | VEqual cv ->
883
          (version_compare v cv) = 0
884
      | VOr (op1, op2) ->
885
          (comparator_apply v op1) || (comparator_apply v op2)
886
      | VAnd (op1, op2) ->
887
          (comparator_apply v op1) && (comparator_apply v op2)
888

    
889

    
890
  let rec string_of_comparator =
891
    function
892
      | VGreater v  -> "> "^(string_of_version v)
893
      | VEqual v    -> "= "^(string_of_version v)
894
      | VLesser v   -> "< "^(string_of_version v)
895
      | VGreaterEqual v -> ">= "^(string_of_version v)
896
      | VLesserEqual v  -> "<= "^(string_of_version v)
897
      | VOr (c1, c2)  ->
898
          (string_of_comparator c1)^" || "^(string_of_comparator c2)
899
      | VAnd (c1, c2) ->
900
          (string_of_comparator c1)^" && "^(string_of_comparator c2)
901

    
902

    
903
  let rec varname_of_comparator =
904
    let concat p v =
905
      OASISUtils.varname_concat
906
        p
907
        (OASISUtils.varname_of_string
908
           (string_of_version v))
909
    in
910
      function
911
        | VGreater v -> concat "gt" v
912
        | VLesser v  -> concat "lt" v
913
        | VEqual v   -> concat "eq" v
914
        | VGreaterEqual v -> concat "ge" v
915
        | VLesserEqual v  -> concat "le" v
916
        | VOr (c1, c2) ->
917
            (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2)
918
        | VAnd (c1, c2) ->
919
            (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2)
920

    
921

    
922
  let rec comparator_ge v' =
923
    let cmp v = version_compare v v' >= 0 in
924
    function
925
      | VEqual v
926
      | VGreaterEqual v
927
      | VGreater v -> cmp v
928
      | VLesserEqual _
929
      | VLesser _ -> false
930
      | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2
931
      | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2
932

    
933

    
934
end
935

    
936
module OASISLicense = struct
937
(* # 22 "src/oasis/OASISLicense.ml" *)
938

    
939

    
940
  (** License for _oasis fields
941
      @author Sylvain Le Gall
942
    *)
943

    
944

    
945

    
946

    
947

    
948
  type license = string
949

    
950

    
951
  type license_exception = string
952

    
953

    
954
  type license_version =
955
    | Version of OASISVersion.t
956
    | VersionOrLater of OASISVersion.t
957
    | NoVersion
958

    
959

    
960

    
961
  type license_dep_5_unit =
962
    {
963
      license:   license;
964
      excption:  license_exception option;
965
      version:   license_version;
966
    }
967

    
968

    
969

    
970
  type license_dep_5 =
971
    | DEP5Unit of license_dep_5_unit
972
    | DEP5Or of license_dep_5 list
973
    | DEP5And of license_dep_5 list
974

    
975

    
976
  type t =
977
    | DEP5License of license_dep_5
978
    | OtherLicense of string (* URL *)
979

    
980

    
981

    
982
end
983

    
984
module OASISExpr = struct
985
(* # 22 "src/oasis/OASISExpr.ml" *)
986

    
987

    
988

    
989

    
990

    
991
  open OASISGettext
992

    
993

    
994
  type test = string
995

    
996

    
997
  type flag = string
998

    
999

    
1000
  type t =
1001
    | EBool of bool
1002
    | ENot of t
1003
    | EAnd of t * t
1004
    | EOr of t * t
1005
    | EFlag of flag
1006
    | ETest of test * string
1007

    
1008

    
1009

    
1010
  type 'a choices = (t * 'a) list
1011

    
1012

    
1013
  let eval var_get t =
1014
    let rec eval' =
1015
      function
1016
        | EBool b ->
1017
            b
1018

    
1019
        | ENot e ->
1020
            not (eval' e)
1021

    
1022
        | EAnd (e1, e2) ->
1023
            (eval' e1) && (eval' e2)
1024

    
1025
        | EOr (e1, e2) ->
1026
            (eval' e1) || (eval' e2)
1027

    
1028
        | EFlag nm ->
1029
            let v =
1030
              var_get nm
1031
            in
1032
              assert(v = "true" || v = "false");
1033
              (v = "true")
1034

    
1035
        | ETest (nm, vl) ->
1036
            let v =
1037
              var_get nm
1038
            in
1039
              (v = vl)
1040
    in
1041
      eval' t
1042

    
1043

    
1044
  let choose ?printer ?name var_get lst =
1045
    let rec choose_aux =
1046
      function
1047
        | (cond, vl) :: tl ->
1048
            if eval var_get cond then
1049
              vl
1050
            else
1051
              choose_aux tl
1052
        | [] ->
1053
            let str_lst =
1054
              if lst = [] then
1055
                s_ "<empty>"
1056
              else
1057
                String.concat
1058
                  (s_ ", ")
1059
                  (List.map
1060
                     (fun (cond, vl) ->
1061
                        match printer with
1062
                          | Some p -> p vl
1063
                          | None -> s_ "<no printer>")
1064
                     lst)
1065
            in
1066
              match name with
1067
                | Some nm ->
1068
                    failwith
1069
                      (Printf.sprintf
1070
                         (f_ "No result for the choice list '%s': %s")
1071
                         nm str_lst)
1072
                | None ->
1073
                    failwith
1074
                      (Printf.sprintf
1075
                         (f_ "No result for a choice list: %s")
1076
                         str_lst)
1077
    in
1078
      choose_aux (List.rev lst)
1079

    
1080

    
1081
end
1082

    
1083
module OASISText = struct
1084
(* # 22 "src/oasis/OASISText.ml" *)
1085

    
1086

    
1087

    
1088
  type elt =
1089
    | Para of string
1090
    | Verbatim of string
1091
    | BlankLine
1092

    
1093

    
1094
  type t = elt list
1095

    
1096
end
1097

    
1098
module OASISTypes = struct
1099
(* # 22 "src/oasis/OASISTypes.ml" *)
1100

    
1101

    
1102

    
1103

    
1104

    
1105
  type name          = string
1106
  type package_name  = string
1107
  type url           = string
1108
  type unix_dirname  = string
1109
  type unix_filename = string
1110
  type host_dirname  = string
1111
  type host_filename = string
1112
  type prog          = string
1113
  type arg           = string
1114
  type args          = string list
1115
  type command_line  = (prog * arg list)
1116

    
1117

    
1118
  type findlib_name = string
1119
  type findlib_full = string
1120

    
1121

    
1122
  type compiled_object =
1123
    | Byte
1124
    | Native
1125
    | Best
1126

    
1127

    
1128

    
1129
  type dependency =
1130
    | FindlibPackage of findlib_full * OASISVersion.comparator option
1131
    | InternalLibrary of name
1132

    
1133

    
1134

    
1135
  type tool =
1136
    | ExternalTool of name
1137
    | InternalExecutable of name
1138

    
1139

    
1140

    
1141
  type vcs =
1142
    | Darcs
1143
    | Git
1144
    | Svn
1145
    | Cvs
1146
    | Hg
1147
    | Bzr
1148
    | Arch
1149
    | Monotone
1150
    | OtherVCS of url
1151

    
1152

    
1153

    
1154
  type plugin_kind =
1155
      [  `Configure
1156
       | `Build
1157
       | `Doc
1158
       | `Test
1159
       | `Install
1160
       | `Extra
1161
      ]
1162

    
1163

    
1164
  type plugin_data_purpose =
1165
      [  `Configure
1166
       | `Build
1167
       | `Install
1168
       | `Clean
1169
       | `Distclean
1170
       | `Install
1171
       | `Uninstall
1172
       | `Test
1173
       | `Doc
1174
       | `Extra
1175
       | `Other of string
1176
      ]
1177

    
1178

    
1179
  type 'a plugin = 'a * name * OASISVersion.t option
1180

    
1181

    
1182
  type all_plugin = plugin_kind plugin
1183

    
1184

    
1185
  type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list
1186

    
1187

    
1188
(* # 115 "src/oasis/OASISTypes.ml" *)
1189

    
1190

    
1191
  type 'a conditional = 'a OASISExpr.choices
1192

    
1193

    
1194
  type custom =
1195
      {
1196
        pre_command:  (command_line option) conditional;
1197
        post_command: (command_line option) conditional;
1198
      }
1199

    
1200

    
1201

    
1202
  type common_section =
1203
      {
1204
        cs_name: name;
1205
        cs_data: PropList.Data.t;
1206
        cs_plugin_data: plugin_data;
1207
      }
1208

    
1209

    
1210

    
1211
  type build_section =
1212
      {
1213
        bs_build:           bool conditional;
1214
        bs_install:         bool conditional;
1215
        bs_path:            unix_dirname;
1216
        bs_compiled_object: compiled_object;
1217
        bs_build_depends:   dependency list;
1218
        bs_build_tools:     tool list;
1219
        bs_c_sources:       unix_filename list;
1220
        bs_data_files:      (unix_filename * unix_filename option) list;
1221
        bs_ccopt:           args conditional;
1222
        bs_cclib:           args conditional;
1223
        bs_dlllib:          args conditional;
1224
        bs_dllpath:         args conditional;
1225
        bs_byteopt:         args conditional;
1226
        bs_nativeopt:       args conditional;
1227
      }
1228

    
1229

    
1230

    
1231
  type library =
1232
      {
1233
        lib_modules:            string list;
1234
        lib_pack:               bool;
1235
        lib_internal_modules:   string list;
1236
        lib_findlib_parent:     findlib_name option;
1237
        lib_findlib_name:       findlib_name option;
1238
        lib_findlib_containers: findlib_name list;
1239
      }
1240

    
1241

    
1242
  type object_ =
1243
      {
1244
        obj_modules:            string list;
1245
        obj_findlib_fullname:   findlib_name list option;
1246
      }
1247

    
1248

    
1249
  type executable =
1250
      {
1251
        exec_custom:          bool;
1252
        exec_main_is:         unix_filename;
1253
      }
1254

    
1255

    
1256
  type flag =
1257
      {
1258
        flag_description:  string option;
1259
        flag_default:      bool conditional;
1260
      }
1261

    
1262

    
1263
  type source_repository =
1264
      {
1265
        src_repo_type:        vcs;
1266
        src_repo_location:    url;
1267
        src_repo_browser:     url option;
1268
        src_repo_module:      string option;
1269
        src_repo_branch:      string option;
1270
        src_repo_tag:         string option;
1271
        src_repo_subdir:      unix_filename option;
1272
      }
1273

    
1274

    
1275
  type test =
1276
      {
1277
        test_type:               [`Test] plugin;
1278
        test_command:            command_line conditional;
1279
        test_custom:             custom;
1280
        test_working_directory:  unix_filename option;
1281
        test_run:                bool conditional;
1282
        test_tools:              tool list;
1283
      }
1284

    
1285

    
1286
  type doc_format =
1287
    | HTML of unix_filename
1288
    | DocText
1289
    | PDF
1290
    | PostScript
1291
    | Info of unix_filename
1292
    | DVI
1293
    | OtherDoc
1294

    
1295

    
1296

    
1297
  type doc =
1298
      {
1299
        doc_type:        [`Doc] plugin;
1300
        doc_custom:      custom;
1301
        doc_build:       bool conditional;
1302
        doc_install:     bool conditional;
1303
        doc_install_dir: unix_filename;
1304
        doc_title:       string;
1305
        doc_authors:     string list;
1306
        doc_abstract:    string option;
1307
        doc_format:      doc_format;
1308
        doc_data_files:  (unix_filename * unix_filename option) list;
1309
        doc_build_tools: tool list;
1310
      }
1311

    
1312

    
1313
  type section =
1314
    | Library    of common_section * build_section * library
1315
    | Object     of common_section * build_section * object_
1316
    | Executable of common_section * build_section * executable
1317
    | Flag       of common_section * flag
1318
    | SrcRepo    of common_section * source_repository
1319
    | Test       of common_section * test
1320
    | Doc        of common_section * doc
1321

    
1322

    
1323

    
1324
  type section_kind =
1325
      [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ]
1326

    
1327

    
1328
  type package =
1329
      {
1330
        oasis_version:          OASISVersion.t;
1331
        ocaml_version:          OASISVersion.comparator option;
1332
        findlib_version:        OASISVersion.comparator option;
1333
        alpha_features:         string list;
1334
        beta_features:          string list;
1335
        name:                   package_name;
1336
        version:                OASISVersion.t;
1337
        license:                OASISLicense.t;
1338
        license_file:           unix_filename option;
1339
        copyrights:             string list;
1340
        maintainers:            string list;
1341
        authors:                string list;
1342
        homepage:               url option;
1343
        synopsis:               string;
1344
        description:            OASISText.t option;
1345
        categories:             url list;
1346

    
1347
        conf_type:              [`Configure] plugin;
1348
        conf_custom:            custom;
1349

    
1350
        build_type:             [`Build] plugin;
1351
        build_custom:           custom;
1352

    
1353
        install_type:           [`Install] plugin;
1354
        install_custom:         custom;
1355
        uninstall_custom:       custom;
1356

    
1357
        clean_custom:           custom;
1358
        distclean_custom:       custom;
1359

    
1360
        files_ab:               unix_filename list;
1361
        sections:               section list;
1362
        plugins:                [`Extra] plugin list;
1363
        disable_oasis_section:  unix_filename list;
1364
        schema_data:            PropList.Data.t;
1365
        plugin_data:            plugin_data;
1366
      }
1367

    
1368

    
1369
end
1370

    
1371
module OASISFeatures = struct
1372
(* # 22 "src/oasis/OASISFeatures.ml" *)
1373

    
1374
  open OASISTypes
1375
  open OASISUtils
1376
  open OASISGettext
1377
  open OASISVersion
1378

    
1379
  module MapPlugin =
1380
    Map.Make
1381
      (struct
1382
         type t = plugin_kind * name
1383
         let compare = Pervasives.compare
1384
       end)
1385

    
1386
  module Data =
1387
  struct
1388
    type t =
1389
        {
1390
          oasis_version: OASISVersion.t;
1391
          plugin_versions: OASISVersion.t option MapPlugin.t;
1392
          alpha_features: string list;
1393
          beta_features: string list;
1394
        }
1395

    
1396
    let create oasis_version alpha_features beta_features =
1397
      {
1398
        oasis_version = oasis_version;
1399
        plugin_versions = MapPlugin.empty;
1400
        alpha_features = alpha_features;
1401
        beta_features = beta_features
1402
      }
1403

    
1404
    let of_package pkg =
1405
      create
1406
        pkg.OASISTypes.oasis_version
1407
        pkg.OASISTypes.alpha_features
1408
        pkg.OASISTypes.beta_features
1409

    
1410
    let add_plugin (plugin_kind, plugin_name, plugin_version) t =
1411
      {t with
1412
           plugin_versions = MapPlugin.add
1413
                               (plugin_kind, plugin_name)
1414
                               plugin_version
1415
                               t.plugin_versions}
1416

    
1417
    let plugin_version plugin_kind plugin_name t =
1418
      MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions
1419

    
1420
    let to_string t =
1421
      Printf.sprintf
1422
        "oasis_version: %s; alpha_features: %s; beta_features: %s; \
1423
         plugins_version: %s"
1424
        (OASISVersion.string_of_version t.oasis_version)
1425
        (String.concat ", " t.alpha_features)
1426
        (String.concat ", " t.beta_features)
1427
        (String.concat ", "
1428
           (MapPlugin.fold
1429
              (fun (_, plg) ver_opt acc ->
1430
                 (plg^
1431
                  (match ver_opt with
1432
                     | Some v ->
1433
                         " "^(OASISVersion.string_of_version v)
1434
                     | None -> ""))
1435
                 :: acc)
1436
              t.plugin_versions []))
1437
  end
1438

    
1439
  type origin =
1440
    | Field of string * string
1441
    | Section of string
1442
    | NoOrigin
1443

    
1444
  type stage = Alpha | Beta
1445

    
1446

    
1447
  let string_of_stage =
1448
    function
1449
      | Alpha -> "alpha"
1450
      | Beta -> "beta"
1451

    
1452

    
1453
  let field_of_stage =
1454
    function
1455
      | Alpha -> "AlphaFeatures"
1456
      | Beta -> "BetaFeatures"
1457

    
1458
  type publication = InDev of stage | SinceVersion of OASISVersion.t
1459

    
1460
  type t =
1461
      {
1462
        name: string;
1463
        plugin: all_plugin option;
1464
        publication: publication;
1465
        description: unit -> string;
1466
      }
1467

    
1468
  (* TODO: mutex protect this. *)
1469
  let all_features = Hashtbl.create 13
1470

    
1471

    
1472
  let since_version ver_str = SinceVersion (version_of_string ver_str)
1473
  let alpha = InDev Alpha
1474
  let beta = InDev Beta
1475

    
1476

    
1477
  let to_string t =
1478
    Printf.sprintf
1479
      "feature: %s; plugin: %s; publication: %s"
1480
      t.name
1481
      (match t.plugin with
1482
         | None -> "<none>"
1483
         | Some (_, nm, _) -> nm)
1484
      (match t.publication with
1485
         | InDev stage -> string_of_stage stage
1486
         | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver))
1487

    
1488
  let data_check t data origin =
1489
    let no_message = "no message" in
1490

    
1491
    let check_feature features stage =
1492
      let has_feature = List.mem t.name features in
1493
      if not has_feature then
1494
        match origin with
1495
          | Field (fld, where) ->
1496
              Some
1497
                (Printf.sprintf
1498
                   (f_ "Field %s in %s is only available when feature %s \
1499
                        is in field %s.")
1500
                   fld where t.name (field_of_stage stage))
1501
          | Section sct ->
1502
              Some
1503
                (Printf.sprintf
1504
                   (f_ "Section %s is only available when features %s \
1505
                        is in field %s.")
1506
                   sct t.name (field_of_stage stage))
1507
          | NoOrigin ->
1508
              Some no_message
1509
      else
1510
        None
1511
    in
1512

    
1513
    let version_is_good ~min_version version fmt =
1514
      let version_is_good =
1515
        OASISVersion.comparator_apply
1516
          version (OASISVersion.VGreaterEqual min_version)
1517
      in
1518
        Printf.ksprintf
1519
          (fun str ->
1520
             if version_is_good then
1521
               None
1522
             else
1523
               Some str)
1524
          fmt
1525
    in
1526

    
1527
    match origin, t.plugin, t.publication with
1528
      | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha
1529
      | _, _, InDev Beta -> check_feature data.Data.beta_features Beta
1530
      | Field(fld, where), None, SinceVersion min_version ->
1531
          version_is_good ~min_version data.Data.oasis_version
1532
            (f_ "Field %s in %s is only valid since OASIS v%s, update \
1533
                 OASISFormat field from '%s' to '%s' after checking \
1534
                 OASIS changelog.")
1535
            fld where (string_of_version min_version)
1536
            (string_of_version data.Data.oasis_version)
1537
            (string_of_version min_version)
1538

    
1539
      | Field(fld, where), Some(plugin_knd, plugin_name, _),
1540
        SinceVersion min_version ->
1541
          begin
1542
            try
1543
              let plugin_version_current =
1544
                try
1545
                  match Data.plugin_version plugin_knd plugin_name data with
1546
                    | Some ver -> ver
1547
                    | None ->
1548
                        failwithf
1549
                          (f_ "Field %s in %s is only valid for the OASIS \
1550
                               plugin %s since v%s, but no plugin version is \
1551
                               defined in the _oasis file, change '%s' to \
1552
                               '%s (%s)' in your _oasis file.")
1553
                          fld where plugin_name (string_of_version min_version)
1554
                          plugin_name
1555
                          plugin_name (string_of_version min_version)
1556
                with Not_found ->
1557
                  failwithf
1558
                    (f_ "Field %s in %s is only valid when the OASIS plugin %s \
1559
                         is defined.")
1560
                    fld where plugin_name
1561
              in
1562
              version_is_good ~min_version plugin_version_current
1563
                (f_ "Field %s in %s is only valid for the OASIS plugin %s \
1564
                     since v%s, update your plugin from '%s (%s)' to \
1565
                     '%s (%s)' after checking the plugin's changelog.")
1566
                fld where plugin_name (string_of_version min_version)
1567
                plugin_name (string_of_version plugin_version_current)
1568
                plugin_name (string_of_version min_version)
1569
            with Failure msg ->
1570
              Some msg
1571
          end
1572

    
1573
      | Section sct, None, SinceVersion min_version ->
1574
          version_is_good ~min_version data.Data.oasis_version
1575
            (f_ "Section %s is only valid for since OASIS v%s, update \
1576
                 OASISFormat field from '%s' to '%s' after checking OASIS \
1577
                 changelog.")
1578
            sct (string_of_version min_version)
1579
            (string_of_version data.Data.oasis_version)
1580
            (string_of_version min_version)
1581

    
1582
      | Section sct, Some(plugin_knd, plugin_name, _),
1583
        SinceVersion min_version ->
1584
          begin
1585
            try
1586
              let plugin_version_current =
1587
                try
1588
                  match Data.plugin_version plugin_knd plugin_name data with
1589
                    | Some ver -> ver
1590
                    | None ->
1591
                        failwithf
1592
                          (f_ "Section %s is only valid for the OASIS \
1593
                               plugin %s since v%s, but no plugin version is \
1594
                               defined in the _oasis file, change '%s' to \
1595
                               '%s (%s)' in your _oasis file.")
1596
                          sct plugin_name (string_of_version min_version)
1597
                          plugin_name
1598
                          plugin_name (string_of_version min_version)
1599
                with Not_found ->
1600
                  failwithf
1601
                    (f_ "Section %s is only valid when the OASIS plugin %s \
1602
                         is defined.")
1603
                    sct plugin_name
1604
              in
1605
              version_is_good ~min_version plugin_version_current
1606
                (f_ "Section %s is only valid for the OASIS plugin %s \
1607
                     since v%s, update your plugin from '%s (%s)' to \
1608
                     '%s (%s)' after checking the plugin's changelog.")
1609
                sct plugin_name (string_of_version min_version)
1610
                plugin_name (string_of_version plugin_version_current)
1611
                plugin_name (string_of_version min_version)
1612
            with Failure msg ->
1613
              Some msg
1614
          end
1615

    
1616
      | NoOrigin, None, SinceVersion min_version ->
1617
          version_is_good ~min_version data.Data.oasis_version "%s" no_message
1618

    
1619
      | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version ->
1620
          begin
1621
            try
1622
              let plugin_version_current =
1623
                match Data.plugin_version plugin_knd plugin_name data with
1624
                  | Some ver -> ver
1625
                  | None -> raise Not_found
1626
              in
1627
              version_is_good ~min_version plugin_version_current
1628
                "%s" no_message
1629
            with Not_found ->
1630
              Some no_message
1631
          end
1632

    
1633

    
1634
  let data_assert t data origin =
1635
    match data_check t data origin with
1636
      | None -> ()
1637
      | Some str -> failwith str
1638

    
1639

    
1640
  let data_test t data =
1641
    match data_check t data NoOrigin with
1642
      | None -> true
1643
      | Some str -> false
1644

    
1645

    
1646
  let package_test t pkg =
1647
    data_test t (Data.of_package pkg)
1648

    
1649

    
1650
  let create ?plugin name publication description =
1651
    let () =
1652
      if Hashtbl.mem all_features name then
1653
        failwithf "Feature '%s' is already declared." name
1654
    in
1655
    let t =
1656
      {
1657
        name = name;
1658
        plugin = plugin;
1659
        publication = publication;
1660
        description = description;
1661
      }
1662
    in
1663
      Hashtbl.add all_features name t;
1664
      t
1665

    
1666

    
1667
  let get_stage name =
1668
    try
1669
      (Hashtbl.find all_features name).publication
1670
    with Not_found ->
1671
      failwithf (f_ "Feature %s doesn't exist.") name
1672

    
1673

    
1674
  let list () =
1675
    Hashtbl.fold (fun _ v acc -> v :: acc) all_features []
1676

    
1677
  (*
1678
   * Real flags.
1679
   *)
1680

    
1681

    
1682
  let features =
1683
    create "features_fields"
1684
      (since_version "0.4")
1685
      (fun () ->
1686
         s_ "Enable to experiment not yet official features.")
1687

    
1688

    
1689
  let flag_docs =
1690
    create "flag_docs"
1691
      (since_version "0.3")
1692
      (fun () ->
1693
         s_ "Building docs require '-docs' flag at configure.")
1694

    
1695

    
1696
  let flag_tests =
1697
    create "flag_tests"
1698
      (since_version "0.3")
1699
      (fun () ->
1700
         s_ "Running tests require '-tests' flag at configure.")
1701

    
1702

    
1703
  let pack =
1704
    create "pack"
1705
      (since_version "0.3")
1706
      (fun () ->
1707
         s_ "Allow to create packed library.")
1708

    
1709

    
1710
  let section_object =
1711
    create "section_object" beta
1712
      (fun () ->
1713
         s_ "Implement an object section.")
1714

    
1715

    
1716
  let dynrun_for_release =
1717
    create "dynrun_for_release" alpha
1718
      (fun () ->
1719
         s_ "Make '-setup-update dynamic' suitable for releasing project.")
1720

    
1721

    
1722
  let compiled_setup_ml =
1723
    create "compiled_setup_ml" alpha
1724
      (fun () ->
1725
         s_ "It compiles the setup.ml and speed-up actions done with it.")
1726

    
1727
  let disable_oasis_section =
1728
    create "disable_oasis_section" alpha
1729
      (fun () ->
1730
        s_ "Allows the OASIS section comments and digest to be omitted in \
1731
            generated files.")
1732
end
1733

    
1734
module OASISUnixPath = struct
1735
(* # 22 "src/oasis/OASISUnixPath.ml" *)
1736

    
1737

    
1738
  type unix_filename = string
1739
  type unix_dirname = string
1740

    
1741

    
1742
  type host_filename = string
1743
  type host_dirname = string
1744

    
1745

    
1746
  let current_dir_name = "."
1747

    
1748

    
1749
  let parent_dir_name = ".."
1750

    
1751

    
1752
  let is_current_dir fn =
1753
    fn = current_dir_name || fn = ""
1754

    
1755

    
1756
  let concat f1 f2 =
1757
    if is_current_dir f1 then
1758
      f2
1759
    else
1760
      let f1' =
1761
        try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1
1762
      in
1763
        f1'^"/"^f2
1764

    
1765

    
1766
  let make =
1767
    function
1768
      | hd :: tl ->
1769
          List.fold_left
1770
            (fun f p -> concat f p)
1771
            hd
1772
            tl
1773
      | [] ->
1774
          invalid_arg "OASISUnixPath.make"
1775

    
1776

    
1777
  let dirname f =
1778
    try
1779
      String.sub f 0 (String.rindex f '/')
1780
    with Not_found ->
1781
      current_dir_name
1782

    
1783

    
1784
  let basename f =
1785
    try
1786
      let pos_start =
1787
        (String.rindex f '/') + 1
1788
      in
1789
        String.sub f pos_start ((String.length f) - pos_start)
1790
    with Not_found ->
1791
      f
1792

    
1793

    
1794
  let chop_extension f =
1795
    try
1796
      let last_dot =
1797
        String.rindex f '.'
1798
      in
1799
      let sub =
1800
        String.sub f 0 last_dot
1801
      in
1802
        try
1803
          let last_slash =
1804
            String.rindex f '/'
1805
          in
1806
            if last_slash < last_dot then
1807
              sub
1808
            else
1809
              f
1810
        with Not_found ->
1811
          sub
1812

    
1813
    with Not_found ->
1814
      f
1815

    
1816

    
1817
  let capitalize_file f =
1818
    let dir = dirname f in
1819
    let base = basename f in
1820
    concat dir (String.capitalize base)
1821

    
1822

    
1823
  let uncapitalize_file f =
1824
    let dir = dirname f in
1825
    let base = basename f in
1826
    concat dir (String.uncapitalize base)
1827

    
1828

    
1829
end
1830

    
1831
module OASISHostPath = struct
1832
(* # 22 "src/oasis/OASISHostPath.ml" *)
1833

    
1834

    
1835
  open Filename
1836

    
1837

    
1838
  module Unix = OASISUnixPath
1839

    
1840

    
1841
  let make =
1842
    function
1843
      | [] ->
1844
          invalid_arg "OASISHostPath.make"
1845
      | hd :: tl ->
1846
          List.fold_left Filename.concat hd tl
1847

    
1848

    
1849
  let of_unix ufn =
1850
    if Sys.os_type = "Unix" then
1851
      ufn
1852
    else
1853
      make
1854
        (List.map
1855
           (fun p ->
1856
              if p = Unix.current_dir_name then
1857
                current_dir_name
1858
              else if p = Unix.parent_dir_name then
1859
                parent_dir_name
1860
              else
1861
                p)
1862
           (OASISString.nsplit ufn '/'))
1863

    
1864

    
1865
end
1866

    
1867
module OASISSection = struct
1868
(* # 22 "src/oasis/OASISSection.ml" *)
1869

    
1870

    
1871
  open OASISTypes
1872

    
1873

    
1874
  let section_kind_common =
1875
    function
1876
      | Library (cs, _, _) ->
1877
          `Library, cs
1878
      | Object (cs, _, _) ->
1879
          `Object, cs
1880
      | Executable (cs, _, _) ->
1881
          `Executable, cs
1882
      | Flag (cs, _) ->
1883
          `Flag, cs
1884
      | SrcRepo (cs, _) ->
1885
          `SrcRepo, cs
1886
      | Test (cs, _) ->
1887
          `Test, cs
1888
      | Doc (cs, _) ->
1889
          `Doc, cs
1890

    
1891

    
1892
  let section_common sct =
1893
    snd (section_kind_common sct)
1894

    
1895

    
1896
  let section_common_set cs =
1897
    function
1898
      | Library (_, bs, lib)     -> Library (cs, bs, lib)
1899
      | Object (_, bs, obj)      -> Object (cs, bs, obj)
1900
      | Executable (_, bs, exec) -> Executable (cs, bs, exec)
1901
      | Flag (_, flg)            -> Flag (cs, flg)
1902
      | SrcRepo (_, src_repo)    -> SrcRepo (cs, src_repo)
1903
      | Test (_, tst)            -> Test (cs, tst)
1904
      | Doc (_, doc)             -> Doc (cs, doc)
1905

    
1906

    
1907
  (** Key used to identify section
1908
    *)
1909
  let section_id sct =
1910
    let k, cs =
1911
      section_kind_common sct
1912
    in
1913
      k, cs.cs_name
1914

    
1915

    
1916
  let string_of_section sct =
1917
    let k, nm =
1918
      section_id sct
1919
    in
1920
      (match k with
1921
         | `Library    -> "library"
1922
         | `Object     -> "object"
1923
         | `Executable -> "executable"
1924
         | `Flag       -> "flag"
1925
         | `SrcRepo    -> "src repository"
1926
         | `Test       -> "test"
1927
         | `Doc        -> "doc")
1928
      ^" "^nm
1929

    
1930

    
1931
  let section_find id scts =
1932
    List.find
1933
      (fun sct -> id = section_id sct)
1934
      scts
1935

    
1936

    
1937
  module CSection =
1938
  struct
1939
    type t = section
1940

    
1941
    let id = section_id
1942

    
1943
    let compare t1 t2 =
1944
      compare (id t1) (id t2)
1945

    
1946
    let equal t1 t2 =
1947
      (id t1) = (id t2)
1948

    
1949
    let hash t =
1950
      Hashtbl.hash (id t)
1951
  end
1952

    
1953

    
1954
  module MapSection = Map.Make(CSection)
1955
  module SetSection = Set.Make(CSection)
1956

    
1957

    
1958
end
1959

    
1960
module OASISBuildSection = struct
1961
(* # 22 "src/oasis/OASISBuildSection.ml" *)
1962

    
1963

    
1964
end
1965

    
1966
module OASISExecutable = struct
1967
(* # 22 "src/oasis/OASISExecutable.ml" *)
1968

    
1969

    
1970
  open OASISTypes
1971

    
1972

    
1973
  let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program =
1974
    let dir =
1975
      OASISUnixPath.concat
1976
        bs.bs_path
1977
        (OASISUnixPath.dirname exec.exec_main_is)
1978
    in
1979
    let is_native_exec =
1980
      match bs.bs_compiled_object with
1981
        | Native -> true
1982
        | Best -> is_native ()
1983
        | Byte -> false
1984
    in
1985

    
1986
      OASISUnixPath.concat
1987
        dir
1988
        (cs.cs_name^(suffix_program ())),
1989

    
1990
      if not is_native_exec &&
1991
         not exec.exec_custom &&
1992
         bs.bs_c_sources <> [] then
1993
        Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ()))
1994
      else
1995
        None
1996

    
1997

    
1998
end
1999

    
2000
module OASISLibrary = struct
2001
(* # 22 "src/oasis/OASISLibrary.ml" *)
2002

    
2003

    
2004
  open OASISTypes
2005
  open OASISUtils
2006
  open OASISGettext
2007
  open OASISSection
2008

    
2009

    
2010
  (* Look for a module file, considering capitalization or not. *)
2011
  let find_module source_file_exists bs modul =
2012
    let possible_base_fn =
2013
      List.map
2014
        (OASISUnixPath.concat bs.bs_path)
2015
        [modul;
2016
         OASISUnixPath.uncapitalize_file modul;
2017
         OASISUnixPath.capitalize_file modul]
2018
    in
2019
      (* TODO: we should be able to be able to determine the source for every
2020
       * files. Hence we should introduce a Module(source: fn) for the fields
2021
       * Modules and InternalModules
2022
       *)
2023
      List.fold_left
2024
        (fun acc base_fn ->
2025
           match acc with
2026
             | `No_sources _ ->
2027
                 begin
2028
                   let file_found =
2029
                     List.fold_left
2030
                       (fun acc ext ->
2031
                          if source_file_exists (base_fn^ext) then
2032
                            (base_fn^ext) :: acc
2033
                          else
2034
                            acc)
2035
                       []
2036
                       [".ml"; ".mli"; ".mll"; ".mly"]
2037
                   in
2038
                     match file_found with
2039
                       | [] ->
2040
                           acc
2041
                       | lst ->
2042
                           `Sources (base_fn, lst)
2043
                 end
2044
             | `Sources _ ->
2045
                 acc)
2046
        (`No_sources possible_base_fn)
2047
        possible_base_fn
2048

    
2049

    
2050
  let source_unix_files ~ctxt (cs, bs, lib) source_file_exists =
2051
    List.fold_left
2052
      (fun acc modul ->
2053
         match find_module source_file_exists bs modul with
2054
           | `Sources (base_fn, lst) ->
2055
               (base_fn, lst) :: acc
2056
           | `No_sources _ ->
2057
               OASISMessage.warning
2058
                 ~ctxt
2059
                 (f_ "Cannot find source file matching \
2060
                      module '%s' in library %s")
2061
                 modul cs.cs_name;
2062
               acc)
2063
      []
2064
      (lib.lib_modules @ lib.lib_internal_modules)
2065

    
2066

    
2067
  let generated_unix_files
2068
        ~ctxt
2069
        ~is_native
2070
        ~has_native_dynlink
2071
        ~ext_lib
2072
        ~ext_dll
2073
        ~source_file_exists
2074
        (cs, bs, lib) =
2075

    
2076
    let find_modules lst ext =
2077
      let find_module modul =
2078
        match find_module source_file_exists bs modul with
2079
          | `Sources (base_fn, [fn]) when ext <> "cmi"
2080
                                       && Filename.check_suffix fn ".mli" ->
2081
              None (* No implementation files for pure interface. *)
2082
          | `Sources (base_fn, _) ->
2083
              Some [base_fn]
2084
          | `No_sources lst ->
2085
              OASISMessage.warning
2086
                ~ctxt
2087
                (f_ "Cannot find source file matching \
2088
                     module '%s' in library %s")
2089
                modul cs.cs_name;
2090
              Some lst
2091
      in
2092
      List.fold_left
2093
        (fun acc nm ->
2094
          match find_module nm with
2095
            | None -> acc
2096
            | Some base_fns ->
2097
                List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc)
2098
        []
2099
        lst
2100
    in
2101

    
2102
    (* The headers that should be compiled along *)
2103
    let headers =
2104
      if lib.lib_pack then
2105
        []
2106
      else
2107
        find_modules
2108
          lib.lib_modules
2109
          "cmi"
2110
    in
2111

    
2112
    (* The .cmx that be compiled along *)
2113
    let cmxs =
2114
      let should_be_built =
2115
        match bs.bs_compiled_object with
2116
          | Native -> true
2117
          | Best -> is_native
2118
          | Byte -> false
2119
      in
2120
        if should_be_built then
2121
          if lib.lib_pack then
2122
            find_modules
2123
              [cs.cs_name]
2124
              "cmx"
2125
          else
2126
            find_modules
2127
              (lib.lib_modules @ lib.lib_internal_modules)
2128
              "cmx"
2129
        else
2130
          []
2131
    in
2132

    
2133
    let acc_nopath =
2134
      []
2135
    in
2136

    
2137
    (* Compute what libraries should be built *)
2138
    let acc_nopath =
2139
      (* Add the packed header file if required *)
2140
      let add_pack_header acc =
2141
        if lib.lib_pack then
2142
          [cs.cs_name^".cmi"] :: acc
2143
        else
2144
          acc
2145
      in
2146
      let byte acc =
2147
        add_pack_header ([cs.cs_name^".cma"] :: acc)
2148
      in
2149
      let native acc =
2150
        let acc =
2151
          add_pack_header
2152
            (if has_native_dynlink then
2153
               [cs.cs_name^".cmxs"] :: acc
2154
             else acc)
2155
        in
2156
          [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc
2157
      in
2158
        match bs.bs_compiled_object with
2159
          | Native ->
2160
              byte (native acc_nopath)
2161
          | Best when is_native ->
2162
              byte (native acc_nopath)
2163
          | Byte | Best ->
2164
              byte acc_nopath
2165
    in
2166

    
2167
    (* Add C library to be built *)
2168
    let acc_nopath =
2169
      if bs.bs_c_sources <> [] then
2170
        begin
2171
          ["lib"^cs.cs_name^"_stubs"^ext_lib]
2172
          ::
2173
          ["dll"^cs.cs_name^"_stubs"^ext_dll]
2174
          ::
2175
          acc_nopath
2176
        end
2177
      else
2178
        acc_nopath
2179
    in
2180

    
2181
      (* All the files generated *)
2182
      List.rev_append
2183
        (List.rev_map
2184
           (List.rev_map
2185
              (OASISUnixPath.concat bs.bs_path))
2186
           acc_nopath)
2187
        (headers @ cmxs)
2188

    
2189

    
2190
end
2191

    
2192
module OASISObject = struct
2193
(* # 22 "src/oasis/OASISObject.ml" *)
2194

    
2195

    
2196
  open OASISTypes
2197
  open OASISGettext
2198

    
2199

    
2200
  let source_unix_files ~ctxt (cs, bs, obj) source_file_exists =
2201
    List.fold_left
2202
      (fun acc modul ->
2203
         match OASISLibrary.find_module source_file_exists bs modul with
2204
           | `Sources (base_fn, lst) ->
2205
               (base_fn, lst) :: acc
2206
           | `No_sources _ ->
2207
               OASISMessage.warning
2208
                 ~ctxt
2209
                 (f_ "Cannot find source file matching \
2210
                      module '%s' in object %s")
2211
                 modul cs.cs_name;
2212
               acc)
2213
      []
2214
      obj.obj_modules
2215

    
2216

    
2217
  let generated_unix_files
2218
        ~ctxt
2219
        ~is_native
2220
        ~source_file_exists
2221
        (cs, bs, obj) =
2222

    
2223
    let find_module ext modul =
2224
      match OASISLibrary.find_module source_file_exists bs modul with
2225
        | `Sources (base_fn, _) -> [base_fn ^ ext]
2226
        | `No_sources lst ->
2227
          OASISMessage.warning
2228
            ~ctxt
2229
            (f_ "Cannot find source file matching \
2230
                 module '%s' in object %s")
2231
            modul cs.cs_name ;
2232
          lst
2233
    in
2234

    
2235
    let header, byte, native, c_object, f =
2236
      match obj.obj_modules with
2237
        | [ m ] -> (find_module ".cmi" m,
2238
                    find_module ".cmo" m,
2239
                    find_module ".cmx" m,
2240
                    find_module ".o" m,
2241
                    fun x -> x)
2242
        | _ -> ([cs.cs_name ^ ".cmi"],
2243
                [cs.cs_name ^ ".cmo"],
2244
                [cs.cs_name ^ ".cmx"],
2245
                [cs.cs_name ^ ".o"],
2246
                OASISUnixPath.concat bs.bs_path)
2247
    in
2248
      List.map (List.map f) (
2249
        match bs.bs_compiled_object with
2250
          | Native ->
2251
              native :: c_object :: byte :: header :: []
2252
          | Best when is_native ->
2253
              native :: c_object :: byte :: header :: []
2254
          | Byte | Best ->
2255
              byte :: header :: [])
2256

    
2257

    
2258
end
2259

    
2260
module OASISFindlib = struct
2261
(* # 22 "src/oasis/OASISFindlib.ml" *)
2262

    
2263

    
2264
  open OASISTypes
2265
  open OASISUtils
2266
  open OASISGettext
2267
  open OASISSection
2268

    
2269

    
2270
  type library_name = name
2271
  type findlib_part_name = name
2272
  type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t
2273

    
2274

    
2275
  exception InternalLibraryNotFound of library_name
2276
  exception FindlibPackageNotFound of findlib_name
2277

    
2278

    
2279
  type group_t =
2280
    | Container of findlib_name * group_t list
2281
    | Package of (findlib_name *
2282
                  common_section *
2283
                  build_section *
2284
                  [`Library of library | `Object of object_] *
2285
                  group_t list)
2286

    
2287

    
2288
  type data = common_section *
2289
              build_section *
2290
              [`Library of library | `Object of object_]
2291
  type tree =
2292
    | Node of (data option) * (tree MapString.t)
2293
    | Leaf of data
2294

    
2295

    
2296
  let findlib_mapping pkg =
2297
    (* Map from library name to either full findlib name or parts + parent. *)
2298
    let fndlb_parts_of_lib_name =
2299
      let fndlb_parts cs lib =
2300
        let name =
2301
          match lib.lib_findlib_name with
2302
            | Some nm -> nm
2303
            | None -> cs.cs_name
2304
        in
2305
        let name =
2306
          String.concat "." (lib.lib_findlib_containers @ [name])
2307
        in
2308
          name
2309
      in
2310
        List.fold_left
2311
          (fun mp ->
2312
             function
2313
               | Library (cs, _, lib) ->
2314
                   begin
2315
                     let lib_name = cs.cs_name in
2316
                     let fndlb_parts = fndlb_parts cs lib in
2317
                       if MapString.mem lib_name mp then
2318
                         failwithf
2319
                           (f_ "The library name '%s' is used more than once.")
2320
                           lib_name;
2321
                       match lib.lib_findlib_parent with
2322
                         | Some lib_name_parent ->
2323
                             MapString.add
2324
                               lib_name
2325
                               (`Unsolved (lib_name_parent, fndlb_parts))
2326
                               mp
2327
                         | None ->
2328
                             MapString.add
2329
                               lib_name
2330
                               (`Solved fndlb_parts)
2331
                               mp
2332
                   end
2333

    
2334
               | Object (cs, _, obj) ->
2335
                   begin
2336
                     let obj_name = cs.cs_name in
2337
                     if MapString.mem obj_name mp then
2338
                       failwithf
2339
                         (f_ "The object name '%s' is used more than once.")
2340
                         obj_name;
2341
                     let findlib_full_name = match obj.obj_findlib_fullname with
2342
                       | Some ns -> String.concat "." ns
2343
                       | None -> obj_name
2344
                     in
2345
                     MapString.add
2346
                       obj_name
2347
                       (`Solved findlib_full_name)
2348
                       mp
2349
                   end
2350

    
2351
               | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ ->
2352
                   mp)
2353
          MapString.empty
2354
          pkg.sections
2355
    in
2356

    
2357
    (* Solve the above graph to be only library name to full findlib name. *)
2358
    let fndlb_name_of_lib_name =
2359
      let rec solve visited mp lib_name lib_name_child =
2360
        if SetString.mem lib_name visited then
2361
          failwithf
2362
            (f_ "Library '%s' is involved in a cycle \
2363
                 with regard to findlib naming.")
2364
            lib_name;
2365
        let visited = SetString.add lib_name visited in
2366
          try
2367
            match MapString.find lib_name mp with
2368
              | `Solved fndlb_nm ->
2369
                  fndlb_nm, mp
2370
              | `Unsolved (lib_nm_parent, post_fndlb_nm) ->
2371
                  let pre_fndlb_nm, mp =
2372
                    solve visited mp lib_nm_parent lib_name
2373
                  in
2374
                  let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in
2375
                    fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp
2376
          with Not_found ->
2377
            failwithf
2378
              (f_ "Library '%s', which is defined as the findlib parent of \
2379
                   library '%s', doesn't exist.")
2380
              lib_name lib_name_child
2381
      in
2382
      let mp =
2383
        MapString.fold
2384
          (fun lib_name status mp ->
2385
             match status with
2386
               | `Solved _ ->
2387
                   (* Solved initialy, no need to go further *)
2388
                   mp
2389
               | `Unsolved _ ->
2390
                   let _, mp = solve SetString.empty mp lib_name "<none>" in
2391
                     mp)
2392
          fndlb_parts_of_lib_name
2393
          fndlb_parts_of_lib_name
2394
      in
2395
        MapString.map
2396
          (function
2397
             | `Solved fndlb_nm -> fndlb_nm
2398
             | `Unsolved _ -> assert false)
2399
          mp
2400
    in
2401

    
2402
    (* Convert an internal library name to a findlib name. *)
2403
    let findlib_name_of_library_name lib_nm =
2404
      try
2405
        MapString.find lib_nm fndlb_name_of_lib_name
2406
      with Not_found ->
2407
        raise (InternalLibraryNotFound lib_nm)
2408
    in
2409

    
2410
    (* Add a library to the tree.
2411
     *)
2412
    let add sct mp =
2413
      let fndlb_fullname =
2414
        let cs, _, _ = sct in
2415
        let lib_name = cs.cs_name in
2416
          findlib_name_of_library_name lib_name
2417
      in
2418
      let rec add_children nm_lst (children: tree MapString.t) =
2419
        match nm_lst with
2420
          | (hd :: tl) ->
2421
              begin
2422
                let node =
2423
                  try
2424
                    add_node tl (MapString.find hd children)
2425
                  with Not_found ->
2426
                    (* New node *)
2427
                    new_node tl
2428
                in
2429
                  MapString.add hd node children
2430
              end
2431
          | [] ->
2432
              (* Should not have a nameless library. *)
2433
              assert false
2434
      and add_node tl node =
2435
        if tl = [] then
2436
          begin
2437
            match node with
2438
              | Node (None, children) ->
2439
                  Node (Some sct, children)
2440
              | Leaf (cs', _, _) | Node (Some (cs', _, _), _) ->
2441
                  (* TODO: allow to merge Package, i.e.
2442
                   * archive(byte) = "foo.cma foo_init.cmo"
2443
                   *)
2444
                  let cs, _, _ = sct in
2445
                    failwithf
2446
                      (f_ "Library '%s' and '%s' have the same findlib name '%s'")
2447
                      cs.cs_name cs'.cs_name fndlb_fullname
2448
          end
2449
        else
2450
          begin
2451
            match node with
2452
              | Leaf data ->
2453
                  Node (Some data, add_children tl MapString.empty)
2454
              | Node (data_opt, children) ->
2455
                  Node (data_opt, add_children tl children)
2456
          end
2457
      and new_node =
2458
        function
2459
          | [] ->
2460
              Leaf sct
2461
          | hd :: tl ->
2462
              Node (None, MapString.add hd (new_node tl) MapString.empty)
2463
      in
2464
        add_children (OASISString.nsplit fndlb_fullname '.') mp
2465
    in
2466

    
2467
    let rec group_of_tree mp =
2468
      MapString.fold
2469
        (fun nm node acc ->
2470
           let cur =
2471
             match node with
2472
               | Node (Some (cs, bs, lib), children) ->
2473
                   Package (nm, cs, bs, lib, group_of_tree children)
2474
               | Node (None, children) ->
2475
                   Container (nm, group_of_tree children)
2476
               | Leaf (cs, bs, lib) ->
2477
                   Package (nm, cs, bs, lib, [])
2478
           in
2479
             cur :: acc)
2480
        mp []
2481
    in
2482

    
2483
    let group_mp =
2484
      List.fold_left
2485
        (fun mp ->
2486
           function
2487
             | Library (cs, bs, lib) ->
2488
                 add (cs, bs, `Library lib) mp
2489
             | Object (cs, bs, obj) ->
2490
                 add (cs, bs, `Object obj) mp
2491
             | _ ->
2492
                 mp)
2493
        MapString.empty
2494
        pkg.sections
2495
    in
2496

    
2497
    let groups =
2498
      group_of_tree group_mp
2499
    in
2500

    
2501
    let library_name_of_findlib_name =
2502
      Lazy.lazy_from_fun
2503
        (fun () ->
2504
           (* Revert findlib_name_of_library_name. *)
2505
           MapString.fold
2506
             (fun k v mp -> MapString.add v k mp)
2507
             fndlb_name_of_lib_name
2508
             MapString.empty)
2509
    in
2510
    let library_name_of_findlib_name fndlb_nm =
2511
      try
2512
        MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name)
2513
      with Not_found ->
2514
        raise (FindlibPackageNotFound fndlb_nm)
2515
    in
2516

    
2517
      groups,
2518
      findlib_name_of_library_name,
2519
      library_name_of_findlib_name
2520

    
2521

    
2522
  let findlib_of_group =
2523
    function
2524
      | Container (fndlb_nm, _)
2525
      | Package (fndlb_nm, _, _, _, _) -> fndlb_nm
2526

    
2527

    
2528
  let root_of_group grp =
2529
    let rec root_lib_aux =
2530
      (* We do a DFS in the group. *)
2531
      function
2532
        | Container (_, children) ->
2533
            List.fold_left
2534
              (fun res grp ->
2535
                 if res = None then
2536
                   root_lib_aux grp
2537
                 else
2538
                   res)
2539
              None
2540
              children
2541
        | Package (_, cs, bs, lib, _) ->
2542
            Some (cs, bs, lib)
2543
    in
2544
      match root_lib_aux grp with
2545
        | Some res ->
2546
            res
2547
        | None ->
2548
            failwithf
2549
              (f_ "Unable to determine root library of findlib library '%s'")
2550
              (findlib_of_group grp)
2551

    
2552

    
2553
end
2554

    
2555
module OASISFlag = struct
2556
(* # 22 "src/oasis/OASISFlag.ml" *)
2557

    
2558

    
2559
end
2560

    
2561
module OASISPackage = struct
2562
(* # 22 "src/oasis/OASISPackage.ml" *)
2563

    
2564

    
2565
end
2566

    
2567
module OASISSourceRepository = struct
2568
(* # 22 "src/oasis/OASISSourceRepository.ml" *)
2569

    
2570

    
2571
end
2572

    
2573
module OASISTest = struct
2574
(* # 22 "src/oasis/OASISTest.ml" *)
2575

    
2576

    
2577
end
2578

    
2579
module OASISDocument = struct
2580
(* # 22 "src/oasis/OASISDocument.ml" *)
2581

    
2582

    
2583
end
2584

    
2585
module OASISExec = struct
2586
(* # 22 "src/oasis/OASISExec.ml" *)
2587

    
2588

    
2589
  open OASISGettext
2590
  open OASISUtils
2591
  open OASISMessage
2592

    
2593

    
2594
  (* TODO: I don't like this quote, it is there because $(rm) foo expands to
2595
   * 'rm -f' foo...
2596
   *)
2597
  let run ~ctxt ?f_exit_code ?(quote=true) cmd args =
2598
    let cmd =
2599
      if quote then
2600
        if Sys.os_type = "Win32" then
2601
          if String.contains cmd ' ' then
2602
            (* Double the 1st double quote... win32... sigh *)
2603
            "\""^(Filename.quote cmd)
2604
          else
2605
            cmd
2606
        else
2607
          Filename.quote cmd
2608
      else
2609
        cmd
2610
    in
2611
    let cmdline =
2612
      String.concat " " (cmd :: args)
2613
    in
2614
      info ~ctxt (f_ "Running command '%s'") cmdline;
2615
      match f_exit_code, Sys.command cmdline with
2616
        | None, 0 -> ()
2617
        | None, i ->
2618
            failwithf
2619
              (f_ "Command '%s' terminated with error code %d")
2620
              cmdline i
2621
        | Some f, i ->
2622
            f i
2623

    
2624

    
2625
  let run_read_output ~ctxt ?f_exit_code cmd args =
2626
    let fn =
2627
      Filename.temp_file "oasis-" ".txt"
2628
    in
2629
      try
2630
        begin
2631
          let () =
2632
            run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn])
2633
          in
2634
          let chn =
2635
            open_in fn
2636
          in
2637
          let routput =
2638
            ref []
2639
          in
2640
            begin
2641
              try
2642
                while true do
2643
                  routput := (input_line chn) :: !routput
2644
                done
2645
              with End_of_file ->
2646
                ()
2647
            end;
2648
            close_in chn;
2649
            Sys.remove fn;
2650
            List.rev !routput
2651
        end
2652
      with e ->
2653
        (try Sys.remove fn with _ -> ());
2654
        raise e
2655

    
2656

    
2657
  let run_read_one_line ~ctxt ?f_exit_code cmd args =
2658
    match run_read_output ~ctxt ?f_exit_code cmd args with
2659
      | [fst] ->
2660
          fst
2661
      | lst ->
2662
          failwithf
2663
            (f_ "Command return unexpected output %S")
2664
            (String.concat "\n" lst)
2665
end
2666

    
2667
module OASISFileUtil = struct
2668
(* # 22 "src/oasis/OASISFileUtil.ml" *)
2669

    
2670

    
2671
  open OASISGettext
2672

    
2673

    
2674
  let file_exists_case fn =
2675
    let dirname = Filename.dirname fn in
2676
    let basename = Filename.basename fn in
2677
      if Sys.file_exists dirname then
2678
        if basename = Filename.current_dir_name then
2679
          true
2680
        else
2681
          List.mem
2682
            basename
2683
            (Array.to_list (Sys.readdir dirname))
2684
      else
2685
        false
2686

    
2687

    
2688
  let find_file ?(case_sensitive=true) paths exts =
2689

    
2690
    (* Cardinal product of two list *)
2691
    let ( * ) lst1 lst2 =
2692
      List.flatten
2693
        (List.map
2694
           (fun a ->
2695
              List.map
2696
                (fun b -> a, b)
2697
                lst2)
2698
           lst1)
2699
    in
2700

    
2701
    let rec combined_paths lst =
2702
      match lst with
2703
        | p1 :: p2 :: tl ->
2704
            let acc =
2705
              (List.map
2706
                 (fun (a, b) -> Filename.concat a b)
2707
                 (p1 * p2))
2708
            in
2709
              combined_paths (acc :: tl)
2710
        | [e] ->
2711
            e
2712
        | [] ->
2713
            []
2714
    in
2715

    
2716
    let alternatives =
2717
      List.map
2718
        (fun (p, e) ->
2719
           if String.length e > 0 && e.[0] <> '.' then
2720
             p ^ "." ^ e
2721
           else
2722
             p ^ e)
2723
        ((combined_paths paths) * exts)
2724
    in
2725
      List.find (fun file ->
2726
        (if case_sensitive then
2727
           file_exists_case file
2728
         else
2729
           Sys.file_exists file)
2730
        && not (Sys.is_directory file)
2731
      ) alternatives
2732

    
2733

    
2734
  let which ~ctxt prg =
2735
    let path_sep =
2736
      match Sys.os_type with
2737
        | "Win32" ->
2738
            ';'
2739
        | _ ->
2740
            ':'
2741
    in
2742
    let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in
2743
    let exec_ext =
2744
      match Sys.os_type with
2745
        | "Win32" ->
2746
            "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep)
2747
        | _ ->
2748
            [""]
2749
    in
2750
      find_file ~case_sensitive:false [path_lst; [prg]] exec_ext
2751

    
2752

    
2753
  (**/**)
2754
  let rec fix_dir dn =
2755
    (* Windows hack because Sys.file_exists "src\\" = false when
2756
     * Sys.file_exists "src" = true
2757
     *)
2758
    let ln =
2759
      String.length dn
2760
    in
2761
      if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then
2762
        fix_dir (String.sub dn 0 (ln - 1))
2763
      else
2764
        dn
2765

    
2766

    
2767
  let q = Filename.quote
2768
  (**/**)
2769

    
2770

    
2771
  let cp ~ctxt ?(recurse=false) src tgt =
2772
    if recurse then
2773
      match Sys.os_type with
2774
        | "Win32" ->
2775
            OASISExec.run ~ctxt
2776
              "xcopy" [q src; q tgt; "/E"]
2777
        | _ ->
2778
            OASISExec.run ~ctxt
2779
              "cp" ["-r"; q src; q tgt]
2780
    else
2781
      OASISExec.run ~ctxt
2782
        (match Sys.os_type with
2783
         | "Win32" -> "copy"
2784
         | _ -> "cp")
2785
        [q src; q tgt]
2786

    
2787

    
2788
  let mkdir ~ctxt tgt =
2789
    OASISExec.run ~ctxt
2790
      (match Sys.os_type with
2791
         | "Win32" -> "md"
2792
         | _ -> "mkdir")
2793
      [q tgt]
2794

    
2795

    
2796
  let rec mkdir_parent ~ctxt f tgt =
2797
    let tgt =
2798
      fix_dir tgt
2799
    in
2800
      if Sys.file_exists tgt then
2801
        begin
2802
          if not (Sys.is_directory tgt) then
2803
            OASISUtils.failwithf
2804
              (f_ "Cannot create directory '%s', a file of the same name already \
2805
                   exists")
2806
              tgt
2807
        end
2808
      else
2809
        begin
2810
          mkdir_parent ~ctxt f (Filename.dirname tgt);
2811
          if not (Sys.file_exists tgt) then
2812
            begin
2813
              f tgt;
2814
              mkdir ~ctxt tgt
2815
            end
2816
        end
2817

    
2818

    
2819
  let rmdir ~ctxt tgt =
2820
    if Sys.readdir tgt = [||] then begin
2821
      match Sys.os_type with
2822
        | "Win32" ->
2823
            OASISExec.run ~ctxt "rd" [q tgt]
2824
        | _ ->
2825
            OASISExec.run ~ctxt "rm" ["-r"; q tgt]
2826
    end else begin
2827
      OASISMessage.error ~ctxt
2828
        (f_ "Cannot remove directory '%s': not empty.")
2829
        tgt
2830
    end
2831

    
2832

    
2833
  let glob ~ctxt fn =
2834
   let basename =
2835
     Filename.basename fn
2836
   in
2837
     if String.length basename >= 2 &&
2838
        basename.[0] = '*' &&
2839
        basename.[1] = '.' then
2840
       begin
2841
         let ext_len =
2842
           (String.length basename) - 2
2843
         in
2844
         let ext =
2845
           String.sub basename 2 ext_len
2846
         in
2847
         let dirname =
2848
           Filename.dirname fn
2849
         in
2850
           Array.fold_left
2851
             (fun acc fn ->
2852
                try
2853
                  let fn_ext =
2854
                    String.sub
2855
                      fn
2856
                      ((String.length fn) - ext_len)
2857
                      ext_len
2858
                  in
2859
                    if fn_ext = ext then
2860
                      (Filename.concat dirname fn) :: acc
2861
                    else
2862
                      acc
2863
                with Invalid_argument _ ->
2864
                  acc)
2865
             []
2866
             (Sys.readdir dirname)
2867
       end
2868
     else
2869
       begin
2870
         if file_exists_case fn then
2871
           [fn]
2872
         else
2873
           []
2874
       end
2875
end
2876

    
2877

    
2878
# 2878 "setup.ml"
2879
module BaseEnvLight = struct
2880
(* # 22 "src/base/BaseEnvLight.ml" *)
2881

    
2882

    
2883
  module MapString = Map.Make(String)
2884

    
2885

    
2886
  type t = string MapString.t
2887

    
2888

    
2889
  let default_filename =
2890
    Filename.concat
2891
      (Sys.getcwd ())
2892
      "setup.data"
2893

    
2894

    
2895
  let load ?(allow_empty=false) ?(filename=default_filename) () =
2896
    if Sys.file_exists filename then
2897
      begin
2898
        let chn =
2899
          open_in_bin filename
2900
        in
2901
        let st =
2902
          Stream.of_channel chn
2903
        in
2904
        let line =
2905
          ref 1
2906
        in
2907
        let st_line =
2908
          Stream.from
2909
            (fun _ ->
2910
               try
2911
                 match Stream.next st with
2912
                   | '\n' -> incr line; Some '\n'
2913
                   | c -> Some c
2914
               with Stream.Failure -> None)
2915
        in
2916
        let lexer =
2917
          Genlex.make_lexer ["="] st_line
2918
        in
2919
        let rec read_file mp =
2920
          match Stream.npeek 3 lexer with
2921
            | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] ->
2922
                Stream.junk lexer;
2923
                Stream.junk lexer;
2924
                Stream.junk lexer;
2925
                read_file (MapString.add nm value mp)
2926
            | [] ->
2927
                mp
2928
            | _ ->
2929
                failwith
2930
                  (Printf.sprintf
2931
                     "Malformed data file '%s' line %d"
2932
                     filename !line)
2933
        in
2934
        let mp =
2935
          read_file MapString.empty
2936
        in
2937
          close_in chn;
2938
          mp
2939
      end
2940
    else if allow_empty then
2941
      begin
2942
        MapString.empty
2943
      end
2944
    else
2945
      begin
2946
        failwith
2947
          (Printf.sprintf
2948
             "Unable to load environment, the file '%s' doesn't exist."
2949
             filename)
2950
      end
2951

    
2952

    
2953
  let rec var_expand str env =
2954
    let buff =
2955
      Buffer.create ((String.length str) * 2)
2956
    in
2957
      Buffer.add_substitute
2958
        buff
2959
        (fun var ->
2960
           try
2961
             var_expand (MapString.find var env) env
2962
           with Not_found ->
2963
             failwith
2964
               (Printf.sprintf
2965
                  "No variable %s defined when trying to expand %S."
2966
                  var
2967
                  str))
2968
        str;
2969
      Buffer.contents buff
2970

    
2971

    
2972
  let var_get name env =
2973
    var_expand (MapString.find name env) env
2974

    
2975

    
2976
  let var_choose lst env =
2977
    OASISExpr.choose
2978
      (fun nm -> var_get nm env)
2979
      lst
2980
end
2981

    
2982

    
2983
# 2983 "setup.ml"
2984
module BaseContext = struct
2985
(* # 22 "src/base/BaseContext.ml" *)
2986

    
2987
  (* TODO: get rid of this module. *)
2988
  open OASISContext
2989

    
2990

    
2991
  let args () = fst (fspecs ())
2992

    
2993

    
2994
  let default = default
2995

    
2996
end
2997

    
2998
module BaseMessage = struct
2999
(* # 22 "src/base/BaseMessage.ml" *)
3000

    
3001

    
3002
  (** Message to user, overrid for Base
3003
      @author Sylvain Le Gall
3004
    *)
3005
  open OASISMessage
3006
  open BaseContext
3007

    
3008

    
3009
  let debug fmt   = debug ~ctxt:!default fmt
3010

    
3011

    
3012
  let info fmt    = info ~ctxt:!default fmt
3013

    
3014

    
3015
  let warning fmt = warning ~ctxt:!default fmt
3016

    
3017

    
3018
  let error fmt = error ~ctxt:!default fmt
3019

    
3020
end
3021

    
3022
module BaseEnv = struct
3023
(* # 22 "src/base/BaseEnv.ml" *)
3024

    
3025
  open OASISGettext
3026
  open OASISUtils
3027
  open PropList
3028

    
3029

    
3030
  module MapString = BaseEnvLight.MapString
3031

    
3032

    
3033
  type origin_t =
3034
    | ODefault
3035
    | OGetEnv
3036
    | OFileLoad
3037
    | OCommandLine
3038

    
3039

    
3040
  type cli_handle_t =
3041
    | CLINone
3042
    | CLIAuto
3043
    | CLIWith
3044
    | CLIEnable
3045
    | CLIUser of (Arg.key * Arg.spec * Arg.doc) list
3046

    
3047

    
3048
  type definition_t =
3049
      {
3050
        hide:       bool;
3051
        dump:       bool;
3052
        cli:        cli_handle_t;
3053
        arg_help:   string option;
3054
        group:      string option;
3055
      }
3056

    
3057

    
3058
  let schema =
3059
    Schema.create "environment"
3060

    
3061

    
3062
  (* Environment data *)
3063
  let env =
3064
    Data.create ()
3065

    
3066

    
3067
  (* Environment data from file *)
3068
  let env_from_file =
3069
    ref MapString.empty
3070

    
3071

    
3072
  (* Lexer for var *)
3073
  let var_lxr =
3074
    Genlex.make_lexer []
3075

    
3076

    
3077
  let rec var_expand str =
3078
    let buff =
3079
      Buffer.create ((String.length str) * 2)
3080
    in
3081
      Buffer.add_substitute
3082
        buff
3083
        (fun var ->
3084
           try
3085
             (* TODO: this is a quick hack to allow calling Test.Command
3086
              * without defining executable name really. I.e. if there is
3087
              * an exec Executable toto, then $(toto) should be replace
3088
              * by its real name. It is however useful to have this function
3089
              * for other variable that depend on the host and should be
3090
              * written better than that.
3091
              *)
3092
             let st =
3093
               var_lxr (Stream.of_string var)
3094
             in
3095
               match Stream.npeek 3 st with
3096
                 | [Genlex.Ident "utoh"; Genlex.Ident nm] ->
3097
                     OASISHostPath.of_unix (var_get nm)
3098
                 | [Genlex.Ident "utoh"; Genlex.String s] ->
3099
                     OASISHostPath.of_unix s
3100
                 | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] ->
3101
                     String.escaped (var_get nm)
3102
                 | [Genlex.Ident "ocaml_escaped"; Genlex.String s] ->
3103
                     String.escaped s
3104
                 | [Genlex.Ident nm] ->
3105
                     var_get nm
3106
                 | _ ->
3107
                     failwithf
3108
                       (f_ "Unknown expression '%s' in variable expansion of %s.")
3109
                       var
3110
                       str
3111
           with
3112
             | Unknown_field (_, _) ->
3113
                 failwithf
3114
                   (f_ "No variable %s defined when trying to expand %S.")
3115
                   var
3116
                   str
3117
             | Stream.Error e ->
3118
                 failwithf
3119
                   (f_ "Syntax error when parsing '%s' when trying to \
3120
                        expand %S: %s")
3121
                   var
3122
                   str
3123
                   e)
3124
        str;
3125
      Buffer.contents buff
3126

    
3127

    
3128
  and var_get name =
3129
    let vl =
3130
      try
3131
        Schema.get schema env name
3132
      with Unknown_field _ as e ->
3133
        begin
3134
          try
3135
            MapString.find name !env_from_file
3136
          with Not_found ->
3137
            raise e
3138
        end
3139
    in
3140
      var_expand vl
3141

    
3142

    
3143
  let var_choose ?printer ?name lst =
3144
    OASISExpr.choose
3145
      ?printer
3146
      ?name
3147
      var_get
3148
      lst
3149

    
3150

    
3151
  let var_protect vl =
3152
    let buff =
3153
      Buffer.create (String.length vl)
3154
    in
3155
      String.iter
3156
        (function
3157
           | '$' -> Buffer.add_string buff "\\$"
3158
           | c   -> Buffer.add_char   buff c)
3159
        vl;
3160
      Buffer.contents buff
3161

    
3162

    
3163
  let var_define
3164
        ?(hide=false)
3165
        ?(dump=true)
3166
        ?short_desc
3167
        ?(cli=CLINone)
3168
        ?arg_help
3169
        ?group
3170
        name (* TODO: type constraint on the fact that name must be a valid OCaml
3171
                  id *)
3172
        dflt =
3173

    
3174
    let default =
3175
      [
3176
        OFileLoad, (fun () -> MapString.find name !env_from_file);
3177
        ODefault,  dflt;
3178
        OGetEnv,   (fun () -> Sys.getenv name);
3179
      ]
3180
    in
3181

    
3182
    let extra =
3183
      {
3184
        hide     = hide;
3185
        dump     = dump;
3186
        cli      = cli;
3187
        arg_help = arg_help;
3188
        group    = group;
3189
      }
3190
    in
3191

    
3192
    (* Try to find a value that can be defined
3193
     *)
3194
    let var_get_low lst =
3195
      let errors, res =
3196
        List.fold_left
3197
          (fun (errors, res) (o, v) ->
3198
             if res = None then
3199
               begin
3200
                 try
3201
                   errors, Some (v ())
3202
                 with
3203
                   | Not_found ->
3204
                        errors, res
3205
                   | Failure rsn ->
3206
                       (rsn :: errors), res
3207
                   | e ->
3208
                       (Printexc.to_string e) :: errors, res
3209
               end
3210
             else
3211
               errors, res)
3212
          ([], None)
3213
          (List.sort
3214
             (fun (o1, _) (o2, _) ->
3215
                Pervasives.compare o2 o1)
3216
             lst)
3217
      in
3218
        match res, errors with
3219
          | Some v, _ ->
3220
              v
3221
          | None, [] ->
3222
              raise (Not_set (name, None))
3223
          | None, lst ->
3224
              raise (Not_set (name, Some (String.concat (s_ ", ") lst)))
3225
    in
3226

    
3227
    let help =
3228
      match short_desc with
3229
        | Some fs -> Some fs
3230
        | None -> None
3231
    in
3232

    
3233
    let var_get_lst =
3234
      FieldRO.create
3235
        ~schema
3236
        ~name
3237
        ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s])
3238
        ~print:var_get_low
3239
        ~default
3240
        ~update:(fun ?context x old_x -> x @ old_x)
3241
        ?help
3242
        extra
3243
    in
3244

    
3245
      fun () ->
3246
        var_expand (var_get_low (var_get_lst env))
3247

    
3248

    
3249
  let var_redefine
3250
        ?hide
3251
        ?dump
3252
        ?short_desc
3253
        ?cli
3254
        ?arg_help
3255
        ?group
3256
        name
3257
        dflt =
3258
    if Schema.mem schema name then
3259
      begin
3260
        (* TODO: look suspsicious, we want to memorize dflt not dflt () *)
3261
        Schema.set schema env ~context:ODefault name (dflt ());
3262
        fun () -> var_get name
3263
      end
3264
    else
3265
      begin
3266
        var_define
3267
          ?hide
3268
          ?dump
3269
          ?short_desc
3270
          ?cli
3271
          ?arg_help
3272
          ?group
3273
          name
3274
          dflt
3275
      end
3276

    
3277

    
3278
  let var_ignore (e: unit -> string) = ()
3279

    
3280

    
3281
  let print_hidden =
3282
    var_define
3283
      ~hide:true
3284
      ~dump:false
3285
      ~cli:CLIAuto
3286
      ~arg_help:"Print even non-printable variable. (debug)"
3287
      "print_hidden"
3288
      (fun () -> "false")
3289

    
3290

    
3291
  let var_all () =
3292
    List.rev
3293
      (Schema.fold
3294
         (fun acc nm def _ ->
3295
            if not def.hide || bool_of_string (print_hidden ()) then
3296
              nm :: acc
3297
            else
3298
              acc)
3299
         []
3300
         schema)
3301

    
3302

    
3303
  let default_filename =
3304
    BaseEnvLight.default_filename
3305

    
3306

    
3307
  let load ?allow_empty ?filename () =
3308
    env_from_file := BaseEnvLight.load ?allow_empty ?filename ()
3309

    
3310

    
3311
  let unload () =
3312
    env_from_file := MapString.empty;
3313
    Data.clear env
3314

    
3315

    
3316
  let dump ?(filename=default_filename) () =
3317
    let chn =
3318
      open_out_bin filename
3319
    in
3320
    let output nm value =
3321
      Printf.fprintf chn "%s=%S\n" nm value
3322
    in
3323
    let mp_todo =
3324
      (* Dump data from schema *)
3325
      Schema.fold
3326
        (fun mp_todo nm def _ ->
3327
           if def.dump then
3328
             begin
3329
               try
3330
                 let value =
3331
                   Schema.get
3332
                     schema
3333
                     env
3334
                     nm
3335
                 in
3336
                   output nm value
3337
               with Not_set _ ->
3338
                 ()
3339
             end;
3340
           MapString.remove nm mp_todo)
3341
        !env_from_file
3342
        schema
3343
    in
3344
      (* Dump data defined outside of schema *)
3345
      MapString.iter output mp_todo;
3346

    
3347
      (* End of the dump *)
3348
      close_out chn
3349

    
3350

    
3351
  let print () =
3352
    let printable_vars =
3353
      Schema.fold
3354
        (fun acc nm def short_descr_opt ->
3355
           if not def.hide || bool_of_string (print_hidden ()) then
3356
             begin
3357
               try
3358
                 let value =
3359
                   Schema.get
3360
                     schema
3361
                     env
3362
                     nm
3363
                 in
3364
                 let txt =
3365
                   match short_descr_opt with
3366
                     | Some s -> s ()
3367
                     | None -> nm
3368
                 in
3369
                   (txt, value) :: acc
3370
               with Not_set _ ->
3371
                   acc
3372
             end
3373
           else
3374
             acc)
3375
        []
3376
        schema
3377
    in
3378
    let max_length =
3379
      List.fold_left max 0
3380
        (List.rev_map String.length
3381
           (List.rev_map fst printable_vars))
3382
    in
3383
    let dot_pad str =
3384
      String.make ((max_length - (String.length str)) + 3) '.'
3385
    in
3386

    
3387
    Printf.printf "\nConfiguration: \n";
3388
    List.iter
3389
      (fun (name, value) ->
3390
        Printf.printf "%s: %s %s\n" name (dot_pad name) value)
3391
      (List.rev printable_vars);
3392
    Printf.printf "\n%!"
3393

    
3394

    
3395
  let args () =
3396
    let arg_concat =
3397
      OASISUtils.varname_concat ~hyphen:'-'
3398
    in
3399
      [
3400
        "--override",
3401
         Arg.Tuple
3402
           (
3403
             let rvr = ref ""
3404
             in
3405
             let rvl = ref ""
3406
             in
3407
               [
3408
                 Arg.Set_string rvr;
3409
                 Arg.Set_string rvl;
3410
                 Arg.Unit
3411
                   (fun () ->
3412
                      Schema.set
3413
                        schema
3414
                        env
3415
                        ~context:OCommandLine
3416
                        !rvr
3417
                        !rvl)
3418
               ]
3419
           ),
3420
        "var+val  Override any configuration variable.";
3421

    
3422
      ]
3423
      @
3424
      List.flatten
3425
        (Schema.fold
3426
          (fun acc name def short_descr_opt ->
3427
             let var_set s =
3428
               Schema.set
3429
                 schema
3430
                 env
3431
                 ~context:OCommandLine
3432
                 name
3433
                 s
3434
             in
3435

    
3436
             let arg_name =
3437
               OASISUtils.varname_of_string ~hyphen:'-' name
3438
             in
3439

    
3440
             let hlp =
3441
               match short_descr_opt with
3442
                 | Some txt -> txt ()
3443
                 | None -> ""
3444
             in
3445

    
3446
             let arg_hlp =
3447
               match def.arg_help with
3448
                 | Some s -> s
3449
                 | None   -> "str"
3450
             in
3451

    
3452
             let default_value =
3453
               try
3454
                 Printf.sprintf
3455
                   (f_ " [%s]")
3456
                   (Schema.get
3457
                      schema
3458
                      env
3459
                      name)
3460
               with Not_set _ ->
3461
                 ""
3462
             in
3463

    
3464
             let args =
3465
               match def.cli with
3466
                 | CLINone ->
3467
                     []
3468
                 | CLIAuto ->
3469
                     [
3470
                       arg_concat "--" arg_name,
3471
                       Arg.String var_set,
3472
                       Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value
3473
                     ]
3474
                 | CLIWith ->
3475
                     [
3476
                       arg_concat "--with-" arg_name,
3477
                       Arg.String var_set,
3478
                       Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value
3479
                     ]
3480
                 | CLIEnable ->
3481
                     let dflt =
3482
                       if default_value = " [true]" then
3483
                         s_ " [default: enabled]"
3484
                       else
3485
                         s_ " [default: disabled]"
3486
                     in
3487
                       [
3488
                         arg_concat "--enable-" arg_name,
3489
                         Arg.Unit (fun () -> var_set "true"),
3490
                         Printf.sprintf (f_ " %s%s") hlp dflt;
3491

    
3492
                         arg_concat "--disable-" arg_name,
3493
                         Arg.Unit (fun () -> var_set "false"),
3494
                         Printf.sprintf (f_ " %s%s") hlp dflt
3495
                       ]
3496
                 | CLIUser lst ->
3497
                     lst
3498
             in
3499
               args :: acc)
3500
           []
3501
           schema)
3502
end
3503

    
3504
module BaseArgExt = struct
3505
(* # 22 "src/base/BaseArgExt.ml" *)
3506

    
3507

    
3508
  open OASISUtils
3509
  open OASISGettext
3510

    
3511

    
3512
  let parse argv args =
3513
      (* Simulate command line for Arg *)
3514
      let current =
3515
        ref 0
3516
      in
3517

    
3518
        try
3519
          Arg.parse_argv
3520
            ~current:current
3521
            (Array.concat [[|"none"|]; argv])
3522
            (Arg.align args)
3523
            (failwithf (f_ "Don't know what to do with arguments: '%s'"))
3524
            (s_ "configure options:")
3525
        with
3526
          | Arg.Help txt ->
3527
              print_endline txt;
3528
              exit 0
3529
          | Arg.Bad txt ->
3530
              prerr_endline txt;
3531
              exit 1
3532
end
3533

    
3534
module BaseCheck = struct
3535
(* # 22 "src/base/BaseCheck.ml" *)
3536

    
3537

    
3538
  open BaseEnv
3539
  open BaseMessage
3540
  open OASISUtils
3541
  open OASISGettext
3542

    
3543

    
3544
  let prog_best prg prg_lst =
3545
    var_redefine
3546
      prg
3547
      (fun () ->
3548
         let alternate =
3549
           List.fold_left
3550
             (fun res e ->
3551
                match res with
3552
                  | Some _ ->
3553
                      res
3554
                  | None ->
3555
                      try
3556
                        Some (OASISFileUtil.which ~ctxt:!BaseContext.default e)
3557
                      with Not_found ->
3558
                        None)
3559
             None
3560
             prg_lst
3561
         in
3562
           match alternate with
3563
             | Some prg -> prg
3564
             | None -> raise Not_found)
3565

    
3566

    
3567
  let prog prg =
3568
    prog_best prg [prg]
3569

    
3570

    
3571
  let prog_opt prg =
3572
    prog_best prg [prg^".opt"; prg]
3573

    
3574

    
3575
  let ocamlfind =
3576
    prog "ocamlfind"
3577

    
3578

    
3579
  let version
3580
        var_prefix
3581
        cmp
3582
        fversion
3583
        () =
3584
    (* Really compare version provided *)
3585
    let var =
3586
      var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp)
3587
    in
3588
      var_redefine
3589
        ~hide:true
3590
        var
3591
        (fun () ->
3592
           let version_str =
3593
             match fversion () with
3594
               | "[Distributed with OCaml]" ->
3595
                   begin
3596
                     try
3597
                       (var_get "ocaml_version")
3598
                     with Not_found ->
3599
                       warning
3600
                         (f_ "Variable ocaml_version not defined, fallback \
3601
                              to default");
3602
                       Sys.ocaml_version
3603
                   end
3604
               | res ->
3605
                   res
3606
           in
3607
           let version =
3608
             OASISVersion.version_of_string version_str
3609
           in
3610
             if OASISVersion.comparator_apply version cmp then
3611
               version_str
3612
             else
3613
               failwithf
3614
                 (f_ "Cannot satisfy version constraint on %s: %s (version: %s)")
3615
                 var_prefix
3616
                 (OASISVersion.string_of_comparator cmp)
3617
                 version_str)
3618
        ()
3619

    
3620

    
3621
  let package_version pkg =
3622
    OASISExec.run_read_one_line ~ctxt:!BaseContext.default
3623
      (ocamlfind ())
3624
      ["query"; "-format"; "%v"; pkg]
3625

    
3626

    
3627
  let package ?version_comparator pkg () =
3628
    let var =
3629
      OASISUtils.varname_concat
3630
        "pkg_"
3631
        (OASISUtils.varname_of_string pkg)
3632
    in
3633
    let findlib_dir pkg =
3634
      let dir =
3635
        OASISExec.run_read_one_line ~ctxt:!BaseContext.default
3636
          (ocamlfind ())
3637
          ["query"; "-format"; "%d"; pkg]
3638
      in
3639
        if Sys.file_exists dir && Sys.is_directory dir then
3640
          dir
3641
        else
3642
          failwithf
3643
            (f_ "When looking for findlib package %s, \
3644
                 directory %s return doesn't exist")
3645
            pkg dir
3646
    in
3647
    let vl =
3648
      var_redefine
3649
        var
3650
        (fun () -> findlib_dir pkg)
3651
        ()
3652
    in
3653
      (
3654
        match version_comparator with
3655
          | Some ver_cmp ->
3656
              ignore
3657
                (version
3658
                   var
3659
                   ver_cmp
3660
                   (fun _ -> package_version pkg)
3661
                   ())
3662
          | None ->
3663
              ()
3664
      );
3665
      vl
3666
end
3667

    
3668
module BaseOCamlcConfig = struct
3669
(* # 22 "src/base/BaseOCamlcConfig.ml" *)
3670

    
3671

    
3672
  open BaseEnv
3673
  open OASISUtils
3674
  open OASISGettext
3675

    
3676

    
3677
  module SMap = Map.Make(String)
3678

    
3679

    
3680
  let ocamlc =
3681
    BaseCheck.prog_opt "ocamlc"
3682

    
3683

    
3684
  let ocamlc_config_map =
3685
    (* Map name to value for ocamlc -config output
3686
       (name ^": "^value)
3687
     *)
3688
    let rec split_field mp lst =
3689
      match lst with
3690
        | line :: tl ->
3691
            let mp =
3692
              try
3693
                let pos_semicolon =
3694
                  String.index line ':'
3695
                in
3696
                  if pos_semicolon > 1 then
3697
                    (
3698
                      let name =
3699
                        String.sub line 0 pos_semicolon
3700
                      in
3701
                      let linelen =
3702
                        String.length line
3703
                      in
3704
                      let value =
3705
                        if linelen > pos_semicolon + 2 then
3706
                          String.sub
3707
                            line
3708
                            (pos_semicolon + 2)
3709
                            (linelen - pos_semicolon - 2)
3710
                        else
3711
                          ""
3712
                      in
3713
                        SMap.add name value mp
3714
                    )
3715
                  else
3716
                    (
3717
                      mp
3718
                    )
3719
              with Not_found ->
3720
                (
3721
                  mp
3722
                )
3723
            in
3724
              split_field mp tl
3725
        | [] ->
3726
            mp
3727
    in
3728

    
3729
    let cache =
3730
      lazy
3731
        (var_protect
3732
           (Marshal.to_string
3733
              (split_field
3734
                 SMap.empty
3735
                 (OASISExec.run_read_output
3736
                    ~ctxt:!BaseContext.default
3737
                    (ocamlc ()) ["-config"]))
3738
              []))
3739
    in
3740
      var_redefine
3741
        "ocamlc_config_map"
3742
        ~hide:true
3743
        ~dump:false
3744
        (fun () ->
3745
           (* TODO: update if ocamlc change !!! *)
3746
           Lazy.force cache)
3747

    
3748

    
3749
  let var_define nm =
3750
    (* Extract data from ocamlc -config *)
3751
    let avlbl_config_get () =
3752
      Marshal.from_string
3753
        (ocamlc_config_map ())
3754
        0
3755
    in
3756
    let chop_version_suffix s =
3757
      try
3758
        String.sub s 0 (String.index s '+')
3759
      with _ ->
3760
        s
3761
     in
3762

    
3763
    let nm_config, value_config =
3764
      match nm with
3765
        | "ocaml_version" ->
3766
            "version", chop_version_suffix
3767
        | _ -> nm, (fun x -> x)
3768
    in
3769
      var_redefine
3770
        nm
3771
        (fun () ->
3772
          try
3773
             let map =
3774
               avlbl_config_get ()
3775
             in
3776
             let value =
3777
               SMap.find nm_config map
3778
             in
3779
               value_config value
3780
           with Not_found ->
3781
             failwithf
3782
               (f_ "Cannot find field '%s' in '%s -config' output")
3783
               nm
3784
               (ocamlc ()))
3785

    
3786
end
3787

    
3788
module BaseStandardVar = struct
3789
(* # 22 "src/base/BaseStandardVar.ml" *)
3790

    
3791

    
3792
  open OASISGettext
3793
  open OASISTypes
3794
  open OASISExpr
3795
  open BaseCheck
3796
  open BaseEnv
3797

    
3798

    
3799
  let ocamlfind  = BaseCheck.ocamlfind
3800
  let ocamlc     = BaseOCamlcConfig.ocamlc
3801
  let ocamlopt   = prog_opt "ocamlopt"
3802
  let ocamlbuild = prog "ocamlbuild"
3803

    
3804

    
3805
  (**/**)
3806
  let rpkg =
3807
    ref None
3808

    
3809

    
3810
  let pkg_get () =
3811
    match !rpkg with
3812
      | Some pkg -> pkg
3813
      | None -> failwith (s_ "OASIS Package is not set")
3814

    
3815

    
3816
  let var_cond = ref []
3817

    
3818

    
3819
  let var_define_cond ~since_version f dflt =
3820
    let holder = ref (fun () -> dflt) in
3821
    let since_version =
3822
      OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version)
3823
    in
3824
      var_cond :=
3825
      (fun ver ->
3826
         if OASISVersion.comparator_apply ver since_version then
3827
           holder := f ()) :: !var_cond;
3828
      fun () -> !holder ()
3829

    
3830

    
3831
  (**/**)
3832

    
3833

    
3834
  let pkg_name =
3835
    var_define
3836
      ~short_desc:(fun () -> s_ "Package name")
3837
      "pkg_name"
3838
      (fun () -> (pkg_get ()).name)
3839

    
3840

    
3841
  let pkg_version =
3842
    var_define
3843
      ~short_desc:(fun () -> s_ "Package version")
3844
      "pkg_version"
3845
      (fun () ->
3846
         (OASISVersion.string_of_version (pkg_get ()).version))
3847

    
3848

    
3849
  let c = BaseOCamlcConfig.var_define
3850

    
3851

    
3852
  let os_type        = c "os_type"
3853
  let system         = c "system"
3854
  let architecture   = c "architecture"
3855
  let ccomp_type     = c "ccomp_type"
3856
  let ocaml_version  = c "ocaml_version"
3857

    
3858

    
3859
  (* TODO: Check standard variable presence at runtime *)
3860

    
3861

    
3862
  let standard_library_default = c "standard_library_default"
3863
  let standard_library         = c "standard_library"
3864
  let standard_runtime         = c "standard_runtime"
3865
  let bytecomp_c_compiler      = c "bytecomp_c_compiler"
3866
  let native_c_compiler        = c "native_c_compiler"
3867
  let model                    = c "model"
3868
  let ext_obj                  = c "ext_obj"
3869
  let ext_asm                  = c "ext_asm"
3870
  let ext_lib                  = c "ext_lib"
3871
  let ext_dll                  = c "ext_dll"
3872
  let default_executable_name  = c "default_executable_name"
3873
  let systhread_supported      = c "systhread_supported"
3874

    
3875

    
3876
  let flexlink =
3877
    BaseCheck.prog "flexlink"
3878

    
3879

    
3880
  let flexdll_version =
3881
    var_define
3882
      ~short_desc:(fun () -> "FlexDLL version (Win32)")
3883
      "flexdll_version"
3884
      (fun () ->
3885
         let lst =
3886
           OASISExec.run_read_output ~ctxt:!BaseContext.default
3887
             (flexlink ()) ["-help"]
3888
         in
3889
           match lst with
3890
             | line :: _ ->
3891
                 Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver)
3892
             | [] ->
3893
                 raise Not_found)
3894

    
3895

    
3896
  (**/**)
3897
  let p name hlp dflt =
3898
    var_define
3899
      ~short_desc:hlp
3900
      ~cli:CLIAuto
3901
      ~arg_help:"dir"
3902
      name
3903
      dflt
3904

    
3905

    
3906
  let (/) a b =
3907
    if os_type () = Sys.os_type then
3908
      Filename.concat a b
3909
    else if os_type () = "Unix" then
3910
      OASISUnixPath.concat a b
3911
    else
3912
      OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat")
3913
        (os_type ())
3914
  (**/**)
3915

    
3916

    
3917
  let prefix =
3918
    p "prefix"
3919
      (fun () -> s_ "Install architecture-independent files dir")
3920
      (fun () ->
3921
         match os_type () with
3922
           | "Win32" ->
3923
               let program_files =
3924
                 Sys.getenv "PROGRAMFILES"
3925
               in
3926
                 program_files/(pkg_name ())
3927
           | _ ->
3928
               "/usr/local")
3929

    
3930

    
3931
  let exec_prefix =
3932
    p "exec_prefix"
3933
      (fun () -> s_ "Install architecture-dependent files in dir")
3934
      (fun () -> "$prefix")
3935

    
3936

    
3937
  let bindir =
3938
    p "bindir"
3939
      (fun () -> s_ "User executables")
3940
      (fun () -> "$exec_prefix"/"bin")
3941

    
3942

    
3943
  let sbindir =
3944
    p "sbindir"
3945
      (fun () -> s_ "System admin executables")
3946
      (fun () -> "$exec_prefix"/"sbin")
3947

    
3948

    
3949
  let libexecdir =
3950
    p "libexecdir"
3951
      (fun () -> s_ "Program executables")
3952
      (fun () -> "$exec_prefix"/"libexec")
3953

    
3954

    
3955
  let sysconfdir =
3956
    p "sysconfdir"
3957
      (fun () -> s_ "Read-only single-machine data")
3958
      (fun () -> "$prefix"/"etc")
3959

    
3960

    
3961
  let sharedstatedir =
3962
    p "sharedstatedir"
3963
      (fun () -> s_ "Modifiable architecture-independent data")
3964
      (fun () -> "$prefix"/"com")
3965

    
3966

    
3967
  let localstatedir =
3968
    p "localstatedir"
3969
      (fun () -> s_ "Modifiable single-machine data")
3970
      (fun () -> "$prefix"/"var")
3971

    
3972

    
3973
  let libdir =
3974
    p "libdir"
3975
      (fun () -> s_ "Object code libraries")
3976
      (fun () -> "$exec_prefix"/"lib")
3977

    
3978

    
3979
  let datarootdir =
3980
    p "datarootdir"
3981
      (fun () -> s_ "Read-only arch-independent data root")
3982
      (fun () -> "$prefix"/"share")
3983

    
3984

    
3985
  let datadir =
3986
    p "datadir"
3987
      (fun () -> s_ "Read-only architecture-independent data")
3988
      (fun () -> "$datarootdir")
3989

    
3990

    
3991
  let infodir =
3992
    p "infodir"
3993
      (fun () -> s_ "Info documentation")
3994
      (fun () -> "$datarootdir"/"info")
3995

    
3996

    
3997
  let localedir =
3998
    p "localedir"
3999
      (fun () -> s_ "Locale-dependent data")
4000
      (fun () -> "$datarootdir"/"locale")
4001

    
4002

    
4003
  let mandir =
4004
    p "mandir"
4005
      (fun () -> s_ "Man documentation")
4006
      (fun () -> "$datarootdir"/"man")
4007

    
4008

    
4009
  let docdir =
4010
    p "docdir"
4011
      (fun () -> s_ "Documentation root")
4012
      (fun () -> "$datarootdir"/"doc"/"$pkg_name")
4013

    
4014

    
4015
  let htmldir =
4016
    p "htmldir"
4017
      (fun () -> s_ "HTML documentation")
4018
      (fun () -> "$docdir")
4019

    
4020

    
4021
  let dvidir =
4022
    p "dvidir"
4023
      (fun () -> s_ "DVI documentation")
4024
      (fun () -> "$docdir")
4025

    
4026

    
4027
  let pdfdir =
4028
    p "pdfdir"
4029
      (fun () -> s_ "PDF documentation")
4030
      (fun () -> "$docdir")
4031

    
4032

    
4033
  let psdir =
4034
    p "psdir"
4035
      (fun () -> s_ "PS documentation")
4036
      (fun () -> "$docdir")
4037

    
4038

    
4039
  let destdir =
4040
    p "destdir"
4041
      (fun () -> s_ "Prepend a path when installing package")
4042
      (fun () ->
4043
         raise
4044
           (PropList.Not_set
4045
              ("destdir",
4046
               Some (s_ "undefined by construct"))))
4047

    
4048

    
4049
  let findlib_version =
4050
    var_define
4051
      "findlib_version"
4052
      (fun () ->
4053
         BaseCheck.package_version "findlib")
4054

    
4055

    
4056
  let is_native =
4057
    var_define
4058
      "is_native"
4059
      (fun () ->
4060
         try
4061
           let _s: string =
4062
             ocamlopt ()
4063
           in
4064
             "true"
4065
         with PropList.Not_set _ ->
4066
           let _s: string =
4067
             ocamlc ()
4068
           in
4069
             "false")
4070

    
4071

    
4072
  let ext_program =
4073
    var_define
4074
      "suffix_program"
4075
      (fun () ->
4076
         match os_type () with
4077
           | "Win32" | "Cygwin" -> ".exe"
4078
           | _ -> "")
4079

    
4080

    
4081
  let rm =
4082
    var_define
4083
      ~short_desc:(fun () -> s_ "Remove a file.")
4084
      "rm"
4085
      (fun () ->
4086
         match os_type () with
4087
           | "Win32" -> "del"
4088
           | _ -> "rm -f")
4089

    
4090

    
4091
  let rmdir =
4092
    var_define
4093
      ~short_desc:(fun () -> s_ "Remove a directory.")
4094
      "rmdir"
4095
      (fun () ->
4096
         match os_type () with
4097
           | "Win32" -> "rd"
4098
           | _ -> "rm -rf")
4099

    
4100

    
4101
  let debug =
4102
    var_define
4103
      ~short_desc:(fun () -> s_ "Turn ocaml debug flag on")
4104
      ~cli:CLIEnable
4105
      "debug"
4106
      (fun () -> "true")
4107

    
4108

    
4109
  let profile =
4110
    var_define
4111
      ~short_desc:(fun () -> s_ "Turn ocaml profile flag on")
4112
      ~cli:CLIEnable
4113
      "profile"
4114
      (fun () -> "false")
4115

    
4116

    
4117
  let tests =
4118
    var_define_cond ~since_version:"0.3"
4119
      (fun () ->
4120
         var_define
4121
           ~short_desc:(fun () ->
4122
                          s_ "Compile tests executable and library and run them")
4123
           ~cli:CLIEnable
4124
           "tests"
4125
           (fun () -> "false"))
4126
      "true"
4127

    
4128

    
4129
  let docs =
4130
    var_define_cond ~since_version:"0.3"
4131
      (fun () ->
4132
         var_define
4133
           ~short_desc:(fun () -> s_ "Create documentations")
4134
           ~cli:CLIEnable
4135
           "docs"
4136
           (fun () -> "true"))
4137
      "true"
4138

    
4139

    
4140
  let native_dynlink =
4141
    var_define
4142
      ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.")
4143
      ~cli:CLINone
4144
      "native_dynlink"
4145
      (fun () ->
4146
         let res =
4147
           let ocaml_lt_312 () =
4148
             OASISVersion.comparator_apply
4149
               (OASISVersion.version_of_string (ocaml_version ()))
4150
               (OASISVersion.VLesser
4151
                  (OASISVersion.version_of_string "3.12.0"))
4152
           in
4153
           let flexdll_lt_030 () =
4154
             OASISVersion.comparator_apply
4155
               (OASISVersion.version_of_string (flexdll_version ()))
4156
               (OASISVersion.VLesser
4157
                  (OASISVersion.version_of_string "0.30"))
4158
           in
4159
           let has_native_dynlink =
4160
             let ocamlfind = ocamlfind () in
4161
               try
4162
                 let fn =
4163
                   OASISExec.run_read_one_line
4164
                     ~ctxt:!BaseContext.default
4165
                     ocamlfind
4166
                     ["query"; "-predicates"; "native"; "dynlink";
4167
                      "-format"; "%d/%a"]
4168
                 in
4169
                   Sys.file_exists fn
4170
               with _ ->
4171
                 false
4172
           in
4173
             if not has_native_dynlink then
4174
               false
4175
             else if ocaml_lt_312 () then
4176
               false
4177
             else if (os_type () = "Win32" || os_type () = "Cygwin")
4178
                     && flexdll_lt_030 () then
4179
               begin
4180
                 BaseMessage.warning
4181
                   (f_ ".cmxs generation disabled because FlexDLL needs to be \
4182
                        at least 0.30. Please upgrade FlexDLL from %s to 0.30.")
4183
                   (flexdll_version ());
4184
                 false
4185
               end
4186
             else
4187
               true
4188
         in
4189
           string_of_bool res)
4190

    
4191

    
4192
  let init pkg =
4193
    rpkg := Some pkg;
4194
    List.iter (fun f -> f pkg.oasis_version) !var_cond
4195

    
4196
end
4197

    
4198
module BaseFileAB = struct
4199
(* # 22 "src/base/BaseFileAB.ml" *)
4200

    
4201

    
4202
  open BaseEnv
4203
  open OASISGettext
4204
  open BaseMessage
4205

    
4206

    
4207
  let to_filename fn =
4208
    let fn =
4209
      OASISHostPath.of_unix fn
4210
    in
4211
      if not (Filename.check_suffix fn ".ab") then
4212
        warning
4213
          (f_ "File '%s' doesn't have '.ab' extension")
4214
          fn;
4215
      Filename.chop_extension fn
4216

    
4217

    
4218
  let replace fn_lst =
4219
    let buff =
4220
      Buffer.create 13
4221
    in
4222
      List.iter
4223
        (fun fn ->
4224
           let fn =
4225
             OASISHostPath.of_unix fn
4226
           in
4227
           let chn_in =
4228
             open_in fn
4229
           in
4230
           let chn_out =
4231
             open_out (to_filename fn)
4232
           in
4233
             (
4234
               try
4235
                 while true do
4236
                  Buffer.add_string buff (var_expand (input_line chn_in));
4237
                  Buffer.add_char buff '\n'
4238
                 done
4239
               with End_of_file ->
4240
                 ()
4241
             );
4242
             Buffer.output_buffer chn_out buff;
4243
             Buffer.clear buff;
4244
             close_in chn_in;
4245
             close_out chn_out)
4246
        fn_lst
4247
end
4248

    
4249
module BaseLog = struct
4250
(* # 22 "src/base/BaseLog.ml" *)
4251

    
4252

    
4253
  open OASISUtils
4254

    
4255

    
4256
  let default_filename =
4257
    Filename.concat
4258
      (Filename.dirname BaseEnv.default_filename)
4259
      "setup.log"
4260

    
4261

    
4262
  module SetTupleString =
4263
    Set.Make
4264
      (struct
4265
         type t = string * string
4266
         let compare (s11, s12) (s21, s22) =
4267
           match String.compare s11 s21 with
4268
             | 0 -> String.compare s12 s22
4269
             | n -> n
4270
       end)
4271

    
4272

    
4273
  let load () =
4274
    if Sys.file_exists default_filename then
4275
      begin
4276
        let chn =
4277
          open_in default_filename
4278
        in
4279
        let scbuf =
4280
          Scanf.Scanning.from_file default_filename
4281
        in
4282
        let rec read_aux (st, lst) =
4283
          if not (Scanf.Scanning.end_of_input scbuf) then
4284
            begin
4285
              let acc =
4286
                try
4287
                  Scanf.bscanf scbuf "%S %S\n"
4288
                    (fun e d ->
4289
                       let t =
4290
                         e, d
4291
                       in
4292
                         if SetTupleString.mem t st then
4293
                           st, lst
4294
                         else
4295
                           SetTupleString.add t st,
4296
                           t :: lst)
4297
                with Scanf.Scan_failure _ ->
4298
                  failwith
4299
                    (Scanf.bscanf scbuf
4300
                       "%l"
4301
                       (fun line ->
4302
                          Printf.sprintf
4303
                            "Malformed log file '%s' at line %d"
4304
                            default_filename
4305
                            line))
4306
              in
4307
                read_aux acc
4308
            end
4309
          else
4310
            begin
4311
              close_in chn;
4312
              List.rev lst
4313
            end
4314
        in
4315
          read_aux (SetTupleString.empty, [])
4316
      end
4317
    else
4318
      begin
4319
        []
4320
      end
4321

    
4322

    
4323
  let register event data =
4324
    let chn_out =
4325
      open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename
4326
    in
4327
      Printf.fprintf chn_out "%S %S\n" event data;
4328
      close_out chn_out
4329

    
4330

    
4331
  let unregister event data =
4332
    if Sys.file_exists default_filename then
4333
      begin
4334
        let lst =
4335
          load ()
4336
        in
4337
        let chn_out =
4338
          open_out default_filename
4339
        in
4340
        let write_something =
4341
          ref false
4342
        in
4343
          List.iter
4344
            (fun (e, d) ->
4345
               if e <> event || d <> data then
4346
                 begin
4347
                   write_something := true;
4348
                   Printf.fprintf chn_out "%S %S\n" e d
4349
                 end)
4350
            lst;
4351
          close_out chn_out;
4352
          if not !write_something then
4353
            Sys.remove default_filename
4354
      end
4355

    
4356

    
4357
  let filter events =
4358
    let st_events =
4359
      List.fold_left
4360
        (fun st e ->
4361
           SetString.add e st)
4362
        SetString.empty
4363
        events
4364
    in
4365
      List.filter
4366
        (fun (e, _) -> SetString.mem e st_events)
4367
        (load ())
4368

    
4369

    
4370
  let exists event data =
4371
    List.exists
4372
      (fun v -> (event, data) = v)
4373
      (load ())
4374
end
4375

    
4376
module BaseBuilt = struct
4377
(* # 22 "src/base/BaseBuilt.ml" *)
4378

    
4379

    
4380
  open OASISTypes
4381
  open OASISGettext
4382
  open BaseStandardVar
4383
  open BaseMessage
4384

    
4385

    
4386
  type t =
4387
    | BExec    (* Executable *)
4388
    | BExecLib (* Library coming with executable *)
4389
    | BLib     (* Library *)
4390
    | BObj     (* Library *)
4391
    | BDoc     (* Document *)
4392

    
4393

    
4394
  let to_log_event_file t nm =
4395
    "built_"^
4396
    (match t with
4397
       | BExec -> "exec"
4398
       | BExecLib -> "exec_lib"
4399
       | BLib -> "lib"
4400
       | BObj -> "obj"
4401
       | BDoc -> "doc")^
4402
    "_"^nm
4403

    
4404

    
4405
  let to_log_event_done t nm =
4406
    "is_"^(to_log_event_file t nm)
4407

    
4408

    
4409
  let register t nm lst =
4410
    BaseLog.register
4411
      (to_log_event_done t nm)
4412
      "true";
4413
    List.iter
4414
      (fun alt ->
4415
         let registered =
4416
           List.fold_left
4417
             (fun registered fn ->
4418
                if OASISFileUtil.file_exists_case fn then
4419
                  begin
4420
                    BaseLog.register
4421
                      (to_log_event_file t nm)
4422
                      (if Filename.is_relative fn then
4423
                         Filename.concat (Sys.getcwd ()) fn
4424
                       else
4425
                         fn);
4426
                    true
4427
                  end
4428
                else
4429
                  registered)
4430
             false
4431
             alt
4432
         in
4433
           if not registered then
4434
             warning
4435
               (f_ "Cannot find an existing alternative files among: %s")
4436
               (String.concat (s_ ", ") alt))
4437
      lst
4438

    
4439

    
4440
  let unregister t nm =
4441
    List.iter
4442
      (fun (e, d) ->
4443
         BaseLog.unregister e d)
4444
      (BaseLog.filter
4445
         [to_log_event_file t nm;
4446
          to_log_event_done t nm])
4447

    
4448

    
4449
  let fold t nm f acc =
4450
    List.fold_left
4451
      (fun acc (_, fn) ->
4452
         if OASISFileUtil.file_exists_case fn then
4453
           begin
4454
             f acc fn
4455
           end
4456
         else
4457
           begin
4458
             warning
4459
               (f_ "File '%s' has been marked as built \
4460
                  for %s but doesn't exist")
4461
               fn
4462
               (Printf.sprintf
4463
                  (match t with
4464
                     | BExec | BExecLib ->
4465
                         (f_ "executable %s")
4466
                     | BLib ->
4467
                         (f_ "library %s")
4468
                     | BObj ->
4469
                         (f_ "object %s")
4470
                     | BDoc ->
4471
                         (f_ "documentation %s"))
4472
                  nm);
4473
             acc
4474
           end)
4475
      acc
4476
      (BaseLog.filter
4477
         [to_log_event_file t nm])
4478

    
4479

    
4480
  let is_built t nm =
4481
    List.fold_left
4482
      (fun is_built (_, d) ->
4483
         (try
4484
            bool_of_string d
4485
          with _ ->
4486
            false))
4487
      false
4488
      (BaseLog.filter
4489
         [to_log_event_done t nm])
4490

    
4491

    
4492
  let of_executable ffn (cs, bs, exec) =
4493
    let unix_exec_is, unix_dll_opt =
4494
      OASISExecutable.unix_exec_is
4495
        (cs, bs, exec)
4496
        (fun () ->
4497
           bool_of_string
4498
             (is_native ()))
4499
        ext_dll
4500
        ext_program
4501
    in
4502
    let evs =
4503
      (BExec, cs.cs_name, [[ffn unix_exec_is]])
4504
      ::
4505
      (match unix_dll_opt with
4506
         | Some fn ->
4507
             [BExecLib, cs.cs_name, [[ffn fn]]]
4508
         | None ->
4509
             [])
4510
    in
4511
      evs,
4512
      unix_exec_is,
4513
      unix_dll_opt
4514

    
4515

    
4516
  let of_library ffn (cs, bs, lib) =
4517
    let unix_lst =
4518
      OASISLibrary.generated_unix_files
4519
        ~ctxt:!BaseContext.default
4520
        ~source_file_exists:(fun fn ->
4521
           OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn))
4522
        ~is_native:(bool_of_string (is_native ()))
4523
        ~has_native_dynlink:(bool_of_string (native_dynlink ()))
4524
        ~ext_lib:(ext_lib ())
4525
        ~ext_dll:(ext_dll ())
4526
        (cs, bs, lib)
4527
    in
4528
    let evs =
4529
      [BLib,
4530
       cs.cs_name,
4531
       List.map (List.map ffn) unix_lst]
4532
    in
4533
      evs, unix_lst
4534

    
4535

    
4536
  let of_object ffn (cs, bs, obj) =
4537
    let unix_lst =
4538
      OASISObject.generated_unix_files
4539
        ~ctxt:!BaseContext.default
4540
        ~source_file_exists:(fun fn ->
4541
           OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn))
4542
        ~is_native:(bool_of_string (is_native ()))
4543
        (cs, bs, obj)
4544
    in
4545
    let evs =
4546
      [BObj,
4547
       cs.cs_name,
4548
       List.map (List.map ffn) unix_lst]
4549
    in
4550
      evs, unix_lst
4551

    
4552
end
4553

    
4554
module BaseCustom = struct
4555
(* # 22 "src/base/BaseCustom.ml" *)
4556

    
4557

    
4558
  open BaseEnv
4559
  open BaseMessage
4560
  open OASISTypes
4561
  open OASISGettext
4562

    
4563

    
4564
  let run cmd args extra_args =
4565
    OASISExec.run ~ctxt:!BaseContext.default ~quote:false
4566
      (var_expand cmd)
4567
      (List.map
4568
         var_expand
4569
         (args @ (Array.to_list extra_args)))
4570

    
4571

    
4572
  let hook ?(failsafe=false) cstm f e =
4573
    let optional_command lst =
4574
      let printer =
4575
        function
4576
          | Some (cmd, args) -> String.concat " " (cmd :: args)
4577
          | None -> s_ "No command"
4578
      in
4579
        match
4580
          var_choose
4581
            ~name:(s_ "Pre/Post Command")
4582
            ~printer
4583
            lst with
4584
          | Some (cmd, args) ->
4585
              begin
4586
                try
4587
                  run cmd args [||]
4588
                with e when failsafe ->
4589
                  warning
4590
                    (f_ "Command '%s' fail with error: %s")
4591
                    (String.concat " " (cmd :: args))
4592
                    (match e with
4593
                       | Failure msg -> msg
4594
                       | e -> Printexc.to_string e)
4595
              end
4596
          | None ->
4597
              ()
4598
    in
4599
    let res =
4600
      optional_command cstm.pre_command;
4601
      f e
4602
    in
4603
      optional_command cstm.post_command;
4604
      res
4605
end
4606

    
4607
module BaseDynVar = struct
4608
(* # 22 "src/base/BaseDynVar.ml" *)
4609

    
4610

    
4611
  open OASISTypes
4612
  open OASISGettext
4613
  open BaseEnv
4614
  open BaseBuilt
4615

    
4616

    
4617
  let init pkg =
4618
    (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *)
4619
    (* TODO: provide compile option for library libary_byte_args_VARNAME... *)
4620
    List.iter
4621
      (function
4622
         | Executable (cs, bs, exec) ->
4623
             if var_choose bs.bs_build then
4624
               var_ignore
4625
                 (var_redefine
4626
                    (* We don't save this variable *)
4627
                    ~dump:false
4628
                    ~short_desc:(fun () ->
4629
                                   Printf.sprintf
4630
                                     (f_ "Filename of executable '%s'")
4631
                                     cs.cs_name)
4632
                    (OASISUtils.varname_of_string cs.cs_name)
4633
                    (fun () ->
4634
                       let fn_opt =
4635
                         fold
4636
                           BExec cs.cs_name
4637
                           (fun _ fn -> Some fn)
4638
                           None
4639
                       in
4640
                         match fn_opt with
4641
                           | Some fn -> fn
4642
                           | None ->
4643
                               raise
4644
                                 (PropList.Not_set
4645
                                    (cs.cs_name,
4646
                                     Some (Printf.sprintf
4647
                                             (f_ "Executable '%s' not yet built.")
4648
                                             cs.cs_name)))))
4649

    
4650
         | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ ->
4651
             ())
4652
      pkg.sections
4653
end
4654

    
4655
module BaseTest = struct
4656
(* # 22 "src/base/BaseTest.ml" *)
4657

    
4658

    
4659
  open BaseEnv
4660
  open BaseMessage
4661
  open OASISTypes
4662
  open OASISExpr
4663
  open OASISGettext
4664

    
4665

    
4666
  let test lst pkg extra_args =
4667

    
4668
    let one_test (failure, n) (test_plugin, cs, test) =
4669
      if var_choose
4670
           ~name:(Printf.sprintf
4671
                    (f_ "test %s run")
4672
                    cs.cs_name)
4673
           ~printer:string_of_bool
4674
           test.test_run then
4675
        begin
4676
          let () =
4677
            info (f_ "Running test '%s'") cs.cs_name
4678
          in
4679
          let back_cwd =
4680
            match test.test_working_directory with
4681
              | Some dir ->
4682
                  let cwd =
4683
                    Sys.getcwd ()
4684
                  in
4685
                  let chdir d =
4686
                    info (f_ "Changing directory to '%s'") d;
4687
                    Sys.chdir d
4688
                  in
4689
                    chdir dir;
4690
                    fun () -> chdir cwd
4691

    
4692
              | None ->
4693
                  fun () -> ()
4694
          in
4695
            try
4696
              let failure_percent =
4697
                BaseCustom.hook
4698
                  test.test_custom
4699
                  (test_plugin pkg (cs, test))
4700
                  extra_args
4701
              in
4702
                back_cwd ();
4703
                (failure_percent +. failure, n + 1)
4704
            with e ->
4705
              begin
4706
                back_cwd ();
4707
                raise e
4708
              end
4709
        end
4710
      else
4711
        begin
4712
          info (f_ "Skipping test '%s'") cs.cs_name;
4713
          (failure, n)
4714
        end
4715
    in
4716
    let failed, n =
4717
      List.fold_left
4718
        one_test
4719
        (0.0, 0)
4720
        lst
4721
    in
4722
    let failure_percent =
4723
      if n = 0 then
4724
        0.0
4725
      else
4726
        failed /. (float_of_int n)
4727
    in
4728
    let msg =
4729
      Printf.sprintf
4730
        (f_ "Tests had a %.2f%% failure rate")
4731
        (100. *. failure_percent)
4732
    in
4733
      if failure_percent > 0.0 then
4734
        failwith msg
4735
      else
4736
        info "%s" msg;
4737

    
4738
      (* Possible explanation why the tests where not run. *)
4739
      if OASISFeatures.package_test OASISFeatures.flag_tests pkg &&
4740
         not (bool_of_string (BaseStandardVar.tests ())) &&
4741
         lst <> [] then
4742
        BaseMessage.warning
4743
          "Tests are turned off, consider enabling with \
4744
           'ocaml setup.ml -configure --enable-tests'"
4745
end
4746

    
4747
module BaseDoc = struct
4748
(* # 22 "src/base/BaseDoc.ml" *)
4749

    
4750

    
4751
  open BaseEnv
4752
  open BaseMessage
4753
  open OASISTypes
4754
  open OASISGettext
4755

    
4756

    
4757
  let doc lst pkg extra_args =
4758

    
4759
    let one_doc (doc_plugin, cs, doc) =
4760
      if var_choose
4761
           ~name:(Printf.sprintf
4762
                   (f_ "documentation %s build")
4763
                   cs.cs_name)
4764
           ~printer:string_of_bool
4765
           doc.doc_build then
4766
        begin
4767
          info (f_ "Building documentation '%s'") cs.cs_name;
4768
          BaseCustom.hook
4769
            doc.doc_custom
4770
            (doc_plugin pkg (cs, doc))
4771
            extra_args
4772
        end
4773
    in
4774
      List.iter one_doc lst;
4775

    
4776
      if OASISFeatures.package_test OASISFeatures.flag_docs pkg &&
4777
         not (bool_of_string (BaseStandardVar.docs ())) &&
4778
         lst <> [] then
4779
        BaseMessage.warning
4780
          "Docs are turned off, consider enabling with \
4781
           'ocaml setup.ml -configure --enable-docs'"
4782
end
4783

    
4784
module BaseSetup = struct
4785
(* # 22 "src/base/BaseSetup.ml" *)
4786

    
4787
  open BaseEnv
4788
  open BaseMessage
4789
  open OASISTypes
4790
  open OASISSection
4791
  open OASISGettext
4792
  open OASISUtils
4793

    
4794

    
4795
  type std_args_fun =
4796
      package -> string array -> unit
4797

    
4798

    
4799
  type ('a, 'b) section_args_fun =
4800
      name * (package -> (common_section * 'a) -> string array -> 'b)
4801

    
4802

    
4803
  type t =
4804
      {
4805
        configure:        std_args_fun;
4806
        build:            std_args_fun;
4807
        doc:              ((doc, unit)  section_args_fun) list;
4808
        test:             ((test, float) section_args_fun) list;
4809
        install:          std_args_fun;
4810
        uninstall:        std_args_fun;
4811
        clean:            std_args_fun list;
4812
        clean_doc:        (doc, unit) section_args_fun list;
4813
        clean_test:       (test, unit) section_args_fun list;
4814
        distclean:        std_args_fun list;
4815
        distclean_doc:    (doc, unit) section_args_fun list;
4816
        distclean_test:   (test, unit) section_args_fun list;
4817
        package:          package;
4818
        oasis_fn:         string option;
4819
        oasis_version:    string;
4820
        oasis_digest:     Digest.t option;
4821
        oasis_exec:       string option;
4822
        oasis_setup_args: string list;
4823
        setup_update:     bool;
4824
      }
4825

    
4826

    
4827
  (* Associate a plugin function with data from package *)
4828
  let join_plugin_sections filter_map lst =
4829
    List.rev
4830
      (List.fold_left
4831
         (fun acc sct ->
4832
            match filter_map sct with
4833
              | Some e ->
4834
                  e :: acc
4835
              | None ->
4836
                  acc)
4837
         []
4838
         lst)
4839

    
4840

    
4841
  (* Search for plugin data associated with a section name *)
4842
  let lookup_plugin_section plugin action nm lst =
4843
    try
4844
      List.assoc nm lst
4845
    with Not_found ->
4846
      failwithf
4847
        (f_ "Cannot find plugin %s matching section %s for %s action")
4848
        plugin
4849
        nm
4850
        action
4851

    
4852

    
4853
  let configure t args =
4854
    (* Run configure *)
4855
    BaseCustom.hook
4856
      t.package.conf_custom
4857
      (fun () ->
4858
         (* Reload if preconf has changed it *)
4859
         begin
4860
           try
4861
             unload ();
4862
             load ();
4863
           with _ ->
4864
             ()
4865
         end;
4866

    
4867
         (* Run plugin's configure *)
4868
         t.configure t.package args;
4869

    
4870
         (* Dump to allow postconf to change it *)
4871
         dump ())
4872
      ();
4873

    
4874
    (* Reload environment *)
4875
    unload ();
4876
    load ();
4877

    
4878
    (* Save environment *)
4879
    print ();
4880

    
4881
    (* Replace data in file *)
4882
    BaseFileAB.replace t.package.files_ab
4883

    
4884

    
4885
  let build t args =
4886
    BaseCustom.hook
4887
      t.package.build_custom
4888
      (t.build t.package)
4889
      args
4890

    
4891

    
4892
  let doc t args =
4893
    BaseDoc.doc
4894
      (join_plugin_sections
4895
         (function
4896
            | Doc (cs, e) ->
4897
                Some
4898
                  (lookup_plugin_section
4899
                     "documentation"
4900
                     (s_ "build")
4901
                     cs.cs_name
4902
                     t.doc,
4903
                   cs,
4904
                   e)
4905
            | _ ->
4906
                None)
4907
         t.package.sections)
4908
      t.package
4909
      args
4910

    
4911

    
4912
  let test t args =
4913
    BaseTest.test
4914
      (join_plugin_sections
4915
         (function
4916
            | Test (cs, e) ->
4917
                Some
4918
                  (lookup_plugin_section
4919
                     "test"
4920
                     (s_ "run")
4921
                     cs.cs_name
4922
                     t.test,
4923
                   cs,
4924
                   e)
4925
            | _ ->
4926
                None)
4927
         t.package.sections)
4928
      t.package
4929
      args
4930

    
4931

    
4932
  let all t args =
4933
    let rno_doc =
4934
      ref false
4935
    in
4936
    let rno_test =
4937
      ref false
4938
    in
4939
    let arg_rest =
4940
      ref []
4941
    in
4942
      Arg.parse_argv
4943
        ~current:(ref 0)
4944
        (Array.of_list
4945
           ((Sys.executable_name^" all") ::
4946
            (Array.to_list args)))
4947
        [
4948
          "-no-doc",
4949
          Arg.Set rno_doc,
4950
          s_ "Don't run doc target";
4951

    
4952
          "-no-test",
4953
          Arg.Set rno_test,
4954
          s_ "Don't run test target";
4955

    
4956
          "--",
4957
          Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest),
4958
          s_ "All arguments for configure.";
4959
        ]
4960
        (failwithf (f_ "Don't know what to do with '%s'"))
4961
        "";
4962

    
4963
      info "Running configure step";
4964
      configure t (Array.of_list (List.rev !arg_rest));
4965

    
4966
      info "Running build step";
4967
      build     t [||];
4968

    
4969
      (* Load setup.log dynamic variables *)
4970
      BaseDynVar.init t.package;
4971

    
4972
      if not !rno_doc then
4973
        begin
4974
          info "Running doc step";
4975
          doc t [||];
4976
        end
4977
      else
4978
        begin
4979
          info "Skipping doc step"
4980
        end;
4981

    
4982
      if not !rno_test then
4983
        begin
4984
          info "Running test step";
4985
          test t [||]
4986
        end
4987
      else
4988
        begin
4989
          info "Skipping test step"
4990
        end
4991

    
4992

    
4993
  let install t args =
4994
    BaseCustom.hook
4995
      t.package.install_custom
4996
      (t.install t.package)
4997
      args
4998

    
4999

    
5000
  let uninstall t args =
5001
    BaseCustom.hook
5002
      t.package.uninstall_custom
5003
      (t.uninstall t.package)
5004
      args
5005

    
5006

    
5007
  let reinstall t args =
5008
    uninstall t args;
5009
    install t args
5010

    
5011

    
5012
  let clean, distclean =
5013
    let failsafe f a =
5014
      try
5015
        f a
5016
      with e ->
5017
        warning
5018
          (f_ "Action fail with error: %s")
5019
          (match e with
5020
             | Failure msg -> msg
5021
             | e -> Printexc.to_string e)
5022
    in
5023

    
5024
    let generic_clean t cstm mains docs tests args =
5025
      BaseCustom.hook
5026
        ~failsafe:true
5027
        cstm
5028
        (fun () ->
5029
           (* Clean section *)
5030
           List.iter
5031
             (function
5032
                | Test (cs, test) ->
5033
                    let f =
5034
                      try
5035
                        List.assoc cs.cs_name tests
5036
                      with Not_found ->
5037
                        fun _ _ _ -> ()
5038
                    in
5039
                      failsafe
5040
                        (f t.package (cs, test))
5041
                        args
5042
                | Doc (cs, doc) ->
5043
                    let f =
5044
                      try
5045
                        List.assoc cs.cs_name docs
5046
                      with Not_found ->
5047
                        fun _ _ _ -> ()
5048
                    in
5049
                      failsafe
5050
                        (f t.package (cs, doc))
5051
                        args
5052
                | Library _
5053
                | Object _
5054
                | Executable _
5055
                | Flag _
5056
                | SrcRepo _ ->
5057
                    ())
5058
             t.package.sections;
5059
           (* Clean whole package *)
5060
           List.iter
5061
             (fun f ->
5062
                failsafe
5063
                  (f t.package)
5064
                  args)
5065
             mains)
5066
        ()
5067
    in
5068

    
5069
    let clean t args =
5070
      generic_clean
5071
        t
5072
        t.package.clean_custom
5073
        t.clean
5074
        t.clean_doc
5075
        t.clean_test
5076
        args
5077
    in
5078

    
5079
    let distclean t args =
5080
      (* Call clean *)
5081
      clean t args;
5082

    
5083
      (* Call distclean code *)
5084
      generic_clean
5085
        t
5086
        t.package.distclean_custom
5087
        t.distclean
5088
        t.distclean_doc
5089
        t.distclean_test
5090
        args;
5091

    
5092
      (* Remove generated file *)
5093
      List.iter
5094
        (fun fn ->
5095
           if Sys.file_exists fn then
5096
             begin
5097
               info (f_ "Remove '%s'") fn;
5098
               Sys.remove fn
5099
             end)
5100
        (BaseEnv.default_filename
5101
         ::
5102
         BaseLog.default_filename
5103
         ::
5104
         (List.rev_map BaseFileAB.to_filename t.package.files_ab))
5105
    in
5106

    
5107
      clean, distclean
5108

    
5109

    
5110
  let version t _ =
5111
    print_endline t.oasis_version
5112

    
5113

    
5114
  let update_setup_ml, no_update_setup_ml_cli =
5115
    let b = ref true in
5116
      b,
5117
      ("-no-update-setup-ml",
5118
       Arg.Clear b,
5119
       s_ " Don't try to update setup.ml, even if _oasis has changed.")
5120

    
5121

    
5122
  let default_oasis_fn = "_oasis"
5123

    
5124

    
5125
  let update_setup_ml t =
5126
    let oasis_fn =
5127
      match t.oasis_fn with
5128
        | Some fn -> fn
5129
        | None -> default_oasis_fn
5130
    in
5131
    let oasis_exec =
5132
      match t.oasis_exec with
5133
        | Some fn -> fn
5134
        | None -> "oasis"
5135
    in
5136
    let ocaml =
5137
      Sys.executable_name
5138
    in
5139
    let setup_ml, args =
5140
      match Array.to_list Sys.argv with
5141
        | setup_ml :: args ->
5142
            setup_ml, args
5143
        | [] ->
5144
            failwith
5145
              (s_ "Expecting non-empty command line arguments.")
5146
    in
5147
    let ocaml, setup_ml =
5148
      if Sys.executable_name = Sys.argv.(0) then
5149
        (* We are not running in standard mode, probably the script
5150
         * is precompiled.
5151
         *)
5152
        "ocaml", "setup.ml"
5153
      else
5154
        ocaml, setup_ml
5155
    in
5156
    let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in
5157
    let do_update () =
5158
      let oasis_exec_version =
5159
        OASISExec.run_read_one_line
5160
          ~ctxt:!BaseContext.default
5161
          ~f_exit_code:
5162
          (function
5163
             | 0 ->
5164
                 ()
5165
             | 1 ->
5166
                 failwithf
5167
                   (f_ "Executable '%s' is probably an old version \
5168
                      of oasis (< 0.3.0), please update to version \
5169
                      v%s.")
5170
                   oasis_exec t.oasis_version
5171
             | 127 ->
5172
                 failwithf
5173
                   (f_ "Cannot find executable '%s', please install \
5174
                        oasis v%s.")
5175
                   oasis_exec t.oasis_version
5176
             | n ->
5177
                 failwithf
5178
                   (f_ "Command '%s version' exited with code %d.")
5179
                   oasis_exec n)
5180
          oasis_exec ["version"]
5181
      in
5182
        if OASISVersion.comparator_apply
5183
             (OASISVersion.version_of_string oasis_exec_version)
5184
             (OASISVersion.VGreaterEqual
5185
                (OASISVersion.version_of_string t.oasis_version)) then
5186
          begin
5187
            (* We have a version >= for the executable oasis, proceed with
5188
             * update.
5189
             *)
5190
            (* TODO: delegate this check to 'oasis setup'. *)
5191
            if Sys.os_type = "Win32" then
5192
              failwithf
5193
                (f_ "It is not possible to update the running script \
5194
                     setup.ml on Windows. Please update setup.ml by \
5195
                     running '%s'.")
5196
                (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args))
5197
            else
5198
              begin
5199
                OASISExec.run
5200
                  ~ctxt:!BaseContext.default
5201
                  ~f_exit_code:
5202
                  (function
5203
                     | 0 ->
5204
                         ()
5205
                     | n ->
5206
                         failwithf
5207
                           (f_ "Unable to update setup.ml using '%s', \
5208
                                please fix the problem and retry.")
5209
                           oasis_exec)
5210
                  oasis_exec ("setup" :: t.oasis_setup_args);
5211
                OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args)
5212
              end
5213
          end
5214
        else
5215
          failwithf
5216
            (f_ "The version of '%s' (v%s) doesn't match the version of \
5217
                 oasis used to generate the %s file. Please install at \
5218
                 least oasis v%s.")
5219
            oasis_exec oasis_exec_version setup_ml t.oasis_version
5220
    in
5221

    
5222
    if !update_setup_ml then
5223
      begin
5224
        try
5225
          match t.oasis_digest with
5226
            | Some dgst ->
5227
              if Sys.file_exists oasis_fn &&
5228
                 dgst <> Digest.file default_oasis_fn then
5229
                begin
5230
                  do_update ();
5231
                  true
5232
                end
5233
              else
5234
                false
5235
            | None ->
5236
                false
5237
        with e ->
5238
          error
5239
            (f_ "Error when updating setup.ml. If you want to avoid this error, \
5240
                 you can bypass the update of %s by running '%s %s %s %s'")
5241
            setup_ml ocaml setup_ml no_update_setup_ml_cli
5242
            (String.concat " " args);
5243
          raise e
5244
      end
5245
    else
5246
      false
5247

    
5248

    
5249
  let setup t =
5250
    let catch_exn =
5251
      ref true
5252
    in
5253
      try
5254
        let act_ref =
5255
          ref (fun _ ->
5256
                 failwithf
5257
                   (f_ "No action defined, run '%s %s -help'")
5258
                   Sys.executable_name
5259
                   Sys.argv.(0))
5260

    
5261
        in
5262
        let extra_args_ref =
5263
          ref []
5264
        in
5265
        let allow_empty_env_ref =
5266
          ref false
5267
        in
5268
        let arg_handle ?(allow_empty_env=false) act =
5269
          Arg.Tuple
5270
            [
5271
              Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref);
5272

    
5273
              Arg.Unit
5274
                (fun () ->
5275
                   allow_empty_env_ref := allow_empty_env;
5276
                   act_ref := act);
5277
            ]
5278
        in
5279

    
5280
          Arg.parse
5281
            (Arg.align
5282
               ([
5283
                 "-configure",
5284
                 arg_handle ~allow_empty_env:true configure,
5285
                 s_ "[options*] Configure the whole build process.";
5286

    
5287
                 "-build",
5288
                 arg_handle build,
5289
                 s_ "[options*] Build executables and libraries.";
5290

    
5291
                 "-doc",
5292
                 arg_handle doc,
5293
                 s_ "[options*] Build documents.";
5294

    
5295
                 "-test",
5296
                 arg_handle test,
5297
                 s_ "[options*] Run tests.";
5298

    
5299
                 "-all",
5300
                 arg_handle ~allow_empty_env:true all,
5301
                 s_ "[options*] Run configure, build, doc and test targets.";
5302

    
5303
                 "-install",
5304
                 arg_handle install,
5305
                 s_ "[options*] Install libraries, data, executables \
5306
                                and documents.";
5307

    
5308
                 "-uninstall",
5309
                 arg_handle uninstall,
5310
                 s_ "[options*] Uninstall libraries, data, executables \
5311
                                and documents.";
5312

    
5313
                 "-reinstall",
5314
                 arg_handle reinstall,
5315
                 s_ "[options*] Uninstall and install libraries, data, \
5316
                                executables and documents.";
5317

    
5318
                 "-clean",
5319
                 arg_handle ~allow_empty_env:true clean,
5320
                 s_ "[options*] Clean files generated by a build.";
5321

    
5322
                 "-distclean",
5323
                 arg_handle ~allow_empty_env:true distclean,
5324
                 s_ "[options*] Clean files generated by a build and configure.";
5325

    
5326
                 "-version",
5327
                 arg_handle ~allow_empty_env:true version,
5328
                 s_ " Display version of OASIS used to generate this setup.ml.";
5329

    
5330
                 "-no-catch-exn",
5331
                 Arg.Clear catch_exn,
5332
                 s_ " Don't catch exception, useful for debugging.";
5333
               ]
5334
               @
5335
                (if t.setup_update then
5336
                   [no_update_setup_ml_cli]
5337
                 else
5338
                   [])
5339
               @ (BaseContext.args ())))
5340
            (failwithf (f_ "Don't know what to do with '%s'"))
5341
            (s_ "Setup and run build process current package\n");
5342

    
5343
          (* Build initial environment *)
5344
          load ~allow_empty:!allow_empty_env_ref ();
5345

    
5346
          (** Initialize flags *)
5347
          List.iter
5348
            (function
5349
               | Flag (cs, {flag_description = hlp;
5350
                            flag_default = choices}) ->
5351
                   begin
5352
                     let apply ?short_desc () =
5353
                       var_ignore
5354
                         (var_define
5355
                            ~cli:CLIEnable
5356
                            ?short_desc
5357
                            (OASISUtils.varname_of_string cs.cs_name)
5358
                            (fun () ->
5359
                               string_of_bool
5360
                                 (var_choose
5361
                                    ~name:(Printf.sprintf
5362
                                             (f_ "default value of flag %s")
5363
                                             cs.cs_name)
5364
                                    ~printer:string_of_bool
5365
                                             choices)))
5366
                     in
5367
                       match hlp with
5368
                         | Some hlp ->
5369
                             apply ~short_desc:(fun () -> hlp) ()
5370
                         | None ->
5371
                             apply ()
5372
                   end
5373
               | _ ->
5374
                   ())
5375
            t.package.sections;
5376

    
5377
          BaseStandardVar.init t.package;
5378

    
5379
          BaseDynVar.init t.package;
5380

    
5381
          if t.setup_update && update_setup_ml t then
5382
            ()
5383
          else
5384
            !act_ref t (Array.of_list (List.rev !extra_args_ref))
5385

    
5386
      with e when !catch_exn ->
5387
        error "%s" (Printexc.to_string e);
5388
        exit 1
5389

    
5390

    
5391
end
5392

    
5393

    
5394
# 5394 "setup.ml"
5395
module InternalConfigurePlugin = struct
5396
(* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *)
5397

    
5398

    
5399
  (** Configure using internal scheme
5400
      @author Sylvain Le Gall
5401
    *)
5402

    
5403

    
5404
  open BaseEnv
5405
  open OASISTypes
5406
  open OASISUtils
5407
  open OASISGettext
5408
  open BaseMessage
5409

    
5410

    
5411
  (** Configure build using provided series of check to be done
5412
    * and then output corresponding file.
5413
    *)
5414
  let configure pkg argv =
5415
    let var_ignore_eval var = let _s: string = var () in () in
5416
    let errors = ref SetString.empty in
5417
    let buff = Buffer.create 13 in
5418

    
5419
    let add_errors fmt =
5420
      Printf.kbprintf
5421
        (fun b ->
5422
           errors := SetString.add (Buffer.contents b) !errors;
5423
           Buffer.clear b)
5424
        buff
5425
        fmt
5426
    in
5427

    
5428
    let warn_exception e =
5429
      warning "%s" (Printexc.to_string e)
5430
    in
5431

    
5432
    (* Check tools *)
5433
    let check_tools lst =
5434
      List.iter
5435
        (function
5436
           | ExternalTool tool ->
5437
               begin
5438
                 try
5439
                   var_ignore_eval (BaseCheck.prog tool)
5440
                 with e ->
5441
                   warn_exception e;
5442
                   add_errors (f_ "Cannot find external tool '%s'") tool
5443
               end
5444
           | InternalExecutable nm1 ->
5445
               (* Check that matching tool is built *)
5446
               List.iter
5447
                 (function
5448
                    | Executable ({cs_name = nm2},
5449
                                  {bs_build = build},
5450
                                  _) when nm1 = nm2 ->
5451
                         if not (var_choose build) then
5452
                           add_errors
5453
                             (f_ "Cannot find buildable internal executable \
5454
                                  '%s' when checking build depends")
5455
                             nm1
5456
                    | _ ->
5457
                        ())
5458
                 pkg.sections)
5459
        lst
5460
    in
5461

    
5462
    let build_checks sct bs =
5463
      if var_choose bs.bs_build then
5464
        begin
5465
          if bs.bs_compiled_object = Native then
5466
            begin
5467
              try
5468
                var_ignore_eval BaseStandardVar.ocamlopt
5469
              with e ->
5470
                warn_exception e;
5471
                add_errors
5472
                  (f_ "Section %s requires native compilation")
5473
                  (OASISSection.string_of_section sct)
5474
            end;
5475

    
5476
          (* Check tools *)
5477
          check_tools bs.bs_build_tools;
5478

    
5479
          (* Check depends *)
5480
          List.iter
5481
            (function
5482
               | FindlibPackage (findlib_pkg, version_comparator) ->
5483
                   begin
5484
                     try
5485
                       var_ignore_eval
5486
                         (BaseCheck.package ?version_comparator findlib_pkg)
5487
                     with e ->
5488
                       warn_exception e;
5489
                       match version_comparator with
5490
                         | None ->
5491
                             add_errors
5492
                               (f_ "Cannot find findlib package %s")
5493
                               findlib_pkg
5494
                         | Some ver_cmp ->
5495
                             add_errors
5496
                               (f_ "Cannot find findlib package %s (%s)")
5497
                               findlib_pkg
5498
                               (OASISVersion.string_of_comparator ver_cmp)
5499
                   end
5500
               | InternalLibrary nm1 ->
5501
                   (* Check that matching library is built *)
5502
                   List.iter
5503
                     (function
5504
                        | Library ({cs_name = nm2},
5505
                                   {bs_build = build},
5506
                                   _) when nm1 = nm2 ->
5507
                             if not (var_choose build) then
5508
                               add_errors
5509
                                 (f_ "Cannot find buildable internal library \
5510
                                      '%s' when checking build depends")
5511
                                 nm1
5512
                        | _ ->
5513
                            ())
5514
                     pkg.sections)
5515
            bs.bs_build_depends
5516
        end
5517
    in
5518

    
5519
    (* Parse command line *)
5520
    BaseArgExt.parse argv (BaseEnv.args ());
5521

    
5522
    (* OCaml version *)
5523
    begin
5524
      match pkg.ocaml_version with
5525
        | Some ver_cmp ->
5526
            begin
5527
              try
5528
                var_ignore_eval
5529
                  (BaseCheck.version
5530
                     "ocaml"
5531
                     ver_cmp
5532
                     BaseStandardVar.ocaml_version)
5533
              with e ->
5534
                warn_exception e;
5535
                add_errors
5536
                  (f_ "OCaml version %s doesn't match version constraint %s")
5537
                  (BaseStandardVar.ocaml_version ())
5538
                  (OASISVersion.string_of_comparator ver_cmp)
5539
            end
5540
        | None ->
5541
            ()
5542
    end;
5543

    
5544
    (* Findlib version *)
5545
    begin
5546
      match pkg.findlib_version with
5547
        | Some ver_cmp ->
5548
            begin
5549
              try
5550
                var_ignore_eval
5551
                  (BaseCheck.version
5552
                     "findlib"
5553
                     ver_cmp
5554
                     BaseStandardVar.findlib_version)
5555
              with e ->
5556
                warn_exception e;
5557
                add_errors
5558
                  (f_ "Findlib version %s doesn't match version constraint %s")
5559
                  (BaseStandardVar.findlib_version ())
5560
                  (OASISVersion.string_of_comparator ver_cmp)
5561
            end
5562
        | None ->
5563
            ()
5564
    end;
5565
    (* Make sure the findlib version is fine for the OCaml compiler. *)
5566
    begin
5567
      let ocaml_ge4 =
5568
        OASISVersion.version_compare
5569
          (OASISVersion.version_of_string (BaseStandardVar.ocaml_version()))
5570
          (OASISVersion.version_of_string "4.0.0") >= 0 in
5571
      if ocaml_ge4 then
5572
        let findlib_lt132 =
5573
          OASISVersion.version_compare
5574
            (OASISVersion.version_of_string (BaseStandardVar.findlib_version()))
5575
            (OASISVersion.version_of_string "1.3.2") < 0 in
5576
        if findlib_lt132 then
5577
          add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2"
5578
    end;
5579

    
5580
    (* FlexDLL *)
5581
    if BaseStandardVar.os_type () = "Win32" ||
5582
       BaseStandardVar.os_type () = "Cygwin" then
5583
      begin
5584
        try
5585
          var_ignore_eval BaseStandardVar.flexlink
5586
        with e ->
5587
          warn_exception e;
5588
          add_errors (f_ "Cannot find 'flexlink'")
5589
      end;
5590

    
5591
    (* Check build depends *)
5592
    List.iter
5593
      (function
5594
         | Executable (_, bs, _)
5595
         | Library (_, bs, _) as sct ->
5596
             build_checks sct bs
5597
         | Doc (_, doc) ->
5598
             if var_choose doc.doc_build then
5599
               check_tools doc.doc_build_tools
5600
         | Test (_, test) ->
5601
             if var_choose test.test_run then
5602
               check_tools test.test_tools
5603
         | _ ->
5604
             ())
5605
      pkg.sections;
5606

    
5607
    (* Check if we need native dynlink (presence of libraries that compile to
5608
     * native)
5609
     *)
5610
    begin
5611
      let has_cmxa =
5612
        List.exists
5613
          (function
5614
             | Library (_, bs, _) ->
5615
                 var_choose bs.bs_build &&
5616
                 (bs.bs_compiled_object = Native ||
5617
                  (bs.bs_compiled_object = Best &&
5618
                   bool_of_string (BaseStandardVar.is_native ())))
5619
             | _  ->
5620
                 false)
5621
          pkg.sections
5622
      in
5623
        if has_cmxa then
5624
          var_ignore_eval BaseStandardVar.native_dynlink
5625
    end;
5626

    
5627
    (* Check errors *)
5628
    if SetString.empty != !errors then
5629
      begin
5630
        List.iter
5631
          (fun e -> error "%s" e)
5632
          (SetString.elements !errors);
5633
        failwithf
5634
          (fn_
5635
             "%d configuration error"
5636
             "%d configuration errors"
5637
             (SetString.cardinal !errors))
5638
          (SetString.cardinal !errors)
5639
      end
5640

    
5641

    
5642
end
5643

    
5644
module InternalInstallPlugin = struct
5645
(* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *)
5646

    
5647

    
5648
  (** Install using internal scheme
5649
      @author Sylvain Le Gall
5650
    *)
5651

    
5652

    
5653
  open BaseEnv
5654
  open BaseStandardVar
5655
  open BaseMessage
5656
  open OASISTypes
5657
  open OASISFindlib
5658
  open OASISGettext
5659
  open OASISUtils
5660

    
5661

    
5662
  let exec_hook =
5663
    ref (fun (cs, bs, exec) -> cs, bs, exec)
5664

    
5665

    
5666
  let lib_hook =
5667
    ref (fun (cs, bs, lib) -> cs, bs, lib, [])
5668

    
5669

    
5670
  let obj_hook =
5671
    ref (fun (cs, bs, obj) -> cs, bs, obj, [])
5672

    
5673

    
5674
  let doc_hook =
5675
    ref (fun (cs, doc) -> cs, doc)
5676

    
5677

    
5678
  let install_file_ev =
5679
    "install-file"
5680

    
5681

    
5682
  let install_dir_ev =
5683
    "install-dir"
5684

    
5685

    
5686
  let install_findlib_ev =
5687
    "install-findlib"
5688

    
5689

    
5690
  let win32_max_command_line_length = 8000
5691

    
5692

    
5693
  let split_install_command ocamlfind findlib_name meta files =
5694
    if Sys.os_type = "Win32" then
5695
      (* Arguments for the first command: *)
5696
      let first_args = ["install"; findlib_name; meta] in
5697
      (* Arguments for remaining commands: *)
5698
      let other_args = ["install"; findlib_name; "-add"] in
5699
      (* Extract as much files as possible from [files], [len] is
5700
         the current command line length: *)
5701
      let rec get_files len acc files =
5702
        match files with
5703
          | [] ->
5704
              (List.rev acc, [])
5705
          | file :: rest ->
5706
              let len = len + 1 + String.length file in
5707
              if len > win32_max_command_line_length then
5708
                (List.rev acc, files)
5709
              else
5710
                get_files len (file :: acc) rest
5711
      in
5712
      (* Split the command into several commands. *)
5713
      let rec split args files =
5714
        match files with
5715
          | [] ->
5716
              []
5717
          | _ ->
5718
              (* Length of "ocamlfind install <lib> [META|-add]" *)
5719
              let len =
5720
                List.fold_left
5721
                  (fun len arg ->
5722
                     len + 1 (* for the space *) + String.length arg)
5723
                  (String.length ocamlfind)
5724
                  args
5725
              in
5726
              match get_files len [] files with
5727
                | ([], _) ->
5728
                    failwith (s_ "Command line too long.")
5729
                | (firsts, others) ->
5730
                    let cmd = args @ firsts in
5731
                    (* Use -add for remaining commands: *)
5732
                    let () =
5733
                      let findlib_ge_132 =
5734
                        OASISVersion.comparator_apply
5735
                          (OASISVersion.version_of_string
5736
                             (BaseStandardVar.findlib_version ()))
5737
                          (OASISVersion.VGreaterEqual
5738
                             (OASISVersion.version_of_string "1.3.2"))
5739
                      in
5740
                        if not findlib_ge_132 then
5741
                          failwithf
5742
                            (f_ "Installing the library %s require to use the \
5743
                                 flag '-add' of ocamlfind because the command \
5744
                                 line is too long. This flag is only available \
5745
                                 for findlib 1.3.2. Please upgrade findlib from \
5746
                                 %s to 1.3.2")
5747
                            findlib_name (BaseStandardVar.findlib_version ())
5748
                    in
5749
                    let cmds = split other_args others in
5750
                    cmd :: cmds
5751
      in
5752
      (* The first command does not use -add: *)
5753
      split first_args files
5754
    else
5755
      ["install" :: findlib_name :: meta :: files]
5756

    
5757

    
5758
  let install pkg argv =
5759

    
5760
    let in_destdir =
5761
      try
5762
        let destdir =
5763
          destdir ()
5764
        in
5765
          (* Practically speaking destdir is prepended
5766
           * at the beginning of the target filename
5767
           *)
5768
          fun fn -> destdir^fn
5769
      with PropList.Not_set _ ->
5770
        fun fn -> fn
5771
    in
5772

    
5773
    let install_file ?tgt_fn src_file envdir =
5774
      let tgt_dir =
5775
        in_destdir (envdir ())
5776
      in
5777
      let tgt_file =
5778
        Filename.concat
5779
          tgt_dir
5780
          (match tgt_fn with
5781
             | Some fn ->
5782
                 fn
5783
             | None ->
5784
                 Filename.basename src_file)
5785
      in
5786
        (* Create target directory if needed *)
5787
        OASISFileUtil.mkdir_parent
5788
          ~ctxt:!BaseContext.default
5789
          (fun dn ->
5790
             info (f_ "Creating directory '%s'") dn;
5791
             BaseLog.register install_dir_ev dn)
5792
          tgt_dir;
5793

    
5794
        (* Really install files *)
5795
        info (f_ "Copying file '%s' to '%s'") src_file tgt_file;
5796
        OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file;
5797
        BaseLog.register install_file_ev tgt_file
5798
    in
5799

    
5800
    (* Install data into defined directory *)
5801
    let install_data srcdir lst tgtdir =
5802
      let tgtdir =
5803
        OASISHostPath.of_unix (var_expand tgtdir)
5804
      in
5805
        List.iter
5806
          (fun (src, tgt_opt) ->
5807
             let real_srcs =
5808
               OASISFileUtil.glob
5809
                 ~ctxt:!BaseContext.default
5810
                 (Filename.concat srcdir src)
5811
             in
5812
               if real_srcs = [] then
5813
                 failwithf
5814
                   (f_ "Wildcard '%s' doesn't match any files")
5815
                   src;
5816
               List.iter
5817
                 (fun fn ->
5818
                    install_file
5819
                      fn
5820
                      (fun () ->
5821
                         match tgt_opt with
5822
                           | Some s ->
5823
                               OASISHostPath.of_unix (var_expand s)
5824
                           | None ->
5825
                               tgtdir))
5826
                 real_srcs)
5827
          lst
5828
    in
5829

    
5830
    (** Install all libraries *)
5831
    let install_libs pkg =
5832

    
5833
      let files_of_library (f_data, acc) data_lib =
5834
        let cs, bs, lib, lib_extra =
5835
          !lib_hook data_lib
5836
        in
5837
          if var_choose bs.bs_install &&
5838
             BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then
5839
            begin
5840
              let acc =
5841
                (* Start with acc + lib_extra *)
5842
                List.rev_append lib_extra acc
5843
              in
5844
              let acc =
5845
                (* Add uncompiled header from the source tree *)
5846
                let path =
5847
                  OASISHostPath.of_unix bs.bs_path
5848
                in
5849
                  List.fold_left
5850
                    (fun acc modul ->
5851
                       try
5852
                         List.find
5853
                           OASISFileUtil.file_exists_case
5854
                           (List.map
5855
                              (Filename.concat path)
5856
                              [modul^".mli";
5857
                               modul^".ml";
5858
                               String.uncapitalize modul^".mli";
5859
                               String.capitalize   modul^".mli";
5860
                               String.uncapitalize modul^".ml";
5861
                               String.capitalize   modul^".ml"])
5862
                         :: acc
5863
                       with Not_found ->
5864
                         begin
5865
                           warning
5866
                             (f_ "Cannot find source header for module %s \
5867
                                  in library %s")
5868
                             modul cs.cs_name;
5869
                           acc
5870
                         end)
5871
                    acc
5872
                    lib.lib_modules
5873
              in
5874

    
5875
              let acc =
5876
               (* Get generated files *)
5877
               BaseBuilt.fold
5878
                 BaseBuilt.BLib
5879
                 cs.cs_name
5880
                 (fun acc fn -> fn :: acc)
5881
                 acc
5882
              in
5883

    
5884
              let f_data () =
5885
                (* Install data associated with the library *)
5886
                install_data
5887
                  bs.bs_path
5888
                  bs.bs_data_files
5889
                  (Filename.concat
5890
                     (datarootdir ())
5891
                     pkg.name);
5892
                f_data ()
5893
              in
5894

    
5895
                (f_data, acc)
5896
            end
5897
           else
5898
            begin
5899
              (f_data, acc)
5900
            end
5901
      and files_of_object (f_data, acc) data_obj =
5902
        let cs, bs, obj, obj_extra =
5903
          !obj_hook data_obj
5904
        in
5905
          if var_choose bs.bs_install &&
5906
             BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then
5907
            begin
5908
              let acc =
5909
                (* Start with acc + obj_extra *)
5910
                List.rev_append obj_extra acc
5911
              in
5912
              let acc =
5913
                (* Add uncompiled header from the source tree *)
5914
                let path =
5915
                  OASISHostPath.of_unix bs.bs_path
5916
                in
5917
                  List.fold_left
5918
                    (fun acc modul ->
5919
                       try
5920
                         List.find
5921
                           OASISFileUtil.file_exists_case
5922
                           (List.map
5923
                              (Filename.concat path)
5924
                              [modul^".mli";
5925
                               modul^".ml";
5926
                               String.uncapitalize modul^".mli";
5927
                               String.capitalize   modul^".mli";
5928
                               String.uncapitalize modul^".ml";
5929
                               String.capitalize   modul^".ml"])
5930
                         :: acc
5931
                       with Not_found ->
5932
                         begin
5933
                           warning
5934