helm/DEVEL/pxp/netstring/nethtml.ml

   1 (* $Id$
   2  * ----------------------------------------------------------------------
   3  *
   4  *)
   5
   6 open Nethtml_scanner;;
   7
   8 type document =
   9     Element of (string  *  (string*string) list  *  document list)
  10   | Data of string
  11 ;;
  12
  13
  14 exception End_of_scan;;
  15
  16
  17 let no_end_tag =  (* empty HTML elements *)
  18   ref
  19     [ "isindex";
  20       "base";
  21       "meta";
  22       "link";
  23       "hr";
  24       "input";
  25       "img";
  26       "param";
  27       "basefont";
  28       "br";
  29       "area";
  30     ]
  31 ;;
  32
  33
  34 let special_tag =   (* other lexical rules *)
  35   ref
  36     [ "script";
  37       "style";
  38     ]
  39 ;;
  40
  41
  42 let rec parse_comment buf =
  43   let t = scan_comment buf in
  44   match t with
  45       Mcomment ->
  46         parse_comment buf
  47     | Eof ->
  48         raise End_of_scan
  49     | _ ->
  50         ()
  51 ;;
  52
  53
  54 let rec parse_doctype buf =
  55   let t = scan_doctype buf in
  56   match t with
  57       Mdoctype ->
  58         parse_doctype buf
  59     | Eof ->
  60         raise End_of_scan
  61     | _ ->
  62         ()
  63 ;;
  64
  65
  66 let parse_document buf =
  67   let current_name = ref "" in
  68   let current_atts = ref [] in
  69   let current_subs = ref [] in
  70   let stack = Stack.create() in
  71
  72   let parse_atts() =
  73     let rec next_no_space() =
  74       match scan_element buf with
  75           Space _ -> next_no_space()
  76         | t -> t
  77     in
  78
  79     let rec parse_atts_lookahead next =
  80       match next with
  81           Relement -> []
  82         | Name n ->
  83             begin match next_no_space() with
  84                 Is ->
  85                   begin match next_no_space() with
  86                       Name v ->
  87                         (String.lowercase n, String.uppercase v) ::
  88                         parse_atts_lookahead (next_no_space())
  89                     | Literal v ->
  90                         (String.lowercase n,v) ::
  91                         parse_atts_lookahead (next_no_space())
  92                     | Eof ->
  93                         raise End_of_scan
  94                     | Relement ->
  95                         (* Illegal *)
  96                         []
  97                     | _ ->
  98                         (* Illegal *)
  99                         parse_atts_lookahead (next_no_space())
 100                   end
 101               | Eof ->
 102                   raise End_of_scan
 103               | Relement ->
 104                   (* <tag name> <==> <tag name="name"> *)
 105                   [ String.lowercase n, String.lowercase n ]
 106               | next' ->
 107                   (* assume <tag name ... > <==> <tag name="name" ...> *)
 108                   ( String.lowercase n, String.lowercase n ) ::
 109                   parse_atts_lookahead next'
 110             end
 111         | Eof ->
 112             raise End_of_scan
 113         | _ ->
 114             (* Illegal *)
 115             parse_atts_lookahead (next_no_space())
 116     in
 117     parse_atts_lookahead (next_no_space())
 118   in
 119
 120   let rec parse_special name =
 121     (* Parse until </name> *)
 122     match scan_special buf with
 123         Lelementend n ->
 124           if n = name then
 125             ""
 126           else
 127             "</" ^ n ^ parse_special name
 128       | Eof ->
 129           raise End_of_scan
 130       | Cdata s ->
 131           s ^ parse_special name
 132       | _ ->
 133           (* Illegal *)
 134           parse_special name
 135   in
 136
 137   let rec skip_element() =
 138     (* Skip until ">" *)
 139     match scan_element buf with
 140         Relement ->
 141           ()
 142       | Eof ->
 143           raise End_of_scan
 144       | _ ->
 145           skip_element()
 146   in
 147
 148   let rec parse_next() =
 149     let t = scan_document buf in
 150     match t with
 151         Lcomment ->
 152           parse_comment buf;
 153           parse_next()
 154       | Ldoctype ->
 155           parse_doctype buf;
 156           parse_next()
 157       | Lelement name ->
 158           let name = String.lowercase name in
 159           if List.mem name !no_end_tag then begin
 160             let atts = parse_atts() in
 161             current_subs := (Element(name, atts, [])) :: !current_subs;
 162             parse_next()
 163           end
 164           else if List.mem name !special_tag then begin
 165             let atts = parse_atts() in
 166             let data = parse_special name in
 167             (* Read until ">" *)
 168             skip_element();
 169             current_subs := (Element(name, atts, [Data data])) :: !current_subs;
 170             parse_next()
 171           end
 172           else begin
 173             let atts = parse_atts() in
 174             Stack.push (!current_name, !current_atts, !current_subs) stack;
 175             current_name := name;
 176             current_atts := atts;
 177             current_subs := [];
 178             parse_next()
 179           end
 180       | Cdata data ->
 181           current_subs := (Data data) :: !current_subs;
 182           parse_next()
 183       | Lelementend name ->
 184           let name = String.lowercase name in
 185           (* Read until ">" *)
 186           skip_element();
 187           (* Search the element to close on the stack: *)
 188           let found = ref (name = !current_name) in
 189           Stack.iter
 190             (fun (old_name, _, _) ->
 191                if name = old_name then found := true)
 192             stack;
 193           (* If not found, the end tag is wrong. Simply ignore it. *)
 194           if not !found then
 195             parse_next()
 196           else begin
 197             (* Put the current element on to the stack: *)
 198             Stack.push (!current_name, !current_atts, !current_subs) stack;
 199             (* If found: Remove the elements from the stack, and append
 200              * them to the previous element as sub elements
 201              *)
 202             let rec remove() =
 203               let old_name, old_atts, old_subs = Stack.pop stack in
 204                 (* or raise Stack.Empty *)
 205               if old_name = name then
 206                 old_name, old_atts, old_subs
 207               else
 208                 let older_name, older_atts, older_subs = remove() in
 209                 older_name,
 210                 older_atts,
 211                 (Element (old_name, old_atts, List.rev old_subs) :: older_subs)
 212             in
 213             let old_name, old_atts, old_subs = remove() in
 214             (* Remove one more element: the element containing the element
 215              * currently being closed.
 216              *)
 217             let new_name, new_atts, new_subs = Stack.pop stack in
 218             current_name := new_name;
 219             current_atts := new_atts;
 220             current_subs := (Element (old_name, old_atts, List.rev old_subs))
 221                             :: new_subs;
 222             (* Go on *)
 223             parse_next()
 224           end
 225       | Eof ->
 226           raise End_of_scan
 227       | _ ->
 228           parse_next()
 229   in
 230   try
 231     parse_next();
 232     List.rev !current_subs
 233   with
 234       End_of_scan ->
 235         (* Close all remaining elements: *)
 236         Stack.push (!current_name, !current_atts, !current_subs) stack;
 237         let rec remove() =
 238           let old_name, old_atts, old_subs = Stack.pop stack in
 239                 (* or raise Stack.Empty *)
 240           try
 241             let older_name, older_atts, older_subs = remove() in
 242             older_name,
 243             older_atts,
 244             (Element (old_name, old_atts, List.rev old_subs) :: older_subs)
 245           with
 246               Stack.Empty ->
 247                 old_name, old_atts, old_subs
 248         in
 249         let name, atts, subs = remove() in
 250         List.rev subs
 251 ;;
 252
 253
 254 let parse_string s =
 255   let buf = Lexing.from_string s in
 256   parse_document buf
 257 ;;
 258
 259
 260 let parse_file fd =
 261   let buf = Lexing.from_channel fd in
 262   parse_document buf
 263 ;;
 264
 265 (* ======================================================================
 266  * History:
 267  *
 268  * $Log$
 269  * Revision 1.1  2000/11/17 09:57:28  lpadovan
 270  * Initial revision
 271  *
 272  * Revision 1.1  2000/03/03 01:07:25  gerd
 273  *      Initial revision.
 274  *
 275  *
 276  *)