Project

General

Profile

Download (175 KB) Statistics
| Branch: | Tag: | Revision:
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