+++ /dev/null
-(* $Id$
- * ----------------------------------------------------------------------
- *
- *)
-
-open Nethtml_scanner;;
-
-type document =
- Element of (string * (string*string) list * document list)
- | Data of string
-;;
-
-
-exception End_of_scan;;
-
-
-let no_end_tag = (* empty HTML elements *)
- ref
- [ "isindex";
- "base";
- "meta";
- "link";
- "hr";
- "input";
- "img";
- "param";
- "basefont";
- "br";
- "area";
- ]
-;;
-
-
-let special_tag = (* other lexical rules *)
- ref
- [ "script";
- "style";
- ]
-;;
-
-
-let rec parse_comment buf =
- let t = scan_comment buf in
- match t with
- Mcomment ->
- parse_comment buf
- | Eof ->
- raise End_of_scan
- | _ ->
- ()
-;;
-
-
-let rec parse_doctype buf =
- let t = scan_doctype buf in
- match t with
- Mdoctype ->
- parse_doctype buf
- | Eof ->
- raise End_of_scan
- | _ ->
- ()
-;;
-
-
-let parse_document buf =
- let current_name = ref "" in
- let current_atts = ref [] in
- let current_subs = ref [] in
- let stack = Stack.create() in
-
- let parse_atts() =
- let rec next_no_space() =
- match scan_element buf with
- Space _ -> next_no_space()
- | t -> t
- in
-
- let rec parse_atts_lookahead next =
- match next with
- Relement -> []
- | Name n ->
- begin match next_no_space() with
- Is ->
- begin match next_no_space() with
- Name v ->
- (String.lowercase n, String.uppercase v) ::
- parse_atts_lookahead (next_no_space())
- | Literal v ->
- (String.lowercase n,v) ::
- parse_atts_lookahead (next_no_space())
- | Eof ->
- raise End_of_scan
- | Relement ->
- (* Illegal *)
- []
- | _ ->
- (* Illegal *)
- parse_atts_lookahead (next_no_space())
- end
- | Eof ->
- raise End_of_scan
- | Relement ->
- (* <tag name> <==> <tag name="name"> *)
- [ String.lowercase n, String.lowercase n ]
- | next' ->
- (* assume <tag name ... > <==> <tag name="name" ...> *)
- ( String.lowercase n, String.lowercase n ) ::
- parse_atts_lookahead next'
- end
- | Eof ->
- raise End_of_scan
- | _ ->
- (* Illegal *)
- parse_atts_lookahead (next_no_space())
- in
- parse_atts_lookahead (next_no_space())
- in
-
- let rec parse_special name =
- (* Parse until </name> *)
- match scan_special buf with
- Lelementend n ->
- if n = name then
- ""
- else
- "</" ^ n ^ parse_special name
- | Eof ->
- raise End_of_scan
- | Cdata s ->
- s ^ parse_special name
- | _ ->
- (* Illegal *)
- parse_special name
- in
-
- let rec skip_element() =
- (* Skip until ">" *)
- match scan_element buf with
- Relement ->
- ()
- | Eof ->
- raise End_of_scan
- | _ ->
- skip_element()
- in
-
- let rec parse_next() =
- let t = scan_document buf in
- match t with
- Lcomment ->
- parse_comment buf;
- parse_next()
- | Ldoctype ->
- parse_doctype buf;
- parse_next()
- | Lelement name ->
- let name = String.lowercase name in
- if List.mem name !no_end_tag then begin
- let atts = parse_atts() in
- current_subs := (Element(name, atts, [])) :: !current_subs;
- parse_next()
- end
- else if List.mem name !special_tag then begin
- let atts = parse_atts() in
- let data = parse_special name in
- (* Read until ">" *)
- skip_element();
- current_subs := (Element(name, atts, [Data data])) :: !current_subs;
- parse_next()
- end
- else begin
- let atts = parse_atts() in
- Stack.push (!current_name, !current_atts, !current_subs) stack;
- current_name := name;
- current_atts := atts;
- current_subs := [];
- parse_next()
- end
- | Cdata data ->
- current_subs := (Data data) :: !current_subs;
- parse_next()
- | Lelementend name ->
- let name = String.lowercase name in
- (* Read until ">" *)
- skip_element();
- (* Search the element to close on the stack: *)
- let found = ref (name = !current_name) in
- Stack.iter
- (fun (old_name, _, _) ->
- if name = old_name then found := true)
- stack;
- (* If not found, the end tag is wrong. Simply ignore it. *)
- if not !found then
- parse_next()
- else begin
- (* Put the current element on to the stack: *)
- Stack.push (!current_name, !current_atts, !current_subs) stack;
- (* If found: Remove the elements from the stack, and append
- * them to the previous element as sub elements
- *)
- let rec remove() =
- let old_name, old_atts, old_subs = Stack.pop stack in
- (* or raise Stack.Empty *)
- if old_name = name then
- old_name, old_atts, old_subs
- else
- let older_name, older_atts, older_subs = remove() in
- older_name,
- older_atts,
- (Element (old_name, old_atts, List.rev old_subs) :: older_subs)
- in
- let old_name, old_atts, old_subs = remove() in
- (* Remove one more element: the element containing the element
- * currently being closed.
- *)
- let new_name, new_atts, new_subs = Stack.pop stack in
- current_name := new_name;
- current_atts := new_atts;
- current_subs := (Element (old_name, old_atts, List.rev old_subs))
- :: new_subs;
- (* Go on *)
- parse_next()
- end
- | Eof ->
- raise End_of_scan
- | _ ->
- parse_next()
- in
- try
- parse_next();
- List.rev !current_subs
- with
- End_of_scan ->
- (* Close all remaining elements: *)
- Stack.push (!current_name, !current_atts, !current_subs) stack;
- let rec remove() =
- let old_name, old_atts, old_subs = Stack.pop stack in
- (* or raise Stack.Empty *)
- try
- let older_name, older_atts, older_subs = remove() in
- older_name,
- older_atts,
- (Element (old_name, old_atts, List.rev old_subs) :: older_subs)
- with
- Stack.Empty ->
- old_name, old_atts, old_subs
- in
- let name, atts, subs = remove() in
- List.rev subs
-;;
-
-
-let parse_string s =
- let buf = Lexing.from_string s in
- parse_document buf
-;;
-
-
-let parse_file fd =
- let buf = Lexing.from_channel fd in
- parse_document buf
-;;
-
-(* ======================================================================
- * History:
- *
- * $Log$
- * Revision 1.1 2000/11/17 09:57:28 lpadovan
- * Initial revision
- *
- * Revision 1.1 2000/03/03 01:07:25 gerd
- * Initial revision.
- *
- *
- *)
projects / helm.git / blobdiff