Skip to content
This repository
tag: v1024
Fetching contributors…

Cannot retrieve contributors at this time

file 356 lines (323 sloc) 11.355 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356
(*
Copyright © 2011 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
module StringMap = Map.Make(
  struct
    type t = string
    let compare = String.compare
  end)

(* Environment **********************************)
type env = string StringMap.t

let empty_env = StringMap.empty

let add_env = StringMap.add

let fill_with_sysenv t =
  Array.fold_left
    (fun t s ->
       match Str.split (Str.regexp "=") s with
       | var::values ->
           let value = String.concat " " values in
           add_env var value t
       | _ -> assert false)
    t (Unix.environment ())


(* Options **************************************)
type options = {
  env : env;
  output_suffix : string option (**Destination file*);
  force_static : bool;
}

let default_options env = {
  env = env;
  output_suffix = None;
  force_static = false;
}

(* Preprocess functions *************************)
exception PPParse_error of string

type lang_description = {
  open_com : string;
  close_com : string;
  open_block : string;
  close_block : string;
  debug_module : string;
}

type cond =
  | Test of string * string * string
  | Set of string

(* Represent an if *)
type pp_if = {
  cond : cond;
  if_ : pp_expr list;
  else_ : pp_expr list option;
}

(* Represent an pp expr *)
and pp_expr =
  | Normal of string
  | Ifstatic of pp_if
  | If of pp_if

(* Print code *)
let print_code ?(doeval=false) ?(eval=fun _ -> true) description buf code =
  let doeval = ref doeval in
  let open_com ~comment =
    if comment then Buffer.add_string buf description.open_com;
  in
  let close_com ~comment =
    if comment then Buffer.add_string buf description.close_com in
  let open_block () =
    Buffer.add_string buf description.open_block in
  let close_block () =
    Buffer.add_string buf description.close_block in
  let dmodule = description.debug_module in

  let rec print_expr ~comment = function
    | Normal x ->
        open_com ~comment;
        Buffer.add_string buf x;
        close_com ~comment;
    | Ifstatic if_ ->
        open_com ~comment;
        print_if ~comment `static if_;
        close_com ~comment;
    | If if_ ->
        print_if ~comment `dyn if_;

  and print_lexpr ~block ~comment l =
    open_com ~comment;
    if block then open_block ();
    List.iter (print_expr ~comment:false) l;
    if block then close_block ();
    close_com ~comment

  and print_if_cond ~comment s cond =
    match s with
    | `static ->
        let str =
          (match cond with
           | Set c -> Printf.sprintf "#<Ifstatic:%s>" c
           | Test (_, c1, c2) -> Printf.sprintf "#<Ifstatic:%s %s>" c1 c2) in
        open_com ~comment;
        Buffer.add_string buf str;
        close_com ~comment;
      | `dyn ->
          let dyntest =
            (match cond with
             | Set c ->
                 Printf.sprintf " if (%s.default) %s.%s then " dmodule dmodule
                   (String.lowercase c);
             | Test (t, c1, c2) ->
                 Printf.sprintf " if (%s.%s %s) %s.%s then " dmodule t c2 dmodule
                   (String.lowercase c1)) in
          let pptest =
            (match cond with
             | Set c ->
                 Printf.sprintf "#<If:%s>" c;
             | Test (t, c1, c2) ->
                 Printf.sprintf "#<If:%s$%s %s>" c1 t c2 ) in
          open_com ~comment:!doeval;
          Buffer.add_string buf pptest;
          close_com ~comment:!doeval;
          if !doeval then Buffer.add_string buf dyntest;

  and print_if ~comment s if_ =
    ignore (comment);
    let evaluated = eval if_.cond in
    print_if_cond ~comment:!doeval s if_.cond;
    let sv = !doeval in
    doeval := sv && evaluated;
    print_lexpr ~block:(`static != s) ~comment:(if s = `static then sv && not evaluated else false) if_.if_;
    doeval := sv && not evaluated;
    (let comment = if s = `static then sv && evaluated else false in
     match if_.else_ with
     | Some else_ ->
         if (s = `dyn) then Buffer.add_string buf " else ";
         open_com ~comment:sv;
         Buffer.add_string buf "#<Else>";
         close_com ~comment:sv;
         print_lexpr ~block:(s = `dyn) ~comment else_;
     | None -> ());
    doeval := sv;
    open_com ~comment:!doeval;
    Buffer.add_string buf "#<End>";
    close_com ~comment:!doeval;
    ()
  in
  print_lexpr ~block:false ~comment:false code

(* Parse a string *)
let parse content options =
  let set_debugvar, get_debugvar =
    let dvar = ref None in
    (fun str -> dvar := Some str),
    (fun () ->
       match !dvar with
       | None -> failwith ("The debug variable doesn't exists")
       | Some s -> s) in
  let content =
    Str.full_split (Str.regexp "#<[^<>]*>") content in

  let if_regexp = Str.regexp "#<\\([^ :]*\\):\\([^>]*\\)>" in
  let cond1_regexp = Str.regexp "\\([^ ]*\\)\\$\\([^ ]*\\) \\([^ ]*\\)" in
  let cond2_regexp = Str.regexp "\\$\\([^ ]*\\) \\([^ ]*\\)" in
  let cond3_regexp = Str.regexp "\\([^ ]*\\) \\([^ ]*\\)" in
  let dvar_regexp = Str.regexp "#<Debugvar: *\\([^ ]*\\) *" in

  let rec aux (result, lst) =
    match lst with
    | Str.Delim "#<Else>"::_
    | Str.Delim "#<End>"::_ -> (List.rev result), lst
    | Str.Delim tag::queue ->
        (try
           let error i =
             raise (PPParse_error
                      (Printf.sprintf "Error (%d) on pptag \"%s\" : Bad formatted" i tag))
           in
           if Str.string_match dvar_regexp tag 0 then (
             set_debugvar (Str.matched_group 1 tag);
             aux (result, queue)
           ) else if tag = "#<If>" || Str.string_match if_regexp tag 0 then (
             let typif_ =
               if options.force_static then `static
               else if tag = "#<If>" || Str.matched_group 1 tag = "If" then
                 `dyn
               else if tag = "#<Ifstatic>" || Str.matched_group 1 tag = "Ifstatic" then
                 `static
               else error 1
             in
             let cond =
               if tag = "#<If>" || tag = "#<Ifstatic>"then(
                 Set (get_debugvar ())
               )else
                 let cond = Str.matched_group 2 tag in
                 if Str.string_match cond1_regexp cond 0 then(
                   Test (Str.matched_group 2 cond,
                         Str.matched_group 1 cond,
                         Str.matched_group 3 cond)
                 )else if Str.string_match cond2_regexp cond 0 then(
                   Test (Str.matched_group 1 cond,
                         get_debugvar (),
                         Str.matched_group 2 cond)
                 )else if Str.string_match cond3_regexp cond 0 then(
                   Test ("",
                         Str.matched_group 1 cond,
                         Str.matched_group 2 cond)
                 )else(
                   Set cond)
             in
             let if_, queue = aux ([], queue) in
             let else_, queue =
               match queue with
               | Str.Delim "#<Else>"::queue ->
                   let else_, queue = aux ([], queue) in
                   Some else_, queue
               | _ -> None, queue in
             (* End if *)
             (match queue with
              | Str.Delim "#<End>"::queue ->
                  let result =
                    let if_ = {cond = cond; if_ = if_; else_ = else_} in
                    (match typif_ with
                     |`static -> Ifstatic if_
                     |`dyn -> If if_)::result
                  in
                  aux (result, queue)
              | _ -> failwith ("Error expected end"))
           ) else error 2
         with | PPParse_error _ -> aux (result, (Str.Text tag)::queue)
        )

    | Str.Text normal::queue ->
        aux (Normal normal::result, queue)
    | _ -> (List.rev result), lst
  in match aux ([], content) with
  | content, [] -> content
  | _, t::_ ->
      (match t with
       | Str.Delim r
       | Str.Text r -> failwith (Printf.sprintf "Error on \"%s\"" r))

