Fixed for Perl 5.8.2.
[perl4caml.git] / wrappers / pl_HTML_Element.ml
1 (** Wrapper around Perl [HTML::Element] class.
2   *
3   * Copyright (C) 2003 Merjis Ltd.
4   *
5   * $Id: pl_HTML_Element.ml,v 1.4 2003-10-16 13:41:07 rich Exp $
6   *)
7
8 open Perl
9
10 let _ = eval "use HTML::Element"
11
12 type 'a content_t = Element of 'a | String of string
13
14 class html_element sv =
15
16   let rec assocs_of_svlist = function
17       [] -> []
18     | [x] -> failwith "HTML::Element all_attr returned odd-length list!"
19     | svname :: svvalue :: xs ->
20         (string_of_sv svname, string_of_sv svvalue) :: assocs_of_svlist xs
21   in
22
23   let rec list_of_svlist = function
24       [] -> []
25     | sv :: xs ->
26         string_of_sv sv :: list_of_svlist xs
27   in
28
29 object (self)
30
31   method sv = sv
32
33   method attr name =
34     string_of_sv (call_method sv "attr" [sv_of_string name])
35   method set_attr name value =
36     call_method_void sv "attr" [sv_of_string name; sv_of_string value]
37   method tag =
38     string_of_sv (call_method sv "tag" [])
39   method set_tag tag =
40     call_method_void sv "tag" [sv_of_string tag]
41   method parent =
42     let sv = call_method sv "parent" [] in
43     new html_element sv
44   method set_parent (parent : html_element) =
45     call_method_void sv "parent" [parent#sv]
46   method content_list =
47     let svlist = call_method_array sv "content_list" [] in
48     List.map
49       (fun c ->
50          (* Not very satisfactory, but sv_type fails to discern the type
51           * for some reason. XXX
52           *)
53          let str = string_of_sv c in
54          let marker = "HTML::Element=HASH(" in
55          let marker_len = String.length marker in
56          if String.length str > marker_len &&
57            String.sub str 0 marker_len = marker then
58              Element (new html_element c)
59          else
60            String (string_of_sv c)
61       ) svlist
62   method all_attr =
63     let svlist = call_method_array sv "all_attr" [] in
64     assocs_of_svlist svlist
65   method all_attr_names =
66     let svlist = call_method_array sv "all_attr_names" [] in
67     list_of_svlist svlist
68   method all_external_attr =
69     let svlist = call_method_array sv "all_external_attr" [] in
70     assocs_of_svlist svlist
71   method all_external_attr_names =
72     let svlist = call_method_array sv "all_external_attr_names" [] in
73     list_of_svlist svlist
74
75 end
76
77 (* Note that "new" is a reserved word, so I've appended an _ character. *)
78 let new_ tag attrs =
79   let rec loop = function
80       [] -> []
81     | (name, value) :: xs -> sv_of_string name :: sv_of_string value :: loop xs
82   in
83   let sv = call_class_method "HTML::Element" "new"
84              (sv_of_string tag :: loop attrs) in
85   new html_element sv