Net/XMPP2/Writer.pm

package Net::XMPP2::Writer;
use warnings;
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 as expat does support parsing of 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.

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