Net/XMPP2/Writer.pm

package Net::XMPP2::Writer;
use strict;
use XML::Writer;
use Authen::SASL;
use MIME::Base64;
use Net::XMPP2::Namespaces qw/xmpp_ns/;
use Net::XMPP2::Util qw/simxml/;

=head1 NAME

Net::XMPP2::Writer - "XML" writer for XMPP

=head1 SYNOPSIS

   use Net::XMPP2::Writer;
   ...

=head1 DESCRIPTION

This module contains some helper functions for writing XMPP "XML",
which is not real XML at all ;-( I use L<XML::Writer> and tune it
until it creates "XML" that is accepted by most servers propably
(all of the XMPP servers I tested should work (jabberd14, jabberd2,
ejabberd, googletalk).

I hope the semantics of L<XML::Writer> don't change much over the future,
but if they do and you run into problems, please report them!

The whole "XML" concept of XMPP is fundamentally broken anyway. It's supposed
to be an subset of XML. But a subset of XML productions is not XML. Strictly
speaking you need a special XMPP "XML" parser and writer to be 100% conformant.

On top of that XMPP B<requires> you to parse these partial "XML" documents.
But a partial XML document is not well-formed, heck, it's not even a XML document!.
And a parser should bail out with an error. But XMPP doesn't care, it just relies on
implementation dependend behaviour of chunked parsing modes for SAX parsing.
This functionality isn't even specified by the XML recommendation in any way.
The recommendation even says that it's undefined what happens if you process
not-well-formed XML documents.

But I try to be as "XML" XMPP conformant as possible (it should be around 99-100%).
But it's hard to say what XML is conformant, as the specifications of XMPP "XML" and XML
are contradicting. For example XMPP also says you only have to generated and accept
utf-8 encodings of XML, but the XML recommendation says that each parser has
to accept utf-8 B<and> utf-16. So, what do you do? Do you use a XML conformant parser
or do you write your own?

I'm using XML::Parser::Expat because expat knows how to parse broken (aka 'partial')
"XML" documents, as XMPP requires. Another argument is that if you capture a XMPP
conversation to the end, and even if a '</stream:stream>' tag was captured, you
wont have a valid XML document. The problem is that you have to resent a <stream> tag
after TLS and SASL authentication each! Awww... I'm repeating myself.

But well... Net::XMPP2 does it's best with expat to cope with the fundamental brokeness
of "XML" in XMPP.

Back to the issue with "XML" generation: I've discoverd that many XMPP servers (eg.
jabberd14 and ejabberd) have problems with XML namespaces. Thats the reason why
I'm assigning the namespace prefixes manually: The servers just don't accept validly
namespaced XML. The draft 3921bis does even state that a client SHOULD generate a 'stream'
prefix for the <stream> tag.

I advice you to explictly set the namespaces too if you generate "XML" for XMPP yourself,
at least until all or most of the XMPP servers have been fixed. Which might take some
years :-) And maybe will happen never.

And another note: As XMPP requires all predefined entity characters to be escaped
in character data you need a "XML" writer that will escape everything:

   RFC 3920 - 11.1.  Restrictions:

     character data or attribute values containing unescaped characters
     that map to the predefined entities (Section 4.6 therein);
     such characters MUST be escaped

This means:
You have to escape '>' in the character data. I don't know whether XML::Writer
does that. And I honestly don't care much about this. XMPP is broken by design and
I have barely time to writer my own XML parsers and writers to suit their sick taste
of "XML". (Do I repeat myself?)

I would be happy if they finally say (in RFC3920): "XMPP is NOT XML. It's just
XML-like, and some XML utilities allow you to process this kind of XML.".

=head1 METHODS

=over 4

=item B<new (%args)>

This methods takes following arguments:

=over 4

=item write_cb

The callback that is called when a XML stanza was completly written
and is ready for transfer. The first argument of the callback
will be the character data to send to the socket.

=back

And calls C<init>.

=cut

sub new {
   my $this = shift;
   my $class = ref($this) || $this;
   my $self = {
      write_cb     => sub {},
      send_iq_cb   => sub {},
      send_msg_cb  => sub {},
      send_pres_cb => sub {},
      @_
   };
   bless $self, $class;
   $self->init;
   return $self;
}

=item B<init>

(Re)initializes the writer.

=cut

sub init {
   my ($self) = @_;
   $self->{write_buf} = "";
   $self->{writer} = XML::Writer->new (OUTPUT => \$self->{write_buf}, NAMESPACES => 1);
}

=item B<flush ()>

This method flushes the internal write buffer and will invoke the C<write_cb>
callback. (see also C<new ()> above)

=cut

sub flush {
   my ($self) = @_;
   $self->{write_cb}->(substr $self->{write_buf}, 0, (length $self->{write_buf}), '');
}

=item B<send_init_stream ($domain)>

This method will generate a XMPP stream header. C<$domain> has to be the
domain of the server (or endpoint) we want to connect to.

=cut

sub send_init_stream {
   my ($self, $language, $domain) = @_;

   my $w = $self->{writer};
   $w->xmlDecl ('UTF-8');
   $w->addPrefix (xmpp_ns ('stream'), 'stream');
   $w->addPrefix (xmpp_ns ('client'), '');
   $w->forceNSDecl (xmpp_ns ('client'));
   $w->startTag (
      [xmpp_ns ('stream'), 'stream'],
      to => $domain,
      version => '1.0',
      [xmpp_ns ('xml'), 'lang'] => $language
   );
   $self->flush;
}

=item B<send_end_of_stream>

Sends end of the stream.

=cut

