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