← Back to branch summary

~ubuntu-branches/ubuntu/oneiric/ocsigen/oneiric

« back to all changes in this revision

Viewing changes to xmlp4/newocaml/simplexmlparser.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stephane Glondu
  • Date: 2009-07-02 10:02:08 UTC
  • mfrom: (1.1.9 upstream) (4.1.3 squeeze)
  • Revision ID: james.westby@ubuntu.com-20090702100208-n158b1sqwzn0asil
Tags: 1.2.0-2
Fix build on non-native architectures

Show diffs side-by-side

added added

removed removed

Lines of Context:
xmlp4/newocaml/simplexmlparser.ml
31
31
        "Caml code not allowed in configuration file. Use $$ to escape $." ;
32
32
 
33
33
 
34
 
module B = Xmllexer.BasicTypes;
35
 
 
36
 
        type state =
37
 
      { stream : Stream.t (B.token * Loc.t); stack : Stack.t B.token; loc : Loc.t
38
 
      };
39
 
    type error_msg =
40
 
      [ EndOfTagExpected of string
41
 
      | EOFExpected ];
42
 
    exception Internal_error of error_msg;
43
 
    exception NoMoreData;
44
 
 
45
 
   (* Stack - the type of s is state *)
46
 
    value pop s =
47
 
      try ((Stack.pop s.stack), s)
48
 
      with
49
 
      [ Stack.Empty ->
50
 
          let (t, l) = Stream.next s.stream
51
 
          in (t, {  stream = s.stream; stack = s.stack; loc = l; }) ];
52
 
    value push t s = Stack.push t s.stack;
53
 
 
54
 
   (* Convert a stream of tokens into an xml tree list *)
55
 
    value rec read_nodes s acc =
56
 
      match pop s with
57
 
      [ (B.Comment _, s) -> read_nodes s acc
58
 
      | (B.Whitespace _, s) -> read_nodes s acc
59
 
      | (B.PCData pcdata, s) -> read_nodes s [(PCData pcdata)::acc]
60
 
      | (B.Tag (tag, attlist, closed), s) ->
61
 
                  match closed with
62
 
          [ True -> read_nodes s [Element (tag, (read_attlist s attlist), [])::acc]
63
 
          | False ->read_nodes s
64
 
                           [Element (tag, (read_attlist s attlist), (read_elems ~tag s))::acc]
65
 
                  ]
66
 
      | (B.CamlExpr _, _) | (B.CamlString _, _)|(B.CamlList _, _) ->
67
 
                        raise (Xml_parser_error nocaml_msg)
68
 
          | (B.Eof, _)|(B.Endtag _,_) as t ->
69
 
                        do { push (fst t) s; List.rev acc}
70
 
          ]
71
 
 
72
 
   and read_elems ?tag s =
73
 
      let elems = read_nodes s [] in
74
 
        match pop s with
75
 
        [ (B.Endtag s, _) when (Some s) = tag -> elems
76
 
        | (B.Eof, _) when tag = None -> elems
77
 
        | (t, loc) ->
78
 
            match tag with
79
 
            [ None -> raise (Internal_error EOFExpected)
80
 
            | Some s -> raise (Internal_error (EndOfTagExpected s)) ] ]
81
 
 
82
 
   and read_attlist s =
83
 
      fun
84
 
      [ [] -> []
85
 
      | [ `Attribute (`Attr a, `Val v) :: l ] ->
86
 
          [ (a,v) :: (read_attlist s l) ]
87
 
      | [ `Attribute (`CamlAttr _, `Val _) :: _ ] |
88
 
          [ `Attribute (_, `CamlVal _) :: _ ] | [ `CamlList _ :: _ ] ->
89
 
                  raise (Xml_parser_error nocaml_msg)];
90
 
 
91
 
    value to_expr_taglist stream loc =
92
 
      let s = {  stream = stream; stack = Stack.create (); loc = loc; } in
93
 
          read_nodes s [];
94
 
 
95
 
value rawxmlparser_file s =
 
34
(* We raise this error when parsing Ocsigen configuration files. *)
 
35
exception ParseException of (Xmllexer.lexing_error * Camlp4.PreCast.Loc.t) ;
 
36
 
 
37
value parse_error_to_string x loc =
 
38
  Printf.sprintf "%s (%s)"
 
39
    (Xmllexer.lex_error_to_string x) (Loc.to_string loc);
 
40
 
 
41
 
 
42
module LexerArg = struct
 
43
  value error loc e = ParseException (e, loc);
 
44
 
 
45
  type attr_name =  [ = `AttrName of string ];
 
46
  type attr_value = [ = `AttrVal of string ];
 
47
  type attribute =  [ = `Attribute of (attr_name * attr_value) ];
 
48
 
 
49
  type token = [
 
50
  = `Tag of (string * (list attribute) * bool)
 
51
  | `PCData of string
 
52
  | `Endtag of string
 
53
  | `Comment of string
 
54
  | `Whitespace of string
 
55
  | `Eof
 
56
  ];
 
57
 
 
58
  value parse_dollar_attrname  c loc lexbuf =
 
59
      raise (ParseException (Xmllexer.EAttributeNameExpected, loc));
 