sub send_end_of_stream {
   my ($self) = @_;
   my $w = $self->{writer};
   $w->endTag ([xmpp_ns ('stream'), 'stream']);
   $self->flush;
}

=item B<send_sasl_auth ($mechanisms)>

This methods sends the start of a SASL authentication. C<$mechanisms> is
a string with space seperated mechanisms that are supported by the other
end.

=cut

sub send_sasl_auth {
   my ($self, $mechanisms, $user, $domain, $pass) = @_;

   my $sasl = Authen::SASL->new (
      mechanism => $mechanisms,
      callback => {
 # XXX: removed authname, because it ensures maximum connectivitiy
 #      along multiple server implementations - XMPP is such a crap
 #        authname => $user . '@' . $domain,
         user => $user,
         pass => $pass,
      }
   );

   $self->{sasl} = $sasl->client_new ('xmpp', $domain);

   my $w = $self->{writer};
   $w->addPrefix (xmpp_ns ('sasl'),   '');
   $w->startTag ([xmpp_ns ('sasl'), 'auth'], mechanism => $self->{sasl}->mechanism);
   $w->characters (MIME::Base64::encode_base64 ($self->{sasl}->client_start, ''));
   $w->endTag;
   $self->flush;
}

=item B<send_sasl_response ($challenge)>

This method generated the SASL authentication response to a C<$challenge>.
You must not call this method without calling C<send_sasl_auth ()> before.

=cut

sub send_sasl_response {
   my ($self, $challenge) = @_;
   $challenge = MIME::Base64::decode_base64 ($challenge);
   my $ret = '';
   unless ($challenge =~ /rspauth=/) { # rspauth basically means: we are done
      $ret = $self->{sasl}->client_step ($challenge);
      unless ($ret) {
         die "Error in SASL authentication in client step with challenge: '$challenge'\n";
      }
   }
   my $w = $self->{writer};
   $w->addPrefix (xmpp_ns ('sasl'),   '');
   $w->startTag ([xmpp_ns ('sasl'), 'response']);
   $w->characters (MIME::Base64::encode_base64 ($ret, ''));
   $w->endTag;
   $self->flush;
}

=item B<send_starttls>

Sends the starttls command to the server.

=cut

sub send_starttls {
   my ($self) = @_;
   my $w = $self->{writer};
   $w->addPrefix (xmpp_ns ('tls'),   '');
   $w->emptyTag ([xmpp_ns ('tls'), 'starttls']);
   $self->flush;
}

=item B<send_iq ($id, $type, $create_cb, %attrs)>

This method sends an IQ stanza of type C<$type> (to be compliant
only use: 'get', 'set', 'result' and 'error'). C<$create_cb>
will be called with an XML::Writer instance as first argument.
C<$create_cb> should be used to fill the IQ xml stanza.
If C<$create_cb> is undefined an empty tag will be generated.

C<%attrs> should have further attributes for the IQ stanza tag.
For example 'to' or 'from'. If the C<%attrs> contain a 'lang' attribute
it will be put into the 'xml' namespace.

C<$id> is the id to give this IQ stanza and is mandatory in this API.

=cut

sub send_iq {
   my ($self, $id, $type, $create_cb, %attrs) = @_;

   $create_cb = _trans_create_cb ($create_cb);
   $create_cb = $self->_fetch_cb_additions (send_iq_cb => $create_cb, $id, $type, \%attrs);

   my $w = $self->{writer};
   $w->addPrefix (xmpp_ns ('bind'), '');
   my (@from) = ($self->{jid} ? (from => $self->{jid}) : ());
   if ($attrs{lang}) {
      push @from, ([ xmpp_ns ('xml'), 'lang' ] => delete $attrs{leng})
   }
   push @from, (id => $id) if defined $id;
   if (defined $create_cb) {
      $w->startTag ('iq', type => $type, @from, %attrs);
      $create_cb->($w);
      $w->endTag;
   } else {
      $w->emptyTag ('iq', type => $type, @from, %attrs);
   }
   $self->flush;
}

=item B<send_presence ($id, $type, $create_cb, %attrs)>

Sends a presence stanza.

C<$create_cb> has the same meaning as for C<send_iq>.
C<%attrs> will let you pass further optional arguments like 'to'.

C<$type> is the type of the presence, which may be one of:

   unavailable, subscribe, subscribed, unsubscribe, unsubscribed, probe, error

Or undef, in case you want to send a 'normal' presence.
Or something completly different if you don't like the RFC 3921 :-)

C<%attrs> contains further attributes for the presence tag or may contain one of the
following exceptional keys:

If C<%attrs> contains a 'show' key: a child xml tag with that name will be geenerated
with the value as the content, which should be one of 'away', 'chat', 'dnd' and 'xa'.

If C<%attrs> contains a 'status' key: a child xml tag with that name will be generated
with the value as content. If the value of the 'status' key is an hash reference
the keys will be interpreted as language identifiers for the xml:lang attribute
of each status element. If one of these keys is the empty string '' no xml:lang attribute
will be generated for it. The values will be the character content of the status tags.

If C<%attrs> contains a 'priority' key: a child xml tag with that name will be generated
with the value as content, which must be a number between -128 and +127.

Note: If C<$create_cb> is undefined and one of the above attributes (show,
status or priority) were given, the generates presence tag won't be empty.

=cut

sub _generate_key_xml {
   my ($w, $key, $value) = @_;
   $w->startTag ($key);
   $w->characters ($value);
   $w->endTag;
}

