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 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_iq ($id, $type, $create_cb, %attrs)

This method sends an IQ stanza of type C<$type>. 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.

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.

=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})
   }
   $w->startTag ('iq', id => $id, type => $type, @from, %attrs);
   $create_cb->($w);
   $w->endTag;
   $self->flush;
}

sub send_initial_presence {
   my ($self) = @_;
   my $w = $self->{writer};
   $w->addPrefix (xmpp_ns ('client'), '');
   $w->emptyTag ('presence', from => $self->{jid});
   $self->flush;
}

# XXX
sub send_presence {
   my ($self, $to) = @_;
   my $w = $self->{writer};
   $w->addPrefix (xmpp_ns ('client'), '');
   $w->emptyTag ('presence', from => $self->{jid}, to => $to);
   $self->flush;
}

# XXX
sub send_message {
   my ($self, $to, $type, $cb) = @_;
   my $w = $self->{writer};
   $w->addPrefix (xmpp_ns ('client'), '');
   $w->startTag ('message', to => $to, from => $self->{jid}, type => $type);
   $cb->($w);
   $w->endTag;
   $self->flush;
}

=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.1
Committed:	Tue Jan 23 15:56:47 2007 UTC (19 years, 8 months ago) by elmex
Branch:	MAIN
Log Message:	initial checkin.
#	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			=head1 METHODS
19
20			=head2 new (%args)
21
22			This methods takes following arguments:
23
24			=over 4
25
26			=item write_cb
27
28			The callback that is called when a XML stanza was completly written
29			and is ready for transfer. The first argument of the callback
30			will be the character data to send to the socket.
31
32			And calls C<init>.
33
34			=back
35
36			=cut
37
38			sub new {
39			my $this = shift;
40			my $class = ref($this) \|\| $this;
41			my $self = { write_cb => sub {}, @_ };
42			bless $self, $class;
43			$self->init;
44			return $self;
45			}
46
47			=head2 init
48
49			(Re)initializes the writer.
50
51			=cut
52
53			sub init {
54			my ($self) = @_;
55			$self->{write_buf} = "";
56			$self->{writer} = XML::Writer->new (OUTPUT => \$self->{write_buf}, NAMESPACES => 1);
57			}
58
59			=head2 flush ()
60
61			This method flushes the internal write buffer and will invoke the C<write_cb>
62			callback. (see also C<new ()> above)
63
64			=cut
65
66			sub flush {
67			my ($self) = @_;
68			$self->{write_cb}->(substr $self->{write_buf}, 0, (length $self->{write_buf}), '');
69			}
70
71			=head2 send_init_stream ($domain)
72
73			This method will generate a XMPP stream header. C<$domain> has to be the
74			domain of the server (or endpoint) we want to connect to.
75
76			=cut
77
78			sub send_init_stream {
79			my ($self, $language, $domain) = @_;
80
81			my $w = $self->{writer};
82			$w->xmlDecl ('UTF-8');
83			$w->addPrefix (xmpp_ns ('stream'), 'stream');
84			$w->addPrefix (xmpp_ns ('client'), '');
85			$w->forceNSDecl ('jabber:client');
86			$w->startTag (
87			[xmpp_ns ('stream'), 'stream'],
88			to => $domain,
89			version => '1.0',
90			[xmpp_ns ('xml'), 'lang'] => $language
91			);
92			$self->flush;
93			}
94
95			=head2 send_end_of_stream
96
97			Sends end of the stream.
98
99			=cut
100
101			sub send_end_of_stream {
102			my ($self) = @_;
103			my $w = $self->{writer};
104			$w->endTag ([xmpp_ns ('stream'), 'stream']);
105			$self->flush;
106			}
107
108			=head2 send_sasl_auth ($mechanisms)
109
110			This methods sends the start of a SASL authentication. C<$mechanisms> is
111			a string with space seperated mechanisms that are supported by the other
112			end.
113
114			=cut
115
116			sub send_sasl_auth {
117			my ($self, $mechanisms, $user, $domain, $pass) = @_;
118
119			my $sasl = Authen::SASL->new (
120			mechanism => $mechanisms,
121			callback => {
122			authname => $user,
123			user => $user,
124			pass => $pass,
125			}
126			);
127
128			$self->{sasl} = $sasl->client_new ('xmpp', $domain);
129
130			my $w = $self->{writer};
131			$w->addPrefix (xmpp_ns ('sasl'), '');
132			$w->startTag ([xmpp_ns ('sasl'), 'auth'], mechanism => $self->{sasl}->mechanism);
133			$w->characters (MIME::Base64::encode_base64 ($self->{sasl}->client_start, ''));
134			$w->endTag;
135			$self->flush;
136			}
137
138			=head2 send_sasl_response ($challenge)
139
140			This method generated the SASL authentication response to a C<$challenge>.
141			You must not call this method without calling C<send_sasl_auth ()> before.
142
143			=cut
144
145			sub send_sasl_response {
146			my ($self, $challenge) = @_;
147			$challenge = MIME::Base64::decode_base64 ($challenge);
148			my $ret = '';
149			unless ($challenge =~ /rspauth=/) { # rspauth basically means: we are done
150			$ret = $self->{sasl}->client_step ($challenge);
151			unless ($ret) {
152			die "Error in SASL authentication in client step with challenge: '$challenge'\n";
153			}
154			}
155			my $w = $self->{writer};
156			$w->addPrefix (xmpp_ns ('sasl'), '');
157			$w->startTag ([xmpp_ns ('sasl'), 'response']);
158			$w->characters (MIME::Base64::encode_base64 ($ret, ''));
159			$w->endTag;
160			$self->flush;
161			}
162
163			=head2 send_iq ($id, $type, $create_cb, %attrs)
164
165			This method sends an IQ stanza of type C<$type>. C<$create_cb>
166			will be called with an XML::Writer instance as first argument.
167			C<$create_cb> should be used to fill the IQ xml stanza.
168
169			C<%attrs> should have further attributes for the IQ stanza tag.
170			For example 'to' or 'from'. If the C<%attrs> contain a 'lang' attribute
171			it will be put into the 'xml' namespace.
172
173			C<$id> is the id to give this IQ stanza.
174
175			=cut
176
177			sub send_iq {
178			my ($self, $id, $type, $create_cb, %attrs) = @_;
179			my $w = $self->{writer};
180			$w->addPrefix (xmpp_ns ('bind'), '');
181			my (@from) = ($self->{jid} ? (from => $self->{jid}) : ());
182			if ($attrs{lang}) {
183			push @from, ([ xmpp_ns ('xml'), 'lang' ] => delete $attrs{leng})
184			}
185			$w->startTag ('iq', id => $id, type => $type, @from, %attrs);
186			$create_cb->($w);
187			$w->endTag;
188			$self->flush;
189			}
190
191			sub send_initial_presence {
192			my ($self) = @_;
193			my $w = $self->{writer};
194			$w->addPrefix (xmpp_ns ('client'), '');
195			$w->emptyTag ('presence', from => $self->{jid});
196			$self->flush;
197			}
198
199			# XXX
200			sub send_presence {
201			my ($self, $to) = @_;
202			my $w = $self->{writer};
203			$w->addPrefix (xmpp_ns ('client'), '');
204			$w->emptyTag ('presence', from => $self->{jid}, to => $to);
205			$self->flush;
206			}
207
208			# XXX
209			sub send_message {
210			my ($self, $to, $type, $cb) = @_;
211			my $w = $self->{writer};
212			$w->addPrefix (xmpp_ns ('client'), '');
213			$w->startTag ('message', to => $to, from => $self->{jid}, type => $type);
214			$cb->($w);
215			$w->endTag;
216			$self->flush;
217			}
218
219			=head1 AUTHOR
220
221			Robin Redeker, C<< <elmex at ta-sa.org> >>
222
223			=head1 BUGS
224
225			Please report any bugs or feature requests to
226			C<bug-net-xmpp2 at rt.cpan.org>, or through the web interface at
227			L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-XMPP2>.
228			I will be notified, and then you'll automatically be notified of progress on
229			your bug as I make changes.
230
231			=head1 SUPPORT
232
233			You can find documentation for this module with the perldoc command.
234
235			perldoc Net::XMPP2
236
237			You can also look for information at:
238
239			=over 4
240
241			=item * AnnoCPAN: Annotated CPAN documentation
242
243			L<http://annocpan.org/dist/Net-XMPP2>
244
245			=item * CPAN Ratings
246
247			L<http://cpanratings.perl.org/d/Net-XMPP2>
248
249			=item * RT: CPAN's request tracker
250
251			L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-XMPP2>
252
253			=item * Search CPAN
254
255			L<http://search.cpan.org/dist/Net-XMPP2>
256
257			=back
258
259			=head1 ACKNOWLEDGEMENTS
260
261			=head1 COPYRIGHT & LICENSE
262
263			Copyright 2007 Robin Redeker, all rights reserved.
264
265			This program is free software; you can redistribute it and/or modify it
266			under the same terms as Perl itself.
267
268			=cut
269
270			1; # End of Net::XMPP2