Dogcows Code - chaz/p5-AnyEvent-XMPP-Ext-HTML/blob - lib/AnyEvent/XMPP/Ext/HTML.pm

   1 package AnyEvent::XMPP::Ext::HTML;
   2 # ABSTRACT: XEP-0071: XHTML-IM (Version 1.5) for AnyEvent::XMPP
   3
   4 use warnings;
   5 use strict;
   6
   7 use AnyEvent::XMPP::Ext;
   8 use AnyEvent::XMPP::Namespaces qw/set_xmpp_ns_alias xmpp_ns/;
   9
  10 our @ISA = qw/AnyEvent::XMPP::Ext/;
  11
  12 =head1 SYNOPSIS
  13
  14     my $c = AnyEvent::XMPP::Connection->new(...);
  15     $c->add_extension(my $disco = AnyEvent::XMPP::Ext::Disco->new);
  16     $c->add_extension(AnyEvent::XMPP::Ext::HTML->new(disco => $disco));
  17
  18     $c->send_message(
  19         body => "This is plain text; same as usual.",
  20         html => "This is <em>XHTML</em>!",
  21     );
  22
  23 =head1 DESCRIPTION
  24
  25 An implementation of XEP-0071: XHTML-IM for HTML-formatted messages.
  26
  27 =head1 CAVEATS
  28
  29 HTML messages are not validated nor escaped, so it is your responsibility to
  30 use valid XHTML-IM tags and to close them properly.
  31
  32 =method new
  33
  34 Creates a new extension handle.  It takes an optional C<disco> argument which
  35 is a L<AnyEvent::XMPP::Ext::Disco> object for which this extension will be
  36 enabled.
  37
  38 =cut
  39
  40 sub new {
  41     my $this = shift;
  42     my $class = ref($this) || $this;
  43     my $self = bless { @_ }, $class;
  44     $self->init;
  45     $self;
  46 }
  47
  48 =method init
  49
  50 Initialize the extension.  This does not need to be called externally.
  51
  52 =cut
  53
  54 sub init {
  55     my $self = shift;
  56
  57     set_xmpp_ns_alias(xhtml_im => 'http://jabber.org/protocol/xhtml-im');
  58     set_xmpp_ns_alias(xhtml => 'http://www.w3.org/1999/xhtml');
  59
  60     $self->{disco}->enable_feature($self->disco_feature) if defined $self->{disco};
  61
  62     $self->{cb_id} = $self->reg_cb(
  63         send_message_hook => sub {
  64             my ($self, $con, $id, $to, $type, $attrs, $create_cb) = @_;
  65
  66             return unless exists $attrs->{html};
  67             my $html = delete $attrs->{html};
  68
  69             push @$create_cb, sub {
  70                 my ($w) = @_;
  71
  72                 $w->addPrefix(xmpp_ns('xhtml_im'), '');
  73                 $w->startTag([xmpp_ns('xhtml_im'), 'html']);
  74                 if (ref($html) eq 'HASH') {
  75                     for (keys %$html) {
  76                         $w->addPrefix(xmpp_ns('xhtml'), '');
  77                         $w->startTag([xmpp_ns('xhtml'), 'body'], ($_ ne '' ? ([xmpp_ns('xml'), 'lang'] => $_) : ()));
  78                         $w->raw($html->{$_});
  79                         $w->endTag;
  80                     }
  81                 } else {
  82                     $w->addPrefix(xmpp_ns('xhtml'), '');
  83                     $w->startTag([xmpp_ns('xhtml'), 'body']);
  84                     $w->raw($html);
  85                     $w->endTag;
  86                 }
  87                 $w->endTag;
  88             };
  89         },
  90     );
  91 }
  92
  93 sub disco_feature {
  94     xmpp_ns('xhtml_im');
  95 }
  96
  97 sub DESTROY {
  98     my $self = shift;
  99     $self->unreg_cb($self->{cb_id});
 100 }
 101
 102 1;