sub _generate_key_xmls {
   my ($w, $key, $value) = @_;
   if (ref ($value) eq 'HASH') {
      for (keys %$value) {
         $w->startTag ($key, ($_ ne '' ? ([xmpp_ns ('xml'), 'lang'] => $_) : ()));
         $w->characters ($value->{$_});
         $w->endTag;
      }
   } else {
      $w->startTag ($key);
      $w->characters ($value);
      $w->endTag;
   }
}

sub _trans_create_cb {
   my ($cb) = @_;
   return unless defined $cb;
   if (ref ($cb) eq 'HASH') {
      my $args = $cb;
      $cb = sub {
         my ($w) = @_;
         simxml ($w, %$args);
      }
   }
   $cb
}

sub _fetch_cb_additions {
   my ($self, $key, $create_cb, @args) = @_;
   my @add_cbs;
   $self->{$key}->(@args, \@add_cbs);
   @add_cbs = map { _trans_create_cb ($_) } @add_cbs;

   if (@add_cbs) {
      my $crcb = $create_cb;
      $create_cb = sub {
         my (@args) = @_;
         $crcb->(@args) if $crcb;
         for (@add_cbs) { $_->(@args) }
      }
   }

   $create_cb
}

sub send_presence {
   my ($self, $id, $type, $create_cb, %attrs) = @_;

   $create_cb = _trans_create_cb ($create_cb);
   $create_cb = $self->_fetch_cb_additions (send_pres_cb => $create_cb, $id, $type, \%attrs);

   my $w = $self->{writer};
   $w->addPrefix (xmpp_ns ('client'), '');

   my @add;
   push @add, (type => $type) if defined $type;
   push @add, (id => $id) if defined $id;

   my %fattrs =
      map { $_ => $attrs{$_} }
         grep { my $k = $_; not grep { $k eq $_ } qw/show priority status/ }
            keys %attrs;

   if (defined $create_cb) {
      $w->startTag ('presence', @add, %fattrs);
      _generate_key_xml ($w, show => $attrs{show})         if defined $attrs{show};
      _generate_key_xml ($w, priority => $attrs{priority}) if defined $attrs{priority};
      _generate_key_xmls ($w, status => $attrs{status})    if defined $attrs{status};
      $create_cb->($w);
      $w->endTag;
   } else {
      if (exists $attrs{show} or $attrs{priority} or $attrs{status}) {
         $w->startTag ('presence', @add, %fattrs);
         _generate_key_xml ($w, show => $attrs{show})         if defined $attrs{show};
         _generate_key_xml ($w, priority => $attrs{priority}) if defined $attrs{priority};
         _generate_key_xmls ($w, status => $attrs{status})    if defined $attrs{status};
         $w->endTag;
      } else {
         $w->emptyTag ('presence', @add, %fattrs);
      }
   }

   $self->flush;
}

=item B<send_message ($id, $to, $type, $create_cb, %attrs)>

Sends a message stanza.

C<$to> is the destination JID of the message. C<$type> is
the type of the message, and if C<$type> is undefined it will default to 'chat'.
C<$type> must be one of the following: 'chat', 'error', 'groupchat', 'headline'
or 'normal'.

C<$create_cb> has the same meaning as in C<send_iq>.

C<%attrs> contains further attributes for the message tag or may contain one of the
following exceptional keys:

If C<%attrs> contains a 'body' key: a child xml tag with that name will be generated
with the value as content. If the value of the 'body' key is an hash reference
the keys will be interpreted as language identifiers for the xml:lang attribute
of each body element. If one of these keys is the empty string '' no xml:lang attribute
will be generated for it. The values will be the character content of the body tags.

If C<%attrs> contains a 'subject' key: a child xml tag with that name will be generated
with the value as content. If the value of the 'subject' key is an hash reference
the keys will be interpreted as language identifiers for the xml:lang attribute
of each subject element. If one of these keys is the empty string '' no xml:lang attribute
will be generated for it. The values will be the character content of the subject tags.

If C<%attrs> contains a 'thread' key: a child xml tag with that name will be generated
and the value will be the character content.

=cut

sub send_message {
   my ($self, $id, $to, $type, $create_cb, %attrs) = @_;

   $create_cb = _trans_create_cb ($create_cb);
   $create_cb = $self->_fetch_cb_additions (send_msg_cb => $create_cb, $id, $to, $type, \%attrs);

   my $w = $self->{writer};
   $w->addPrefix (xmpp_ns ('client'), '');

   my @add;
   push @add, (id => $id) if defined $id;

   $type ||= 'chat';

   my %fattrs =
      map { $_ => $attrs{$_} }
         grep { my $k = $_; not grep { $k eq $_ } qw/subject body thread/ }
            keys %attrs;

   if (defined $create_cb) {
      $w->startTag ('message', @add, to => $to, type => $type, %fattrs);
      _generate_key_xmls ($w, subject => $attrs{subject})    if defined $attrs{subject};
      _generate_key_xmls ($w, body => $attrs{body})          if defined $attrs{body};
      _generate_key_xml ($w, thread => $attrs{thread})       if defined $attrs{thread};
      $create_cb->($w);
      $w->endTag;
   } else {
      if (exists $attrs{subject} or $attrs{body} or $attrs{thread}) {
         $w->startTag ('message', @add, to => $to, type => $type, %fattrs);
         _generate_key_xmls ($w, subject => $attrs{subject})    if defined $attrs{subject};
         _generate_key_xmls ($w, body => $attrs{body})          if defined $attrs{body};
         _generate_key_xml ($w, thread => $attrs{thread})       if defined $attrs{thread};
         $w->endTag;
      } else {
         $w->emptyTag ('message', @add, to => $to, type => $type, %fattrs);
      }
   }

   $self->flush;
}


=item B<write_error_tag ($error_stanza_node, $error_type, $error)>

