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/;

=head1 NAME

Net::XMPP2::Writer - A "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 yet work (jabberd14, jabberd2, ejabberd).

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.

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 E<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!

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?)

=head1 METHODS

=head2 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.

And calls C<init>.

=back

=cut

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

=head2 init

(Re)initializes the writer.

=cut

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

=head2 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}), '');
}

=head2 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 ('jabber:client');
   $w->startTag (
      [xmpp_ns ('stream'), 'stream'],
      to => $domain,
      version => '1.0',
      [xmpp_ns ('xml'), 'lang'] => $language
   );
   $self->flush;
}

=head2 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;
}

=head2 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 => {
         authname => $user,
         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;
}

=head2 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;
}

=head2 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;
}

=head2 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) = @_;
   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;
}

=head2 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 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, [xmpp_ns ('xml'), 'lang'] => $_);
         $w->characters ($value->{$_});
         $w->endTag;
      }
   } else {
      $w->startTag ($key);
      $w->characters ($value);
      $w->endTag;
   }
}

sub send_presence {
   my ($self, $id, $type, $create_cb, %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;

   if (defined $create_cb) {
      $w->startTag ('presence', @add, %attrs);
      _generate_key_xml (show => $attrs{show})         if defined $attrs{show};
      _generate_key_xml (priority => $attrs{priority}) if defined $attrs{priority};
      _generate_key_xmls (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, %attrs);
         _generate_key_xml (show => $attrs{show})         if defined $attrs{show};
         _generate_key_xml (priority => $attrs{priority}) if defined $attrs{priority};
         _generate_key_xmls (status => $attrs{status})    if defined $attrs{status};
         $w->endTag;
      } else {
         $w->emptyTag ('presence', @add, %attrs);
      }
   }

   $self->flush;
}

=head2 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) = @_;

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

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

   $type ||= 'chat';

   if (defined $create_cb) {
      $w->startTag ('message', @add, to => $to, type => $type, %attrs);
      _generate_key_xmls (subject => $attrs{subject})    if defined $attrs{subject};
      _generate_key_xmls (body => $attrs{body})          if defined $attrs{body};
      _generate_key_xml (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, %attrs);
         _generate_key_xmls (subject => $attrs{subject})    if defined $attrs{subject};
         _generate_key_xmls (body => $attrs{body})          if defined $attrs{body};
         _generate_key_xml (thread => $attrs{thread})       if defined $attrs{thread};
         $w->endTag;
      } else {
         $w->emptyTag ('message', @add, to => $to, type => $type, %attrs);
      }
   }

   $self->flush;
}


=head2 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];
   }

   if ($Net::XMPP2::EXTENSION_ENABLED{'86'} and defined $STANZA_ERRORS{$error}) {
      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;
}

=head1 AUTHOR

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

=head1 BUGS

Please report any bugs or feature requests to
C<bug-net-xmpp2 at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-XMPP2>.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Net::XMPP2

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Net-XMPP2>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Net-XMPP2>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-XMPP2>

=item * Search CPAN

L<http://search.cpan.org/dist/Net-XMPP2>

=back

=head1 ACKNOWLEDGEMENTS

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