Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / setup.ml @ a1daa793

History | View | Annotate | Download (153 KB)

1 e2068500 Temesghen Kahsai
(* setup.ml generated for the first time by OASIS v0.2.0 *)
2
3
(* OASIS_START *)
4
(* DO NOT EDIT (digest: cbef9780a942e499729218b6c22c21f0) *)
5
(*
6
   Regenerated by OASIS v0.3.0
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
(* # 21 "src/oasis/OASISGettext.ml" *)
12
13
  let ns_ str =
14
    str
15
16
  let s_ str =
17
    str
18
19
  let f_ (str : ('a, 'b, 'c, 'd) format4) =
20
    str
21
22
  let fn_ fmt1 fmt2 n =
23
    if n = 1 then
24
      fmt1^^""
25
    else
26
      fmt2^^""
27
28
  let init =
29
    []
30
31
end
32
33
module OASISContext = struct
34
(* # 21 "src/oasis/OASISContext.ml" *)
35
36
  open OASISGettext
37
38
  type level =
39
    [ `Debug
40
    | `Info
41
    | `Warning
42
    | `Error]
43
44
  type t =
45
    {
46
      quiet:                 bool;
47
      info:                  bool;
48
      debug:                 bool;
49
      ignore_plugins:        bool;
50
      ignore_unknown_fields: bool;
51
      printf:                level -> string -> unit;
52
    }
53
54
  let printf lvl str =
55
    let beg =
56
      match lvl with
57
        | `Error -> s_ "E: "
58
        | `Warning -> s_ "W: "
59
        | `Info  -> s_ "I: "
60
        | `Debug -> s_ "D: "
61
    in
62
      prerr_endline (beg^str)
63
64
  let default =
65
    ref
66
      {
67
        quiet                 = false;
68
        info                  = false;
69
        debug                 = false;
70
        ignore_plugins        = false;
71
        ignore_unknown_fields = false;
72
        printf                = printf;
73
      }
74
75
  let quiet =
76
    {!default with quiet = true}
77
78
79
  let args () =
80
    ["-quiet",
81
     Arg.Unit (fun () -> default := {!default with quiet = true}),
82
     (s_ " Run quietly");
83
84
     "-info",
85
     Arg.Unit (fun () -> default := {!default with info = true}),
86
     (s_ " Display information message");
87
88
89
     "-debug",
90
     Arg.Unit (fun () -> default := {!default with debug = true}),
91
     (s_ " Output debug message")]
92
end
93
94
module OASISString = struct
95
(* # 1 "src/oasis/OASISString.ml" *)
96
97
98
99
  (** Various string utilities.
100
     
101
      Mostly inspired by extlib and batteries ExtString and BatString libraries.
102
103
      @author Sylvain Le Gall
104
    *)
105
106
  let nsplitf str f =
107
    if str = "" then
108
      []
109
    else
110
      let buf = Buffer.create 13 in
111
      let lst = ref [] in
112
      let push () =
113
        lst := Buffer.contents buf :: !lst;
114
        Buffer.clear buf
115
      in
116
      let str_len = String.length str in
117
        for i = 0 to str_len - 1 do
118
          if f str.[i] then
119
            push ()
120
          else
121
            Buffer.add_char buf str.[i]
122
        done;
123
        push ();
124
        List.rev !lst
125
126
  (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the
127
      separator.
128
    *)
129
  let nsplit str c =
130
    nsplitf str ((=) c)
131
132
  let find ~what ?(offset=0) str =
133
    let what_idx = ref 0 in
134
    let str_idx = ref offset in 
135
      while !str_idx < String.length str && 
136
            !what_idx < String.length what do
137
        if str.[!str_idx] = what.[!what_idx] then
138
          incr what_idx
139
        else
140
          what_idx := 0;
141
        incr str_idx
142
      done;
143
      if !what_idx <> String.length what then
144
        raise Not_found
145
      else 
146
        !str_idx - !what_idx
147
148
  let sub_start str len = 
149
    let str_len = String.length str in
150
    if len >= str_len then
151
      ""
152
    else
153
      String.sub str len (str_len - len)
154
155
  let sub_end ?(offset=0) str len =
156
    let str_len = String.length str in
157
    if len >= str_len then
158
      ""
159
    else
160
      String.sub str 0 (str_len - len)
161
162
  let starts_with ~what ?(offset=0) str =
163
    let what_idx = ref 0 in
164
    let str_idx = ref offset in
165
    let ok = ref true in
166
      while !ok &&
167
            !str_idx < String.length str && 
168
            !what_idx < String.length what do
169
        if str.[!str_idx] = what.[!what_idx] then
170
          incr what_idx
171
        else
172
          ok := false;
173
        incr str_idx
174
      done;
175
      if !what_idx = String.length what then
176
        true
177
      else 
178
        false
179
180
  let strip_starts_with ~what str =
181
    if starts_with ~what str then
182
      sub_start str (String.length what)
183
    else
184
      raise Not_found
185
186
  let ends_with ~what ?(offset=0) str =
187
    let what_idx = ref ((String.length what) - 1) in
188
    let str_idx = ref ((String.length str) - 1) in
189
    let ok = ref true in
190
      while !ok &&
191
            offset <= !str_idx && 
192
            0 <= !what_idx do
193
        if str.[!str_idx] = what.[!what_idx] then
194
          decr what_idx
195
        else
196
          ok := false;
197
        decr str_idx
198
      done;
199
      if !what_idx = -1 then
200
        true
201
      else 
202
        false
203
204
  let strip_ends_with ~what str =
205
    if ends_with ~what str then
206
      sub_end str (String.length what)
207
    else
208
      raise Not_found
209
210
  let replace_chars f s =
211
    let buf = String.make (String.length s) 'X' in
212
      for i = 0 to String.length s - 1 do
213
        buf.[i] <- f s.[i]
214
      done;
215
      buf
216
217
end
218
219
module OASISUtils = struct
220
(* # 21 "src/oasis/OASISUtils.ml" *)
221
222
  open OASISGettext
223
224
  module MapString = Map.Make(String)
225
226
  let map_string_of_assoc assoc =
227
    List.fold_left
228
      (fun acc (k, v) -> MapString.add k v acc)
229
      MapString.empty
230
      assoc
231
232
  module SetString = Set.Make(String)
233
234
  let set_string_add_list st lst =
235
    List.fold_left
236
      (fun acc e -> SetString.add e acc)
237
      st
238
      lst
239
240
  let set_string_of_list =
241
    set_string_add_list
242
      SetString.empty
243
244
245
  let compare_csl s1 s2 =
246
    String.compare (String.lowercase s1) (String.lowercase s2)
247
248
  module HashStringCsl =
249
    Hashtbl.Make
250
      (struct
251
         type t = string
252
253
         let equal s1 s2 =
254
             (String.lowercase s1) = (String.lowercase s2)
255
256
         let hash s =
257
           Hashtbl.hash (String.lowercase s)
258
       end)
259
260
  let varname_of_string ?(hyphen='_') s =
261
    if String.length s = 0 then
262
      begin
263
        invalid_arg "varname_of_string"
264
      end
265
    else
266
      begin
267
        let buf =
268
          OASISString.replace_chars
269
            (fun c ->
270
               if ('a' <= c && c <= 'z')
271
                 ||
272
                  ('A' <= c && c <= 'Z')
273
                 ||
274
                  ('0' <= c && c <= '9') then
275
                 c
276
               else
277
                 hyphen)
278
            s;
279
        in
280
        let buf =
281
          (* Start with a _ if digit *)
282
          if '0' <= s.[0] && s.[0] <= '9' then
283
            "_"^buf
284
          else
285
            buf
286
        in
287
          String.lowercase buf
288
      end
289
290
  let varname_concat ?(hyphen='_') p s =
291
    let what = String.make 1 hyphen in
292
    let p =
293
      try
294
        OASISString.strip_ends_with ~what p
295
      with Not_found ->
296
        p
297
    in
298
    let s =
299
      try
300
        OASISString.strip_starts_with ~what s
301
      with Not_found ->
302
        s
303
    in
304
      p^what^s
305
306
307
  let is_varname str =
308
    str = varname_of_string str
309
310
  let failwithf fmt = Printf.ksprintf failwith fmt
311
312
end
313
314
module PropList = struct
315
(* # 21 "src/oasis/PropList.ml" *)
316
317
  open OASISGettext
318
319
  type name = string
320
321
  exception Not_set of name * string option
322
  exception No_printer of name
323
  exception Unknown_field of name * name
324
325
  let () =
326
    Printexc.register_printer
327
      (function
328
         | Not_set (nm, Some rsn) ->
329
             Some 
330
               (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn)
331
         | Not_set (nm, None) ->
332
             Some 
333
               (Printf.sprintf (f_ "Field '%s' is not set") nm)
334
         | No_printer nm ->
335
             Some
336
               (Printf.sprintf (f_ "No default printer for value %s") nm)
337
         | Unknown_field (nm, schm) ->
338
             Some 
339
               (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm)
340
         | _ ->
341
             None)
342
343
  module Data =
344
  struct
345
346
    type t =
347
        (name, unit -> unit) Hashtbl.t
348
349
    let create () =
350
      Hashtbl.create 13
351
352
    let clear t =
353
      Hashtbl.clear t
354
355
(* # 71 "src/oasis/PropList.ml" *)
356
  end
357
358
  module Schema =
359
  struct
360
361
    type ('ctxt, 'extra) value =
362
        {
363
          get:   Data.t -> string;
364
          set:   Data.t -> ?context:'ctxt -> string -> unit;
365
          help:  (unit -> string) option;
366
          extra: 'extra;
367
        }
368
369
    type ('ctxt, 'extra) t =
370
        {
371
          name:      name;
372
          fields:    (name, ('ctxt, 'extra) value) Hashtbl.t;
373
          order:     name Queue.t;
374
          name_norm: string -> string;
375
        }
376
377
    let create ?(case_insensitive=false) nm =
378
      {
379
        name      = nm;
380
        fields    = Hashtbl.create 13;
381
        order     = Queue.create ();
382
        name_norm =
383
          (if case_insensitive then
384
             String.lowercase
385
           else
386
             fun s -> s);
387
      }
388
389
    let add t nm set get extra help =
390
      let key =
391
        t.name_norm nm
392
      in
393
394
        if Hashtbl.mem t.fields key then
395
          failwith
396
            (Printf.sprintf
397
               (f_ "Field '%s' is already defined in schema '%s'")
398
               nm t.name);
399
        Hashtbl.add
400
          t.fields
401
          key
402
          {
403
            set   = set;
404
            get   = get;
405
            help  = help;
406
            extra = extra;
407
          };
408
        Queue.add nm t.order
409
410
    let mem t nm =
411
      Hashtbl.mem t.fields nm
412
413
    let find t nm =
414
      try
415
        Hashtbl.find t.fields (t.name_norm nm)
416
      with Not_found ->
417
        raise (Unknown_field (nm, t.name))
418
419
    let get t data nm =
420
      (find t nm).get data
421
422
    let set t data nm ?context x =
423
      (find t nm).set
424
        data
425
        ?context
426
        x
427
428
    let fold f acc t =
429
      Queue.fold
430
        (fun acc k ->
431
           let v =
432
             find t k
433
           in
434
             f acc k v.extra v.help)
435
        acc
436
        t.order
437
438
    let iter f t =
439
      fold
440
        (fun () -> f)
441
        ()
442
        t
443
444
    let name t =
445
      t.name
446
  end
447
448
  module Field =
449
  struct
450
451
    type ('ctxt, 'value, 'extra) t =
452
        {
453
          set:    Data.t -> ?context:'ctxt -> 'value -> unit;
454
          get:    Data.t -> 'value;
455
          sets:   Data.t -> ?context:'ctxt -> string -> unit;
456
          gets:   Data.t -> string;
457
          help:   (unit -> string) option;
458
          extra:  'extra;
459
        }
460
461
    let new_id =
462
      let last_id =
463
        ref 0
464
      in
465
        fun () -> incr last_id; !last_id
466
467
    let create ?schema ?name ?parse ?print ?default ?update ?help extra =
468
      (* Default value container *)
469
      let v =
470
        ref None
471
      in
472
473
      (* If name is not given, create unique one *)
474
      let nm =
475
        match name with
476
          | Some s -> s
477
          | None -> Printf.sprintf "_anon_%d" (new_id ())
478
      in
479
480
      (* Last chance to get a value: the default *)
481
      let default () =
482
        match default with
483
          | Some d -> d
484
          | None -> raise (Not_set (nm, Some (s_ "no default value")))
485
      in
486
487
      (* Get data *)
488
      let get data =
489
        (* Get value *)
490
        try
491
          (Hashtbl.find data nm) ();
492
          match !v with
493
            | Some x -> x
494
            | None -> default ()
495
        with Not_found ->
496
          default ()
497
      in
498
499
      (* Set data *)
500
      let set data ?context x =
501
        let x =
502
          match update with
503
            | Some f ->
504
                begin
505
                  try
506
                    f ?context (get data) x
507
                  with Not_set _ ->
508
                    x
509
                end
510
            | None ->
511
                x
512
        in
513
          Hashtbl.replace
514
            data
515
            nm
516
            (fun () -> v := Some x)
517
      in
518
519
      (* Parse string value, if possible *)
520
      let parse =
521
        match parse with
522
          | Some f ->
523
              f
524
          | None ->
525
              fun ?context s ->
526
                failwith
527
                  (Printf.sprintf
528
                     (f_ "Cannot parse field '%s' when setting value %S")
529
                     nm
530
                     s)
531
      in
532
533
      (* Set data, from string *)
534
      let sets data ?context s =
535
        set ?context data (parse ?context s)
536
      in
537
538
      (* Output value as string, if possible *)
539
      let print =
540
        match print with
541
          | Some f ->
542
              f
543
          | None ->
544
              fun _ -> raise (No_printer nm)
545
      in
546
547
      (* Get data, as a string *)
548
      let gets data =
549
        print (get data)
550
      in
551
552
        begin
553
          match schema with
554
            | Some t ->
555
                Schema.add t nm sets gets extra help
556
            | None ->
557
                ()
558
        end;
559
560
        {
561
          set   = set;
562
          get   = get;
563
          sets  = sets;
564
          gets  = gets;
565
          help  = help;
566
          extra = extra;
567
        }
568
569
    let fset data t ?context x =
570
      t.set data ?context x
571
572
    let fget data t =
573
      t.get data
574
575
    let fsets data t ?context s =
576
      t.sets data ?context s
577
578
    let fgets data t =
579
      t.gets data
580
581
  end
582
583
  module FieldRO =
584
  struct
585
586
    let create ?schema ?name ?parse ?print ?default ?update ?help extra =
587
      let fld =
588
        Field.create ?schema ?name ?parse ?print ?default ?update ?help extra
589
      in
590
        fun data -> Field.fget data fld
591
592
  end
593
end
594
595
module OASISMessage = struct
596
(* # 21 "src/oasis/OASISMessage.ml" *)
597
598
599
  open OASISGettext
600
  open OASISContext
601
602
  let generic_message ~ctxt lvl fmt =
603
    let cond =
604
      if ctxt.quiet then
605
        false
606
      else
607
        match lvl with
608
          | `Debug -> ctxt.debug
609
          | `Info  -> ctxt.info
610
          | _ -> true
611
    in
612
      Printf.ksprintf
613
        (fun str ->
614
           if cond then
615
             begin
616
               ctxt.printf lvl str
617
             end)
618
        fmt
619
620
  let debug ~ctxt fmt =
621
    generic_message ~ctxt `Debug fmt
622
623
  let info ~ctxt fmt =
624
    generic_message ~ctxt `Info fmt
625
626
  let warning ~ctxt fmt =
627
    generic_message ~ctxt `Warning fmt
628
629
  let error ~ctxt fmt =
630
    generic_message ~ctxt `Error fmt
631
632
end
633
634
module OASISVersion = struct
635
(* # 21 "src/oasis/OASISVersion.ml" *)
636
637
  open OASISGettext
638
639
640
641
  type s = string
642
643
  type t = string 
644
645
  type comparator =
646
    | VGreater of t
647
    | VGreaterEqual of t
648
    | VEqual of t
649
    | VLesser of t
650
    | VLesserEqual of t
651
    | VOr of  comparator * comparator
652
    | VAnd of comparator * comparator
653
    
654
655
  (* Range of allowed characters *)
656
  let is_digit c =
657
    '0' <= c && c <= '9'
658
659
  let is_alpha c =
660
    ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z')
661
662
  let is_special =
663
    function
664
      | '.' | '+' | '-' | '~' -> true
665
      | _ -> false
666
667
  let rec version_compare v1 v2 =
668
    if v1 <> "" || v2 <> "" then
669
      begin
670
        (* Compare ascii string, using special meaning for version
671
         * related char
672
         *)
673
        let val_ascii c =
674
          if c = '~' then -1
675
          else if is_digit c then 0
676
          else if c = '\000' then 0
677
          else if is_alpha c then Char.code c
678
          else (Char.code c) + 256
679
        in
680
681
        let len1 = String.length v1 in
682
        let len2 = String.length v2 in
683
684
        let p = ref 0 in
685
686
        (** Compare ascii part *)
687
        let compare_vascii () =
688
          let cmp = ref 0 in
689
          while !cmp = 0 &&
690
                !p < len1 && !p < len2 &&
691
                not (is_digit v1.[!p] && is_digit v2.[!p]) do
692
            cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]);
693
            incr p
694
          done;
695
          if !cmp = 0 && !p < len1 && !p = len2 then
696
            val_ascii v1.[!p]
697
          else if !cmp = 0 && !p = len1 && !p < len2 then
698
            - (val_ascii v2.[!p])
699
          else
700
            !cmp
701
        in
702
703
        (** Compare digit part *)
704
        let compare_digit () =
705
          let extract_int v p =
706
            let start_p = !p in
707
              while !p < String.length v && is_digit v.[!p] do
708
                incr p
709
              done;
710
              let substr = 
711
                String.sub v !p ((String.length v) - !p)
712
              in 
713
              let res = 
714
                match String.sub v start_p (!p - start_p) with 
715
                  | "" -> 0
716
                  | s -> int_of_string s
717
              in
718
                res, substr
719
          in
720
          let i1, tl1 = extract_int v1 (ref !p) in
721
          let i2, tl2 = extract_int v2 (ref !p) in
722
            i1 - i2, tl1, tl2
723
        in
724
725
          match compare_vascii () with
726
            | 0 ->
727
                begin
728
                  match compare_digit () with
729
                    | 0, tl1, tl2 ->
730
                        if tl1 <> "" && is_digit tl1.[0] then
731
                          1
732
                        else if tl2 <> "" && is_digit tl2.[0] then
733
                          -1
734
                        else
735
                          version_compare tl1 tl2
736
                    | n, _, _ ->
737
                        n
738
                end
739
            | n ->
740
                n
741
      end
742
    else
743
      begin
744
        0
745
      end
746
747
748
  let version_of_string str = str
749
750
  let string_of_version t = t
751
752
  let chop t =
753
    try
754
      let pos =
755
        String.rindex t '.'
756
      in
757
        String.sub t 0 pos
758
    with Not_found ->
759
      t
760
761
  let rec comparator_apply v op =
762
    match op with
763
      | VGreater cv ->
764
          (version_compare v cv) > 0
765
      | VGreaterEqual cv ->
766
          (version_compare v cv) >= 0
767
      | VLesser cv ->
768
          (version_compare v cv) < 0
769
      | VLesserEqual cv ->
770
          (version_compare v cv) <= 0
771
      | VEqual cv ->
772
          (version_compare v cv) = 0
773
      | VOr (op1, op2) ->
774
          (comparator_apply v op1) || (comparator_apply v op2)
775
      | VAnd (op1, op2) ->
776
          (comparator_apply v op1) && (comparator_apply v op2)
777
778
  let rec string_of_comparator =
779
    function
780
      | VGreater v  -> "> "^(string_of_version v)
781
      | VEqual v    -> "= "^(string_of_version v)
782
      | VLesser v   -> "< "^(string_of_version v)
783
      | VGreaterEqual v -> ">= "^(string_of_version v)
784
      | VLesserEqual v  -> "<= "^(string_of_version v)
785
      | VOr (c1, c2)  ->
786
          (string_of_comparator c1)^" || "^(string_of_comparator c2)
787
      | VAnd (c1, c2) ->
788
          (string_of_comparator c1)^" && "^(string_of_comparator c2)
789
790
  let rec varname_of_comparator =
791
    let concat p v =
792
      OASISUtils.varname_concat
793
        p
794
        (OASISUtils.varname_of_string
795
           (string_of_version v))
796
    in
797
      function
798
        | VGreater v -> concat "gt" v
799
        | VLesser v  -> concat "lt" v
800
        | VEqual v   -> concat "eq" v
801
        | VGreaterEqual v -> concat "ge" v
802
        | VLesserEqual v  -> concat "le" v
803
        | VOr (c1, c2) ->
804
            (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2)
805
        | VAnd (c1, c2) ->
806
            (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2)
807
808
  let version_0_3_or_after t =
809
    comparator_apply t (VGreaterEqual (string_of_version "0.3"))
810
811
end
812
813
module OASISLicense = struct
814
(* # 21 "src/oasis/OASISLicense.ml" *)
815
816
  (** License for _oasis fields
817
      @author Sylvain Le Gall
818
    *)
819
820
821
822
  type license = string 
823
824
  type license_exception = string 
825
826
  type license_version =
827
    | Version of OASISVersion.t
828
    | VersionOrLater of OASISVersion.t
829
    | NoVersion
830
    
831
832
  type license_dep_5_unit =
833
    {
834
      license:   license;
835
      excption:  license_exception option;
836
      version:   license_version;
837
    }
838
    
839
840
  type license_dep_5 =
841
    | DEP5Unit of license_dep_5_unit
842
    | DEP5Or of license_dep_5 list
843
    | DEP5And of license_dep_5 list
844
    
845
846
  type t =
847
    | DEP5License of license_dep_5
848
    | OtherLicense of string (* URL *)
849
    
850
851
end
852
853
module OASISExpr = struct
854
(* # 21 "src/oasis/OASISExpr.ml" *)
855
856
857
858
  open OASISGettext
859
860
  type test = string 
861
862
  type flag = string 
863
864
  type t =
865
    | EBool of bool
866
    | ENot of t
867
    | EAnd of t * t
868
    | EOr of t * t
869
    | EFlag of flag
870
    | ETest of test * string
871
    
872
873
  type 'a choices = (t * 'a) list 
874
875
  let eval var_get t =
876
    let rec eval' =
877
      function
878
        | EBool b ->
879
            b
880
881
        | ENot e ->
882
            not (eval' e)
883
884
        | EAnd (e1, e2) ->
885
            (eval' e1) && (eval' e2)
886
887
        | EOr (e1, e2) ->
888
            (eval' e1) || (eval' e2)
889
890
        | EFlag nm ->
891
            let v =
892
              var_get nm
893
            in
894
              assert(v = "true" || v = "false");
895
              (v = "true")
896
897
        | ETest (nm, vl) ->
898
            let v =
899
              var_get nm
900
            in
901
              (v = vl)
902
    in
903
      eval' t
904
905
  let choose ?printer ?name var_get lst =
906
    let rec choose_aux =
907
      function
908
        | (cond, vl) :: tl ->
909
            if eval var_get cond then
910
              vl
911
            else
912
              choose_aux tl
913
        | [] ->
914
            let str_lst =
915
              if lst = [] then
916
                s_ "<empty>"
917
              else
918
                String.concat
919
                  (s_ ", ")
920
                  (List.map
921
                     (fun (cond, vl) ->
922
                        match printer with
923
                          | Some p -> p vl
924
                          | None -> s_ "<no printer>")
925
                     lst)
926
            in
927
              match name with
928
                | Some nm ->
929
                    failwith
930
                      (Printf.sprintf
931
                         (f_ "No result for the choice list '%s': %s")
932
                         nm str_lst)
933
                | None ->
934
                    failwith
935
                      (Printf.sprintf
936
                         (f_ "No result for a choice list: %s")
937
                         str_lst)
938
    in
939
      choose_aux (List.rev lst)
940
941
end
942
943
module OASISTypes = struct
944
(* # 21 "src/oasis/OASISTypes.ml" *)
945
946
947
948
949
  type name          = string 
950
  type package_name  = string 
951
  type url           = string 
952
  type unix_dirname  = string 
953
  type unix_filename = string 
954
  type host_dirname  = string 
955
  type host_filename = string 
956
  type prog          = string 
957
  type arg           = string 
958
  type args          = string list 
959
  type command_line  = (prog * arg list) 
960
961
  type findlib_name = string 
962
  type findlib_full = string 
963
964
  type compiled_object =
965
    | Byte
966
    | Native
967
    | Best
968
    
969
970
  type dependency =
971
    | FindlibPackage of findlib_full * OASISVersion.comparator option
972
    | InternalLibrary of name
973
    
974
975
  type tool =
976
    | ExternalTool of name
977
    | InternalExecutable of name
978
    
979
980
  type vcs =
981
    | Darcs
982
    | Git
983
    | Svn
984
    | Cvs
985
    | Hg
986
    | Bzr
987
    | Arch
988
    | Monotone
989
    | OtherVCS of url
990
    
991
992
  type plugin_kind =
993
      [  `Configure
994
       | `Build
995
       | `Doc
996
       | `Test
997
       | `Install
998
       | `Extra
999
      ]
1000
1001
  type plugin_data_purpose =
1002
      [  `Configure
1003
       | `Build
1004
       | `Install
1005
       | `Clean
1006
       | `Distclean
1007
       | `Install
1008
       | `Uninstall
1009
       | `Test
1010
       | `Doc
1011
       | `Extra
1012
       | `Other of string
1013
      ]
1014
1015
  type 'a plugin = 'a * name * OASISVersion.t option 
1016
1017
  type all_plugin = plugin_kind plugin
1018
1019
  type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list
1020
1021
(* # 102 "src/oasis/OASISTypes.ml" *)
1022
1023
  type 'a conditional = 'a OASISExpr.choices 
1024
1025
  type custom =
1026
      {
1027
        pre_command:  (command_line option) conditional;
1028
        post_command: (command_line option) conditional;
1029
      }
1030
      
1031
1032
  type common_section =
1033
      {
1034
        cs_name: name;
1035
        cs_data: PropList.Data.t;
1036
        cs_plugin_data: plugin_data;
1037
      }
1038
      
1039
1040
  type build_section =
1041
      {
1042
        bs_build:           bool conditional;
1043
        bs_install:         bool conditional;
1044
        bs_path:            unix_dirname;
1045
        bs_compiled_object: compiled_object;
1046
        bs_build_depends:   dependency list;
1047
        bs_build_tools:     tool list;
1048
        bs_c_sources:       unix_filename list;
1049
        bs_data_files:      (unix_filename * unix_filename option) list;
1050
        bs_ccopt:           args conditional;
1051
        bs_cclib:           args conditional;
1052
        bs_dlllib:          args conditional;
1053
        bs_dllpath:         args conditional;
1054
        bs_byteopt:         args conditional;
1055
        bs_nativeopt:       args conditional;
1056
      }
1057
      
1058
1059
  type library =
1060
      {
1061
        lib_modules:            string list;
1062
        lib_pack:               bool;
1063
        lib_internal_modules:   string list;
1064
        lib_findlib_parent:     findlib_name option;
1065
        lib_findlib_name:       findlib_name option;
1066
        lib_findlib_containers: findlib_name list;
1067
      } 
1068
1069
  type executable =
1070
      {
1071
        exec_custom:          bool;
1072
        exec_main_is:         unix_filename;
1073
      } 
1074
1075
  type flag =
1076
      {
1077
        flag_description:  string option;
1078
        flag_default:      bool conditional;
1079
      } 
1080
1081
  type source_repository =
1082
      {
1083
        src_repo_type:        vcs;
1084
        src_repo_location:    url;
1085
        src_repo_browser:     url option;
1086
        src_repo_module:      string option;
1087
        src_repo_branch:      string option;
1088
        src_repo_tag:         string option;
1089
        src_repo_subdir:      unix_filename option;
1090
      } 
1091
1092
  type test =
1093
      {
1094
        test_type:               [`Test] plugin;
1095
        test_command:            command_line conditional;
1096
        test_custom:             custom;
1097
        test_working_directory:  unix_filename option;
1098
        test_run:                bool conditional;
1099
        test_tools:              tool list;
1100
      } 
1101
1102
  type doc_format =
1103
    | HTML of unix_filename
1104
    | DocText
1105
    | PDF
1106
    | PostScript
1107
    | Info of unix_filename
1108
    | DVI
1109
    | OtherDoc
1110
    
1111
1112
  type doc =
1113
      {
1114
        doc_type:        [`Doc] plugin;
1115
        doc_custom:      custom;
1116
        doc_build:       bool conditional;
1117
        doc_install:     bool conditional;
1118
        doc_install_dir: unix_filename;
1119
        doc_title:       string;
1120
        doc_authors:     string list;
1121
        doc_abstract:    string option;
1122
        doc_format:      doc_format;
1123
        doc_data_files:  (unix_filename * unix_filename option) list;
1124
        doc_build_tools: tool list;
1125
      } 
1126
1127
  type section =
1128
    | Library    of common_section * build_section * library
1129
    | Executable of common_section * build_section * executable
1130
    | Flag       of common_section * flag
1131
    | SrcRepo    of common_section * source_repository
1132
    | Test       of common_section * test
1133
    | Doc        of common_section * doc
1134
    
1135
1136
  type section_kind =
1137
      [ `Library | `Executable | `Flag | `SrcRepo | `Test | `Doc ]
1138
1139
  type package = 
1140
      {
1141
        oasis_version:    OASISVersion.t;
1142
        ocaml_version:    OASISVersion.comparator option;
1143
        findlib_version:  OASISVersion.comparator option;
1144
        name:             package_name;
1145
        version:          OASISVersion.t;
1146
        license:          OASISLicense.t;
1147
        license_file:     unix_filename option;
1148
        copyrights:       string list;
1149
        maintainers:      string list;
1150
        authors:          string list;
1151
        homepage:         url option;
1152
        synopsis:         string;
1153
        description:      string option;
1154
        categories:       url list;
1155
1156
        conf_type:        [`Configure] plugin;
1157
        conf_custom:      custom;
1158
1159
        build_type:       [`Build] plugin;
1160
        build_custom:     custom;
1161
1162
        install_type:     [`Install] plugin;
1163
        install_custom:   custom;
1164
        uninstall_custom: custom;
1165
1166
        clean_custom:     custom;
1167
        distclean_custom: custom;
1168
1169
        files_ab:         unix_filename list;
1170
        sections:         section list;
1171
        plugins:          [`Extra] plugin list;
1172
        schema_data:      PropList.Data.t;
1173
        plugin_data:      plugin_data;
1174
      } 
1175
1176
end
1177
1178
module OASISUnixPath = struct
1179
(* # 21 "src/oasis/OASISUnixPath.ml" *)
1180
1181
  type unix_filename = string
1182
  type unix_dirname = string
1183
1184
  type host_filename = string
1185
  type host_dirname = string
1186
1187
  let current_dir_name = "."
1188
1189
  let parent_dir_name = ".."
1190
1191
  let is_current_dir fn =
1192
    fn = current_dir_name || fn = ""
1193
1194
  let concat f1 f2 =
1195
    if is_current_dir f1 then
1196
      f2
1197
    else
1198
      let f1' =
1199
        try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1
1200
      in
1201
        f1'^"/"^f2
1202
1203
  let make =
1204
    function
1205
      | hd :: tl ->
1206
          List.fold_left
1207
            (fun f p -> concat f p)
1208
            hd
1209
            tl
1210
      | [] ->
1211
          invalid_arg "OASISUnixPath.make"
1212
1213
  let dirname f =
1214
    try
1215
      String.sub f 0 (String.rindex f '/')
1216
    with Not_found ->
1217
      current_dir_name
1218
1219
  let basename f =
1220
    try
1221
      let pos_start =
1222
        (String.rindex f '/') + 1
1223
      in
1224
        String.sub f pos_start ((String.length f) - pos_start)
1225
    with Not_found ->
1226
      f
1227
1228
  let chop_extension f =
1229
    try
1230
      let last_dot =
1231
        String.rindex f '.'
1232
      in
1233
      let sub =
1234
        String.sub f 0 last_dot
1235
      in
1236
        try
1237
          let last_slash =
1238
            String.rindex f '/'
1239
          in
1240
            if last_slash < last_dot then
1241
              sub
1242
            else
1243
              f
1244
        with Not_found ->
1245
          sub
1246
1247
    with Not_found ->
1248
      f
1249
1250
  let capitalize_file f =
1251
    let dir = dirname f in
1252
    let base = basename f in
1253
    concat dir (String.capitalize base)
1254
1255
  let uncapitalize_file f =
1256
    let dir = dirname f in
1257
    let base = basename f in
1258
    concat dir (String.uncapitalize base)
1259
1260
end
1261
1262
module OASISHostPath = struct
1263
(* # 21 "src/oasis/OASISHostPath.ml" *)
1264
1265
1266
  open Filename
1267
1268
  module Unix = OASISUnixPath
1269
1270
  let make =
1271
    function
1272
      | [] ->
1273
          invalid_arg "OASISHostPath.make"
1274
      | hd :: tl ->
1275
          List.fold_left Filename.concat hd tl
1276
1277
  let of_unix ufn =
1278
    if Sys.os_type = "Unix" then
1279
      ufn
1280
    else
1281
      make
1282
        (List.map
1283
           (fun p ->
1284
              if p = Unix.current_dir_name then
1285
                current_dir_name
1286
              else if p = Unix.parent_dir_name then
1287
                parent_dir_name
1288
              else
1289
                p)
1290
           (OASISString.nsplit ufn '/'))
1291
1292
1293
end
1294
1295
module OASISSection = struct
1296
(* # 21 "src/oasis/OASISSection.ml" *)
1297
1298
  open OASISTypes
1299
1300
  let section_kind_common = 
1301
    function
1302
      | Library (cs, _, _) -> 
1303
          `Library, cs
1304
      | Executable (cs, _, _) ->
1305
          `Executable, cs
1306
      | Flag (cs, _) ->
1307
          `Flag, cs
1308
      | SrcRepo (cs, _) ->
1309
          `SrcRepo, cs
1310
      | Test (cs, _) ->
1311
          `Test, cs
1312
      | Doc (cs, _) ->
1313
          `Doc, cs
1314
1315
  let section_common sct =
1316
    snd (section_kind_common sct)
1317
1318
  let section_common_set cs =
1319
    function
1320
      | Library (_, bs, lib)     -> Library (cs, bs, lib)
1321
      | Executable (_, bs, exec) -> Executable (cs, bs, exec)
1322
      | Flag (_, flg)            -> Flag (cs, flg)
1323
      | SrcRepo (_, src_repo)    -> SrcRepo (cs, src_repo)
1324
      | Test (_, tst)            -> Test (cs, tst)
1325
      | Doc (_, doc)             -> Doc (cs, doc)
1326
1327
  (** Key used to identify section
1328
    *)
1329
  let section_id sct = 
1330
    let k, cs = 
1331
      section_kind_common sct
1332
    in
1333
      k, cs.cs_name
1334
1335
  let string_of_section sct =
1336
    let k, nm =
1337
      section_id sct
1338
    in
1339
      (match k with
1340
         | `Library    -> "library" 
1341
         | `Executable -> "executable"
1342
         | `Flag       -> "flag"
1343
         | `SrcRepo    -> "src repository"
1344
         | `Test       -> "test"
1345
         | `Doc        -> "doc")
1346
      ^" "^nm
1347
1348
  let section_find id scts =
1349
    List.find
1350
      (fun sct -> id = section_id sct)
1351
      scts
1352
1353
  module CSection =
1354
  struct
1355
    type t = section
1356
1357
    let id = section_id
1358
1359
    let compare t1 t2 = 
1360
      compare (id t1) (id t2)
1361
      
1362
    let equal t1 t2 =
1363
      (id t1) = (id t2)
1364
1365
    let hash t =
1366
      Hashtbl.hash (id t)
1367
  end
1368
1369
  module MapSection = Map.Make(CSection)
1370
  module SetSection = Set.Make(CSection)
1371
1372
end
1373
1374
module OASISBuildSection = struct
1375
(* # 21 "src/oasis/OASISBuildSection.ml" *)
1376
1377
end
1378
1379
module OASISExecutable = struct
1380
(* # 21 "src/oasis/OASISExecutable.ml" *)
1381
1382
  open OASISTypes
1383
1384
  let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = 
1385
    let dir = 
1386
      OASISUnixPath.concat
1387
        bs.bs_path
1388
        (OASISUnixPath.dirname exec.exec_main_is)
1389
    in
1390
    let is_native_exec = 
1391
      match bs.bs_compiled_object with
1392
        | Native -> true
1393
        | Best -> is_native ()
1394
        | Byte -> false
1395
    in
1396
1397
      OASISUnixPath.concat
1398
        dir
1399
        (cs.cs_name^(suffix_program ())),
1400
1401
      if not is_native_exec && 
1402
         not exec.exec_custom && 
1403
         bs.bs_c_sources <> [] then
1404
        Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ()))
1405
      else
1406
        None
1407
1408
end
1409
1410
module OASISLibrary = struct
1411
(* # 21 "src/oasis/OASISLibrary.ml" *)
1412
1413
  open OASISTypes
1414
  open OASISUtils
1415
  open OASISGettext
1416
  open OASISSection
1417
1418
  type library_name = name
1419
  type findlib_part_name = name
1420
  type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t
1421
1422
  exception InternalLibraryNotFound of library_name
1423
  exception FindlibPackageNotFound of findlib_name
1424
1425
  type group_t =
1426
    | Container of findlib_name * group_t list
1427
    | Package of (findlib_name *
1428
                  common_section *
1429
                  build_section *
1430
                  library *
1431
                  group_t list)
1432
1433
  (* Look for a module file, considering capitalization or not. *)
1434
  let find_module source_file_exists (cs, bs, lib) modul =
1435
    let possible_base_fn =
1436
      List.map
1437
        (OASISUnixPath.concat bs.bs_path)
1438
        [modul;
1439
         OASISUnixPath.uncapitalize_file modul;
1440
         OASISUnixPath.capitalize_file modul]
1441
    in
1442
      (* TODO: we should be able to be able to determine the source for every
1443
       * files. Hence we should introduce a Module(source: fn) for the fields
1444
       * Modules and InternalModules
1445
       *)
1446
      List.fold_left
1447
        (fun acc base_fn ->
1448
           match acc with
1449
             | `No_sources _ ->
1450
                 begin
1451
                   let file_found =
1452
                     List.fold_left
1453
                       (fun acc ext ->
1454
                          if source_file_exists (base_fn^ext) then
1455
                            (base_fn^ext) :: acc
1456
                          else
1457
                            acc)
1458
                       []
1459
                       [".ml"; ".mli"; ".mll"; ".mly"]
1460
                   in
1461
                     match file_found with
1462
                       | [] ->
1463
                           acc
1464
                       | lst ->
1465
                           `Sources (base_fn, lst)
1466
                 end
1467
             | `Sources _ ->
1468
                 acc)
1469
        (`No_sources possible_base_fn)
1470
        possible_base_fn
1471
1472
  let source_unix_files ~ctxt (cs, bs, lib) source_file_exists =
1473
    List.fold_left
1474
      (fun acc modul ->
1475
         match find_module source_file_exists (cs, bs, lib) modul with
1476
           | `Sources (base_fn, lst) ->
1477
               (base_fn, lst) :: acc
1478
           | `No_sources _ ->
1479
               OASISMessage.warning
1480
                 ~ctxt
1481
                 (f_ "Cannot find source file matching \
1482
                      module '%s' in library %s")
1483
                 modul cs.cs_name;
1484
               acc)
1485
      []
1486
      (lib.lib_modules @ lib.lib_internal_modules)
1487
1488
  let generated_unix_files
1489
        ~ctxt
1490
        ~is_native
1491
        ~has_native_dynlink
1492
        ~ext_lib
1493
        ~ext_dll
1494
        ~source_file_exists
1495
        (cs, bs, lib) =
1496
1497
    let find_modules lst ext = 
1498
      let find_module modul =
1499
        match find_module source_file_exists (cs, bs, lib) modul with
1500
          | `Sources (base_fn, _) ->
1501
              [base_fn]
1502
          | `No_sources lst ->
1503
              OASISMessage.warning
1504
                ~ctxt
1505
                (f_ "Cannot find source file matching \
1506
                     module '%s' in library %s")
1507
                modul cs.cs_name;
1508
              lst
1509
      in
1510
      List.map 
1511
        (fun nm -> 
1512
           List.map 
1513
             (fun base_fn -> base_fn ^"."^ext)
1514
             (find_module nm))
1515
        lst
1516
    in
1517
1518
    (* The headers that should be compiled along *)
1519
    let headers =
1520
      if lib.lib_pack then
1521
        []
1522
      else
1523
        find_modules
1524
          lib.lib_modules
1525
          "cmi"
1526
    in
1527
1528
    (* The .cmx that be compiled along *)
1529
    let cmxs =
1530
      let should_be_built =
1531
        (not lib.lib_pack) && (* Do not install .cmx packed submodules *)
1532
        match bs.bs_compiled_object with
1533
          | Native -> true
1534
          | Best -> is_native
1535
          | Byte -> false
1536
      in
1537
        if should_be_built then
1538
          find_modules
1539
            (lib.lib_modules @ lib.lib_internal_modules)
1540
            "cmx"
1541
        else
1542
          []
1543
    in
1544
1545
    let acc_nopath =
1546
      []
1547
    in
1548
1549
    (* Compute what libraries should be built *)
1550
    let acc_nopath =
1551
      (* Add the packed header file if required *)
1552
      let add_pack_header acc =
1553
        if lib.lib_pack then
1554
          [cs.cs_name^".cmi"] :: acc
1555
        else
1556
          acc
1557
      in
1558
      let byte acc =
1559
        add_pack_header ([cs.cs_name^".cma"] :: acc)
1560
      in
1561
      let native acc =
1562
        let acc = 
1563
          add_pack_header
1564
            (if has_native_dynlink then
1565
               [cs.cs_name^".cmxs"] :: acc
1566
             else acc)
1567
        in
1568
          [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc
1569
      in
1570
        match bs.bs_compiled_object with
1571
          | Native ->
1572
              byte (native acc_nopath)
1573
          | Best when is_native ->
1574
              byte (native acc_nopath)
1575
          | Byte | Best ->
1576
              byte acc_nopath
1577
    in
1578
1579
    (* Add C library to be built *)
1580
    let acc_nopath =
1581
      if bs.bs_c_sources <> [] then
1582
        begin
1583
          ["lib"^cs.cs_name^"_stubs"^ext_lib]
1584
          ::
1585
          ["dll"^cs.cs_name^"_stubs"^ext_dll]
1586
          ::
1587
          acc_nopath
1588
        end
1589
      else
1590
        acc_nopath
1591
    in
1592
1593
      (* All the files generated *)
1594
      List.rev_append
1595
        (List.rev_map
1596
           (List.rev_map
1597
              (OASISUnixPath.concat bs.bs_path))
1598
           acc_nopath)
1599
        (headers @ cmxs)
1600
1601
  type data = common_section * build_section * library
1602
  type tree =
1603
    | Node of (data option) * (tree MapString.t)
1604
    | Leaf of data
1605
1606
  let findlib_mapping pkg =
1607
    (* Map from library name to either full findlib name or parts + parent. *)
1608
    let fndlb_parts_of_lib_name =
1609
      let fndlb_parts cs lib =
1610
        let name =
1611
          match lib.lib_findlib_name with
1612
            | Some nm -> nm
1613
            | None -> cs.cs_name
1614
        in
1615
        let name =
1616
          String.concat "." (lib.lib_findlib_containers @ [name])
1617
        in
1618
          name
1619
      in
1620
        List.fold_left
1621
          (fun mp ->
1622
             function
1623
               | Library (cs, _, lib) ->
1624
                   begin
1625
                     let lib_name = cs.cs_name in
1626
                     let fndlb_parts = fndlb_parts cs lib in
1627
                       if MapString.mem lib_name mp then
1628
                         failwithf
1629
                           (f_ "The library name '%s' is used more than once.")
1630
                           lib_name;
1631
                       match lib.lib_findlib_parent with
1632
                         | Some lib_name_parent ->
1633
                             MapString.add
1634
                               lib_name
1635
                               (`Unsolved (lib_name_parent, fndlb_parts))
1636
                               mp
1637
                         | None ->
1638
                             MapString.add
1639
                               lib_name
1640
                               (`Solved fndlb_parts)
1641
                               mp
1642
                   end
1643
1644
               | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ ->
1645
                   mp)
1646
          MapString.empty
1647
          pkg.sections
1648
    in
1649
1650
    (* Solve the above graph to be only library name to full findlib name. *)
1651
    let fndlb_name_of_lib_name =
1652
      let rec solve visited mp lib_name lib_name_child =
1653
        if SetString.mem lib_name visited then
1654
          failwithf
1655
            (f_ "Library '%s' is involved in a cycle \
1656
                 with regard to findlib naming.")
1657
            lib_name;
1658
        let visited = SetString.add lib_name visited in
1659
          try
1660
            match MapString.find lib_name mp with
1661
              | `Solved fndlb_nm ->
1662
                  fndlb_nm, mp
1663
              | `Unsolved (lib_nm_parent, post_fndlb_nm) ->
1664
                  let pre_fndlb_nm, mp =
1665
                    solve visited mp lib_nm_parent lib_name
1666
                  in
1667
                  let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in
1668
                    fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp
1669
          with Not_found ->
1670
            failwithf
1671
              (f_ "Library '%s', which is defined as the findlib parent of \
1672
                   library '%s', doesn't exist.")
1673
              lib_name lib_name_child
1674
      in
1675
      let mp =
1676
        MapString.fold
1677
          (fun lib_name status mp ->
1678
             match status with
1679
               | `Solved _ ->
1680
                   (* Solved initialy, no need to go further *)
1681
                   mp
1682
               | `Unsolved _ ->
1683
                   let _, mp = solve SetString.empty mp lib_name "<none>" in
1684
                     mp)
1685
          fndlb_parts_of_lib_name
1686
          fndlb_parts_of_lib_name
1687
      in
1688
        MapString.map
1689
          (function
1690
             | `Solved fndlb_nm -> fndlb_nm
1691
             | `Unsolved _ -> assert false)
1692
          mp
1693
    in
1694
1695
    (* Convert an internal library name to a findlib name. *)
1696
    let findlib_name_of_library_name lib_nm =
1697
      try
1698
        MapString.find lib_nm fndlb_name_of_lib_name
1699
      with Not_found ->
1700
        raise (InternalLibraryNotFound lib_nm)
1701
    in
1702
1703
    (* Add a library to the tree.
1704
     *)
1705
    let add sct mp =
1706
      let fndlb_fullname =
1707
        let cs, _, _ = sct in
1708
        let lib_name = cs.cs_name in
1709
          findlib_name_of_library_name lib_name
1710
      in
1711
      let rec add_children nm_lst (children : tree MapString.t) =
1712
        match nm_lst with
1713
          | (hd :: tl) ->
1714
              begin
1715
                let node =
1716
                  try
1717
                    add_node tl (MapString.find hd children)
1718
                  with Not_found ->
1719
                    (* New node *)
1720
                    new_node tl
1721
                in
1722
                  MapString.add hd node children
1723
              end
1724
          | [] ->
1725
              (* Should not have a nameless library. *)
1726
              assert false
1727
      and add_node tl node =
1728
        if tl = [] then
1729
          begin
1730
            match node with
1731
              | Node (None, children) ->
1732
                  Node (Some sct, children)
1733
              | Leaf (cs', _, _) | Node (Some (cs', _, _), _) ->
1734
                  (* TODO: allow to merge Package, i.e.
1735
                   * archive(byte) = "foo.cma foo_init.cmo"
1736
                   *)
1737
                  let cs, _, _ = sct in
1738
                    failwithf
1739
                      (f_ "Library '%s' and '%s' have the same findlib name '%s'")
1740
                      cs.cs_name cs'.cs_name fndlb_fullname
1741
          end
1742
        else
1743
          begin
1744
            match node with
1745
              | Leaf data ->
1746
                  Node (Some data, add_children tl MapString.empty)
1747
              | Node (data_opt, children) ->
1748
                  Node (data_opt, add_children tl children)
1749
          end
1750
      and new_node =
1751
        function
1752
          | [] ->
1753
              Leaf sct
1754
          | hd :: tl ->
1755
              Node (None, MapString.add hd (new_node tl) MapString.empty)
1756
      in
1757
        add_children (OASISString.nsplit fndlb_fullname '.') mp
1758
    in
1759
1760
    let rec group_of_tree mp =
1761
      MapString.fold
1762
        (fun nm node acc ->
1763
           let cur =
1764
             match node with
1765
               | Node (Some (cs, bs, lib), children) ->
1766
                   Package (nm, cs, bs, lib, group_of_tree children)
1767
               | Node (None, children) ->
1768
                   Container (nm, group_of_tree children)
1769
               | Leaf (cs, bs, lib) ->
1770
                   Package (nm, cs, bs, lib, [])
1771
           in
1772
             cur :: acc)
1773
        mp []
1774
    in
1775
1776
    let group_mp =
1777
      List.fold_left
1778
        (fun mp ->
1779
           function
1780
             | Library (cs, bs, lib) ->
1781
                 add (cs, bs, lib) mp
1782
             | _ ->
1783
                 mp)
1784
        MapString.empty
1785
        pkg.sections
1786
    in
1787
1788
    let groups =
1789
      group_of_tree group_mp
1790
    in
1791
1792
    let library_name_of_findlib_name =
1793
      Lazy.lazy_from_fun
1794
        (fun () ->
1795
           (* Revert findlib_name_of_library_name. *)
1796
           MapString.fold
1797
             (fun k v mp -> MapString.add v k mp)
1798
             fndlb_name_of_lib_name
1799
             MapString.empty)
1800
    in
1801
    let library_name_of_findlib_name fndlb_nm =
1802
      try
1803
        MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name)
1804
      with Not_found ->
1805
        raise (FindlibPackageNotFound fndlb_nm)
1806
    in
1807
1808
      groups,
1809
      findlib_name_of_library_name,
1810
      library_name_of_findlib_name
1811
1812
  let findlib_of_group =
1813
    function
1814
      | Container (fndlb_nm, _)
1815
      | Package (fndlb_nm, _, _, _, _) -> fndlb_nm
1816
1817
  let root_of_group grp =
1818
    let rec root_lib_aux =
1819
      (* We do a DFS in the group. *)
1820
      function
1821
        | Container (_, children) ->
1822
            List.fold_left
1823
              (fun res grp ->
1824
                 if res = None then
1825
                   root_lib_aux grp
1826
                 else
1827
                   res)
1828
              None
1829
              children
1830
        | Package (_, cs, bs, lib, _) ->
1831
            Some (cs, bs, lib)
1832
    in
1833
      match root_lib_aux grp with
1834
        | Some res ->
1835
            res
1836
        | None ->
1837
            failwithf
1838
              (f_ "Unable to determine root library of findlib library '%s'")
1839
              (findlib_of_group grp)
1840
1841
end
1842
1843
module OASISFlag = struct
1844
(* # 21 "src/oasis/OASISFlag.ml" *)
1845
1846
end
1847
1848
module OASISPackage = struct
1849
(* # 21 "src/oasis/OASISPackage.ml" *)
1850
1851
end
1852
1853
module OASISSourceRepository = struct
1854
(* # 21 "src/oasis/OASISSourceRepository.ml" *)
1855
1856
end
1857
1858
module OASISTest = struct
1859
(* # 21 "src/oasis/OASISTest.ml" *)
1860
1861
end
1862
1863
module OASISDocument = struct
1864
(* # 21 "src/oasis/OASISDocument.ml" *)
1865
1866
end
1867
1868
module OASISExec = struct
1869
(* # 21 "src/oasis/OASISExec.ml" *)
1870
1871
  open OASISGettext
1872
  open OASISUtils
1873
  open OASISMessage
1874
1875
  (* TODO: I don't like this quote, it is there because $(rm) foo expands to
1876
   * 'rm -f' foo...
1877
   *)
1878
  let run ~ctxt ?f_exit_code ?(quote=true) cmd args =
1879
    let cmd =
1880
      if quote then
1881
        if Sys.os_type = "Win32" then
1882
          if String.contains cmd ' ' then
1883
            (* Double the 1st double quote... win32... sigh *)
1884
            "\""^(Filename.quote cmd)
1885
          else
1886
            cmd
1887
        else
1888
          Filename.quote cmd
1889
      else
1890
        cmd
1891
    in
1892
    let cmdline =
1893
      String.concat " " (cmd :: args)
1894
    in
1895
      info ~ctxt (f_ "Running command '%s'") cmdline;
1896
      match f_exit_code, Sys.command cmdline with
1897
        | None, 0 -> ()
1898
        | None, i ->
1899
            failwithf
1900
              (f_ "Command '%s' terminated with error code %d")
1901
              cmdline i
1902
        | Some f, i ->
1903
            f i
1904
1905
  let run_read_output ~ctxt ?f_exit_code cmd args =
1906
    let fn =
1907
      Filename.temp_file "oasis-" ".txt"
1908
    in
1909
      try
1910
        begin
1911
          let () =
1912
            run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn])
1913
          in
1914
          let chn =
1915
            open_in fn
1916
          in
1917
          let routput =
1918
            ref []
1919
          in
1920
            begin
1921
              try
1922
                while true do
1923
                  routput := (input_line chn) :: !routput
1924
                done
1925
              with End_of_file ->
1926
                ()
1927
            end;
1928
            close_in chn;
1929
            Sys.remove fn;
1930
            List.rev !routput
1931
        end
1932
      with e ->
1933
        (try Sys.remove fn with _ -> ());
1934
        raise e
1935
1936
  let run_read_one_line ~ctxt ?f_exit_code cmd args =
1937
    match run_read_output ~ctxt ?f_exit_code cmd args with
1938
      | [fst] ->
1939
          fst
1940
      | lst ->
1941
          failwithf
1942
            (f_ "Command return unexpected output %S")
1943
            (String.concat "\n" lst)
1944
end
1945
1946
module OASISFileUtil = struct
1947
(* # 21 "src/oasis/OASISFileUtil.ml" *)
1948
1949
  open OASISGettext
1950
1951
  let file_exists_case fn =
1952
    let dirname = Filename.dirname fn in
1953
    let basename = Filename.basename fn in
1954
      if Sys.file_exists dirname then
1955
        if basename = Filename.current_dir_name then
1956
          true
1957
        else
1958
          List.mem
1959
            basename
1960
            (Array.to_list (Sys.readdir dirname))
1961
      else
1962
        false
1963
1964
  let find_file ?(case_sensitive=true) paths exts =
1965
1966
    (* Cardinal product of two list *)
1967
    let ( * ) lst1 lst2 =
1968
      List.flatten
1969
        (List.map
1970
           (fun a ->
1971
              List.map
1972
                (fun b -> a,b)
1973
                lst2)
1974
           lst1)
1975
    in
1976
1977
    let rec combined_paths lst =
1978
      match lst with
1979
        | p1 :: p2 :: tl ->
1980
            let acc =
1981
              (List.map
1982
                 (fun (a,b) -> Filename.concat a b)
1983
                 (p1 * p2))
1984
            in
1985
              combined_paths (acc :: tl)
1986
        | [e] ->
1987
            e
1988
        | [] ->
1989
            []
1990
    in
1991
1992
    let alternatives =
1993
      List.map
1994
        (fun (p,e) ->
1995
           if String.length e > 0 && e.[0] <> '.' then
1996
             p ^ "." ^ e
1997
           else
1998
             p ^ e)
1999
        ((combined_paths paths) * exts)
2000
    in
2001
      List.find
2002
        (if case_sensitive then
2003
           file_exists_case
2004
         else
2005
           Sys.file_exists)
2006
        alternatives
2007
2008
  let which ~ctxt prg =
2009
    let path_sep =
2010
      match Sys.os_type with
2011
        | "Win32" ->
2012
            ';'
2013
        | _ ->
2014
            ':'
2015
    in
2016
    let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in
2017
    let exec_ext =
2018
      match Sys.os_type with
2019
        | "Win32" ->
2020
            "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep)
2021
        | _ ->
2022
            [""]
2023
    in
2024
      find_file ~case_sensitive:false [path_lst; [prg]] exec_ext
2025
2026
  (**/**)
2027
  let rec fix_dir dn =
2028
    (* Windows hack because Sys.file_exists "src\\" = false when
2029
     * Sys.file_exists "src" = true
2030
     *)
2031
    let ln =
2032
      String.length dn
2033
    in
2034
      if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then
2035
        fix_dir (String.sub dn 0 (ln - 1))
2036
      else
2037
        dn
2038
2039
  let q = Filename.quote
2040
  (**/**)
2041
2042
  let cp ~ctxt ?(recurse=false) src tgt =
2043
    if recurse then
2044
      match Sys.os_type with
2045
        | "Win32" ->
2046
            OASISExec.run ~ctxt
2047
              "xcopy" [q src; q tgt; "/E"]
2048
        | _ ->
2049
            OASISExec.run ~ctxt
2050
              "cp" ["-r"; q src; q tgt]
2051
    else
2052
      OASISExec.run ~ctxt
2053
        (match Sys.os_type with
2054
         | "Win32" -> "copy"
2055
         | _ -> "cp")
2056
        [q src; q tgt]
2057
2058
  let mkdir ~ctxt tgt =
2059
    OASISExec.run ~ctxt
2060
      (match Sys.os_type with
2061
         | "Win32" -> "md"
2062
         | _ -> "mkdir")
2063
      [q tgt]
2064
2065
  let rec mkdir_parent ~ctxt f tgt =
2066
    let tgt =
2067
      fix_dir tgt
2068
    in
2069
      if Sys.file_exists tgt then
2070
        begin
2071
          if not (Sys.is_directory tgt) then
2072
            OASISUtils.failwithf
2073
              (f_ "Cannot create directory '%s', a file of the same name already \
2074
                   exists")
2075
              tgt
2076
        end
2077
      else
2078
        begin
2079
          mkdir_parent ~ctxt f (Filename.dirname tgt);
2080
          if not (Sys.file_exists tgt) then
2081
            begin
2082
              f tgt;
2083
              mkdir ~ctxt tgt
2084
            end
2085
        end
2086
2087
  let rmdir ~ctxt tgt =
2088
    if Sys.readdir tgt = [||] then
2089
      begin
2090
        match Sys.os_type with
2091
          | "Win32" ->
2092
              OASISExec.run ~ctxt "rd" [q tgt]
2093
          | _ ->
2094
              OASISExec.run ~ctxt "rm" ["-r"; q tgt]
2095
      end
2096
2097
  let glob ~ctxt fn =
2098
   let basename =
2099
     Filename.basename fn
2100
   in
2101
     if String.length basename >= 2 &&
2102
        basename.[0] = '*' &&
2103
        basename.[1] = '.' then
2104
       begin
2105
         let ext_len =
2106
           (String.length basename) - 2
2107
         in
2108
         let ext =
2109
           String.sub basename 2 ext_len
2110
         in
2111
         let dirname =
2112
           Filename.dirname fn
2113
         in
2114
           Array.fold_left
2115
             (fun acc fn ->
2116
                try
2117
                  let fn_ext =
2118
                    String.sub
2119
                      fn
2120
                      ((String.length fn) - ext_len)
2121
                      ext_len
2122
                  in
2123
                    if fn_ext = ext then
2124
                      (Filename.concat dirname fn) :: acc
2125
                    else
2126
                      acc
2127
                with Invalid_argument _ ->
2128
                  acc)
2129
             []
2130
             (Sys.readdir dirname)
2131
       end
2132
     else
2133
       begin
2134
         if file_exists_case fn then
2135
           [fn]
2136
         else
2137
           []
2138
       end
2139
end
2140
2141
2142
# 2142 "setup.ml"
2143
module BaseEnvLight = struct
2144
(* # 21 "src/base/BaseEnvLight.ml" *)
2145
2146
  module MapString = Map.Make(String)
2147
2148
  type t = string MapString.t
2149
2150
  let default_filename =
2151
    Filename.concat
2152
      (Sys.getcwd ())
2153
      "setup.data"
2154
2155
  let load ?(allow_empty=false) ?(filename=default_filename) () =
2156
    if Sys.file_exists filename then
2157
      begin
2158
        let chn =
2159
          open_in_bin filename
2160
        in
2161
        let st =
2162
          Stream.of_channel chn
2163
        in
2164
        let line =
2165
          ref 1
2166
        in
2167
        let st_line =
2168
          Stream.from
2169
            (fun _ ->
2170
               try
2171
                 match Stream.next st with
2172
                   | '\n' -> incr line; Some '\n'
2173
                   | c -> Some c
2174
               with Stream.Failure -> None)
2175
        in
2176
        let lexer =
2177
          Genlex.make_lexer ["="] st_line
2178
        in
2179
        let rec read_file mp =
2180
          match Stream.npeek 3 lexer with
2181
            | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] ->
2182
                Stream.junk lexer;
2183
                Stream.junk lexer;
2184
                Stream.junk lexer;
2185
                read_file (MapString.add nm value mp)
2186
            | [] ->
2187
                mp
2188
            | _ ->
2189
                failwith
2190
                  (Printf.sprintf
2191
                     "Malformed data file '%s' line %d"
2192
                     filename !line)
2193
        in
2194
        let mp =
2195
          read_file MapString.empty
2196
        in
2197
          close_in chn;
2198
          mp
2199
      end
2200
    else if allow_empty then
2201
      begin
2202
        MapString.empty
2203
      end
2204
    else
2205
      begin
2206
        failwith
2207
          (Printf.sprintf
2208
             "Unable to load environment, the file '%s' doesn't exist."
2209
             filename)
2210
      end
2211
2212
  let var_get name env =
2213
    let rec var_expand str =
2214
      let buff =
2215
        Buffer.create ((String.length str) * 2)
2216
      in
2217
        Buffer.add_substitute
2218
          buff
2219
          (fun var ->
2220
             try
2221
               var_expand (MapString.find var env)
2222
             with Not_found ->
2223
               failwith
2224
                 (Printf.sprintf
2225
                    "No variable %s defined when trying to expand %S."
2226
                    var
2227
                    str))
2228
          str;
2229
        Buffer.contents buff
2230
    in
2231
      var_expand (MapString.find name env)
2232
2233
  let var_choose lst env =
2234
    OASISExpr.choose
2235
      (fun nm -> var_get nm env)
2236
      lst
2237
end
2238
2239
2240
# 2240 "setup.ml"
2241
module BaseContext = struct
2242
(* # 21 "src/base/BaseContext.ml" *)
2243
2244
  open OASISContext
2245
2246
  let args = args
2247
2248
  let default = default
2249
2250
end
2251
2252
module BaseMessage = struct
2253
(* # 21 "src/base/BaseMessage.ml" *)
2254
2255
  (** Message to user, overrid for Base
2256
      @author Sylvain Le Gall
2257
    *)
2258
  open OASISMessage
2259
  open BaseContext
2260
2261
  let debug fmt   = debug ~ctxt:!default fmt
2262
2263
  let info fmt    = info ~ctxt:!default fmt
2264
2265
  let warning fmt = warning ~ctxt:!default fmt
2266
2267
  let error fmt = error ~ctxt:!default fmt
2268
2269
end
2270
2271
module BaseEnv = struct
2272
(* # 21 "src/base/BaseEnv.ml" *)
2273
2274
  open OASISGettext
2275
  open OASISUtils
2276
  open PropList
2277
2278
  module MapString = BaseEnvLight.MapString
2279
2280
  type origin_t =
2281
    | ODefault
2282
    | OGetEnv
2283
    | OFileLoad
2284
    | OCommandLine
2285
2286
  type cli_handle_t =
2287
    | CLINone
2288
    | CLIAuto
2289
    | CLIWith
2290
    | CLIEnable
2291
    | CLIUser of (Arg.key * Arg.spec * Arg.doc) list
2292
2293
  type definition_t =
2294
      {
2295
        hide:       bool;
2296
        dump:       bool;
2297
        cli:        cli_handle_t;
2298
        arg_help:   string option;
2299
        group:      string option;
2300
      }
2301
2302
  let schema =
2303
    Schema.create "environment"
2304
2305
  (* Environment data *)
2306
  let env =
2307
    Data.create ()
2308
2309
  (* Environment data from file *)
2310
  let env_from_file =
2311
    ref MapString.empty
2312
2313
  (* Lexer for var *)
2314
  let var_lxr =
2315
    Genlex.make_lexer []
2316
2317
  let rec var_expand str =
2318
    let buff =
2319
      Buffer.create ((String.length str) * 2)
2320
    in
2321
      Buffer.add_substitute
2322
        buff
2323
        (fun var ->
2324
           try
2325
             (* TODO: this is a quick hack to allow calling Test.Command
2326
              * without defining executable name really. I.e. if there is
2327
              * an exec Executable toto, then $(toto) should be replace
2328
              * by its real name. It is however useful to have this function
2329
              * for other variable that depend on the host and should be
2330
              * written better than that.
2331
              *)
2332
             let st =
2333
               var_lxr (Stream.of_string var)
2334
             in
2335
               match Stream.npeek 3 st with
2336
                 | [Genlex.Ident "utoh"; Genlex.Ident nm] ->
2337
                     OASISHostPath.of_unix (var_get nm)
2338
                 | [Genlex.Ident "utoh"; Genlex.String s] ->
2339
                     OASISHostPath.of_unix s
2340
                 | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] ->
2341
                     String.escaped (var_get nm)
2342
                 | [Genlex.Ident "ocaml_escaped"; Genlex.String s] ->
2343
                     String.escaped s
2344
                 | [Genlex.Ident nm] ->
2345
                     var_get nm
2346
                 | _ ->
2347
                     failwithf
2348
                       (f_ "Unknown expression '%s' in variable expansion of %s.")
2349
                       var
2350
                       str
2351
           with
2352
             | Unknown_field (_, _) ->
2353
                 failwithf
2354
                   (f_ "No variable %s defined when trying to expand %S.")
2355
                   var
2356
                   str
2357
             | Stream.Error e ->
2358
                 failwithf
2359
                   (f_ "Syntax error when parsing '%s' when trying to \
2360
                        expand %S: %s")
2361
                   var
2362
                   str
2363
                   e)
2364
        str;
2365
      Buffer.contents buff
2366
2367
  and var_get name =
2368
    let vl =
2369
      try
2370
        Schema.get schema env name
2371
      with Unknown_field _ as e ->
2372
        begin
2373
          try
2374
            MapString.find name !env_from_file
2375
          with Not_found ->
2376
            raise e
2377
        end
2378
    in
2379
      var_expand vl
2380
2381
  let var_choose ?printer ?name lst =
2382
    OASISExpr.choose
2383
      ?printer
2384
      ?name
2385
      var_get
2386
      lst
2387
2388
  let var_protect vl =
2389
    let buff =
2390
      Buffer.create (String.length vl)
2391
    in
2392
      String.iter
2393
        (function
2394
           | '$' -> Buffer.add_string buff "\\$"
2395
           | c   -> Buffer.add_char   buff c)
2396
        vl;
2397
      Buffer.contents buff
2398
2399
  let var_define
2400
        ?(hide=false)
2401
        ?(dump=true)
2402
        ?short_desc
2403
        ?(cli=CLINone)
2404
        ?arg_help
2405
        ?group
2406
        name (* TODO: type constraint on the fact that name must be a valid OCaml
2407
                  id *)
2408
        dflt =
2409
2410
    let default =
2411
      [
2412
        OFileLoad, (fun () -> MapString.find name !env_from_file);
2413
        ODefault,  dflt;
2414
        OGetEnv,   (fun () -> Sys.getenv name);
2415
      ]
2416
    in
2417
2418
    let extra =
2419
      {
2420
        hide     = hide;
2421
        dump     = dump;
2422
        cli      = cli;
2423
        arg_help = arg_help;
2424
        group    = group;
2425
      }
2426
    in
2427
2428
    (* Try to find a value that can be defined
2429
     *)
2430
    let var_get_low lst =
2431
      let errors, res =
2432
        List.fold_left
2433
          (fun (errors, res) (o, v) ->
2434
             if res = None then
2435
               begin
2436
                 try
2437
                   errors, Some (v ())
2438
                 with
2439
                   | Not_found ->
2440
                        errors, res
2441
                   | Failure rsn ->
2442
                       (rsn :: errors), res
2443
                   | e ->
2444
                       (Printexc.to_string e) :: errors, res
2445
               end
2446
             else
2447
               errors, res)
2448
          ([], None)
2449
          (List.sort
2450
             (fun (o1, _) (o2, _) ->
2451
                Pervasives.compare o2 o1)
2452
             lst)
2453
      in
2454
        match res, errors with
2455
          | Some v, _ ->
2456
              v
2457
          | None, [] ->
2458
              raise (Not_set (name, None))
2459
          | None, lst ->
2460
              raise (Not_set (name, Some (String.concat (s_ ", ") lst)))
2461
    in
2462
2463
    let help =
2464
      match short_desc with
2465
        | Some fs -> Some fs
2466
        | None -> None
2467
    in
2468
2469
    let var_get_lst =
2470
      FieldRO.create
2471
        ~schema
2472
        ~name
2473
        ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s])
2474
        ~print:var_get_low
2475
        ~default
2476
        ~update:(fun ?context x old_x -> x @ old_x)
2477
        ?help
2478
        extra
2479
    in
2480
2481
      fun () ->
2482
        var_expand (var_get_low (var_get_lst env))
2483
2484
  let var_redefine
2485
        ?hide
2486
        ?dump
2487
        ?short_desc
2488
        ?cli
2489
        ?arg_help
2490
        ?group
2491
        name
2492
        dflt =
2493
    if Schema.mem schema name then
2494
      begin
2495
        (* TODO: look suspsicious, we want to memorize dflt not dflt () *)
2496
        Schema.set schema env ~context:ODefault name (dflt ());
2497
        fun () -> var_get name
2498
      end
2499
    else
2500
      begin
2501
        var_define
2502
          ?hide
2503
          ?dump
2504
          ?short_desc
2505
          ?cli
2506
          ?arg_help
2507
          ?group
2508
          name
2509
          dflt
2510
      end
2511
2512
  let var_ignore (e : unit -> string) =
2513
    ()
2514
2515
  let print_hidden =
2516
    var_define
2517
      ~hide:true
2518
      ~dump:false
2519
      ~cli:CLIAuto
2520
      ~arg_help:"Print even non-printable variable. (debug)"
2521
      "print_hidden"
2522
      (fun () -> "false")
2523
2524
  let var_all () =
2525
    List.rev
2526
      (Schema.fold
2527
         (fun acc nm def _ ->
2528
            if not def.hide || bool_of_string (print_hidden ()) then
2529
              nm :: acc
2530
            else
2531
              acc)
2532
         []
2533
         schema)
2534
2535
  let default_filename =
2536
    BaseEnvLight.default_filename
2537
2538
  let load ?allow_empty ?filename () =
2539
    env_from_file := BaseEnvLight.load ?allow_empty ?filename ()
2540
2541
  let unload () =
2542
    env_from_file := MapString.empty;
2543
    Data.clear env
2544
2545
  let dump ?(filename=default_filename) () =
2546
    let chn =
2547
      open_out_bin filename
2548
    in
2549
    let output nm value = 
2550
      Printf.fprintf chn "%s=%S\n" nm value
2551
    in
2552
    let mp_todo = 
2553
      (* Dump data from schema *)
2554
      Schema.fold
2555
        (fun mp_todo nm def _ ->
2556
           if def.dump then
2557
             begin
2558
               try
2559
                 let value =
2560
                   Schema.get
2561
                     schema
2562
                     env
2563
                     nm
2564
                 in
2565
                   output nm value
2566
               with Not_set _ ->
2567
                 ()
2568
             end;
2569
           MapString.remove nm mp_todo)
2570
        !env_from_file
2571
        schema
2572
    in
2573
      (* Dump data defined outside of schema *)
2574
      MapString.iter output mp_todo;
2575
2576
      (* End of the dump *)
2577
      close_out chn
2578
2579
  let print () =
2580
    let printable_vars =
2581
      Schema.fold
2582
        (fun acc nm def short_descr_opt ->
2583
           if not def.hide || bool_of_string (print_hidden ()) then
2584
             begin
2585
               try
2586
                 let value =
2587
                   Schema.get
2588
                     schema
2589
                     env
2590
                     nm
2591
                 in
2592
                 let txt =
2593
                   match short_descr_opt with
2594
                     | Some s -> s ()
2595
                     | None -> nm
2596
                 in
2597
                   (txt, value) :: acc
2598
               with Not_set _ ->
2599
                   acc
2600
             end
2601
           else
2602
             acc)
2603
        []
2604
        schema
2605
    in
2606
    let max_length =
2607
      List.fold_left max 0
2608
        (List.rev_map String.length
2609
           (List.rev_map fst printable_vars))
2610
    in
2611
    let dot_pad str =
2612
      String.make ((max_length - (String.length str)) + 3) '.'
2613
    in
2614
2615
    Printf.printf "\nConfiguration: \n";
2616
    List.iter
2617
      (fun (name,value) ->
2618
        Printf.printf "%s: %s %s\n" name (dot_pad name) value)
2619
      (List.rev printable_vars);
2620
    Printf.printf "\n%!"
2621
2622
  let args () =
2623
    let arg_concat =
2624
      OASISUtils.varname_concat ~hyphen:'-'
2625
    in
2626
      [
2627
        "--override",
2628
         Arg.Tuple
2629
           (
2630
             let rvr = ref ""
2631
             in
2632
             let rvl = ref ""
2633
             in
2634
               [
2635
                 Arg.Set_string rvr;
2636
                 Arg.Set_string rvl;
2637
                 Arg.Unit
2638
                   (fun () ->
2639
                      Schema.set
2640
                        schema
2641
                        env
2642
                        ~context:OCommandLine
2643
                        !rvr
2644
                        !rvl)
2645
               ]
2646
           ),
2647
        "var+val  Override any configuration variable.";
2648
2649
      ]
2650
      @
2651
      List.flatten
2652
        (Schema.fold
2653
          (fun acc name def short_descr_opt ->
2654
             let var_set s =
2655
               Schema.set
2656
                 schema
2657
                 env
2658
                 ~context:OCommandLine
2659
                 name
2660
                 s
2661
             in
2662
2663
             let arg_name =
2664
               OASISUtils.varname_of_string ~hyphen:'-' name
2665
             in
2666
2667
             let hlp =
2668
               match short_descr_opt with
2669
                 | Some txt -> txt ()
2670
                 | None -> ""
2671
             in
2672
2673
             let arg_hlp =
2674
               match def.arg_help with
2675
                 | Some s -> s
2676
                 | None   -> "str"
2677
             in
2678
2679
             let default_value =
2680
               try
2681
                 Printf.sprintf
2682
                   (f_ " [%s]")
2683
                   (Schema.get
2684
                      schema
2685
                      env
2686
                      name)
2687
               with Not_set _ ->
2688
                 ""
2689
             in
2690
2691
             let args =
2692
               match def.cli with
2693
                 | CLINone ->
2694
                     []
2695
                 | CLIAuto ->
2696
                     [
2697
                       arg_concat "--" arg_name,
2698
                       Arg.String var_set,
2699
                       Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value
2700
                     ]
2701
                 | CLIWith ->
2702
                     [
2703
                       arg_concat "--with-" arg_name,
2704
                       Arg.String var_set,
2705
                       Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value
2706
                     ]
2707
                 | CLIEnable ->
2708
                     let dflt =
2709
                       if default_value = " [true]" then
2710
                         s_ " [default: enabled]"
2711
                       else
2712
                         s_ " [default: disabled]"
2713
                     in
2714
                       [
2715
                         arg_concat "--enable-" arg_name,
2716
                         Arg.Unit (fun () -> var_set "true"),
2717
                         Printf.sprintf (f_ " %s%s") hlp dflt;
2718
2719
                         arg_concat "--disable-" arg_name,
2720
                         Arg.Unit (fun () -> var_set "false"),
2721
                         Printf.sprintf (f_ " %s%s") hlp dflt
2722
                       ]
2723
                 | CLIUser lst ->
2724
                     lst
2725
             in
2726
               args :: acc)
2727
           []
2728
           schema)
2729
end
2730
2731
module BaseArgExt = struct
2732
(* # 21 "src/base/BaseArgExt.ml" *)
2733
2734
  open OASISUtils
2735
  open OASISGettext
2736
2737
  let parse argv args =
2738
      (* Simulate command line for Arg *)
2739
      let current =
2740
        ref 0
2741
      in
2742
2743
        try
2744
          Arg.parse_argv
2745
            ~current:current
2746
            (Array.concat [[|"none"|]; argv])
2747
            (Arg.align args)
2748
            (failwithf (f_ "Don't know what to do with arguments: '%s'"))
2749
            (s_ "configure options:")
2750
        with
2751
          | Arg.Help txt ->
2752
              print_endline txt;
2753
              exit 0
2754
          | Arg.Bad txt ->
2755
              prerr_endline txt;
2756
              exit 1
2757
end
2758
2759
module BaseCheck = struct
2760
(* # 21 "src/base/BaseCheck.ml" *)
2761
2762
  open BaseEnv
2763
  open BaseMessage
2764
  open OASISUtils
2765
  open OASISGettext
2766
2767
  let prog_best prg prg_lst =
2768
    var_redefine
2769
      prg
2770
      (fun () ->
2771
         let alternate =
2772
           List.fold_left
2773
             (fun res e ->
2774
                match res with
2775
                  | Some _ ->
2776
                      res
2777
                  | None ->
2778
                      try
2779
                        Some (OASISFileUtil.which ~ctxt:!BaseContext.default e)
2780
                      with Not_found ->
2781
                        None)
2782
             None
2783
             prg_lst
2784
         in
2785
           match alternate with
2786
             | Some prg -> prg
2787
             | None -> raise Not_found)
2788
2789
  let prog prg =
2790
    prog_best prg [prg]
2791
2792
  let prog_opt prg =
2793
    prog_best prg [prg^".opt"; prg]
2794
2795
  let ocamlfind =
2796
    prog "ocamlfind"
2797
2798
  let version
2799
        var_prefix
2800
        cmp
2801
        fversion
2802
        () =
2803
    (* Really compare version provided *)
2804
    let var =
2805
      var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp)
2806
    in
2807
      var_redefine
2808
        ~hide:true
2809
        var
2810
        (fun () ->
2811
           let version_str =
2812
             match fversion () with
2813
               | "[Distributed with OCaml]" ->
2814
                   begin
2815
                     try
2816
                       (var_get "ocaml_version")
2817
                     with Not_found ->
2818
                       warning
2819
                         (f_ "Variable ocaml_version not defined, fallback \
2820
                              to default");
2821
                       Sys.ocaml_version
2822
                   end
2823
               | res ->
2824
                   res
2825
           in
2826
           let version =
2827
             OASISVersion.version_of_string version_str
2828
           in
2829
             if OASISVersion.comparator_apply version cmp then
2830
               version_str
2831
             else
2832
               failwithf
2833
                 (f_ "Cannot satisfy version constraint on %s: %s (version: %s)")
2834
                 var_prefix
2835
                 (OASISVersion.string_of_comparator cmp)
2836
                 version_str)
2837
        ()
2838
2839
  let package_version pkg =
2840
    OASISExec.run_read_one_line ~ctxt:!BaseContext.default
2841
      (ocamlfind ())
2842
      ["query"; "-format"; "%v"; pkg]
2843
2844
  let package ?version_comparator pkg () =
2845
    let var =
2846
      OASISUtils.varname_concat
2847
        "pkg_"
2848
        (OASISUtils.varname_of_string pkg)
2849
    in
2850
    let findlib_dir pkg =
2851
      let dir =
2852
        OASISExec.run_read_one_line ~ctxt:!BaseContext.default
2853
          (ocamlfind ())
2854
          ["query"; "-format"; "%d"; pkg]
2855
      in
2856
        if Sys.file_exists dir && Sys.is_directory dir then
2857
          dir
2858
        else
2859
          failwithf
2860
            (f_ "When looking for findlib package %s, \
2861
                 directory %s return doesn't exist")
2862
            pkg dir
2863
    in
2864
    let vl =
2865
      var_redefine
2866
        var
2867
        (fun () -> findlib_dir pkg)
2868
        ()
2869
    in
2870
      (
2871
        match version_comparator with
2872
          | Some ver_cmp ->
2873
              ignore
2874
                (version
2875
                   var
2876
                   ver_cmp
2877
                   (fun _ -> package_version pkg)
2878
                   ())
2879
          | None ->
2880
              ()
2881
      );
2882
      vl
2883
end
2884
2885
module BaseOCamlcConfig = struct
2886
(* # 21 "src/base/BaseOCamlcConfig.ml" *)
2887
2888
2889
  open BaseEnv
2890
  open OASISUtils
2891
  open OASISGettext
2892
2893
  module SMap = Map.Make(String)
2894
2895
  let ocamlc =
2896
    BaseCheck.prog_opt "ocamlc"
2897
2898
  let ocamlc_config_map =
2899
    (* Map name to value for ocamlc -config output
2900
       (name ^": "^value)
2901
     *)
2902
    let rec split_field mp lst =
2903
      match lst with
2904
        | line :: tl ->
2905
            let mp =
2906
              try
2907
                let pos_semicolon =
2908
                  String.index line ':'
2909
                in
2910
                  if pos_semicolon > 1 then
2911
                    (
2912
                      let name =
2913
                        String.sub line 0 pos_semicolon
2914
                      in
2915
                      let linelen =
2916
                        String.length line
2917
                      in
2918
                      let value =
2919
                        if linelen > pos_semicolon + 2 then
2920
                          String.sub
2921
                            line
2922
                            (pos_semicolon + 2)
2923
                            (linelen - pos_semicolon - 2)
2924
                        else
2925
                          ""
2926
                      in
2927
                        SMap.add name value mp
2928
                    )
2929
                  else
2930
                    (
2931
                      mp
2932
                    )
2933
              with Not_found ->
2934
                (
2935
                  mp
2936
                )
2937
            in
2938
              split_field mp tl
2939
        | [] ->
2940
            mp
2941
    in
2942
2943
    let cache = 
2944
      lazy
2945
        (var_protect
2946
           (Marshal.to_string
2947
              (split_field
2948
                 SMap.empty
2949
                 (OASISExec.run_read_output
2950
                    ~ctxt:!BaseContext.default
2951
                    (ocamlc ()) ["-config"]))
2952
              []))
2953
    in
2954
      var_redefine
2955
        "ocamlc_config_map"
2956
        ~hide:true
2957
        ~dump:false
2958
        (fun () ->
2959
           (* TODO: update if ocamlc change !!! *)
2960
           Lazy.force cache)
2961
2962
  let var_define nm =
2963
    (* Extract data from ocamlc -config *)
2964
    let avlbl_config_get () =
2965
      Marshal.from_string
2966
        (ocamlc_config_map ())
2967
        0
2968
    in
2969
    let chop_version_suffix s =
2970
      try 
2971
        String.sub s 0 (String.index s '+')
2972
      with _ -> 
2973
        s
2974
     in
2975
2976
    let nm_config, value_config =
2977
      match nm with
2978
        | "ocaml_version" -> 
2979
            "version", chop_version_suffix
2980
        | _ -> nm, (fun x -> x)
2981
    in
2982
      var_redefine
2983
        nm
2984
        (fun () ->
2985
          try
2986
             let map =
2987
               avlbl_config_get ()
2988
             in
2989
             let value =
2990
               SMap.find nm_config map
2991
             in
2992
               value_config value
2993
           with Not_found ->
2994
             failwithf
2995
               (f_ "Cannot find field '%s' in '%s -config' output")
2996
               nm
2997
               (ocamlc ()))
2998
2999
end
3000
3001
module BaseStandardVar = struct
3002
(* # 21 "src/base/BaseStandardVar.ml" *)
3003
3004
3005
  open OASISGettext
3006
  open OASISTypes
3007
  open OASISExpr
3008
  open BaseCheck
3009
  open BaseEnv
3010
3011
  let ocamlfind  = BaseCheck.ocamlfind
3012
  let ocamlc     = BaseOCamlcConfig.ocamlc
3013
  let ocamlopt   = prog_opt "ocamlopt"
3014
  let ocamlbuild = prog "ocamlbuild"
3015
3016
3017
  (**/**)
3018
  let rpkg =
3019
    ref None
3020
3021
  let pkg_get () =
3022
    match !rpkg with
3023
      | Some pkg -> pkg
3024
      | None -> failwith (s_ "OASIS Package is not set")
3025
3026
  let var_cond = ref []
3027
3028
  let var_define_cond ~since_version f dflt =
3029
    let holder = ref (fun () -> dflt) in
3030
    let since_version =
3031
      OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version)
3032
    in
3033
      var_cond :=
3034
      (fun ver ->
3035
         if OASISVersion.comparator_apply ver since_version then
3036
           holder := f ()) :: !var_cond;
3037
      fun () -> !holder ()
3038
3039
  (**/**)
3040
3041
  let pkg_name =
3042
    var_define
3043
      ~short_desc:(fun () -> s_ "Package name")
3044
      "pkg_name"
3045
      (fun () -> (pkg_get ()).name)
3046
3047
  let pkg_version =
3048
    var_define
3049
      ~short_desc:(fun () -> s_ "Package version")
3050
      "pkg_version"
3051
      (fun () ->
3052
         (OASISVersion.string_of_version (pkg_get ()).version))
3053
3054
  let c = BaseOCamlcConfig.var_define
3055
3056
  let os_type        = c "os_type"
3057
  let system         = c "system"
3058
  let architecture   = c "architecture"
3059
  let ccomp_type     = c "ccomp_type"
3060
  let ocaml_version  = c "ocaml_version"
3061
3062
  (* TODO: Check standard variable presence at runtime *)
3063
3064
  let standard_library_default = c "standard_library_default"
3065
  let standard_library         = c "standard_library"
3066
  let standard_runtime         = c "standard_runtime"
3067
  let bytecomp_c_compiler      = c "bytecomp_c_compiler"
3068
  let native_c_compiler        = c "native_c_compiler"
3069
  let model                    = c "model"
3070
  let ext_obj                  = c "ext_obj"
3071
  let ext_asm                  = c "ext_asm"
3072
  let ext_lib                  = c "ext_lib"
3073
  let ext_dll                  = c "ext_dll"
3074
  let default_executable_name  = c "default_executable_name"
3075
  let systhread_supported      = c "systhread_supported"
3076
3077
  let flexlink = 
3078
    BaseCheck.prog "flexlink"
3079
3080
  let flexdll_version =
3081
    var_define
3082
      ~short_desc:(fun () -> "FlexDLL version (Win32)")
3083
      "flexdll_version"
3084
      (fun () ->
3085
         let lst = 
3086
           OASISExec.run_read_output ~ctxt:!BaseContext.default
3087
             (flexlink ()) ["-help"]
3088
         in
3089
           match lst with 
3090
             | line :: _ ->
3091
                 Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver)
3092
             | [] ->
3093
                 raise Not_found)
3094
3095
  (**/**)
3096
  let p name hlp dflt =
3097
    var_define
3098
      ~short_desc:hlp
3099
      ~cli:CLIAuto
3100
      ~arg_help:"dir"
3101
      name
3102
      dflt
3103
3104
  let (/) a b =
3105
    if os_type () = Sys.os_type then
3106
      Filename.concat a b
3107
    else if os_type () = "Unix" then
3108
      OASISUnixPath.concat a b
3109
    else
3110
      OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat")
3111
        (os_type ())
3112
  (**/**)
3113
3114
  let prefix =
3115
    p "prefix"
3116
      (fun () -> s_ "Install architecture-independent files dir")
3117
      (fun () ->
3118
         match os_type () with
3119
           | "Win32" ->
3120
               let program_files =
3121
                 Sys.getenv "PROGRAMFILES"
3122
               in
3123
                 program_files/(pkg_name ())
3124
           | _ ->
3125
               "/usr/local")
3126
3127
  let exec_prefix =
3128
    p "exec_prefix"
3129
      (fun () -> s_ "Install architecture-dependent files in dir")
3130
      (fun () -> "$prefix")
3131
3132
  let bindir =
3133
    p "bindir"
3134
      (fun () -> s_ "User executables")
3135
      (fun () -> "$exec_prefix"/"bin")
3136
3137
  let sbindir =
3138
    p "sbindir"
3139
      (fun () -> s_ "System admin executables")
3140
      (fun () -> "$exec_prefix"/"sbin")
3141
3142
  let libexecdir =
3143
    p "libexecdir"
3144
      (fun () -> s_ "Program executables")
3145
      (fun () -> "$exec_prefix"/"libexec")
3146
3147
  let sysconfdir =
3148
    p "sysconfdir"
3149
      (fun () -> s_ "Read-only single-machine data")
3150
      (fun () -> "$prefix"/"etc")
3151
3152
  let sharedstatedir =
3153
    p "sharedstatedir"
3154
      (fun () -> s_ "Modifiable architecture-independent data")
3155
      (fun () -> "$prefix"/"com")
3156
3157
  let localstatedir =
3158
    p "localstatedir"
3159
      (fun () -> s_ "Modifiable single-machine data")
3160
      (fun () -> "$prefix"/"var")
3161
3162
  let libdir =
3163
    p "libdir"
3164
      (fun () -> s_ "Object code libraries")
3165
      (fun () -> "$exec_prefix"/"lib")
3166
3167
  let datarootdir =
3168
    p "datarootdir"
3169
      (fun () -> s_ "Read-only arch-independent data root")
3170
      (fun () -> "$prefix"/"share")
3171
3172
  let datadir =
3173
    p "datadir"
3174
      (fun () -> s_ "Read-only architecture-independent data")
3175
      (fun () -> "$datarootdir")
3176
3177
  let infodir =
3178
    p "infodir"
3179
      (fun () -> s_ "Info documentation")
3180
      (fun () -> "$datarootdir"/"info")
3181
3182
  let localedir =
3183
    p "localedir"
3184
      (fun () -> s_ "Locale-dependent data")
3185
      (fun () -> "$datarootdir"/"locale")
3186
3187
  let mandir =
3188
    p "mandir"
3189
      (fun () -> s_ "Man documentation")
3190
      (fun () -> "$datarootdir"/"man")
3191
3192
  let docdir =
3193
    p "docdir"
3194
      (fun () -> s_ "Documentation root")
3195
      (fun () -> "$datarootdir"/"doc"/"$pkg_name")
3196
3197
  let htmldir =
3198
    p "htmldir"
3199
      (fun () -> s_ "HTML documentation")
3200
      (fun () -> "$docdir")
3201
3202
  let dvidir =
3203
    p "dvidir"
3204
      (fun () -> s_ "DVI documentation")
3205
      (fun () -> "$docdir")
3206
3207
  let pdfdir =
3208
    p "pdfdir"
3209
      (fun () -> s_ "PDF documentation")
3210
      (fun () -> "$docdir")
3211
3212
  let psdir =
3213
    p "psdir"
3214
      (fun () -> s_ "PS documentation")
3215
      (fun () -> "$docdir")
3216
3217
  let destdir =
3218
    p "destdir"
3219
      (fun () -> s_ "Prepend a path when installing package")
3220
      (fun () ->
3221
         raise
3222
           (PropList.Not_set
3223
              ("destdir",
3224
               Some (s_ "undefined by construct"))))
3225
3226
  let findlib_version =
3227
    var_define
3228
      "findlib_version"
3229
      (fun () ->
3230
         BaseCheck.package_version "findlib")
3231
3232
  let is_native =
3233
    var_define
3234
      "is_native"
3235
      (fun () ->
3236
         try
3237
           let _s : string =
3238
             ocamlopt ()
3239
           in
3240
             "true"
3241
         with PropList.Not_set _ ->
3242
           let _s : string =
3243
             ocamlc ()
3244
           in
3245
             "false")
3246
3247
  let ext_program =
3248
    var_define
3249
      "suffix_program"
3250
      (fun () ->
3251
         match os_type () with
3252
           | "Win32" -> ".exe"
3253
           | _ -> "")
3254
3255
  let rm =
3256
    var_define
3257
      ~short_desc:(fun () -> s_ "Remove a file.")
3258
      "rm"
3259
      (fun () ->
3260
         match os_type () with
3261
           | "Win32" -> "del"
3262
           | _ -> "rm -f")
3263
3264
  let rmdir =
3265
    var_define
3266
      ~short_desc:(fun () -> s_ "Remove a directory.")
3267
      "rmdir"
3268
      (fun () ->
3269
         match os_type () with
3270
           | "Win32" -> "rd"
3271
           | _ -> "rm -rf")
3272
3273
  let debug =
3274
    var_define
3275
      ~short_desc:(fun () -> s_ "Turn ocaml debug flag on")
3276
      ~cli:CLIEnable
3277
      "debug"
3278
      (fun () -> "true")
3279
3280
  let profile =
3281
    var_define
3282
      ~short_desc:(fun () -> s_ "Turn ocaml profile flag on")
3283
      ~cli:CLIEnable
3284
      "profile"
3285
      (fun () -> "false")
3286
3287
  let tests =
3288
    var_define_cond ~since_version:"0.3"
3289
      (fun () ->
3290
         var_define
3291
           ~short_desc:(fun () ->
3292
                          s_ "Compile tests executable and library and run them")
3293
           ~cli:CLIEnable
3294
           "tests"
3295
           (fun () -> "false"))
3296
      "true"
3297
3298
  let docs =
3299
    var_define_cond ~since_version:"0.3"
3300
      (fun () ->
3301
         var_define
3302
           ~short_desc:(fun () -> s_ "Create documentations")
3303
           ~cli:CLIEnable
3304
           "docs"
3305
           (fun () -> "true"))
3306
      "true"
3307
3308
  let native_dynlink =
3309
    var_define
3310
      ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.")
3311
      ~cli:CLINone
3312
      "native_dynlink"
3313
      (fun () ->
3314
         let res =
3315
           let ocaml_lt_312 () = 
3316
             OASISVersion.comparator_apply
3317
               (OASISVersion.version_of_string (ocaml_version ()))
3318
               (OASISVersion.VLesser
3319
                  (OASISVersion.version_of_string "3.12.0"))
3320
           in
3321
           let flexdll_lt_030 () =
3322
             OASISVersion.comparator_apply
3323
               (OASISVersion.version_of_string (flexdll_version ()))
3324
               (OASISVersion.VLesser
3325
                  (OASISVersion.version_of_string "0.30"))
3326
           in
3327
           let has_native_dynlink = 
3328
             let ocamlfind = ocamlfind () in
3329
               try
3330
                 let fn =
3331
                   OASISExec.run_read_one_line
3332
                     ~ctxt:!BaseContext.default
3333
                     ocamlfind
3334
                     ["query"; "-predicates"; "native"; "dynlink";
3335
                      "-format"; "%d/%a"]
3336
                 in
3337
                   Sys.file_exists fn
3338
               with _ ->
3339
                 false
3340
           in
3341
             if not has_native_dynlink then
3342
               false
3343
             else if ocaml_lt_312 () then
3344
               false
3345
             else if (os_type () = "Win32" || os_type () = "Cygwin") 
3346
                     && flexdll_lt_030 () then
3347
               begin
3348
                 BaseMessage.warning 
3349
                   (f_ ".cmxs generation disabled because FlexDLL needs to be \
3350
                        at least 0.30. Please upgrade FlexDLL from %s to 0.30.")
3351
                   (flexdll_version ());
3352
                 false
3353
               end
3354
             else
3355
               true
3356
         in
3357
           string_of_bool res)
3358
3359
  let init pkg =
3360
    rpkg := Some pkg;
3361
    List.iter (fun f -> f pkg.oasis_version) !var_cond
3362
3363
end
3364
3365
module BaseFileAB = struct
3366
(* # 21 "src/base/BaseFileAB.ml" *)
3367
3368
  open BaseEnv
3369
  open OASISGettext
3370
  open BaseMessage
3371
3372
  let to_filename fn =
3373
    let fn =
3374
      OASISHostPath.of_unix fn
3375
    in
3376
      if not (Filename.check_suffix fn ".ab") then
3377
        warning
3378
          (f_ "File '%s' doesn't have '.ab' extension")
3379
          fn;
3380
      Filename.chop_extension fn
3381
3382
  let replace fn_lst =
3383
    let buff =
3384
      Buffer.create 13
3385
    in
3386
      List.iter
3387
        (fun fn ->
3388
           let fn =
3389
             OASISHostPath.of_unix fn
3390
           in
3391
           let chn_in =
3392
             open_in fn
3393
           in
3394
           let chn_out =
3395
             open_out (to_filename fn)
3396
           in
3397
             (
3398
               try
3399
                 while true do
3400
                  Buffer.add_string buff (var_expand (input_line chn_in));
3401
                  Buffer.add_char buff '\n'
3402
                 done
3403
               with End_of_file ->
3404
                 ()
3405
             );
3406
             Buffer.output_buffer chn_out buff;
3407
             Buffer.clear buff;
3408
             close_in chn_in;
3409
             close_out chn_out)
3410
        fn_lst
3411
end
3412
3413
module BaseLog = struct
3414
(* # 21 "src/base/BaseLog.ml" *)
3415
3416
  open OASISUtils
3417
3418
  let default_filename =
3419
    Filename.concat
3420
      (Filename.dirname BaseEnv.default_filename)
3421
      "setup.log"
3422
3423
  module SetTupleString =
3424
    Set.Make
3425
      (struct
3426
         type t = string * string
3427
         let compare (s11, s12) (s21, s22) =
3428
           match String.compare s11 s21 with
3429
             | 0 -> String.compare s12 s22
3430
             | n -> n
3431
       end)
3432
3433
  let load () =
3434
    if Sys.file_exists default_filename then
3435
      begin
3436
        let chn =
3437
          open_in default_filename
3438
        in
3439
        let scbuf =
3440
          Scanf.Scanning.from_file default_filename
3441
        in
3442
        let rec read_aux (st, lst) =
3443
          if not (Scanf.Scanning.end_of_input scbuf) then
3444
            begin
3445
              let acc =
3446
                try
3447
                  Scanf.bscanf scbuf "%S %S\n"
3448
                    (fun e d ->
3449
                       let t =
3450
                         e, d
3451
                       in
3452
                         if SetTupleString.mem t st then
3453
                           st, lst
3454
                         else
3455
                           SetTupleString.add t st,
3456
                           t :: lst)
3457
                with Scanf.Scan_failure _ ->
3458
                  failwith
3459
                    (Scanf.bscanf scbuf
3460
                       "%l"
3461
                       (fun line ->
3462
                          Printf.sprintf
3463
                            "Malformed log file '%s' at line %d"
3464
                            default_filename
3465
                            line))
3466
              in
3467
                read_aux acc
3468
            end
3469
          else
3470
            begin
3471
              close_in chn;
3472
              List.rev lst
3473
            end
3474
        in
3475
          read_aux (SetTupleString.empty, [])
3476
      end
3477
    else
3478
      begin
3479
        []
3480
      end
3481
3482
  let register event data =
3483
    let chn_out =
3484
      open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename
3485
    in
3486
      Printf.fprintf chn_out "%S %S\n" event data;
3487
      close_out chn_out
3488
3489
  let unregister event data =
3490
    if Sys.file_exists default_filename then
3491
      begin
3492
        let lst =
3493
          load ()
3494
        in
3495
        let chn_out =
3496
          open_out default_filename
3497
        in
3498
        let write_something =
3499
          ref false
3500
        in
3501
          List.iter
3502
            (fun (e, d) ->
3503
               if e <> event || d <> data then
3504
                 begin
3505
                   write_something := true;
3506
                   Printf.fprintf chn_out "%S %S\n" e d
3507
                 end)
3508
            lst;
3509
          close_out chn_out;
3510
          if not !write_something then
3511
            Sys.remove default_filename
3512
      end
3513
3514
  let filter events =
3515
    let st_events =
3516
      List.fold_left
3517
        (fun st e ->
3518
           SetString.add e st)
3519
        SetString.empty
3520
        events
3521
    in
3522
      List.filter
3523
        (fun (e, _) -> SetString.mem e st_events)
3524
        (load ())
3525
3526
  let exists event data =
3527
    List.exists
3528
      (fun v -> (event, data) = v)
3529
      (load ())
3530
end
3531
3532
module BaseBuilt = struct
3533
(* # 21 "src/base/BaseBuilt.ml" *)
3534
3535
  open OASISTypes
3536
  open OASISGettext
3537
  open BaseStandardVar
3538
  open BaseMessage
3539
3540
  type t =
3541
    | BExec    (* Executable *)
3542
    | BExecLib (* Library coming with executable *)
3543
    | BLib     (* Library *)
3544
    | BDoc     (* Document *)
3545
3546
  let to_log_event_file t nm =
3547
    "built_"^
3548
    (match t with
3549
       | BExec -> "exec"
3550
       | BExecLib -> "exec_lib"
3551
       | BLib -> "lib"
3552
       | BDoc -> "doc")^
3553
    "_"^nm
3554
3555
  let to_log_event_done t nm =
3556
    "is_"^(to_log_event_file t nm)
3557
3558
  let register t nm lst =
3559
    BaseLog.register
3560
      (to_log_event_done t nm)
3561
      "true";
3562
    List.iter
3563
      (fun alt ->
3564
         let registered =
3565
           List.fold_left
3566
             (fun registered fn ->
3567
                if OASISFileUtil.file_exists_case fn then
3568
                  begin
3569
                    BaseLog.register
3570
                      (to_log_event_file t nm)
3571
                      (if Filename.is_relative fn then
3572
                         Filename.concat (Sys.getcwd ()) fn
3573
                       else
3574
                         fn);
3575
                    true
3576
                  end
3577
                else
3578
                  registered)
3579
             false
3580
             alt
3581
         in
3582
           if not registered then
3583
             warning
3584
               (f_ "Cannot find an existing alternative files among: %s")
3585
               (String.concat (s_ ", ") alt))
3586
      lst
3587
3588
  let unregister t nm =
3589
    List.iter
3590
      (fun (e, d) ->
3591
         BaseLog.unregister e d)
3592
      (BaseLog.filter
3593
         [to_log_event_file t nm;
3594
          to_log_event_done t nm])
3595
3596
  let fold t nm f acc =
3597
    List.fold_left
3598
      (fun acc (_, fn) ->
3599
         if OASISFileUtil.file_exists_case fn then
3600
           begin
3601
             f acc fn
3602
           end
3603
         else
3604
           begin
3605
             warning
3606
               (f_ "File '%s' has been marked as built \
3607
                  for %s but doesn't exist")
3608
               fn
3609
               (Printf.sprintf
3610
                  (match t with
3611
                     | BExec | BExecLib ->
3612
                         (f_ "executable %s")
3613
                     | BLib ->
3614
                         (f_ "library %s")
3615
                     | BDoc ->
3616
                         (f_ "documentation %s"))
3617
                  nm);
3618
             acc
3619
           end)
3620
      acc
3621
      (BaseLog.filter
3622
         [to_log_event_file t nm])
3623
3624
  let is_built t nm =
3625
    List.fold_left
3626
      (fun is_built (_, d) ->
3627
         (try
3628
            bool_of_string d
3629
          with _ ->
3630
            false))
3631
      false
3632
      (BaseLog.filter
3633
         [to_log_event_done t nm])
3634
3635
  let of_executable ffn (cs, bs, exec) =
3636
    let unix_exec_is, unix_dll_opt =
3637
      OASISExecutable.unix_exec_is
3638
        (cs, bs, exec)
3639
        (fun () ->
3640
           bool_of_string
3641
             (is_native ()))
3642
        ext_dll
3643
        ext_program
3644
    in
3645
    let evs =
3646
      (BExec, cs.cs_name, [[ffn unix_exec_is]])
3647
      ::
3648
      (match unix_dll_opt with
3649
         | Some fn ->
3650
             [BExecLib, cs.cs_name, [[ffn fn]]]
3651
         | None ->
3652
             [])
3653
    in
3654
      evs,
3655
      unix_exec_is,
3656
      unix_dll_opt
3657
3658
  let of_library ffn (cs, bs, lib) =
3659
    let unix_lst =
3660
      OASISLibrary.generated_unix_files
3661
        ~ctxt:!BaseContext.default
3662
        ~source_file_exists:(fun fn ->
3663
           OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn))
3664
        ~is_native:(bool_of_string (is_native ()))
3665
        ~has_native_dynlink:(bool_of_string (native_dynlink ()))
3666
        ~ext_lib:(ext_lib ())
3667
        ~ext_dll:(ext_dll ())
3668
        (cs, bs, lib)
3669
    in
3670
    let evs =
3671
      [BLib,
3672
       cs.cs_name,
3673
       List.map (List.map ffn) unix_lst]
3674
    in
3675
      evs, unix_lst
3676
3677
end
3678
3679
module BaseCustom = struct
3680
(* # 21 "src/base/BaseCustom.ml" *)
3681
3682
  open BaseEnv
3683
  open BaseMessage
3684
  open OASISTypes
3685
  open OASISGettext
3686
3687
  let run cmd args extra_args =
3688
    OASISExec.run ~ctxt:!BaseContext.default ~quote:false
3689
      (var_expand cmd)
3690
      (List.map
3691
         var_expand
3692
         (args @ (Array.to_list extra_args)))
3693
3694
  let hook ?(failsafe=false) cstm f e =
3695
    let optional_command lst =
3696
      let printer =
3697
        function
3698
          | Some (cmd, args) -> String.concat " " (cmd :: args)
3699
          | None -> s_ "No command"
3700
      in
3701
        match
3702
          var_choose
3703
            ~name:(s_ "Pre/Post Command")
3704
            ~printer
3705
            lst with
3706
          | Some (cmd, args) ->
3707
              begin
3708
                try
3709
                  run cmd args [||]
3710
                with e when failsafe ->
3711
                  warning
3712
                    (f_ "Command '%s' fail with error: %s")
3713
                    (String.concat " " (cmd :: args))
3714
                    (match e with
3715
                       | Failure msg -> msg
3716
                       | e -> Printexc.to_string e)
3717
              end
3718
          | None ->
3719
              ()
3720
    in
3721
    let res =
3722
      optional_command cstm.pre_command;
3723
      f e
3724
    in
3725
      optional_command cstm.post_command;
3726
      res
3727
end
3728
3729
module BaseDynVar = struct
3730
(* # 21 "src/base/BaseDynVar.ml" *)
3731
3732
3733
  open OASISTypes
3734
  open OASISGettext
3735
  open BaseEnv
3736
  open BaseBuilt
3737
3738
  let init pkg =
3739
    (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *)
3740
    (* TODO: provide compile option for library libary_byte_args_VARNAME... *)
3741
    List.iter
3742
      (function
3743
         | Executable (cs, bs, exec) ->
3744
             if var_choose bs.bs_build then
3745
               var_ignore
3746
                 (var_redefine
3747
                    (* We don't save this variable *)
3748
                    ~dump:false
3749
                    ~short_desc:(fun () ->
3750
                                   Printf.sprintf
3751
                                     (f_ "Filename of executable '%s'")
3752
                                     cs.cs_name)
3753
                    (OASISUtils.varname_of_string cs.cs_name)
3754
                    (fun () ->
3755
                       let fn_opt =
3756
                         fold
3757
                           BExec cs.cs_name
3758
                           (fun _ fn -> Some fn)
3759
                           None
3760
                       in
3761
                         match fn_opt with
3762
                           | Some fn -> fn
3763
                           | None ->
3764
                               raise
3765
                                 (PropList.Not_set
3766
                                    (cs.cs_name,
3767
                                     Some (Printf.sprintf
3768
                                             (f_ "Executable '%s' not yet built.")
3769
                                             cs.cs_name)))))
3770
3771
         | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ ->
3772
             ())
3773
      pkg.sections
3774
end
3775
3776
module BaseTest = struct
3777
(* # 21 "src/base/BaseTest.ml" *)
3778
3779
  open BaseEnv
3780
  open BaseMessage
3781
  open OASISTypes
3782
  open OASISExpr
3783
  open OASISGettext
3784
3785
  let test lst pkg extra_args =
3786
3787
    let one_test (failure, n) (test_plugin, cs, test) =
3788
      if var_choose
3789
           ~name:(Printf.sprintf
3790
                    (f_ "test %s run")
3791
                    cs.cs_name)
3792
           ~printer:string_of_bool
3793
           test.test_run then
3794
        begin
3795
          let () =
3796
            info (f_ "Running test '%s'") cs.cs_name
3797
          in
3798
          let back_cwd =
3799
            match test.test_working_directory with
3800
              | Some dir ->
3801
                  let cwd =
3802
                    Sys.getcwd ()
3803
                  in
3804
                  let chdir d =
3805
                    info (f_ "Changing directory to '%s'") d;
3806
                    Sys.chdir d
3807
                  in
3808
                    chdir dir;
3809
                    fun () -> chdir cwd
3810
3811
              | None ->
3812
                  fun () -> ()
3813
          in
3814
            try
3815
              let failure_percent =
3816
                BaseCustom.hook
3817
                  test.test_custom
3818
                  (test_plugin pkg (cs, test))
3819
                  extra_args
3820
              in
3821
                back_cwd ();
3822
                (failure_percent +. failure, n + 1)
3823
            with e ->
3824
              begin
3825
                back_cwd ();
3826
                raise e
3827
              end
3828
        end
3829
      else
3830
        begin
3831
          info (f_ "Skipping test '%s'") cs.cs_name;
3832
          (failure, n)
3833
        end
3834
    in
3835
    let (failed, n) =
3836
      List.fold_left
3837
        one_test
3838
        (0.0, 0)
3839
        lst
3840
    in
3841
    let failure_percent =
3842
      if n = 0 then
3843
        0.0
3844
      else
3845
        failed /. (float_of_int n)
3846
    in
3847
    let msg =
3848
      Printf.sprintf
3849
        (f_ "Tests had a %.2f%% failure rate")
3850
        (100. *. failure_percent)
3851
    in
3852
      if failure_percent > 0.0 then
3853
        failwith msg
3854
      else
3855
        info "%s" msg;
3856
3857
      (* Possible explanation why the tests where not run. *)
3858
      if OASISVersion.version_0_3_or_after pkg.oasis_version &&
3859
         not (bool_of_string (BaseStandardVar.tests ())) &&
3860
         lst <> [] then
3861
        BaseMessage.warning
3862
          "Tests are turned off, consider enabling with \
3863
           'ocaml setup.ml -configure --enable-tests'"
3864
end
3865
3866
module BaseDoc = struct
3867
(* # 21 "src/base/BaseDoc.ml" *)
3868
3869
  open BaseEnv
3870
  open BaseMessage
3871
  open OASISTypes
3872
  open OASISGettext
3873
3874
  let doc lst pkg extra_args =
3875
3876
    let one_doc (doc_plugin, cs, doc) =
3877
      if var_choose
3878
           ~name:(Printf.sprintf
3879
                   (f_ "documentation %s build")
3880
                   cs.cs_name)
3881
           ~printer:string_of_bool
3882
           doc.doc_build then