C<$error_type> is one of 'cancel', 'continue', 'modify', 'auth' and 'wait'.
C<$error> is the name of the error tag child element. If C<$error> is one of
the following:

   'bad-request', 'conflict', 'feature-not-implemented', 'forbidden', 'gone',
   'internal-server-error', 'item-not-found', 'jid-malformed', 'not-acceptable',
   'not-allowed', 'not-authorized', 'payment-required', 'recipient-unavailable',
   'redirect', 'registration-required', 'remote-server-not-found',
   'remote-server-timeout', 'resource-constraint', 'service-unavailable',
   'subscription-required', 'undefined-condition', 'unexpected-request'

then a default can be select for C<$error_type>, and the argument can be undefined.

Note: This method is currently a bit limited in the generation of the xml
for the errors, if you need more please contact me.

=cut

our %STANZA_ERRORS = (
   'bad-request'             => ['modify', 400],
   'conflict'                => ['cancel', 409],
   'feature-not-implemented' => ['cancel', 501],
   'forbidden'               => ['auth',   403],
   'gone'                    => ['modify', 302],
   'internal-server-error'   => ['wait',   500],
   'item-not-found'          => ['cancel', 404],
   'jid-malformed'           => ['modify', 400],
   'not-acceptable'          => ['modify', 406],
   'not-allowed'             => ['cancel', 405],
   'not-authorized'          => ['auth',   401],
   'payment-required'        => ['auth',   402],
   'recipient-unavailable'   => ['wait',   404],
   'redirect'                => ['modify', 302],
   'registration-required'   => ['auth',   407],
   'remote-server-not-found' => ['cancel', 404],
   'remote-server-timeout'   => ['wait',   504],
   'resource-constraint'     => ['wait',   500],
   'service-unavailable'     => ['cancel', 503],
   'subscription-required'   => ['auth',   407],
   'undefined-condition'     => ['cancel', 500],
   'unexpected-request'      => ['wait',   400],
);

sub write_error_tag {
   my ($self, $errstanza, $type, $error) = @_;

   my $w = $self->{writer};

   $_->write_on ($w) for $errstanza->nodes;

   my @add;

   unless (defined $type and defined $STANZA_ERRORS{$error}) {
      $type = $STANZA_ERRORS{$error}->[0];
   }

   push @add, (code => $STANZA_ERRORS{$error}->[1]);

   $w->addPrefix (xmpp_ns ('client'), '');
   $w->startTag ([xmpp_ns ('client') => 'error'], type => $type, @add);
      $w->addPrefix (xmpp_ns ('stanzas'), '');
      $w->emptyTag ([xmpp_ns ('stanzas') => $error]);
   $w->endTag;
}

=back

=head1 AUTHOR

Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>

=head1 COPYRIGHT & LICENSE

