Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / setup.ml @ 22fe1c93

History | View | Annotate | Download (133 KB)

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