(* Process *)
let process description options content =
  (* Parsing *)
  let content = parse content options in
  (* Eval function *)
  let eval cond =
    try
      match cond with
      | Set name ->
          StringMap.mem name options.env
      | Test (_, name, value) ->
          let v = StringMap.find name options.env in
          v = value
    with Not_found -> false in
  (* Print and eval *)
  let buf = Buffer.create 1024 in
  print_code ~doeval:true ~eval description buf content;
  Buffer.contents buf

(* Generic executable *)
module Exe = struct

  let files = ref []

  let options = ref (default_options StringMap.empty)

  let speclist = [
    ("--force-static",
     Arg.Unit (fun() -> options := {!options with force_static = true}),
     "Force all if to be static");
    ("--output-suffix",
     Arg.String (fun s -> options := {!options with output_suffix = Some s}),
     "Output to files using the given suffix instead of stdout")
  ]

  let parse () =
    Arg.parse speclist
      (fun file -> files := file::!files)
      "pprocess"

  (* Get a file content (cc from File) *)
  let content f =
    let stat = Unix.stat f in
    match stat.Unix.st_kind with
    | Unix.S_DIR -> failwith (Printf.sprintf "%S is a directory" f)
    | Unix.S_LNK -> assert false (* stat goes through symbolic links *)
    | Unix.S_CHR (* Character device *)
    | Unix.S_BLK (* Block device *)
    | Unix.S_FIFO (* Named pipe *)
    | Unix.S_SOCK (* Socket *) ->
        (* for these kind of files, the size information is meaningless *)
        let ic = open_in_bin f in
        let len = 10000 in
        let str = String.create len in
        let buf = Buffer.create 10000 in
        let rec aux () =
          let read = input ic str 0 len in
          if read <> 0 then (
            Buffer.add_substring buf str 0 read;
            aux ()
          ) in
        aux ();
        close_in ic;
        Buffer.contents buf
    | Unix.S_REG (* Regular file *) ->
        let size = stat.Unix.st_size in
        assert (size <= Sys.max_string_length) ;
        let ic = open_in_bin f
        and buf = String.create size in
        really_input ic buf 0 size ;
        close_in ic ;
        buf

  let run description =
    parse ();
    let options =
      let options = !options in
      { options with env = fill_with_sysenv options.env } in
    let rec aux files =
      match files with
      | t::q ->
          begin
            let result = process description options (content t) in
            match options.output_suffix with
            | None -> output_string stdout result
            | Some s ->
                let out = open_out (t^s) in
                output_string out result;
                close_out out;
                aux q
          end
      | [] -> ()
    in aux (List.rev !files)
end
Something went wrong with that request. Please try again.