Makefile.config: Avoid annoying coreutils warning
[perl4caml.git] / wrappers / pl_HTML_Element.ml
1 (** Wrapper around Perl [HTML::Element] class. *)
2 (*  Copyright (C) 2003 Merjis Ltd.
3
4     This library is free software; you can redistribute it and/or
5     modify it under the terms of the GNU Library General Public
6     License as published by the Free Software Foundation; either
7     version 2 of the License, or (at your option) any later version.
8
9     This library is distributed in the hope that it will be useful,
10     but WITHOUT ANY WARRANTY; without even the implied warranty of
11     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
12     Library General Public License for more details.
13
14     You should have received a copy of the GNU General Public License
15     along with this library; see the file COPYING.  If not, write to
16     the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
17     Boston, MA 02111-1307, USA.
18
19     $Id: pl_HTML_Element.ml,v 1.5 2008-03-01 13:02:21 rich Exp $
20   *)
21
22 open Perl
23
24 let _ = eval "use HTML::Element"
25
26 type 'a content_t = Element of 'a | String of string
27
28 class html_element sv =
29
30   let rec assocs_of_svlist = function
31       [] -> []
32     | [x] -> failwith "HTML::Element all_attr returned odd-length list!"
33     | svname :: svvalue :: xs ->
34         (string_of_sv svname, string_of_sv svvalue) :: assocs_of_svlist xs
35   in
36
37   let rec list_of_svlist = function
38       [] -> []
39     | sv :: xs ->
40         string_of_sv sv :: list_of_svlist xs
41   in
42
43 object (self)
44
45   method sv = sv
46
47   method attr name =
48     string_of_sv (call_method sv "attr" [sv_of_string name])
49   method set_attr name value =
50     call_method_void sv "attr" [sv_of_string name; sv_of_string value]
51   method tag =
52     string_of_sv (call_method sv "tag" [])
53   method set_tag tag =
54     call_method_void sv "tag" [sv_of_string tag]
55   method parent =
56     let sv = call_method sv "parent" [] in
57     new html_element sv
58   method set_parent (parent : html_element) =
59     call_method_void sv "parent" [parent#sv]
60   method content_list =
61     let svlist = call_method_array sv "content_list" [] in
62     List.map
63       (fun c ->
64          (* Not very satisfactory, but sv_type fails to discern the type
65           * for some reason. XXX
66           *)
67          let str = string_of_sv c in
68          let marker = "HTML::Element=HASH(" in
69          let marker_len = String.length marker in
70          if String.length str > marker_len &&
71            String.sub str 0 marker_len = marker then
72              Element (new html_element c)
73          else
74            String (string_of_sv c)
75       ) svlist
76   method all_attr =
77     let svlist = call_method_array sv "all_attr" [] in
78     assocs_of_svlist svlist
79   method all_attr_names =
80     let svlist = call_method_array sv "all_attr_names" [] in
81     list_of_svlist svlist
82   method all_external_attr =
83     let svlist = call_method_array sv "all_external_attr" [] in
84     assocs_of_svlist svlist
85   method all_external_attr_names =
86     let svlist = call_method_array sv "all_external_attr_names" [] in
87     list_of_svlist svlist
88
89 end
90
91 (* Note that "new" is a reserved word, so I've appended an _ character. *)
92 let new_ tag attrs =
93   let rec loop = function
94       [] -> []
95     | (name, value) :: xs -> sv_of_string name :: sv_of_string value :: loop xs
96   in
97   let sv = call_class_method "HTML::Element" "new"
98              (sv_of_string tag :: loop attrs) in
99   new html_element sv