Copyright 2007 Robin Redeker, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of Net::XMPP2
Revision:	1.19
Committed:	Wed Jul 11 22:29:27 2007 UTC (19 years, 3 months ago) by elmex
Branch:	MAIN
Changes since 1.18:	+28 -1 lines
Log Message:	added send_*_hook event hooks
#	User	Rev	Content
1	elmex	1.1	package Net::XMPP2::Writer;
2			use strict;
3			use XML::Writer;
4			use Authen::SASL;
5			use MIME::Base64;
6			use Net::XMPP2::Namespaces qw/xmpp_ns/;
7	elmex	1.18	use Net::XMPP2::Util qw/simxml/;
8	elmex	1.1
9			=head1 NAME
10
11	elmex	1.17	Net::XMPP2::Writer - "XML" writer for XMPP
12	elmex	1.1
13			=head1 SYNOPSIS
14
15			use Net::XMPP2::Writer;
16			...
17
18	elmex	1.3	=head1 DESCRIPTION
19
20	elmex	1.5	This module contains some helper functions for writing XMPP "XML",
21	elmex	1.3	which is not real XML at all ;-( I use L<XML::Writer> and tune it
22	elmex	1.5	until it creates "XML" that is accepted by most servers propably
23	elmex	1.16	(all of the XMPP servers I tested should work (jabberd14, jabberd2,
24			ejabberd, googletalk).
25	elmex	1.3
26			I hope the semantics of L<XML::Writer> don't change much over the future,
27			but if they do and you run into problems, please report them!
28
29	elmex	1.5	The whole "XML" concept of XMPP is fundamentally broken anyway. It's supposed
30	elmex	1.3	to be an subset of XML. But a subset of XML productions is not XML. Strictly
31	elmex	1.5	speaking you need a special XMPP "XML" parser and writer to be 100% conformant.
32	elmex	1.3
33	elmex	1.14	On top of that XMPP B<requires> you to parse these partial "XML" documents.
34	elmex	1.10	But a partial XML document is not well-formed, heck, it's not even a XML document!.
35			And a parser should bail out with an error. But XMPP doesn't care, it just relies on
36			implementation dependend behaviour of chunked parsing modes for SAX parsing.
37			This functionality isn't even specified by the XML recommendation in any way.
38			The recommendation even says that it's undefined what happens if you process
39			not-well-formed XML documents.
40
41	elmex	1.9	But I try to be as "XML" XMPP conformant as possible (it should be around 99-100%).
42	elmex	1.5	But it's hard to say what XML is conformant, as the specifications of XMPP "XML" and XML
43	elmex	1.3	are contradicting. For example XMPP also says you only have to generated and accept
44			utf-8 encodings of XML, but the XML recommendation says that each parser has
45	elmex	1.14	to accept utf-8 B<and> utf-16. So, what do you do? Do you use a XML conformant parser
46	elmex	1.3	or do you write your own?
47
48	elmex	1.5	I'm using XML::Parser::Expat because expat knows how to parse broken (aka 'partial')
49			"XML" documents, as XMPP requires. Another argument is that if you capture a XMPP
50	elmex	1.3	conversation to the end, and even if a '</stream:stream>' tag was captured, you
51			wont have a valid XML document. The problem is that you have to resent a <stream> tag
52	elmex	1.10	after TLS and SASL authentication each! Awww... I'm repeating myself.
53	elmex	1.3
54			But well... Net::XMPP2 does it's best with expat to cope with the fundamental brokeness
55	elmex	1.5	of "XML" in XMPP.
56	elmex	1.3
57	elmex	1.5	Back to the issue with "XML" generation: I've discoverd that many XMPP servers (eg.
58	elmex	1.3	jabberd14 and ejabberd) have problems with XML namespaces. Thats the reason why
59	elmex	1.9	I'm assigning the namespace prefixes manually: The servers just don't accept validly
60	elmex	1.3	namespaced XML. The draft 3921bis does even state that a client SHOULD generate a 'stream'
61			prefix for the <stream> tag.
62
63	elmex	1.5	I advice you to explictly set the namespaces too if you generate "XML" for XMPP yourself,
64	elmex	1.3	at least until all or most of the XMPP servers have been fixed. Which might take some
65			years :-) And maybe will happen never.
66
67	elmex	1.5	And another note: As XMPP requires all predefined entity characters to be escaped
68			in character data you need a "XML" writer that will escape everything:
69
70			RFC 3920 - 11.1. Restrictions:
71
72			character data or attribute values containing unescaped characters
73			that map to the predefined entities (Section 4.6 therein);
74			such characters MUST be escaped
75
76			This means:
77			You have to escape '>' in the character data. I don't know whether XML::Writer
78	elmex	1.9	does that. And I honestly don't care much about this. XMPP is broken by design and
79			I have barely time to writer my own XML parsers and writers to suit their sick taste
80			of "XML". (Do I repeat myself?)
81	elmex	1.5
82	elmex	1.10	I would be happy if they finally say (in RFC3920): "XMPP is NOT XML. It's just
83			XML-like, and some XML utilities allow you to process this kind of XML.".
84
85	elmex	1.1	=head1 METHODS
86
87	elmex	1.16	=over 4
88
89			=item B<new (%args)>
90	elmex	1.1
91			This methods takes following arguments:
92
93			=over 4
94
95			=item write_cb
96
97			The callback that is called when a XML stanza was completly written
98			and is ready for transfer. The first argument of the callback
99			will be the character data to send to the socket.
100
101	elmex	1.9	=back
102
103	elmex	1.1	And calls C<init>.
104
105			=cut
106
107			sub new {
108			my $this = shift;
109			my $class = ref($this) \|\| $this;
110	elmex	1.19	my $self = {
111			write_cb => sub {},
112			send_iq_cb => sub {},
113			send_msg_cb => sub {},
114			send_pres_cb => sub {},
115			@_
116			};
117	elmex	1.1	bless $self, $class;
118			$self->init;
119			return $self;
120			}
121
122	elmex	1.16	=item B<init>
123	elmex	1.1
124			(Re)initializes the writer.
125
126			=cut
127
128			sub init {
129			my ($self) = @_;
130			$self->{write_buf} = "";
131			$self->{writer} = XML::Writer->new (OUTPUT => \$self->{write_buf}, NAMESPACES => 1);
132			}
133
134	elmex	1.16	=item B<flush ()>
135	elmex	1.1
136			This method flushes the internal write buffer and will invoke the C<write_cb>
137			callback. (see also C<new ()> above)
138
139			=cut
140
141			sub flush {
142			my ($self) = @_;
143			$self->{write_cb}->(substr $self->{write_buf}, 0, (length $self->{write_buf}), '');
144			}
145
146	elmex	1.16	=item B<send_init_stream ($domain)>
147	elmex	1.1
148			This method will generate a XMPP stream header. C<$domain> has to be the
149			domain of the server (or endpoint) we want to connect to.
150
151			=cut
152
153			sub send_init_stream {
154			my ($self, $language, $domain) = @_;
155
156			my $w = $self->{writer};
157			$w->xmlDecl ('UTF-8');
158			$w->addPrefix (xmpp_ns ('stream'), 'stream');
159			$w->addPrefix (xmpp_ns ('client'), '');
160	elmex	1.9	$w->forceNSDecl (xmpp_ns ('client'));
161	elmex	1.1	$w->startTag (
162			[xmpp_ns ('stream'), 'stream'],
163			to => $domain,
164			version => '1.0',
165			[xmpp_ns ('xml'), 'lang'] => $language
166			);
167			$self->flush;
168			}
169
170	elmex	1.16	=item B<send_end_of_stream>
171	elmex	1.1
172			Sends end of the stream.
173
174			=cut
175
176			sub send_end_of_stream {
177			my ($self) = @_;
178			my $w = $self->{writer};
179			$w->endTag ([xmpp_ns ('stream'), 'stream']);
180			$self->flush;
181			}
182
183	elmex	1.16	=item B<send_sasl_auth ($mechanisms)>
184	elmex	1.1
185			This methods sends the start of a SASL authentication. C<$mechanisms> is
186			a string with space seperated mechanisms that are supported by the other
187			end.
188
189			=cut
190
191			sub send_sasl_auth {
192			my ($self, $mechanisms, $user, $domain, $pass) = @_;
193
194			my $sasl = Authen::SASL->new (
195			mechanism => $mechanisms,
196			callback => {
197	elmex	1.15	# XXX: removed authname, because it ensures maximum connectivitiy
198			# along multiple server implementations - XMPP is such a crap
199			# authname => $user . '@' . $domain,
200	elmex	1.1	user => $user,
201			pass => $pass,
202			}
203			);
204
205			$self->{sasl} = $sasl->client_new ('xmpp', $domain);
206
207			my $w = $self->{writer};
208			$w->addPrefix (xmpp_ns ('sasl'), '');
209			$w->startTag ([xmpp_ns ('sasl'), 'auth'], mechanism => $self->{sasl}->mechanism);
210			$w->characters (MIME::Base64::encode_base64 ($self->{sasl}->client_start, ''));
211			$w->endTag;
212			$self->flush;
213			}
214
215	elmex	1.16	=item B<send_sasl_response ($challenge)>
216	elmex	1.1
217			This method generated the SASL authentication response to a C<$challenge>.
218			You must not call this method without calling C<send_sasl_auth ()> before.
219
220			=cut
221
222			sub send_sasl_response {
223			my ($self, $challenge) = @_;
224			$challenge = MIME::Base64::decode_base64 ($challenge);
225			my $ret = '';
226			unless ($challenge =~ /rspauth=/) { # rspauth basically means: we are done
227			$ret = $self->{sasl}->client_step ($challenge);
228			unless ($ret) {
229			die "Error in SASL authentication in client step with challenge: '$challenge'\n";
230			}
231			}
232			my $w = $self->{writer};
233			$w->addPrefix (xmpp_ns ('sasl'), '');
234			$w->startTag ([xmpp_ns ('sasl'), 'response']);
235			$w->characters (MIME::Base64::encode_base64 ($ret, ''));
236			$w->endTag;
237			$self->flush;
238			}
239
240	elmex	1.16	=item B<send_starttls>
241	elmex	1.2
242			Sends the starttls command to the server.
243
244			=cut
245
246			sub send_starttls {
247			my ($self) = @_;
248			my $w = $self->{writer};
249			$w->addPrefix (xmpp_ns ('tls'), '');
250			$w->emptyTag ([xmpp_ns ('tls'), 'starttls']);
251			$self->flush;
252			}
253
254	elmex	1.16	=item B<send_iq ($id, $type, $create_cb, %attrs)>
255	elmex	1.1
256	elmex	1.3	This method sends an IQ stanza of type C<$type> (to be compliant
257			only use: 'get', 'set', 'result' and 'error'). C<$create_cb>
258	elmex	1.1	will be called with an XML::Writer instance as first argument.
259			C<$create_cb> should be used to fill the IQ xml stanza.
260	elmex	1.3	If C<$create_cb> is undefined an empty tag will be generated.
261	elmex	1.1
262			C<%attrs> should have further attributes for the IQ stanza tag.
263			For example 'to' or 'from'. If the C<%attrs> contain a 'lang' attribute
264			it will be put into the 'xml' namespace.
265
266	elmex	1.3	C<$id> is the id to give this IQ stanza and is mandatory in this API.
267	elmex	1.1
268			=cut
269
270			sub send_iq {
271			my ($self, $id, $type, $create_cb, %attrs) = @_;
272	elmex	1.18
273			$create_cb = _trans_create_cb ($create_cb);
274	elmex	1.19	$create_cb = $self->_fetch_cb_additions (send_iq_cb => $create_cb, $id, $type, \%attrs);
275	elmex	1.18
276	elmex	1.1	my $w = $self->{writer};
277			$w->addPrefix (xmpp_ns ('bind'), '');
278			my (@from) = ($self->{jid} ? (from => $self->{jid}) : ());
279			if ($attrs{lang}) {
280			push @from, ([ xmpp_ns ('xml'), 'lang' ] => delete $attrs{leng})
281			}
282	elmex	1.6	push @from, (id => $id) if defined $id;
283	elmex	1.3	if (defined $create_cb) {
284	elmex	1.6	$w->startTag ('iq', type => $type, @from, %attrs);
285	elmex	1.3	$create_cb->($w);
286			$w->endTag;
287			} else {
288	elmex	1.6	$w->emptyTag ('iq', type => $type, @from, %attrs);
289	elmex	1.3	}
290			$self->flush;
291			}
292
293	elmex	1.16	=item B<send_presence ($id, $type, $create_cb, %attrs)>
294	elmex	1.3
295			Sends a presence stanza.
296
297			C<$create_cb> has the same meaning as for C<send_iq>.
298			C<%attrs> will let you pass further optional arguments like 'to'.
299
300			C<$type> is the type of the presence, which may be one of:
301
302			unavailable, subscribe, subscribed, unsubscribe, unsubscribed, probe, error
303
304	elmex	1.18	Or undef, in case you want to send a 'normal' presence.
305	elmex	1.3	Or something completly different if you don't like the RFC 3921 :-)
306
307			C<%attrs> contains further attributes for the presence tag or may contain one of the
308			following exceptional keys:
309
310			If C<%attrs> contains a 'show' key: a child xml tag with that name will be geenerated
311			with the value as the content, which should be one of 'away', 'chat', 'dnd' and 'xa'.
312
313			If C<%attrs> contains a 'status' key: a child xml tag with that name will be generated
314			with the value as content. If the value of the 'status' key is an hash reference
315			the keys will be interpreted as language identifiers for the xml:lang attribute
316			of each status element. If one of these keys is the empty string '' no xml:lang attribute
317			will be generated for it. The values will be the character content of the status tags.
318
319			If C<%attrs> contains a 'priority' key: a child xml tag with that name will be generated
320			with the value as content, which must be a number between -128 and +127.
321
322			Note: If C<$create_cb> is undefined and one of the above attributes (show,
323			status or priority) were given, the generates presence tag won't be empty.
324
325			=cut
326
327			sub _generate_key_xml {
328			my ($w, $key, $value) = @_;
329			$w->startTag ($key);
330			$w->characters ($value);
331	elmex	1.1	$w->endTag;
332			}
333
334	elmex	1.3	sub _generate_key_xmls {
335			my ($w, $key, $value) = @_;
336			if (ref ($value) eq 'HASH') {
337			for (keys %$value) {
338	elmex	1.11	$w->startTag ($key, ($_ ne '' ? ([xmpp_ns ('xml'), 'lang'] => $_) : ()));
339	elmex	1.3	$w->characters ($value->{$_});
340			$w->endTag;
341			}
342			} else {
343			$w->startTag ($key);
344			$w->characters ($value);
345			$w->endTag;
346			}
347	elmex	1.1	}
348
349	elmex	1.18	sub _trans_create_cb {
350			my ($cb) = @_;
351			return unless defined $cb;
352			if (ref ($cb) eq 'HASH') {
353			my $args = $cb;
354			$cb = sub {
355			my ($w) = @_;
356			simxml ($w, %$args);
357			}
358			}
359			$cb
360			}
361
362	elmex	1.19	sub _fetch_cb_additions {
363			my ($self, $key, $create_cb, @args) = @_;
364			my @add_cbs;
365			$self->{$key}->(@args, \@add_cbs);
366			@add_cbs = map { _trans_create_cb ($_) } @add_cbs;
367
368			if (@add_cbs) {
369			my $crcb = $create_cb;
370			$create_cb = sub {
371			my (@args) = @_;
372			$crcb->(@args) if $crcb;
373			for (@add_cbs) { $_->(@args) }
374			}
375			}
376
377			$create_cb
378			}
379
380	elmex	1.1	sub send_presence {
381	elmex	1.4	my ($self, $id, $type, $create_cb, %attrs) = @_;
382	elmex	1.3
383	elmex	1.18	$create_cb = _trans_create_cb ($create_cb);
384	elmex	1.19	$create_cb = $self->_fetch_cb_additions (send_pres_cb => $create_cb, $id, $type, \%attrs);
385	elmex	1.18
386	elmex	1.1	my $w = $self->{writer};
387			$w->addPrefix (xmpp_ns ('client'), '');
388	elmex	1.3
389			my @add;
390	elmex	1.4	push @add, (type => $type) if defined $type;
391			push @add, (id => $id) if defined $id;
392	elmex	1.3
393	elmex	1.7	my %fattrs =
394			map { $_ => $attrs{$_} }
395	elmex	1.12	grep { my $k = $_; not grep { $k eq $_ } qw/show priority status/ }
396	elmex	1.7	keys %attrs;
397
398	elmex	1.3	if (defined $create_cb) {
399	elmex	1.7	$w->startTag ('presence', @add, %fattrs);
400			_generate_key_xml ($w, show => $attrs{show}) if defined $attrs{show};
401			_generate_key_xml ($w, priority => $attrs{priority}) if defined $attrs{priority};
402			_generate_key_xmls ($w, status => $attrs{status}) if defined $attrs{status};
403	elmex	1.3	$create_cb->($w);
404			$w->endTag;
405			} else {
406			if (exists $attrs{show} or $attrs{priority} or $attrs{status}) {
407	elmex	1.7	$w->startTag ('presence', @add, %fattrs);
408			_generate_key_xml ($w, show => $attrs{show}) if defined $attrs{show};
409			_generate_key_xml ($w, priority => $attrs{priority}) if defined $attrs{priority};
410			_generate_key_xmls ($w, status => $attrs{status}) if defined $attrs{status};
411	elmex	1.3	$w->endTag;
412			} else {
413	elmex	1.7	$w->emptyTag ('presence', @add, %fattrs);
414	elmex	1.3	}
415			}
416
417	elmex	1.1	$self->flush;
418			}
419
420	elmex	1.16	=item B<send_message ($id, $to, $type, $create_cb, %attrs)>
421	elmex	1.3
422			Sends a message stanza.
423
424			C<$to> is the destination JID of the message. C<$type> is
425	elmex	1.6	the type of the message, and if C<$type> is undefined it will default to 'chat'.
426	elmex	1.3	C<$type> must be one of the following: 'chat', 'error', 'groupchat', 'headline'
427			or 'normal'.
428
429			C<$create_cb> has the same meaning as in C<send_iq>.
430
431			C<%attrs> contains further attributes for the message tag or may contain one of the
432			following exceptional keys:
433
434			If C<%attrs> contains a 'body' key: a child xml tag with that name will be generated
435			with the value as content. If the value of the 'body' key is an hash reference
436			the keys will be interpreted as language identifiers for the xml:lang attribute
437			of each body element. If one of these keys is the empty string '' no xml:lang attribute
438			will be generated for it. The values will be the character content of the body tags.
439
440			If C<%attrs> contains a 'subject' key: a child xml tag with that name will be generated
441			with the value as content. If the value of the 'subject' key is an hash reference
442			the keys will be interpreted as language identifiers for the xml:lang attribute
443			of each subject element. If one of these keys is the empty string '' no xml:lang attribute
444			will be generated for it. The values will be the character content of the subject tags.
445
446			If C<%attrs> contains a 'thread' key: a child xml tag with that name will be generated
447			and the value will be the character content.
448
449			=cut
450
451	elmex	1.1	sub send_message {
452	elmex	1.4	my ($self, $id, $to, $type, $create_cb, %attrs) = @_;
453	elmex	1.3
454	elmex	1.18	$create_cb = _trans_create_cb ($create_cb);
455	elmex	1.19	$create_cb = $self->_fetch_cb_additions (send_msg_cb => $create_cb, $id, $to, $type, \%attrs);
456	elmex	1.18
457	elmex	1.1	my $w = $self->{writer};
458			$w->addPrefix (xmpp_ns ('client'), '');
459	elmex	1.3
460	elmex	1.4	my @add;
461			push @add, (id => $id) if defined $id;
462
463	elmex	1.3	$type \|\|= 'chat';
464
465	elmex	1.7	my %fattrs =
466			map { $_ => $attrs{$_} }
467	elmex	1.12	grep { my $k = $_; not grep { $k eq $_ } qw/subject body thread/ }
468	elmex	1.7	keys %attrs;
469
470	elmex	1.3	if (defined $create_cb) {
471	elmex	1.7	$w->startTag ('message', @add, to => $to, type => $type, %fattrs);
472			_generate_key_xmls ($w, subject => $attrs{subject}) if defined $attrs{subject};
473			_generate_key_xmls ($w, body => $attrs{body}) if defined $attrs{body};
474			_generate_key_xml ($w, thread => $attrs{thread}) if defined $attrs{thread};
475	elmex	1.3	$create_cb->($w);
476			$w->endTag;
477			} else {
478			if (exists $attrs{subject} or $attrs{body} or $attrs{thread}) {
479	elmex	1.7	$w->startTag ('message', @add, to => $to, type => $type, %fattrs);
480			_generate_key_xmls ($w, subject => $attrs{subject}) if defined $attrs{subject};
481			_generate_key_xmls ($w, body => $attrs{body}) if defined $attrs{body};
482			_generate_key_xml ($w, thread => $attrs{thread}) if defined $attrs{thread};
483	elmex	1.3	$w->endTag;
484			} else {
485	elmex	1.7	$w->emptyTag ('message', @add, to => $to, type => $type, %fattrs);
486	elmex	1.3	}
487			}
488
489	elmex	1.1	$self->flush;
490			}
491
492	elmex	1.4
493	elmex	1.16	=item B<write_error_tag ($error_stanza_node, $error_type, $error)>
494	elmex	1.4
495			C<$error_type> is one of 'cancel', 'continue', 'modify', 'auth' and 'wait'.
496			C<$error> is the name of the error tag child element. If C<$error> is one of
497			the following:
498
499			'bad-request', 'conflict', 'feature-not-implemented', 'forbidden', 'gone',
500			'internal-server-error', 'item-not-found', 'jid-malformed', 'not-acceptable',
501			'not-allowed', 'not-authorized', 'payment-required', 'recipient-unavailable',
502			'redirect', 'registration-required', 'remote-server-not-found',
503			'remote-server-timeout', 'resource-constraint', 'service-unavailable',
504			'subscription-required', 'undefined-condition', 'unexpected-request'
505
506			then a default can be select for C<$error_type>, and the argument can be undefined.
507
508			Note: This method is currently a bit limited in the generation of the xml
509			for the errors, if you need more please contact me.
510
511			=cut
512
513			our %STANZA_ERRORS = (
514			'bad-request' => ['modify', 400],
515			'conflict' => ['cancel', 409],
516			'feature-not-implemented' => ['cancel', 501],
517			'forbidden' => ['auth', 403],
518			'gone' => ['modify', 302],
519			'internal-server-error' => ['wait', 500],
520			'item-not-found' => ['cancel', 404],
521			'jid-malformed' => ['modify', 400],
522			'not-acceptable' => ['modify', 406],
523			'not-allowed' => ['cancel', 405],
524			'not-authorized' => ['auth', 401],
525			'payment-required' => ['auth', 402],
526			'recipient-unavailable' => ['wait', 404],
527			'redirect' => ['modify', 302],
528			'registration-required' => ['auth', 407],
529			'remote-server-not-found' => ['cancel', 404],
530			'remote-server-timeout' => ['wait', 504],
531			'resource-constraint' => ['wait', 500],
532			'service-unavailable' => ['cancel', 503],
533			'subscription-required' => ['auth', 407],
534			'undefined-condition' => ['cancel', 500],
535			'unexpected-request' => ['wait', 400],
536			);
537
538			sub write_error_tag {
539			my ($self, $errstanza, $type, $error) = @_;
540
541			my $w = $self->{writer};
542
543			$_->write_on ($w) for $errstanza->nodes;
544
545			my @add;
546
547			unless (defined $type and defined $STANZA_ERRORS{$error}) {
548			$type = $STANZA_ERRORS{$error}->[0];
549			}
550
551	elmex	1.13	push @add, (code => $STANZA_ERRORS{$error}->[1]);
552	elmex	1.4
553			$w->addPrefix (xmpp_ns ('client'), '');
554			$w->startTag ([xmpp_ns ('client') => 'error'], type => $type, @add);
555			$w->addPrefix (xmpp_ns ('stanzas'), '');
556			$w->emptyTag ([xmpp_ns ('stanzas') => $error]);
557			$w->endTag;
558			}
559
560	elmex	1.16	=back
561
562	elmex	1.1	=head1 AUTHOR
563
564	elmex	1.16	Robin Redeker, C<< <elmex at ta-sa.org> >>, JID: C<< <elmex at jabber.org> >>
565	elmex	1.1
566			=head1 COPYRIGHT & LICENSE
567
568			Copyright 2007 Robin Redeker, all rights reserved.
569
570			This program is free software; you can redistribute it and/or modify it
571			under the same terms as Perl itself.
572
573			=cut
574
575			1; # End of Net::XMPP2