60
  value parse_dollar_attribute c loc lexbuf =
 
61
      raise (ParseException (Xmllexer.EAttributeValueExpected, loc));
 
62
  value parse_dollar_attrvalue = parse_dollar_attrname;
 
63
  value parse_dollar_token c lexbuf = `PCData "$";
 
64
 
 
65
end;
 
66
 
 
67
module Xmllexer = Xmllexer.Make (LexerArg);
 
68
 
 
69
type state = {
 
70
  stream : Stream.t (LexerArg.token * Loc.t);
 
71
  stack : Stack.t LexerArg.token;
 
72
  loc : Loc.t
 
73
};
 
74
type error_msg =
 
75
    [ EndOfTagExpected of string
 
76
    | EOFExpected ];
 
77
exception Internal_error of error_msg;
 
78
 
 
79
(* Stack - the type of s is state *)
 
80
value pop s =
 
81
    try ((Stack.pop s.stack), s)
 
82
    with
 
83
    [ Stack.Empty ->
 
84
        let (t, l) = Stream.next s.stream
 
85
        in (t, {  stream = s.stream; stack = s.stack; loc = l; }) ];
 
86
 
 
87
value push t s = Stack.push t s.stack;
 
88
 
 
89
(* Convert a stream of tokens into an xml tree list *)
 
90
value rec read_nodes s acc =
 
91
    match pop s with
 
92
    [ (`Comment _, s) -> read_nodes s acc
 
93
    | (`Whitespace _, s) -> read_nodes s acc
 
94
    | (`PCData pcdata, s) -> read_nodes s [(PCData pcdata)::acc]
 
95
    | (`Tag ("xi:include",
 
96
             [`Attribute (`AttrName "href", `AttrVal v)], True), s)->
 
97
        let l = rawxmlparser_file v in
 
98
        let acc = List.rev_append l acc in
 
99
        read_nodes s acc
 
100
    | (`Tag ("xi:include", _, _), s) ->
 
101
        raise (Xml_parser_error "Invalid syntax for inclusion directive")
 
102
    | (`Tag (tag, attlist, closed), s) ->
 
103
        match closed with
 
104
        [ True -> read_nodes s [Element (tag, (read_attlist attlist), [])::acc]
 
105
        | False ->read_nodes s
 
106
            [Element (tag, (read_attlist attlist), (read_elems ~tag s))::acc]
 
107
        ]
 
108
    | (`Eof, _)|(`Endtag _,_) as t ->
 
109
      do { push (fst t) s; List.rev acc}
 
110
]
 
111
 
 
112
and read_elems ?tag s =
 
113
  let elems = read_nodes s [] in
 
114
  match pop s with
 
115
  [ (`Endtag s, _) when (Some s) = tag -> elems
 
116
  | (`Eof, _) when tag = None -> elems
 
117
  | (t, loc) ->
 
118
      match tag with
 
119
      [ None -> raise (Internal_error EOFExpected)
 
120
      | Some s -> raise (Internal_error (EndOfTagExpected s)) ] ]
 
121
 
 
122
and read_attlist = List.map (fun [`Attribute (`AttrName a, `AttrVal v) -> (a,v)])
 
123
 
 
124
and to_expr_taglist stream loc =
 
125
  let s = {  stream = stream; stack = Stack.create (); loc = loc; } in
 
126
  read_nodes s []
 
127
 
 
128
and rawxmlparser_file s =
96
129
  let chan = open_in s in
97
 
  let loc = Loc.ghost in
98
 
  let tree = to_expr_taglist (Xmllexer.from_stream loc True (Stream.of_channel chan)) loc
99
 
  in do { close_in chan; tree };
 
130
  try
 
131
    let loc = Loc.mk s in
 
132
    let tree = to_expr_taglist (Xmllexer.from_stream loc True (Stream.of_channel chan)) loc
 
133
    in do { close_in chan; tree }
 
134
 with [ e ->
 
135
        do { close_in chan;
 
136
             match e with
 
137
             [ Sys_error s -> raise (Xml_parser_error s)
 
138
             | _ -> raise e
 
139
             ]
 
140
           } ]
100
141
 
101
 
value rawxmlparser_string s =
 
142
and rawxmlparser_string s =
102
143
  let loc = Loc.ghost in
103
144
  to_expr_taglist (Xmllexer.from_string loc True s) loc;
104
145
 
105
146
value xmlparser rawxmlparser s = try (rawxmlparser s)
106
147
with
107
 
[Internal_error EOFExpected -> raise (Xml_parser_error "EOF expected")
108
 
|Internal_error (EndOfTagExpected s) -> raise (Xml_parser_error ("End of tag expected: "^s))]
 
148
[ ParseException (e, loc) ->
 
149
    raise (Xml_parser_error (parse_error_to_string e loc))
 
150
| Internal_error EOFExpected ->
 
151
    raise (Xml_parser_error "EOF expected")
 
152
| Internal_error (EndOfTagExpected s) ->
 
153
    raise (Xml_parser_error ("End of tag expected: "^s))]
109
154
;
110
155
 
111
156
value xmlparser_file = xmlparser rawxmlparser_file;